← Back to branch summary

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

« back to all changes in this revision

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

  • Committer: Package Import Robot
  • Author(s): Chris Hanson
  • Date: 2011-10-15 03:08:33 UTC
  • mfrom: (1.1.8) (3.1.7 sid)
  • Revision ID: package-import@ubuntu.com-20111015030833-x7qc6yxuulvxbafv
Tags: 9.1-1
* New upstream.
* debian/control, debian/copyright, debian/mit-scheme-doc.*,
  debian/mit-scheme.install, debian/rules, Upstream has removed cover
  texts from documentation licenses, so merge packages mit-scheme and
  mit-scheme-doc back together.
* debian/compat: Bump to current version.
* debian/control: Bump standards-version to current and make
  necessary changes.
* debian/rules: Fix lintian warnings.

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/runtime/mit-macros.scm
1
 
#| -*-Scheme-*-
 
1
#| -*- Mode: Scheme; keyword-style: none -*-
2
2
 
3
3
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
4
4
    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
5
 
    2006, 2007, 2008, 2009, 2010 Massachusetts Institute of Technology
 
5
    2006, 2007, 2008, 2009, 2010, 2011 Massachusetts Institute of
 
6
    Technology
6
7
 
7
8
This file is part of MIT/GNU Scheme.
8
9
 
84
85
(define supported-srfi-features
85
86
  '(MIT
86
87
    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
 
88
    SWANK                      ;Provides SWANK module for SLIME
 
89
    SRFI-0                     ;COND-EXPAND
 
90
    SRFI-1                     ;List Library
 
91
    SRFI-2                     ;AND-LET*
 
92
    SRFI-6                     ;Basic String Ports
 
93
    SRFI-8                     ;RECEIVE
 
94
    SRFI-9                     ;DEFINE-RECORD-TYPE
 
95
    SRFI-23                    ;ERROR
 
96
    SRFI-27                    ;Sources of Random Bits
 
97
    SRFI-30                    ;Nested Multi-Line Comments (#| ... |#)
 
98
    SRFI-62                    ;S-expression comments
 
99
    SRFI-69                    ;Basic Hash Tables
98
100
    ))
99
101
 
100
102
(define-syntax :receive
102
104
   (lambda (form rename compare)
103
105
     compare                            ;ignore
104
106
     (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)))
 
