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