test: Resurrect running boot tests on Guile.
[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 (cond-expand
252  (guile)
253  (mes
254   (define (boolean? x)
255     (or (eq? x #f) (eq? x #t)))
256   (define (char? x)
257     (and (eq? (core:type x) <cell:char>)
258          (> (char->integer x) -1)))))
259
260 ;; -*-scheme-*-
261
262 ;;; GNU Mes --- Maxwell Equations of Software
263 ;;; Copyright (c) 1993-2004 by Richard Kelsey and Jonathan Rees.
264 ;;; Copyright © 2016 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
265 ;;;
266 ;;; This file is part of GNU Mes.
267 ;;;
268 ;;; GNU Mes is free software; you can redistribute it and/or modify it
269 ;;; under the terms of the GNU General Public License as published by
270 ;;; the Free Software Foundation; either version 3 of the License, or (at
271 ;;; your option) any later version.
272 ;;;
273 ;;; GNU Mes is distributed in the hope that it will be useful, but
274 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
275 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
276 ;;; GNU General Public License for more details.
277 ;;;
278 ;;; You should have received a copy of the GNU General Public License
279 ;;; along with GNU Mes.  If not, see <http://www.gnu.org/licenses/>.
280
281 ;;; Commentary:
282
283 ;;; syntax.mes is loaded after scm.mes.  It provides the R5RS hygienic
284 ;;; macros define-syntax, syntax-rules and define-syntax-rule.
285 ;;; syntax-rules is adapted from scheme48-1.1/scheme/alt/syntax.scm
286
287 ;;; Code:
288
289 ;;; Copyright (c) 1993-2004 by Richard Kelsey and Jonathan Rees. See file COPYING.
290
291 ;;; scheme48-1.1/COPYING
292
293 ;; Copyright (c) 1993-2004 Richard Kelsey and Jonathan Rees
294 ;; All rights reserved.
295
296 ;; Redistribution and use in source and binary forms, with or without
297 ;; modification, are permitted provided that the following conditions
298 ;; are met:
299 ;; 1. Redistributions of source code must retain the above copyright
300 ;;    notice, this list of conditions and the following disclaimer.
301 ;; 2. Redistributions in binary form must reproduce the above copyright
302 ;;    notice, this list of conditions and the following disclaimer in the
303 ;;    documentation and/or other materials provided with the distribution.
304 ;; 3. The name of the authors may not be used to endorse or promote products
305 ;;    derived from this software without specific prior written permission.
306
307 ;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
308 ;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
309 ;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
310 ;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
311 ;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
312 ;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
313 ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
314 ;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
315 ;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
316 ;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
317
318
319 (cond-expand
320  (guile)
321  (mes
322   (define-macro (define-syntax macro-name transformer . stuff)
323     `(define-macro (,macro-name . args)
324        (,transformer (cons ',macro-name args)
325                      (lambda (x0) x0)
326                      eq?)))))
327
328 ;; Rewrite-rule compiler (a.k.a. "extend-syntax")
329
330 ;; Example:
331 ;;
332 ;; (define-syntax or
333 ;;   (syntax-rules ()
334 ;;     ((or) #f)
335 ;;     ((or e) e)
336 ;;     ((or e1 e ...) (let ((temp e1))
337 ;;                     (if temp temp (or e ...))))))
338
339 (cond-expand
340  (guile)
341  (mes
342   (define-syntax syntax-rules
343     (let ()
344       (define name? symbol?)
345
346       (define (segment-pattern? pattern)
347         (and (segment-template? pattern)
348              (or (null? (cddr pattern))
349                  (syntax-error0 "segment matching not implemented" pattern))))
350
351       (define (segment-template? pattern)
352         (and (pair? pattern)
353              (pair? (cdr pattern))
354              (memq (cadr pattern) indicators-for-zero-or-more)))
355
356       (define indicators-for-zero-or-more (list (string->symbol "...") '---))
357
358       (lambda (exp r c)
359
360         (define %input (r '%input))     ;Gensym these, if you like.
361         (define %compare (r '%compare))
362         (define %rename (r '%rename))
363         (define %tail (r '%tail))
364         (define %temp (r '%temp))
365
366         (define rules (cddr exp))
367         (define subkeywords (cadr exp))
368
369         (define (make-transformer rules)
370           ;;(core:display-error "make-transformer:") (core:write-error rules) (core:display-error "\n")
371           `(lambda (,%input ,%rename ,%compare)
372              (let ((,%tail (cdr ,%input)))
373                (cond ,@(map process-rule rules)
374                      (else
375                       (syntax-error1
376                        "use of macro doesn't match definition"
377                        ,%input))))))
378
379         (define (process-rule rule)
380           ;;(core:display-error "process-rule:") (core:write-error rule) (core:display-error "\n")
381           (if (and (pair? rule)
382                    (pair? (cdr rule))
383                    (null? (cddr rule)))
384               (let ((pattern (cdar rule))
385                     (template (cadr rule)))
386                 `((and ,@(process-match %tail pattern))
387                   (let* ,(process-pattern pattern
388                                           %tail
389                                           (lambda (x) x))
390                     ,(process-template template
391                                        0
392                                        (meta-variables pattern 0 '())))))
393               (syntax-error2 "ill-formed syntax rule" rule)))
394
395         ;; Generate code to test whether input expression matches pattern
396
397         (define (process-match input pattern)
398           ;;(core:display-error "process-match:") (core:write-error input) (core:display-error "\n")
399           ;;(core:display-error "      pattern:") (core:write-error pattern) (core:display-error "\n")
400           (cond ((name? pattern)
401                  (if (member pattern subkeywords)
402                      `((,%compare ,input (,%rename ',pattern)))
403                      `()))
404                 ((segment-pattern? pattern)
405                  (process-segment-match input (car pattern)))
406                 ((pair? pattern)
407                  `((let ((,%temp ,input))
408                      (and (pair? ,%temp)
409                           ,@(process-match `(car ,%temp) (car pattern))
410                           ,@(process-match `(cdr ,%temp) (cdr pattern))))))
411                 ((or (null? pattern) (boolean? pattern) (char? pattern))
412                  `((eq? ,input ',pattern)))
413                 (else
414                  `((equal? ,input ',pattern)))))
415
416         (define (process-segment-match input pattern)
417           ;;(core:display-error "process-segment-match:") (core:write-error input) (core:display-error "\n")
418           ;;(core:display-error "              pattern:") (core:write-error pattern) (core:display-error "\n")
419           (let ((conjuncts (process-match '(car l) pattern)))
420             (if (null? conjuncts)
421                 `((list? ,input))       ;+++
422                 `((let loop ((l ,input))
423                     (or (null? l)
424                         (and (pair? l)
425                              ,@conjuncts
426                              (loop (cdr l)))))))))
427
428         ;; Generate code to take apart the input expression
429         ;; This is pretty bad, but it seems to work (can't say why).
430
431         (define (process-pattern pattern path mapit)
432           ;;(core:display-error "process-pattern:") (core:write-error pattern) (core:display-error "\n")
433           ;;(core:display-error "           path:") (core:write-error path) (core:display-error "\n")
434           (cond ((name? pattern)
435                  (if (memq pattern subkeywords)
436                      '()
437                      (list (list pattern (mapit path)))))
438                 ((segment-pattern? pattern)
439                  (process-pattern (car pattern)
440                                   %temp
441                                   (lambda (x) ;temp is free in x
442                                     (mapit (if (eq? %temp x)
443                                                path ;+++
444                                                `(map (lambda (,%temp) ,x)
445                                                      ,path))))))
446                 ((pair? pattern)
447                  (append (process-pattern (car pattern) `(car ,path) mapit)
448                          (process-pattern (cdr pattern) `(cdr ,path) mapit)))
449                 (else '())))
450
451         ;; Generate code to compose the output expression according to template
452
453         (define (process-template template rank env)
454           ;;(core:display-error "process-template:") (core:write-error template) (core:display-error "\n")
455           (cond ((name? template)
456                  (let ((probe (assq template env)))
457                    (if probe
458                        (if (<= (cdr probe) rank)
459                            template
460                            (syntax-error3 "template rank error (too few ...'s?)"
461                                          template))
462                        `(,%rename ',template))))
463                 ((segment-template? template)
464                  (let ((vars
465                         (free-meta-variables (car template) (+ rank 1) env '())))
466                    (if (null? vars)
467                        (silent-syntax-error4 "too many ...'s" template)
468                        (let* ((x (process-template (car template)
469                                                    (+ rank 1)
470                                                    env))
471                               (gen (if (equal? (list x) vars)
472                                        x ;+++
473                                        `(map (lambda ,vars ,x)
474                                              ,@vars))))
475                          (if (null? (cddr template))
476                              gen        ;+++
477                              `(append ,gen ,(process-template (cddr template)
478                                                               rank env)))))))
479                 ((pair? template)
480                  `(cons ,(process-template (car template) rank env)
481                         ,(process-template (cdr template) rank env)))
482                 (else `(quote ,template))))
483
484         ;; Return an association list of (var . rank)
485
486         (define (meta-variables pattern rank vars)
487           ;;(core:display-error "meta-variables:") (core:write-error pattern) (core:display-error "\n")
488           (cond ((name? pattern)
489                  (if (memq pattern subkeywords)
490                      vars
491                      (cons (cons pattern rank) vars)))
492                 ((segment-pattern? pattern)
493                  (meta-variables (car pattern) (+ rank 1) vars))
494                 ((pair? pattern)
495                  (meta-variables (car pattern) rank
496                                  (meta-variables (cdr pattern) rank vars)))
497                 (else vars)))
498
499         ;; Return a list of meta-variables of given higher rank
500
501         (define (free-meta-variables template rank env free)
502           ;;(core:display-error "meta-variables:") (core:write-error template) (core:display-error "\n")
503           (cond ((name? template)
504                  (if (and (not (memq template free))
505                           (let ((probe (assq template env)))
506                             (and probe (>= (cdr probe) rank))))
507                      (cons template free)
508                      free))
509                 ((segment-template? template)
510                  (free-meta-variables (car template)
511                                       rank env
512                                       (free-meta-variables (cddr template)
513                                                            rank env free)))
514                 ((pair? template)
515                  (free-meta-variables (car template)
516                                       rank env
517                                       (free-meta-variables (cdr template)
518                                                            rank env free)))
519                 (else free)))
520
521         c                               ;ignored
522
523         ;; Kludge for Scheme48 linker.
524         ;; `(cons ,(make-transformer rules)
525         ;;          ',(find-free-names-in-syntax-rules subkeywords rules))
526
527         (make-transformer rules))))))
528
529 (cond-expand
530  (guile)
531  (mes
532   (define-macro (let-syntax bindings . rest)
533     `((lambda ()
534         ,@(map (lambda (binding)
535                  `(define-macro (,(car binding) . args)
536                     (,(cadr binding) (cons ',(car binding) args)
537                      (lambda (x0) x0)
538                      eq?)))
539                bindings)
540         ,@rest)))))
541
542 (core:display
543  (let-syntax ((xwhen (syntax-rules ()
544                        ((xwhen condition exp ...)
545                         (if (not condition)
546                             (begin exp ...))))))
547    (xwhen #f 42)))