← Back to branch summary

~ubuntu-branches/ubuntu/trusty/mit-scheme/trusty-proposed

« back to all changes in this revision

Viewing changes to src/runtime/mit-macros.scm

  • Committer: Bazaar Package Importer
  • Author(s): Chris Hanson
  • Date: 2010-03-10 02:00:45 UTC
  • mfrom: (1.1.7 upstream) (3.1.6 sid)
  • Revision ID: james.westby@ubuntu.com-20100310020045-4np1y3ro6sk2oz92
Tags: 9.0.1-1
* New upstream.
* debian/watch: Fix, previous version was broken.

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/runtime/mit-macros.scm
 
1
#| -*-Scheme-*-
 
2
 
 
3
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
 
4
    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
 
5
    2006, 2007, 2008, 2009, 2010 Massachusetts Institute of Technology
 
6
 
 
7
This file is part of MIT/GNU Scheme.
 
8
 
 
9
MIT/GNU Scheme is free software; you can redistribute it and/or modify
 
10
it under the terms of the GNU General Public License as published by
 
11
the Free Software Foundation; either version 2 of the License, or (at
 
12
your option) any later version.
 
13
 
 
14
MIT/GNU Scheme 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 GNU
 
17
General Public License for more details.
 
18
 
 
19
You should have received a copy of the GNU General Public License
 
20
along with MIT/GNU Scheme; if not, write to the Free Software
 
21
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
 
22
USA.
 
23
 
 
24
|#
 
25
 
 
26
;;;; MIT/GNU Scheme macros
 
27
 
 
28
(declare (usual-integrations))
 
29
 
 
30
;;;; SRFI features
 
