c++ type-safety.
[mes.git] / syntax-if.mes
1 ;; -*-scheme-*-
2
3 (define (syntax-error message thing)
4   (display "syntax-error:")
5   (display message)
6   (display ":")
7   (display thing)
8   (newline))
9
10 ;;; Adapted from scheme48-1.1/scheme/alt/syntax.scm
11
12 ;;; Copyright (c) 1993-2004 by Richard Kelsey and Jonathan Rees. See file COPYING.
13
14 ;;; scheme48-1.1/COPYING
15
16 ;; Copyright (c) 1993-2004 Richard Kelsey and Jonathan Rees
17 ;; All rights reserved.
18
19 ;; Redistribution and use in source and binary forms, with or without
20 ;; modification, are permitted provided that the following conditions
21 ;; are met:
22 ;; 1. Redistributions of source code must retain the above copyright
23 ;;    notice, this list of conditions and the following disclaimer.
24 ;; 2. Redistributions in binary form must reproduce the above copyright
25 ;;    notice, this list of conditions and the following disclaimer in the
26 ;;    documentation and/or other materials provided with the distribution.
27 ;; 3. The name of the authors may not be used to endorse or promote products
28 ;;    derived from this software without specific prior written permission.
29
30 ;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
31 ;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
32 ;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
33 ;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
34 ;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
35 ;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
36 ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
37 ;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
38 ;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
39 ;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
40
41
42 (define-macro (define-syntax macro-name transformer . stuff)
43   `(define-macro (,macro-name . args)
44      (,transformer (cons ',macro-name args)
45                              (lambda (x) x)
46                              eq?)))
47
48 ;; Rewrite-rule compiler (a.k.a. "extend-syntax")
49
50 ;; Example:
51 ;;
52 ;; (define-syntax or
53 ;;   (syntax-rules ()
54 ;;     ((or) #f)
55 ;;     ((or e) e)
56 ;;     ((or e1 e ...) (let ((temp e1))
57 ;;                     (if temp temp (or e ...))))))
58
59 (define-syntax syntax-rules
60    (let ()
61      (define name? symbol?)
62
63      (define (segment-pattern? pattern)
64        (and (segment-template? pattern)
65             (or (null? (cddr pattern))
66                 (syntax-error "segment matching not implemented" pattern))))
67       
68      (define (segment-template? pattern)
69        (and (pair? pattern)
70             (pair? (cdr pattern))
71             (memq (cadr pattern) indicators-for-zero-or-more)))
72       
73      (define indicators-for-zero-or-more (list (string->symbol "...") '---))
74   
75     (lambda (exp r c)
76
77       (define %input (r '%input))       ;Gensym these, if you like.
78       (define %compare (r '%compare))
79       (define %rename (r '%rename))
80       (define %tail (r '%tail))
81       (define %temp (r '%temp))
82
83       (define rules (cddr exp))
84       (define subkeywords (cadr exp))
85
86       (define (make-transformer rules)
87           `(lambda (,%input ,%rename ,%compare)
88            (let ((,%tail (cdr ,%input)))
89                (cond ,@(map process-rule rules)
90                    (else
91                     (syntax-error
92                      "use of macro doesn't match definition"
93                      ,%input))))))
94
95       (define (process-rule rule)
96         (if (and (pair? rule)
97                  (pair? (cdr rule))
98                  (null? (cddr rule)))
99             (let ((pattern (cdar rule))
100                   (template (cadr rule)))
101               `((and ,@(process-match %tail pattern))
102                 (let* ,(process-pattern pattern
103                                         %tail
104                                         (lambda (x) x))
105                   ,(process-template template
106                                      0
107                                      (meta-variables pattern 0 '())))))
108             (syntax-error "ill-formed syntax rule" rule)))
109
110       ;; Generate code to test whether input expression matches pattern
111
112       (define (process-match input pattern)
113         (cond ((name? pattern)
114                (if (member pattern subkeywords)
115                    `((,%compare ,input (,%rename ',pattern)))
116                    `()))
117               ((segment-pattern? pattern)
118                (process-segment-match input (car pattern)))
119               ((pair? pattern)
120                `((let ((,%temp ,input))
121                    (and (pair? ,%temp)
122                         ,@(process-match `(car ,%temp) (car pattern))
123                         ,@(process-match `(cdr ,%temp) (cdr pattern))))))
124               ((or (null? pattern) (boolean? pattern) (char? pattern))
125                `((eq? ,input ',pattern)))
126               (else
127                `((equal? ,input ',pattern)))))
128
129       (define (process-segment-match input pattern)
130         (let ((conjuncts (process-match '(car l) pattern)))
131           (if (null? conjuncts)
132               `((list? ,input))                 ;+++
133               `((let loop ((l ,input))
134                   (or (null? l)
135                       (and (pair? l)
136                            ,@conjuncts
137                            (loop (cdr l)))))))))
138       
139       ;; Generate code to take apart the input expression
140       ;; This is pretty bad, but it seems to work (can't say why).
141
142       (define (process-pattern pattern path mapit)
143         (cond ((name? pattern)
144                (if (memq pattern subkeywords)
145                    '()
146                    (list (list pattern (mapit path)))))
147               ((segment-pattern? pattern)
148                (process-pattern (car pattern)
149                                 %temp
150                                 (lambda (x)     ;temp is free in x
151                                   (mapit (if (eq? %temp x)
152                                              path ;+++
153                                              `(map (lambda (,%temp) ,x)
154                                                    ,path))))))
155               ((pair? pattern)
156                (append (process-pattern (car pattern) `(car ,path) mapit)
157                        (process-pattern (cdr pattern) `(cdr ,path) mapit)))
158               (else '())))
159
160       ;; Generate code to compose the output expression according to template
161
162       (define (process-template template rank env)
163         (cond ((name? template)
164                (let ((probe (assq template env)))
165                  (if probe
166                      (if (<= (cdr probe) rank)
167                          template
168                          (syntax-error "template rank error (too few ...'s?)"
169                                        template))
170                      `(,%rename ',template))))
171               ((segment-template? template)
172                (let ((vars
173                       (free-meta-variables (car template) (+ rank 1) env '())))
174                  (if (null? vars)
175                      (syntax-error "too many ...'s" template)
176                      (let* ((x (process-template (car template)
177                                                  (+ rank 1)
178                                                  env))
179                             (gen (if (equal? (list x) vars)
180                                      x  ;+++
181                                      `(map (lambda ,vars ,x)
182                                            ,@vars))))
183                        (if (null? (cddr template))
184                            gen          ;+++
185                            `(append ,gen ,(process-template (cddr template)
186                                                             rank env)))))))
187               ((pair? template)
188                `(cons ,(process-template (car template) rank env)
189                       ,(process-template (cdr template) rank env)))
190               (else `(quote ,template))))
191
192       ;; Return an association list of (var . rank)
193
194       (define (meta-variables pattern rank vars)
195         (cond ((name? pattern)
196                (if (memq pattern subkeywords)
197                    vars
198                    (cons (cons pattern rank) vars)))
199               ((segment-pattern? pattern)
200                (meta-variables (car pattern) (+ rank 1) vars))
201               ((pair? pattern)
202                (meta-variables (car pattern) rank
203                                (meta-variables (cdr pattern) rank vars)))
204               (else vars)))
205
206       ;; Return a list of meta-variables of given higher rank
207
208         (define (free-meta-variables template rank env free)
209           (cond ((name? template)
210                  (if (and (not (memq template free))
211                           (let ((probe (assq template env)))
212                             (and probe (>= (cdr probe) rank))))
213                      (cons template free)
214                      free))
215                 ((segment-template? template)
216                  (free-meta-variables (car template)
217                                 rank env
218                                 (free-meta-variables (cddr template)
219                                                      rank env free)))
220                 ((pair? template)
221                  (free-meta-variables (car template)
222                                       rank env
223                                 (free-meta-variables (cdr template)
224                                                      rank env free)))
225                 (else free)))
226
227       c                                 ;ignored
228
229       ;; Kludge for Scheme48 linker.
230       ;; `(cons ,(make-transformer rules)
231       ;;          ',(find-free-names-in-syntax-rules subkeywords rules))
232
233       (make-transformer rules))))
234
235 (define-macro (define-syntax-rule id-pattern . template)
236   `(define-syntax ,(car id-pattern)
237      (syntax-rules ()
238        ((,(car id-pattern) . ,(cdr id-pattern)) ,@template))))