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