31
 
 
32
(define-syntax :cond-expand
 
33
  (er-macro-transformer
 
34
   (lambda (form rename compare)
 
35
     (let ((if-error (lambda () (ill-formed-syntax form))))
 
36
       (if (syntax-match? '(+ (DATUM * FORM)) (cdr form))
 
37
           (let loop ((clauses (cdr form)))
 
38
             (let ((req (caar clauses))
 
39
                   (if-true (lambda () `(,(rename 'BEGIN) ,@(cdar clauses)))))
 
40
               (if (and (identifier? req)
 
41
                        (compare (rename 'ELSE) req))
 
42
                   (if (null? (cdr clauses))
 
43
                       (if-true)
 
44
                       (if-error))
 
45
                   (let req-loop
 
46
                       ((req req)
 
47
                        (if-true if-true)
 
48
                        (if-false
 
49
                         (lambda ()
 
50
                           (if (null? (cdr clauses))
 
51
                               (if-error)
 
52
                               (loop (cdr clauses))))))
 
53
                     (cond ((identifier? req)
 
54
                            (if (any (lambda (feature)
 
55
                                       (compare (rename feature) req))
 
56
                                     supported-srfi-features)
 
57
                                (if-true)
 
58
                                (if-false)))
 
59
                           ((and (syntax-match? '(IDENTIFIER DATUM) req)
 
60
                                 (compare (rename 'NOT) (car req)))
 
61
                            (req-loop (cadr req)
 
62
                                      if-false
 
63
                                      if-true))
 
64
                           ((and (syntax-match? '(IDENTIFIER * DATUM) req)
 
65
                                 (compare (rename 'AND) (car req)))
 
66
                            (let and-loop ((reqs (cdr req)))
 
67
                              (if (pair? reqs)
 
68
                                  (req-loop (car reqs)
 
69
                                            (lambda () (and-loop (cdr reqs)))
 
70
                                            if-false)
 
71
                                  (if-true))))
 
72
                           ((and (syntax-match? '(IDENTIFIER * DATUM) req)
 
73
                                 (compare (rename 'OR) (car req)))
 
74
                            (let or-loop ((reqs (cdr req)))
 
75
                              (if (pair? reqs)
 
76
                                  (req-loop (car reqs)
 
77
                                            if-true
 
78
                                            (lambda () (or-loop (cdr reqs))))
 
79
                                  (if-false))))
 
80
                           (else
 
81
                            (if-error)))))))
 
82
           (if-error))))))
 
83
 
 
84
(define supported-srfi-features
 
85
  '(MIT
 
86
    MIT/GNU
 
87
    SRFI-0                              ;COND-EXPAND
 
88
    SRFI-1                              ;List Library
 
89
    SRFI-2                              ;AND-LET*
 
90
    SRFI-6                              ;Basic String Ports
 
91
    SRFI-8                              ;RECEIVE
 
92
    SRFI-9                              ;DEFINE-RECORD-TYPE
 
93
    SRFI-23                             ;ERROR
 
94
    SRFI-27                             ;Sources of Random Bits
 
95
    SRFI-30                             ;Nested Multi-Line Comments (#| ... |#)
 
96
    SRFI-62                             ;S-expression comments
 
97
    SRFI-69                             ;Basic Hash Tables
 
98
    ))
 
99
 
 
100
(define-syntax :receive
 
101
  (er-macro-transformer
 
102
   (lambda (form rename compare)
 
103
     compare                            ;ignore
 
104
     (if (syntax-match? '(R4RS-BVL FORM + FORM) (cdr form))
 
105
         `(,(rename 'CALL-WITH-VALUES)
 
106
           (,(rename 'LAMBDA) () ,(caddr form))
 
107
           (,(rename 'LAMBDA) ,(cadr form) ,@(cdddr form)))
 
108
         (ill-formed-syntax form)))))
 
109
 
 
110
(define-syntax :define-record-type
 
111
  (er-macro-transformer
 
112
   (lambda (form rename compare)
 
113
     compare                            ;ignore
 
114
     (if (syntax-match? '(IDENTIFIER
 
115
                          (IDENTIFIER * IDENTIFIER)
 
116
                          IDENTIFIER
 
117
                          * (IDENTIFIER IDENTIFIER ? IDENTIFIER))
 
118
                        (cdr form))
 
119
         (let ((type (cadr form))
 
120
               (constructor (car (caddr form)))
 
121
               (c-tags (cdr (caddr form)))
 
122
               (predicate (cadddr form))
 
123
               (fields (cddddr form))
 
124
               (de (rename 'DEFINE)))
 
125
           `(,(rename 'BEGIN)
 
126
             (,de ,type (,(rename 'MAKE-RECORD-TYPE) ',type ',(map car fields)))
 
127
             (,de ,constructor (,(rename 'RECORD-CONSTRUCTOR) ,type ',c-tags))
 
128
             (,de ,predicate (,(rename 'RECORD-PREDICATE) ,type))
 
129
             ,@(append-map
 
130
                (lambda (field)
 
131
                  (let ((name (car field)))
 
132
                    (cons `(,de ,(cadr field)
 
133
                                (,(rename 'RECORD-ACCESSOR) ,type ',name))
 
134
                          (if (pair? (cddr field))
 
135
                              `((,de ,(caddr field)
 
136
                                     (,(rename 'RECORD-MODIFIER) ,type ',name)))
 
137
                              '()))))
 
138
                fields)))
 
139
         (ill-formed-syntax form)))))
 
140
 
 
141
(define-syntax :define
 
142
  (er-macro-transformer
 
143
   (lambda (form rename compare)
 
144
     compare                            ;ignore
 
145
     (receive (name value) (parse-define-form form rename)
 
146
       `(,keyword:define ,name ,value)))))
 
147
 
 
148
(define (parse-define-form form rename)
 
149
  (cond ((syntax-match? '((DATUM . MIT-BVL) + FORM) (cdr form))
 
150
         (parse-define-form
 
151
          `(,(car form) ,(caadr form)
 
152
                        ,(if (identifier? (caadr form))
 
153
                             `(,(rename 'NAMED-LAMBDA) ,@(cdr form))
 
154
                             `(,(rename 'LAMBDA) ,(cdadr form) ,@(cddr form))))
 
155
          rename))
 
156
        ((syntax-match? '(IDENTIFIER ? EXPRESSION) (cdr form))
 
157
         (values (cadr form)
 
158
                 (if (pair? (cddr form))
 
159
                     (caddr form)
 
160
                     (unassigned-expression))))
 
161
        (else
 
162
         (ill-formed-syntax form))))
 
163
 
 
164
(define-syntax :let
 
165
  (er-macro-transformer
 
166
   (lambda (form rename compare)
 
167
     compare                            ;ignore
 
168
     (cond ((syntax-match? '(IDENTIFIER (* (IDENTIFIER ? EXPRESSION)) + FORM)
 
169
                           (cdr form))
 
170
            (let ((name (cadr form))
 
171
                  (bindings (caddr form))
 
172
                  (body (cdddr form)))
 
173
              `((,(rename 'LETREC)
 
174
                 ((,name (,(rename 'NAMED-LAMBDA) (,name ,@(map car bindings))
 
175
                                                  ,@body)))
 
176
                 ,name)
 
177
                ,@(map (lambda (binding)
 
178
                         (if (pair? (cdr binding))
 
179
                             (cadr binding)
 
180
                             (unassigned-expression)))
 
181
                       bindings))))
 
182
           ((syntax-match? '((* (IDENTIFIER ? EXPRESSION)) + FORM) (cdr form))
 
183
            `(,keyword:let ,@(cdr (normalize-let-bindings form))))
 
184
           (else
 
185
            (ill-formed-syntax form))))))
 
186
 
 
187
(define (normalize-let-bindings form)
 
188
  `(,(car form) ,(map (lambda (binding)
 
189
                        (if (pair? (cdr binding))
 
190
                            binding
 
191
                            (list (car binding) (unassigned-expression))))
 
192
                      (cadr form))
 
193
                ,@(cddr form)))
 
194
 
 
195
(define-syntax :let*
 
196
  (er-macro-transformer
 
197
   (lambda (form rename compare)
 
198
     rename compare                     ;ignore
 
199
     (expand/let* form (rename 'LET)))))
 
200
 
 
201
(define-syntax :let*-syntax
 
202
  (er-macro-transformer
 
203
   (lambda (form rename compare)
 
204
     rename compare                     ;ignore
 
205
     (expand/let* form (rename 'LET-SYNTAX)))))
 
206
 
 
207
(define (expand/let* form let-keyword)
 
208
  (syntax-check '(KEYWORD (* DATUM) + FORM) form)
 
209
  (let ((bindings (cadr form))
 
210
        (body (cddr form)))
 
211
    (if (pair? bindings)
 
212
        (let loop ((bindings bindings))
 
213
          (if (pair? (cdr bindings))
 
214
              `(,let-keyword (,(car bindings)) ,(loop (cdr bindings)))
 
215
              `(,let-keyword ,bindings ,@body)))
 
216
        `(,let-keyword ,bindings ,@body))))
 
217
 
 
218
(define-syntax :and
 
219
  (er-macro-transformer
 
220
   (lambda (form rename compare)
 
221
     compare                            ;ignore
 
222
     (syntax-check '(KEYWORD * EXPRESSION) form)
 
223
     (let ((operands (cdr form)))
 
224
       (if (pair? operands)
 
225
           (let ((if-keyword (rename 'IF)))
 
226
             (let loop ((operands operands))
 
227
               (if (pair? (cdr operands))
 
228
                   `(,if-keyword ,(car operands)
 
229
                                 ,(loop (cdr operands))
 
230
                                 #F)
 
231
                   (car operands))))
 
232
           `#T)))))
 
233
 
 
234
(define-syntax :case
 
235
  (er-macro-transformer
 
236
   (lambda (form rename compare)
 
237
     (syntax-check '(KEYWORD EXPRESSION + (DATUM * EXPRESSION)) form)
 
238
     (letrec
 
239
         ((process-clause
 
240
           (lambda (clause rest)
 
241
             (cond ((null? (car clause))
 
242
                    (process-rest rest))
 
243
                   ((and (identifier? (car clause))
 
244
                         (compare (rename 'ELSE) (car clause))
 
245
                         (null? rest))
 
246
                    `(,(rename 'BEGIN) ,@(cdr clause)))
 
247
                   ((list? (car clause))
 
248
                    `(,(rename 'IF) ,(process-predicate (car clause))
 
249
                                    (,(rename 'BEGIN) ,@(cdr clause))
 
250
                                    ,(process-rest rest)))
 
251
                   (else
 
252
                    (syntax-error "Ill-formed clause:" clause)))))
 
253
          (process-rest
 
254
           (lambda (rest)
 
255
             (if (pair? rest)
 
256
                 (process-clause (car rest) (cdr rest))
 
257
                 (unspecific-expression))))
 
258
          (process-predicate
 
259
           (lambda (items)
 
260
             ;; Optimize predicate for speed in compiled code.
 
261
             (cond ((null? (cdr items))
 
262
                    (single-test (car items)))
 
263
                   ((null? (cddr items))
 
264
                    `(,(rename 'OR) ,(single-test (car items))
 
265
                                    ,(single-test (cadr items))))
 
266
                   ((null? (cdddr items))
 
267
                    `(,(rename 'OR) ,(single-test (car items))
 
268
                                    ,(single-test (cadr items))
 
269
                                    ,(single-test (caddr items))))
 
270
                   ((null? (cddddr items))
 
271
                    `(,(rename 'OR) ,(single-test (car items))
 
272
                                    ,(single-test (cadr items))
 
273
                                    ,(single-test (caddr items))
 
274
                                    ,(single-test (cadddr items))))
 
275
                   (else
 
276
                    `(,(rename
 
277
                        (if (for-all? items eq-testable?) 'MEMQ 'MEMV))
 
278
                      ,(rename 'TEMP)
 
279
                      ',items)))))
 
280
          (single-test
 
281
           (lambda (item)
 
282
             `(,(rename (if (eq-testable? item) 'EQ? 'EQV?))
 
283
               ,(rename 'TEMP)
 
284
               ',item)))
 
285
          (eq-testable?
 
286
           (lambda (item)
 
287
             (or (symbol? item)
 
288
                 (boolean? item)
 
289
                 ;; remainder are implementation dependent:
 
290
                 (char? item)
 
291
                 (fix:fixnum? item)))))
 
292
       `(,(rename 'LET) ((,(rename 'TEMP) ,(cadr form)))
 
293
                        ,(process-clause (caddr form)
 
294
                                         (cdddr form)))))))
 
295
 
 
296
(define-syntax :cond
 
297
  (er-macro-transformer
 
298
   (lambda (form rename compare)
 
299
     (let ((clauses (cdr form)))
 
300
       (if (not (pair? clauses))
 
301
           (syntax-error "Form must have at least one clause:" form))
 
302
       (let loop ((clause (car clauses)) (rest (cdr clauses)))
 
303
         (expand/cond-clause clause rename compare (null? rest)
 
304
                             (if (pair? rest)
 
305
                                 (loop (car rest) (cdr rest))
 
306
                                 (unspecific-expression))))))))
 
307
 
 
308
(define-syntax :do
 
309
  (er-macro-transformer
 
310
   (lambda (form rename compare)
 
311
     (syntax-check '(KEYWORD (* (IDENTIFIER EXPRESSION ? EXPRESSION))
 
312
                             (+ FORM)
 
313
                             * FORM)
 
314
                   form)
 
315
     (let ((bindings (cadr form))
 
316
           (r-loop (rename 'DO-LOOP)))
 
317
       `(,(rename 'LET)
 
318
         ,r-loop
 
319
         ,(map (lambda (binding)
 
320
                 (list (car binding) (cadr binding)))
 
321
               bindings)
 
322
         ,(expand/cond-clause (caddr form) rename compare #f
 
323
                              `(,(rename 'BEGIN)
 
324
                                ,@(cdddr form)
 
325
                                (,r-loop ,@(map (lambda (binding)
 
326
                                                  (if (pair? (cddr binding))
 
327
                                                      (caddr binding)
 
328
                                                      (car binding)))
 
329
                                                bindings)))))))))
 
330
 
 
331
(define (expand/cond-clause clause rename compare else-allowed? alternative)
 
332
  (if (not (and (pair? clause) (list? (cdr clause))))
 
333
      (syntax-error "Ill-formed clause:" clause))
 
334
  (cond ((and (identifier? (car clause))
 
335
              (compare (rename 'ELSE) (car clause)))
 
336
         (if (not else-allowed?)
 
337
             (syntax-error "Misplaced ELSE clause:" clause))
 
338
         (if (or (not (pair? (cdr clause)))
 
339
                 (and (identifier? (cadr clause))
 
340
                      (compare (rename '=>) (cadr clause))))
 
341
             (syntax-error "Ill-formed ELSE clause:" clause))
 
342
         `(,(rename 'BEGIN) ,@(cdr clause)))
 
343
        ((not (pair? (cdr clause)))
 
344
         `(,(rename 'OR) ,(car clause) ,alternative))
 
345
        ((and (identifier? (cadr clause))
 
346
              (compare (rename '=>) (cadr clause)))
 
347
         (if (not (and (pair? (cddr clause))
 
348
                       (null? (cdddr clause))))
 
349
             (syntax-error "Ill-formed => clause:" clause))
 
350
         (let ((r-temp (rename 'TEMP)))
 
351
           `(,(rename 'LET) ((,r-temp ,(car clause)))
 
352
                            (,(rename 'IF) ,r-temp
 
353
                                           (,(caddr clause) ,r-temp)
 
354
                                           ,alternative))))
 
355
        (else
 
356
         `(,(rename 'IF) ,(car clause)
 
357
                         (,(rename 'BEGIN) ,@(cdr clause))
 
358
                         ,alternative))))
 
359
 
 
360
(define-syntax :quasiquote
 
361
  (er-macro-transformer
 
362
   (lambda (form rename compare)
 
363
 
 
364
     (define (descend-quasiquote x level return)
 
365
       (cond ((pair? x) (descend-quasiquote-pair x level return))
 
366
             ((vector? x) (descend-quasiquote-vector x level return))
 
367
             (else (return 'QUOTE x))))
 
368
 
 
369
     (define (descend-quasiquote-pair x level return)
 
370
       (cond ((not (and (pair? x)
 
371
                        (identifier? (car x))
 
372
                        (pair? (cdr x))
 
373
                        (null? (cddr x))))
 
374
              (descend-quasiquote-pair* x level return))
 
375
             ((compare (rename 'QUASIQUOTE) (car x))
 
376
              (descend-quasiquote-pair* x (+ level 1) return))
 
377
             ((compare (rename 'UNQUOTE) (car x))
 
378
              (if (zero? level)
 
379
                  (return 'UNQUOTE (cadr x))
 
380
                  (descend-quasiquote-pair* x (- level 1) return)))
 
381
             ((compare (rename 'UNQUOTE-SPLICING) (car x))
 
382
              (if (zero? level)
 
383
                  (return 'UNQUOTE-SPLICING (cadr x))
 
384
                  (descend-quasiquote-pair* x (- level 1) return)))
 
385
             (else
 
386
              (descend-quasiquote-pair* x level return))))
 
387
 
 
388
     (define (descend-quasiquote-pair* x level return)
 
389
       (descend-quasiquote (car x) level
 
390
         (lambda (car-mode car-arg)
 
391
           (descend-quasiquote (cdr x) level
 
392
             (lambda (cdr-mode cdr-arg)
 
393
               (cond ((and (eq? car-mode 'QUOTE) (eq? cdr-mode 'QUOTE))
 
394
                      (return 'QUOTE x))
 
395
                     ((eq? car-mode 'UNQUOTE-SPLICING)
 
396
                      (if (and (eq? cdr-mode 'QUOTE) (null? cdr-arg))
 
397
                          (return 'UNQUOTE car-arg)
 
398
                          (return 'APPEND
 
399
                                  (list car-arg
 
400
                                        (finalize-quasiquote cdr-mode
 
401
                                                             cdr-arg)))))
 
402
                     ((and (eq? cdr-mode 'QUOTE) (list? cdr-arg))
 
403
                      (return 'LIST
 
404
                              (cons (finalize-quasiquote car-mode car-arg)
 
405
                                    (map (lambda (element)
 
406
                                           (finalize-quasiquote 'QUOTE
 
407
                                                                element))
 
408
                                         cdr-arg))))
 
409
                     ((eq? cdr-mode 'LIST)
 
410
                      (return 'LIST
 
411
                              (cons (finalize-quasiquote car-mode car-arg)
 
412
                                    cdr-arg)))
 
413
                     (else
 
414
                      (return
 
415
                       'CONS
 
416
                       (list (finalize-quasiquote car-mode car-arg)
 
417
                             (finalize-quasiquote cdr-mode cdr-arg))))))))))
 
418
 
 
419
     (define (descend-quasiquote-vector x level return)
 
420
       (descend-quasiquote (vector->list x) level
 
421
         (lambda (mode arg)
 
422
           (case mode
 
423
             ((QUOTE) (return 'QUOTE x))
 
424
             ((LIST) (return 'VECTOR arg))
 
425
             (else
 
426
              (return 'LIST->VECTOR
 
427
                      (list (finalize-quasiquote mode arg))))))))
 
428
 
 
429
     (define (finalize-quasiquote mode arg)
 
430
       (case mode
 
431
         ((QUOTE) `(,(rename 'QUOTE) ,arg))
 
432
         ((UNQUOTE) arg)
 
433
         ((UNQUOTE-SPLICING) (syntax-error ",@ in illegal context:" arg))
 
434
         (else `(,(rename mode) ,@arg))))
 
435
 
 
436
     (syntax-check '(KEYWORD EXPRESSION) form)
 
437
     (descend-quasiquote (cadr form) 0 finalize-quasiquote))))
 
438
 
 
439
;;;; SRFI 2: AND-LET*
 
440
 
 
441
;;; The SRFI document is a little unclear about the semantics, imposes
 
442
;;; the weird restriction that variables may be duplicated (citing
 
443
;;; LET*'s similar restriction, which doesn't actually exist), and the
 
444
;;; reference implementation is highly non-standard and hard to
 
445
;;; follow.  This passes all of the tests except for the one that
 
446
;;; detects duplicate bound variables, though.
 
447
 
 
448
(define-syntax :and-let*
 
449
  (er-macro-transformer
 
450
   (lambda (form rename compare)
 
451
     compare
 
452
     (let ((%and (rename 'AND))
 
453
           (%let (rename 'LET))
 
454
           (%begin (rename 'BEGIN)))
 
455
       (cond ((syntax-match? '(() * FORM) (cdr form))
 
456
              `(,%begin #T ,@(cddr form)))
 
457
             ((syntax-match? '((* DATUM) * FORM) (cdr form))
 
458
              (let ((clauses (cadr form))
 
459
                    (body (cddr form)))
 
460
                (define (expand clause recur)
 
461
                  (cond ((syntax-match? 'IDENTIFIER clause)
 
462
                         (recur clause))
 
463
                        ((syntax-match? '(EXPRESSION) clause)
 
464
                         (recur (car clause)))
 
465
                        ((syntax-match? '(IDENTIFIER EXPRESSION) clause)
 
466
                         (let ((tail (recur (car clause))))
 
467
                           (and tail `(,%let (,clause) ,tail))))
 
468
                        (else #f)))
 
469
                (define (recur clauses make-body)
 
470
                  (expand (car clauses)
 
471
                          (let ((clauses (cdr clauses)))
 
472
                            (if (null? clauses)
 
473
                                make-body
 
474
                                (lambda (conjunct)
 
475
                                  `(,%and ,conjunct
 
476
                                          ,(recur clauses make-body)))))))
 
477
                (or (recur clauses
 
478
                           (if (null? body)
 
479
                               (lambda (conjunct) conjunct)
 
480
                               (lambda (conjunct)
 
481
                                 `(,%and ,conjunct (,%begin ,@body)))))
 
482
                    (ill-formed-syntax form))))
 
483
             (else
 
484
              (ill-formed-syntax form)))))))
 
485
 
 
486
(define-syntax :access
 
487
  (er-macro-transformer
 
488
   (lambda (form rename compare)
 
489
     rename compare                     ;ignore
 
490
     (cond ((syntax-match? '(IDENTIFIER EXPRESSION) (cdr form))
 
491
            `(,keyword:access ,@(cdr form)))
 
492
           ((syntax-match? '(IDENTIFIER IDENTIFIER + FORM) (cdr form))
 
493
            `(,keyword:access ,(cadr form) (,(car form) ,@(cddr form))))
 
494
           (else
 
495
            (ill-formed-syntax form))))))
 
496
 
 
497
(define-syntax :cons-stream
 
498
  (er-macro-transformer
 
499
   (lambda (form rename compare)
 
500
     compare                            ;ignore
 
501
     (syntax-check '(KEYWORD EXPRESSION EXPRESSION) form)
 
502
     `(,(rename 'CONS) ,(cadr form)
 
503
                       (,(rename 'DELAY) ,(caddr form))))))
 
504
 
 
505
(define-syntax :define-integrable
 
506
  (er-macro-transformer
 
507
   (lambda (form rename compare)
 
508
     compare                            ;ignore
 
509
     (let ((r-begin (rename 'BEGIN))
 
510
           (r-declare (rename 'DECLARE))
 
511
           (r-define (rename 'DEFINE)))
 
512
       (cond ((syntax-match? '(IDENTIFIER EXPRESSION) (cdr form))
 
513
              `(,r-begin
 
514
                (,r-declare (INTEGRATE ,(cadr form)))
 
515
                (,r-define ,@(cdr form))))
 
516
             ((syntax-match? '((IDENTIFIER * IDENTIFIER) + FORM) (cdr form))
 
517
              `(,r-begin
 
518
                (,r-declare (INTEGRATE-OPERATOR ,(caadr form)))
 
519
                (,r-define ,(cadr form)
 
520
                           (,r-declare (INTEGRATE ,@(cdadr form)))
 
521
                           ,@(cddr form))))
 
522
             (else
 
523
              (ill-formed-syntax form)))))))
 
524
 
 
525
(define-syntax :fluid-let
 
526
  (er-macro-transformer
 
527
   (lambda (form rename compare)
 
528
     compare
 
529
     (syntax-check '(KEYWORD (* (FORM ? EXPRESSION)) + FORM) form)
 
530
     (let ((names (map car (cadr form)))
 
531
           (r-let (rename 'LET))
 
532
           (r-lambda (rename 'LAMBDA))
 
533
           (r-set! (rename 'SET!)))
 
534
       (let ((out-temps
 
535
              (map (lambda (name)
 
536
                     name
 
537
                     (make-synthetic-identifier 'OUT-TEMP))
 
538
                   names))
 
539
             (in-temps
 
540
              (map (lambda (name)
 
541
                     name
 
542
                     (make-synthetic-identifier 'IN-TEMP))
 
543
                   names))
 
544
             (swap
 
545
              (lambda (tos names froms)
 
546
                `(,r-lambda ()
 
547
                            ,@(map (lambda (to name from)
 
548
                                     `(,r-set! ,to
 
549
                                               (,r-set! ,name
 
550
                                                        (,r-set! ,from))))
 
551
                                   tos
 
552
                                   names
 
553
                                   froms)
 
554
                            ,(unspecific-expression)))))
 
555
         `(,r-let (,@(map cons in-temps (map cdr (cadr form)))
 
556
                   ,@(map list out-temps))
 
557
                  (,(rename 'SHALLOW-FLUID-BIND)
 
558
                   ,(swap out-temps names in-temps)
 
559
                   (,r-lambda () ,@(cddr form))
 
560
                   ,(swap in-temps names out-temps))))))))
 
561
 
 
562
(define (unspecific-expression)
 
563
  `(,keyword:unspecific))
 
564
 
 
565
(define (unassigned-expression)
 
566
  `(,keyword:unassigned))
 
 
b'\\ No newline at end of file'