107
         (let ((r-lambda (rename 'LAMBDA)))
 
108
           `(,(rename 'CALL-WITH-VALUES)
 
109
             (,r-lambda () ,(caddr form))
 
110
             (,r-lambda ,(cadr form) ,@(cdddr form))))
108
111
         (ill-formed-syntax form)))))
109
112
 
110
113
(define-syntax :define-record-type
161
164
        (else
162
165
         (ill-formed-syntax form))))
163
166
 
 
167
(define named-let-strategy 'letrec)
 
168
 
164
169
(define-syntax :let
165
170
  (er-macro-transformer
166
171
   (lambda (form rename compare)
170
175
            (let ((name (cadr form))
171
176
                  (bindings (caddr form))
172
177
                  (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))))
 
178
              (case named-let-strategy
 
179
                ((letrec)
 
180
                 `((,(rename 'LETREC)
 
181
                    ((,name (,(rename 'NAMED-LAMBDA) (,name ,@(map car bindings))
 
182
                             ,@body)))
 
183
                    ,name)
 
184
                   ,@(map (lambda (binding)
 
185
                            (if (pair? (cdr binding))
 
186
                                (cadr binding)
 
187
                                (unassigned-expression)))
 
188
                          bindings)))
 
189
                ((fixed-point)
 
190
                 (let ((iter (make-synthetic-identifier 'ITER))
 
191
                       (kernel (make-synthetic-identifier 'KERNEL))
 
192
                       (temps (map (lambda (b)
 
193
                                     (declare (ignore b))
 
194
                                     (make-synthetic-identifier 'TEMP)) bindings))
 
195
                       (r-lambda (rename 'LAMBDA))
 
196
                       (r-declare (rename 'DECLARE)))
 
197
                   `((,r-lambda (,kernel)
 
198
                      (,kernel ,kernel ,@(map (lambda (binding)
 
199
                                                (if (pair? (cdr binding))
 
200
                                                    (cadr binding)
 
201
                                                    (unassigned-expression)))
 
202
                                              bindings)))
 
203
                     (,r-lambda (,iter ,@(map car bindings))
 
204
                      ((,r-lambda (,name)
 
205
                        (,r-declare (INTEGRATE-OPERATOR ,name))
 
206
                        ,@body)
 
207
                       (,r-lambda ,temps
 
208
                        (,r-declare (INTEGRATE ,@temps))
 
209
                        (,iter ,iter ,@temps)))))))
 
210
                (else (error "Unrecognized named-let-strategy: " named-let-strategy)))))
182
211
           ((syntax-match? '((* (IDENTIFIER ? EXPRESSION)) + FORM) (cdr form))
183
212
            `(,keyword:let ,@(cdr (normalize-let-bindings form))))
184
213
           (else
195
224
(define-syntax :let*
196
225
  (er-macro-transformer
197
226
   (lambda (form rename compare)
198
 
     rename compare                     ;ignore
 
227
     compare                    ;ignore
199
228
     (expand/let* form (rename 'LET)))))
200
229
 
201
230
(define-syntax :let*-syntax
202
231
  (er-macro-transformer
203
232
   (lambda (form rename compare)
204
 
     rename compare                     ;ignore
 
233
     compare                    ;ignore
205
234
     (expand/let* form (rename 'LET-SYNTAX)))))
206
235
 
207
236
(define (expand/let* form let-keyword)
527
556
   (lambda (form rename compare)
528
557
     compare
529
558
     (syntax-check '(KEYWORD (* (FORM ? EXPRESSION)) + FORM) form)
530
 
     (let ((names (map car (cadr form)))
 
559
     (let ((left-hand-sides (map car (cadr form)))
 
560
           (right-hand-sides (map cdr (cadr form)))
 
561
           (r-define (rename 'DEFINE))
 
562
           (r-lambda (rename 'LAMBDA))
531
563
           (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))))))))
 
564
           (r-set! (rename 'SET!))
 
565
           (r-shallow-fluid-bind (rename 'SHALLOW-FLUID-BIND))
 
566
           (r-unspecific (rename 'UNSPECIFIC)))
 
567
       (let ((temporaries
 
568
              (map (lambda (lhs)
 
569
                     (make-synthetic-identifier
 
570
                      (if (identifier? lhs) lhs 'TEMPORARY)))
 
571
                   left-hand-sides))
 
572
             (swap! (make-synthetic-identifier 'SWAP!))
 
573
             (body `(,r-lambda () ,@(cddr form))))
 
574
         `(,r-let ,(map cons temporaries right-hand-sides)
 
575
            (,r-define (,swap!)
 
576
              ,@(map (lambda (lhs temporary)
 
577
                       `(,r-set! ,lhs (,r-set! ,temporary (,r-set! ,lhs))))
 
578
                     left-hand-sides
 
579
                     temporaries)
 
580
              ,r-unspecific)
 
581
            (,r-shallow-fluid-bind ,swap! ,body ,swap!)))))))
561
582
 
562
583
(define (unspecific-expression)
563
584
  `(,keyword:unspecific))
564
585
 
565
586
(define (unassigned-expression)
566
 
  `(,keyword:unassigned))
 
 
b'\\ No newline at end of file'
 
587
  `(,keyword:unassigned))
 
588
 
 
589
(define-syntax :begin0
 
590
  (syntax-rules ()
 
591
    ((BEGIN0 form0 form1+ ...)
 
592
     (LET ((RESULT form0))
 
593
       form1+ ...
 
594
       RESULT))))
 
 
b'\\ No newline at end of file'