5551de3afa8e10e617f6c9065d3e42946b95548d
[mes.git] / module / mes / quasiquote.mes
1 ;;; -*-scheme-*-
2
3 ;;; Mes --- Maxwell Equations of Software
4 ;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
5 ;;;
6 ;;; quasiquote.mes: This file is part of Mes.
7 ;;;
8 ;;; Mes is free software; you can redistribute it and/or modify it
9 ;;; under the terms of the GNU General Public License as published by
10 ;;; the Free Software Foundation; either version 3 of the License, or (at
11 ;;; your option) any later version.
12 ;;;
13 ;;; Mes is distributed in the hope that it will be useful, but
14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16 ;;; GNU General Public License for more details.
17 ;;;
18 ;;; You should have received a copy of the GNU General Public License
19 ;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
20
21 (define-macro (slow...quasiquote x)
22   (define (check x)
23     (cond ((pair? (cdr x)) (cond ((null? (cddr x)))
24                                  (#t (error (car x) "invalid form ~s" x))))))
25   (define (loop x)
26     ;;(display "LOOP") (newline)
27     (cond
28      ((not (pair? x)) (cons 'quote (cons x '())))
29      ((eq? (car x) 'quasiquote) (check x) (loop (loop (cadr x))))
30      ((eq? (car x) 'unquote) (check x) (cadr x))
31      ((eq? (car x) 'unquote-splicing)
32       (error 'unquote-splicing "invalid context for ~s" x))
33      (;;(and (pair? (car x)) (eq? (caar x) 'unquote-splicing))
34       (cond ((pair? (car x)) (eq? (caar x) 'unquote-splicing))
35             (#t #f))
36       (check (car x))
37       ;; (let ((d (loop (cdr x))))
38       ;;   (cond ((equal? d '(quote ())) (cadar x))
39       ;;         ;;(#t `(append ,(cadar x) ,d))
40       ;;         (#t (list 'append (cadar x) d))
41       ;;         ))
42       ((lambda (d)
43          (list 'append (cadar x) d))
44        (loop (cdr x))))
45      (#t
46       ;; (let ((a (loop (car x)))
47       ;;       (d (loop (cdr x))))
48       ;;   (cond ((pair? d)
49       ;;          (cond ((eq? (car d) 'quote)
50       ;;                 (cond ((and (pair? a) (eq? (car a) 'quote))
51       ;;                        `'(,(cadr a) . ,(cadr d)))
52       ;;                       (#t (cond ((null? (cadr d))
53       ;;                                  `(list ,a))
54       ;;                                 (#t `(cons* ,a ,d))))))
55       ;;                (#t (cond ((memq (car d) '(list cons*))
56       ;;                           `(,(car d) ,a ,@(cdr d)))
57       ;;                          (#t `(cons* ,a ,d))))))
58       ;;         (#t `(cons* ,a ,d))))
59
60       ((lambda (a d)
61          ;;(display "LAMBDA AD") (newline)
62          (cond ((pair? d)
63                 (cond ((eq? (car d) 'quote)
64                        (cond (;;(and (pair? a) (eq? (car a) 'quote))
65                               (cond ((pair? a) (eq? (car a) 'quote))
66                                     (#t #f))
67                               (list 'quote (cons (cadr a) (cadr d))))
68                              (#t (cond ((null? (cadr d))
69                                         (list 'list a))
70                                        (#t (list 'cons* a d))))))
71                       (#t (cond ((memq (car d) '(list cons*))
72                                  ;;`(,(car d) ,a ,@(cdr d))
73                                  (cons (car d) (cons a (cdr d)))
74                                  )
75                                 ;;(#t `(cons* ,a ,d))
76                                 (#t (list 'cons* a d))
77                                 ))))
78                ;;(#t `(cons* ,a ,d))
79                (#t (list 'cons* a d))
80                ))
81        (loop (car x))
82        (loop (cdr x)))
83
84       )))
85   (loop x))