b3d61040d8d655373d0ed98719a5aa33c5564324
[mes.git] / scaffold / boot / 60-let-syntax.scm
1 ;;; Mes --- Maxwell Equations of Software
2 ;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
3 ;;;
4 ;;; This file is part of Mes.
5 ;;;
6 ;;; Mes is free software; you can redistribute it and/or modify it
7 ;;; under the terms of the GNU General Public License as published by
8 ;;; the Free Software Foundation; either version 3 of the License, or (at
9 ;;; your option) any later version.
10 ;;;
11 ;;; Mes is distributed in the hope that it will be useful, but
12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14 ;;; GNU General Public License for more details.
15 ;;;
16 ;;; You should have received a copy of the GNU General Public License
17 ;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
18
19 (define-macro (and . x)
20   (if (null? x) #t
21       (if (null? (cdr x)) (car x)
22           (list (quote if) (car x) (cons (quote and) (cdr x))
23                 #f))))
24
25 (define-macro (or . x)
26   (if (null? x) #f
27       (if (null? (cdr x)) (car x)
28           (list (list (quote lambda) (list (quote r))
29                       (list (quote if) (quote r) (quote r)
30                             (cons (quote or) (cdr x))))
31                 (car x)))))
32
33 (define else #t)
34 (define-macro (cond . clauses)
35   (list 'if (pair? clauses)
36         (list (cons
37                'lambda
38                (cons
39                 '(test)
40                 (list (list 'if 'test
41                             (if (pair? (cdr (car clauses)))
42                                 (if (eq? (car (cdr (car clauses))) '=>)
43                                     (append2 (cdr (cdr (car clauses))) '(test))
44                                     (list (cons 'lambda (cons '() (cons 'test (cdr (car clauses)))))))
45                                 (list (cons 'lambda (cons '() (cons 'test (cdr (car clauses)))))))
46                             (if (pair? (cdr clauses))
47                                 (cons 'cond (cdr clauses)))))))
48               (car (car clauses)))))
49
50 (define (memq x lst)
51   (if (null? lst) #f
52       (if (eq? x (car lst)) lst
53           (memq x (cdr lst)))))
54
55 ;; (cond-expand
56 ;;  (guile
57 ;;   (define closure identity)
58 ;;   (define body identity)
59 ;;   (define append2 append)
60 ;;   (define (core:apply f a m) (f a))
61 ;;   )
62 ;;  (mes
63   (define <cell:symbol> 11)
64   (define (symbol? x)
65     (eq? (core:type x) <cell:symbol>))
66
67   (define (string->symbol s)
68     (if (not (pair? (core:car s))) '()
69         (core:lookup-symbol (core:car s))))
70
71   (define <cell:string> 10)
72   (define (string? x)
73     (eq? (core:type x) <cell:string>))
74   
75   (define <cell:vector> 14)
76   (define (vector? x)
77     (eq? (core:type x) <cell:vector>))
78  
79   ;; (define (body x)
80   ;; (core:cdr (core:cdr (core:cdr (cdr (assq 'x (current-module)))))))
81   ;; (define (closure x)
82   ;;   (map car (cdr (core:cdr (core:car (core:cdr (cdr (assq 'x (current-module)))))))))
83   ;; ))
84
85 (define (cons* . rest)
86   (if (null? (cdr rest)) (car rest)
87       (cons (car rest) (core:apply cons* (cdr rest) (current-module)))))
88
89 (define (apply f h . t)
90   (if (null? t) (core:apply f h (current-module))
91       (apply f (apply cons* (cons h t)))))
92
93 (define (append . rest)
94   (if (null? rest) '()
95       (if (null? (cdr rest)) (car rest)
96           (append2 (car rest) (apply append (cdr rest))))))
97
98 (define-macro (quasiquote x)
99   ;;(core:display-error "quasiquote:") (core:write-error x) (core:display-error "\n")
100   (define (loop x)
101     ;;(core:display-error "loop:") (core:write-error x) (core:display-error "\n")
102     (if (vector? x) (list 'list->vector (loop (vector->list x)))
103         (if (not (pair? x)) (cons 'quote (cons x '()))
104             (if (eq? (car x) 'quasiquote) (loop (loop (cadr x)))
105                 (if (eq? (car x) 'unquote) (cadr x)
106                     (if (and (pair? (car x)) (eq? (caar x) 'unquote-splicing))
107                         ((lambda (d)
108                            (list 'append (car (cdr (car x))) d))
109                          (loop (cdr x)))
110                         ((lambda (a d)
111                            (if (pair? d)
112                                (if (eq? (car d) 'quote)
113                                    (if (and (pair? a) (eq? (car a) 'quote))
114                                        (list 'quote (cons (cadr a) (cadr d)))
115                                        (if (null? (cadr d))
116                                            (list 'list a)
117                                            (list 'cons* a d)))
118                                    (if (memq (car d) '(list cons*))
119                                        (cons (car d) (cons a (cdr d)))
120                                        (list 'cons* a d)))
121                                (list 'cons* a d)))
122                          (loop (car x))
123                          (loop (cdr x)))))))))
124   (loop x))
125
126 (define (caar x) (car (car x)))
127 (define (cadr x) (car (cdr x)))
128 (define (cdar x) (cdr (car x)))
129 (define (cddr x) (cdr (cdr x)))
130
131 (define-macro (simple-let bindings . rest)
132   (cons (cons 'lambda (cons (map car bindings) rest))
133         (map cadr bindings)))
134
135 (define-macro (xsimple-let bindings rest)
136   `(,`(lambda ,(map car bindings) ,@rest)
137     ,@(map cadr bindings)))
138
139 (define-macro (xnamed-let name bindings rest)
140   `(simple-let ((,name *unspecified*))
141      (set! ,name (lambda ,(map car bindings) ,@rest))
142      (,name ,@(map cadr bindings))))
143
144 (define-macro (let bindings-or-name . rest)
145   (if (symbol? bindings-or-name) ;; IF
146       `(xnamed-let ,bindings-or-name ,(car rest) ,(cdr rest))
147       `(xsimple-let ,bindings-or-name ,rest)))
148
149 (define (expand-let* bindings body)
150   (if (null? bindings)
151       `((lambda () ,@body))
152       `((lambda (,(caar bindings))
153           ,(expand-let* (cdr bindings) body))
154         ,@(cdar bindings))))
155
156 (define-macro (let* bindings . body)
157   (expand-let* bindings body))
158
159 (define (equal2? a b)
160   (if (and (null? a) (null? b)) #t
161       (if (and (pair? a) (pair? b))
162           (and (equal2? (car a) (car b))
163                (equal2? (cdr a) (cdr b)))
164           (if (and (string? a) (string? b))
165               (eq? (string->symbol a) (string->symbol b))
166               (if (and (vector? a) (vector? b))
167                   (equal2? (vector->list a) (vector->list b))
168                   (eq? a b))))))
169
170 (define equal? equal2?)
171 (define (member x lst)
172   (if (null? lst) #f
173       (if (equal2? x (car lst)) lst
174           (member x (cdr lst)))))
175
176 (define (<= . rest)
177   (or (apply < rest)
178       (apply = rest)))
179
180 (define (>= . rest)
181   (or (apply > rest)
182       (apply = rest)))
183
184 (define (list? x)
185   (or (null? x)
186       (and (pair? x) (list? (cdr x)))))
187
188 ;; -*-scheme-*-
189
190 ;;; Mes --- Maxwell Equations of Software
191 ;;; Copyright (c) 1993-2004 by Richard Kelsey and Jonathan Rees.
192 ;;; Copyright © 2016 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
193 ;;;
194 ;;; This file is part of Mes.
195 ;;;
196 ;;; Mes is free software; you can redistribute it and/or modify it
197 ;;; under the terms of the GNU General Public License as published by
198 ;;; the Free Software Foundation; either version 3 of the License, or (at
199 ;;; your option) any later version.
200 ;;;
201 ;;; Mes is distributed in the hope that it will be useful, but
202 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
203 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
204 ;;; GNU General Public License for more details.
205 ;;;
206 ;;; You should have received a copy of the GNU General Public License
207 ;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
208
209 ;;; Commentary:
210
211 ;;; syntax.mes is loaded after scm.mes.  It provides the R5RS hygienic
212 ;;; macros define-syntax, syntax-rules and define-syntax-rule.
213 ;;; syntax-rules is adapted from scheme48-1.1/scheme/alt/syntax.scm
214
215 ;;; Code:
216
217 ;;; Copyright (c) 1993-2004 by Richard Kelsey and Jonathan Rees. See file COPYING.
218
219 ;;; scheme48-1.1/COPYING
220
221 ;; Copyright (c) 1993-2004 Richard Kelsey and Jonathan Rees
222 ;; All rights reserved.
223
224 ;; Redistribution and use in source and binary forms, with or without
225 ;; modification, are permitted provided that the following conditions
226 ;; are met:
227 ;; 1. Redistributions of source code must retain the above copyright
228 ;;    notice, this list of conditions and the following disclaimer.
229 ;; 2. Redistributions in binary form must reproduce the above copyright
230 ;;    notice, this list of conditions and the following disclaimer in the
231 ;;    documentation and/or other materials provided with the distribution.
232 ;; 3. The name of the authors may not be used to endorse or promote products
233 ;;    derived from this software without specific prior written permission.
234
235 ;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
236 ;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
237 ;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
238 ;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
239 ;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
240 ;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
241 ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
242 ;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
243 ;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
244 ;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
245
246
247 (cond-expand
248  (guile)
249  (mes
250   (define-macro (define-syntax macro-name transformer . stuff)
251     `(define-macro (,macro-name . args)
252        (,transformer (cons ',macro-name args)
253                      (lambda (x0) x0)
254                      eq?)))))
255
256 ;; Rewrite-rule compiler (a.k.a. "extend-syntax")
257
258 ;; Example:
259 ;;
260 ;; (define-syntax or
261 ;;   (syntax-rules ()
262 ;;     ((or) #f)
263 ;;     ((or e) e)
264 ;;     ((or e1 e ...) (let ((temp e1))
265 ;;                     (if temp temp (or e ...))))))
266
267 (cond-expand
268  (guile)
269  (mes
270   (define-syntax syntax-rules
271     (let ()
272       (define name? symbol?)
273
274       (define (segment-pattern? pattern)
275         (and (segment-template? pattern)
276              (or (null? (cddr pattern))
277                  (syntax-error "segment matching not implemented" pattern))))
278     
279       (define (segment-template? pattern)
280         (and (pair? pattern)
281              (pair? (cdr pattern))
282              (memq (cadr pattern) indicators-for-zero-or-more)))
283     
284       (define indicators-for-zero-or-more (list (string->symbol "...") '---))
285     
286       (lambda (exp r c)
287
288         (define %input (r '%input))     ;Gensym these, if you like.
289         (define %compare (r '%compare))
290         (define %rename (r '%rename))
291         (define %tail (r '%tail))
292         (define %temp (r '%temp))
293
294         (define rules (cddr exp))
295         (define subkeywords (cadr exp))
296
297         (define (make-transformer rules)
298           ;;(core:display-error "make-transformer:") (core:write-error rules) (core:display-error "\n")
299           `(lambda (,%input ,%rename ,%compare)
300              (let ((,%tail (cdr ,%input)))
301                (cond ,@(map process-rule rules)
302                      (else
303                       (syntax-error
304                        "use of macro doesn't match definition"
305                        ,%input))))))
306
307         (define (process-rule rule)
308           ;;(core:display-error "process-rule:") (core:write-error rule) (core:display-error "\n")
309           (if (and (pair? rule)
310                    (pair? (cdr rule))
311                    (null? (cddr rule)))
312               (let ((pattern (cdar rule))
313                     (template (cadr rule)))
314                 `((and ,@(process-match %tail pattern))
315                   (let* ,(process-pattern pattern
316                                           %tail
317                                           (lambda (x) x))
318                     ,(process-template template
319                                        0
320                                        (meta-variables pattern 0 '())))))
321               (syntax-error "ill-formed syntax rule" rule)))
322       
323         ;; Generate code to test whether input expression matches pattern
324
325         (define (process-match input pattern)
326           ;;(core:display-error "process-match:") (core:write-error input) (core:display-error "\n")
327           ;;(core:display-error "      pattern:") (core:write-error pattern) (core:display-error "\n")
328           (cond ((name? pattern)
329                  (if (member pattern subkeywords)
330                      `((,%compare ,input (,%rename ',pattern)))
331                      `()))
332                 ((segment-pattern? pattern)
333                  (process-segment-match input (car pattern)))
334                 ((pair? pattern)
335                  `((let ((,%temp ,input))
336                      (and (pair? ,%temp)
337                           ,@(process-match `(car ,%temp) (car pattern))
338                           ,@(process-match `(cdr ,%temp) (cdr pattern))))))
339                 ((or (null? pattern) (boolean? pattern) (char? pattern))
340                  `((eq? ,input ',pattern)))
341                 (else
342                  `((equal? ,input ',pattern)))))
343       
344         (define (process-segment-match input pattern)
345           ;;(core:display-error "process-segment-match:") (core:write-error input) (core:display-error "\n")
346           ;;(core:display-error "              pattern:") (core:write-error pattern) (core:display-error "\n")
347           (let ((conjuncts (process-match '(car l) pattern)))
348             (if (null? conjuncts)
349                 `((list? ,input))       ;+++
350                 `((let loop ((l ,input))
351                     (or (null? l)
352                         (and (pair? l)
353                              ,@conjuncts
354                              (loop (cdr l)))))))))
355       
356         ;; Generate code to take apart the input expression
357         ;; This is pretty bad, but it seems to work (can't say why).
358
359         (define (process-pattern pattern path mapit)
360           ;;(core:display-error "process-pattern:") (core:write-error pattern) (core:display-error "\n")
361           ;;(core:display-error "           path:") (core:write-error path) (core:display-error "\n")
362           (cond ((name? pattern)
363                  (if (memq pattern subkeywords)
364                      '()
365                      (list (list pattern (mapit path)))))
366                 ((segment-pattern? pattern)
367                  (process-pattern (car pattern)
368                                   %temp
369                                   (lambda (x) ;temp is free in x
370                                     (mapit (if (eq? %temp x)
371                                                path ;+++
372                                                `(map (lambda (,%temp) ,x)
373                                                      ,path))))))
374                 ((pair? pattern)
375                  (append (process-pattern (car pattern) `(car ,path) mapit)
376                          (process-pattern (cdr pattern) `(cdr ,path) mapit)))
377                 (else '())))
378
379         ;; Generate code to compose the output expression according to template
380
381         (define (process-template template rank env)
382           ;;(core:display-error "process-template:") (core:write-error template) (core:display-error "\n")
383           (cond ((name? template)
384                  (let ((probe (assq template env)))
385                    (if probe
386                        (if (<= (cdr probe) rank)
387                            template
388                            (syntax-error "template rank error (too few ...'s?)"
389                                          template))
390                        `(,%rename ',template))))
391                 ((segment-template? template)
392                  (let ((vars
393                         (free-meta-variables (car template) (+ rank 1) env '())))
394                    (if (null? vars)
395                        (silent-syntax-error "too many ...'s" template)
396                        (let* ((x (process-template (car template)
397                                                    (+ rank 1)
398                                                    env))
399                               (gen (if (equal? (list x) vars)
400                                        x ;+++
401                                        `(map (lambda ,vars ,x)
402                                              ,@vars))))
403                          (if (null? (cddr template))
404                              gen        ;+++
405                              `(append ,gen ,(process-template (cddr template)
406                                                               rank env)))))))
407                 ((pair? template)
408                  `(cons ,(process-template (car template) rank env)
409                         ,(process-template (cdr template) rank env)))
410                 (else `(quote ,template))))
411
412         ;; Return an association list of (var . rank)
413
414         (define (meta-variables pattern rank vars)
415           ;;(core:display-error "meta-variables:") (core:write-error pattern) (core:display-error "\n")
416           (cond ((name? pattern)
417                  (if (memq pattern subkeywords)
418                      vars
419                      (cons (cons pattern rank) vars)))
420                 ((segment-pattern? pattern)
421                  (meta-variables (car pattern) (+ rank 1) vars))
422                 ((pair? pattern)
423                  (meta-variables (car pattern) rank
424                                  (meta-variables (cdr pattern) rank vars)))
425                 (else vars)))
426
427         ;; Return a list of meta-variables of given higher rank
428
429         (define (free-meta-variables template rank env free)
430           ;;(core:display-error "meta-variables:") (core:write-error template) (core:display-error "\n")
431           (cond ((name? template)
432                  (if (and (not (memq template free))
433                           (let ((probe (assq template env)))
434                             (and probe (>= (cdr probe) rank))))
435                      (cons template free)
436                      free))
437                 ((segment-template? template)
438                  (free-meta-variables (car template)
439                                       rank env
440                                       (free-meta-variables (cddr template)
441                                                            rank env free)))
442                 ((pair? template)
443                  (free-meta-variables (car template)
444                                       rank env
445                                       (free-meta-variables (cdr template)
446                                                            rank env free)))
447                 (else free)))
448
449         c                               ;ignored
450
451         ;; Kludge for Scheme48 linker.
452         ;; `(cons ,(make-transformer rules)
453         ;;          ',(find-free-names-in-syntax-rules subkeywords rules))
454
455         (make-transformer rules))))))
456
457 (cond-expand
458  (guile)
459  (mes
460   (define-macro (let-syntax bindings . rest)
461     `((lambda ()
462         ,@(map (lambda (binding)
463                  `(define-macro (,(car binding) . args)
464                     (,(cadr binding) (cons ',(car binding) args)
465                      (lambda (x0) x0)
466                      eq?)))
467                bindings)
468         ,@rest)))))
469
470 (core:display
471  (let-syntax ((xwhen (syntax-rules ()
472                        ((xwhen condition exp ...)
473                         (if (not condition)
474                             (begin exp ...))))))
475    (xwhen #f 42)))
476