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