Changeset 10322 in project


Ignore:
Timestamp:
04/03/08 08:10:44 (12 years ago)
Author:
Alex Shinn
Message:

Adding support for compiled syntax extensions.

Location:
release/3/riaxpander
Files:
1 added
5 edited

Legend:

Unmodified
Added
Removed
  • release/3/riaxpander/chicken-init.scm

    r9373 r10322  
    88(register-feature! 'syntax-rules 'hygienic-macros 'syntactic-closures)
    99
    10 (unless (memq #:standard-syntax ##sys#features)
    11   (load (##sys#resolve-include-filename "riaxpander-chicken-macros.scm" #t #t)))
     10(cond
     11 ((and (not (memq #:standard-syntax ##sys#features))
     12       (not (memq #:bootstrapping-riaxpander ##sys#features)))
     13  (load
     14   (or (##sys#resolve-include-filename "riaxpander-chicken-macros.so" #t #t)
     15       (##sys#resolve-include-filename "riaxpander-chicken-macros.scm" #t #t)))
     16  (load (##sys#resolve-include-filename "riaxpander-dsssl-lambda.scm" #t #t))))
    1217
  • release/3/riaxpander/chicken.scm

    r9885 r10322  
    4444    identifier->symbol
    4545    ##sys#ria-expand-extended-lambda-list
     46    ;; these are for compiled macros - a consistent API should be
     47    ;; decided on and made compatible with the syntactic-closures egg
     48    riaxpander:top-level-environment
     49    syntactic-bind!
     50    make-alias-generator
     51    make-name-comparator
     52    make-keyword
     53    make-transformer
    4654    ;++ more exports
    4755    ))
     
    9098
    9199(define (riaxpander:expand-toplevel form)
    92   (riaxpander:expand form
    93                      (or riaxpander:top-level-environment
    94                          (make-chicken-environment))))
     100  (set! chicken-new-syntax-definitions '())
     101  (let ((form*
     102         (riaxpander:expand form
     103                            (or riaxpander:top-level-environment
     104                                (make-chicken-environment)))))
     105    (cond
     106     ((and (pair? chicken-new-syntax-definitions)
     107           (feature? 'compiling 'compile-syntax)
     108           (not ##sys#current-source-filename))
     109      ;; include code to install the compiled macros at load time
     110      `(begin
     111         ,@(filter-map chicken-expand-toplevel-syntax-definition
     112                       chicken-new-syntax-definitions)
     113         ,form*))
     114     (else
     115      form*))))
     116
     117(define (chicken-expand-toplevel-syntax-definition name)
     118  (and-let* ((transformer
     119              (syntactic-lookup riaxpander:top-level-environment name))
     120             (source (transformer/source transformer))
     121             (form
     122              (chicken-strip-syntactic-closures
     123               source
     124               riaxpander:top-level-environment)))
     125    (cond
     126     ((pair? form)
     127      (case (car form)
     128        ((rsc-macro-transformer)
     129         (chicken-expand-rsc-macro-transformer name form))
     130        ((sc-macro-transformer)
     131         (chicken-expand-sc-macro-transformer name form))
     132        ((er-macro-transformer)
     133         (chicken-expand-er-macro-transformer name form))
     134        (else
     135         (warning "non-standard syntax transformer" name form)
     136         `(syntactic-bind! riaxpander:top-level-environment ',name ,form))))
     137     (else
     138      (warning "non-standard syntax transformer" name form)
     139      `(syntactic-bind! riaxpander:top-level-environment ',name ,form)))))
     140
     141(define (chicken-expand-rsc-macro-transformer name form)
     142  (let ((expr (gensym 'expr))
     143        (use-env (gensym 'use-env))
     144        (close-env (gensym 'close-env)))
     145    `(syntactic-bind!
     146      riaxpander:top-level-environment
     147      ',name
     148      (make-transformer riaxpander:top-level-environment
     149                        ,(and (pair? (cddr form)) (list 'quote (caddr form)))
     150                        (lambda (,expr ,use-env ,close-env)
     151                          (,(cadr form) ,expr ,close-env))
     152                        #f))))
     153
     154(define (chicken-expand-sc-macro-transformer name form)
     155  (let ((expr (gensym 'expr))
     156        (use-env (gensym 'use-env))
     157        (close-env (gensym 'close-env)))
     158    `(syntactic-bind!
     159      riaxpander:top-level-environment
     160      ',name
     161      (make-transformer riaxpander:top-level-environment
     162                        ,(and (pair? (cddr form)) (list 'quote (caddr form)))
     163                        (lambda (,expr ,use-env ,close-env)
     164                          (close-syntax (,(cadr form) ,expr ,use-env)
     165                                        ,close-env))
     166                        #f))))
     167
     168(define (chicken-expand-er-macro-transformer name form)
     169  (let ((expr (gensym 'expr))
     170        (use-env (gensym 'use-env))
     171        (close-env (gensym 'close-env)))
     172    `(syntactic-bind!
     173      riaxpander:top-level-environment
     174      ',name
     175      (make-transformer riaxpander:top-level-environment
     176                        ,(and (pair? (cddr form)) (list 'quote (caddr form)))
     177                        (lambda (,expr ,use-env ,close-env)
     178                          (,(cadr form)
     179                           ,expr
     180                           (make-alias-generator ,close-env)
     181                           (make-name-comparator ,use-env)))
     182                        #f))))
     183
     184;; XXXX use qualified names - since we currently have no modules and
     185;; all top-level macros just reference the same top-level namespace,
     186;; this isn't essential yet
     187(define (chicken-strip-syntactic-closures expr env)
     188  (let strip ((x expr))
     189    (cond
     190     ((pair? x)
     191      ;; XXXX hygienically strip syntax-quote
     192      (if (or (eq? 'syntax-quote (car x))
     193              (and (syntactic-closure? (car x))
     194                   (eq? 'syntax-quote (syntactic-closure/form (car x)))))
     195          (list 'quote (strip (cadr x)))
     196          (cons (strip (car x)) (strip (cdr x)))))
     197     ((syntactic-closure? x)
     198      (strip (syntactic-closure/form x)))
     199     (else
     200      x))))
    95201
    96202(define riaxpander:top-level-environment #f)
     203(define chicken-new-syntax-definitions '())
    97204
    98205(define (riaxpander:install)
     
    240347             (else #f)))
    241348     (lambda (environment name denotation) ;bind!
     349       (set! chicken-new-syntax-definitions
     350             (cons name chicken-new-syntax-definitions))
    242351       (set-global-bindings! environment
    243352                             (cons (cons name denotation)
  • release/3/riaxpander/riaxpander-chicken-macros.scm

    r9399 r10322  
    11;;;; riaxpander-chicken-macros.scm
    2 ;;;; (taken from syntactic-closures-chicken-macros.scm)
     2;;;; (adapted from syntactic-closures-chicken-macros.scm)
    33
    44(define-syntax define-macro
     
    88       (rsc-macro-transformer
    99        (lambda (exp env)
    10           (apply (lambda llist . body) (cdr exp)) ) ) ) )
     10          (apply (lambda llist . body) (cdr exp))))))
    1111    ((_ id expander)
    1212     (define-syntax id
    1313       (rsc-macro-transformer
    1414        (lambda (exp env)
    15           (apply expander (cdr exp)) ) ) ) ) ) )
     15          (apply expander (cdr exp))))))))
     16
     17(define-syntax include
     18  (rsc-macro-transformer
     19   (lambda (exp env)
     20     (syntax-check '(keyword expression) exp)
     21     (let ((filename (cadr exp)))
     22       (let ((path (##sys#resolve-include-filename filename #t)))
     23         (if (load-verbose) (print "; including " path " ..."))
     24         `(,(make-syntactic-closure env '() 'begin)
     25           ,@(with-input-from-file path
     26               (lambda ()
     27                 (do ((x (read) (read))
     28                      (xs '() (cons x xs)))
     29                     ((eof-object? x)
     30                      (reverse xs)))))))))))
    1631
    1732(define-syntax cond-expand
     
    4156                              (if (pair? rest)
    4257                                  (and (test (##sys#slot rest 0))
    43                                        (test `(and ,@(##sys#slot rest 1))) )
    44                                   (err fx) ) ) )
     58                                       (test `(and ,@(##sys#slot rest 1))))
     59                                  (err fx))))
    4560                         ((or)
    4661                          (and (not (eq? rest '()))
    4762                               (if (pair? rest)
    4863                                   (or (test (##sys#slot rest 0))
    49                                        (test `(or ,@(##sys#slot rest 1))) )
    50                                    (err fx) ) ) )
     64                                       (test `(or ,@(##sys#slot rest 1))))
     65                                   (err fx))))
    5166                         ((not) (not (test (cadr fx))))
    5267                         (else (err fx)))
    53                        (err fx)) ))))
     68                       (err fx))))))
    5469
    5570        (let ((clauses (cdr form)))
     
    5873                   (##sys#apply
    5974                    ##sys#error "no matching clause in `cond-expand' form"
    60                     (map car clauses) ) )
     75                    (map car clauses)))
    6176                  ((not (pair? cls)) (err cls))
    6277                  (else
    6378                   (let ((clause (##sys#slot cls 0))
    64                          (rclauses (##sys#slot cls 1)) )
     79                         (rclauses (##sys#slot cls 1)))
    6580                     (if (not (pair? clause))
    6681                         (err clause)
     
    7085                                    (if (null? rest)
    7186                                        '(##core#undefined)
    72                                         `(begin ,@(close-forms rest)) ) ) )
     87                                        `(begin ,@(close-forms rest)))))
    7388                                 ((test id) `(begin ,@(close-forms
    7489                                                       (##sys#slot clause 1))))
    75                                  (else (expand rclauses)) ) ) ) ) ) ) ) ) ) ) ) ) )
    76 
    77 (define-syntax include
    78   (rsc-macro-transformer
    79    (lambda (exp env)
    80      (syntax-check '(keyword expression) exp)
    81      (let ((filename (cadr exp)))
    82        (let ((path (##sys#resolve-include-filename filename #t)))
    83          (when (load-verbose) (print "; including " path " ..."))
    84          `(,(make-syntactic-closure env '() 'begin)
    85            ,@(with-input-from-file path
    86                (lambda ()
    87                  (do ([x (read) (read)]
    88                       [xs '() (cons x xs)] )
    89                      ((eof-object? x)
    90                       (reverse xs))) ) ) ) ) ))))
     90                                 (else (expand rclauses)))))))))))))))
     91
     92(define-syntax when
     93  (syntax-rules ()
     94    ((_ x y z ...) (if x (begin y z ...)))))
     95
     96(define-syntax unless
     97  (syntax-rules ()
     98    ((_ x y z ...) (if x (##core#undefined) (begin y z ...)))))
    9199
    92100(define-syntax receive
    93101  (syntax-rules ()
    94     [(_ vars) (##sys#call-with-values (lambda () vars) ##sys#list)]
    95     [(_ vars x0 x1 x2 ...)
     102    ((_ vars) (##sys#call-with-values (lambda () vars) ##sys#list))
     103    ((_ vars x0 x1 x2 ...)
    96104     (##sys#call-with-values
    97105      (lambda () x0)
    98       (lambda vars x1 x2 ...) ) ] ) )
     106      (lambda vars x1 x2 ...)))))
    99107
    100108(define-syntax time
     
    107115        (lambda tmp
    108116          (##sys#display-times (##sys#stop-timer))
    109           (##sys#apply ##sys#values tmp) ) ) ) ) ) )
     117          (##sys#apply ##sys#values tmp)))))))
    110118
    111119(define-syntax assert
    112120  (syntax-rules ()
    113     [(_ exp)
    114      (assert exp (##core#immutable '"assertion failed")) ]
    115     [(_ exp msg arg1 ...)
     121    ((_ exp)
     122     (assert exp (##core#immutable '"assertion failed")))
     123    ((_ exp msg arg1 ...)
    116124     (if (##core#check exp)
    117125         (##core#undefined)
    118          (##sys#error msg 'exp arg1 ...) ) ] ) )
     126         (##sys#error msg 'exp arg1 ...)))))
    119127
    120128(define-syntax ensure
    121129  (syntax-rules ()
    122     [(_ pred exp)
    123      (let ([tmp exp])
     130    ((_ pred exp)
     131     (let ((tmp exp))
    124132       (if (##core#check (pred tmp))
    125133           tmp
    126            (##sys#error (##core#immutable '"argument has incorrect type") tmp 'pred))) ]
    127     [(_ pred exp arg1 arg2 ...)
     134           (##sys#error (##core#immutable '"argument has incorrect type") tmp 'pred))))
     135    ((_ pred exp arg1 arg2 ...)
    128136     (let ((tmp exp))
    129137       (if (##core#check (pred tmp))
    130138           tmp
    131            (##sys#error arg1 arg2 ...))) ] ) )
     139           (##sys#error arg1 arg2 ...))))))
    132140
    133141(define-syntax case-lambda              ; (reference implementation)
    134142  (syntax-rules ()
    135       ((case-lambda
    136         (?a1 ?e1 ...)
    137         ?clause1 ...)
    138        (lambda args
    139         (let ((l (length args)))
    140            (case-lambda "CLAUSE" args l
    141                         (?a1 ?e1 ...)
    142                         ?clause1 ...))))
    143       ((case-lambda "CLAUSE" ?args ?l
    144                     ((?a1 ...) ?e1 ...)
    145                     ?clause1 ...)
    146        (if (eq? ?l (length '(?a1 ...)))
    147            (##sys#apply (lambda (?a1 ...) ?e1 ...) ?args)
    148            (case-lambda "CLAUSE" ?args ?l
    149                         ?clause1 ...)))
    150       ((case-lambda "CLAUSE" ?args ?l
    151                     ((?a1 . ?ar) ?e1 ...)
    152                     ?clause1 ...)
    153        (case-lambda "IMPROPER" ?args ?l 1 (?a1 . ?ar) (?ar ?e1 ...)
    154                     ?clause1 ...))
    155       ((case-lambda "CLAUSE" ?args ?l
    156                     (?a1 ?e1 ...)
    157                     ?clause1 ...)
    158        (let ((?a1 ?args))
    159         ?e1 ...))
    160       ((case-lambda "CLAUSE" ?args ?l)
    161        (##core#check (##sys#error (##core#immutable '"wrong number of arguments to CASE-LAMBDA."))))
    162       ((case-lambda "IMPROPER" ?args ?l ?k ?al ((?a1 . ?ar) ?e1 ...)
    163                     ?clause1 ...)
    164        (case-lambda "IMPROPER" ?args ?l (+ ?k 1) ?al (?ar ?e1 ...)
    165                     ?clause1 ...))
    166       ((case-lambda "IMPROPER" ?args ?l ?k ?al (?ar ?e1 ...)
    167                     ?clause1 ...)
    168        (if (fx>= ?l ?k)
    169            (##sys#apply (lambda ?al ?e1 ...) ?args)
    170            (case-lambda "CLAUSE" ?args ?l
    171                         ?clause1 ...)))))
     143    ((case-lambda
     144      (?a1 ?e1 ...)
     145      ?clause1 ...)
     146     (lambda args
     147      (let ((l (length args)))
     148         (case-lambda "CLAUSE" args l
     149                      (?a1 ?e1 ...)
     150                      ?clause1 ...))))
     151    ((case-lambda "CLAUSE" ?args ?l
     152                  ((?a1 ...) ?e1 ...)
     153                  ?clause1 ...)
     154     (if (eq? ?l (length '(?a1 ...)))
     155         (##sys#apply (lambda (?a1 ...) ?e1 ...) ?args)
     156         (case-lambda "CLAUSE" ?args ?l
     157                      ?clause1 ...)))
     158    ((case-lambda "CLAUSE" ?args ?l
     159                  ((?a1 . ?ar) ?e1 ...)
     160                  ?clause1 ...)
     161     (case-lambda "IMPROPER" ?args ?l 1 (?a1 . ?ar) (?ar ?e1 ...)
     162                  ?clause1 ...))
     163    ((case-lambda "CLAUSE" ?args ?l
     164                  (?a1 ?e1 ...)
     165                  ?clause1 ...)
     166     (let ((?a1 ?args))
     167      ?e1 ...))
     168    ((case-lambda "CLAUSE" ?args ?l)
     169     (##core#check (##sys#error (##core#immutable '"wrong number of arguments to CASE-LAMBDA."))))
     170    ((case-lambda "IMPROPER" ?args ?l ?k ?al ((?a1 . ?ar) ?e1 ...)
     171                  ?clause1 ...)
     172     (case-lambda "IMPROPER" ?args ?l (+ ?k 1) ?al (?ar ?e1 ...)
     173                  ?clause1 ...))
     174    ((case-lambda "IMPROPER" ?args ?l ?k ?al (?ar ?e1 ...)
     175                  ?clause1 ...)
     176     (if (fx>= ?l ?k)
     177         (##sys#apply (lambda ?al ?e1 ...) ?args)
     178         (case-lambda "CLAUSE" ?args ?l
     179                      ?clause1 ...)))))
    172180
    173181(define-syntax and-let*
    174    (syntax-rules ()
    175       ((and-let* () body ...)
    176        (begin body ...))
    177 
    178       ((and-let* ((var expr) clauses ...) body ...)
    179        (let ((var expr))
    180           (if var (and-let* (clauses ...) body ...) #f)))
    181 
    182       ((and-let* ((expr) clauses ...) body ...)
    183        (if expr (and-let* (clauses ...) body ...) #f))
    184      
    185       ((and-let* (var clauses ...) body ...)
    186        (if var (and-let* (clauses ...) body ...) #f))))
    187 
    188 (define-syntax when
    189   (syntax-rules ()
    190     [(_ x y z ...) (if x (begin y z ...))] ) )
    191 
    192 (define-syntax unless
    193   (syntax-rules ()
    194     [(_ x y z ...) (if x (##core#undefined) (begin y z ...))] ) )
     182  (syntax-rules ()
     183    ((and-let* () body ...)
     184     (begin body ...))
     185
     186    ((and-let* ((var expr) clauses ...) body ...)
     187     (let ((var expr))
     188       (if var (and-let* (clauses ...) body ...) #f)))
     189
     190    ((and-let* ((expr) clauses ...) body ...)
     191     (if expr (and-let* (clauses ...) body ...) #f))
     192   
     193    ((and-let* (var clauses ...) body ...)
     194     (if var (and-let* (clauses ...) body ...) #f))))
    195195
    196196(define-syntax let*-values
    197197  (syntax-rules ()
    198     [(_ () exp1 ...) (let () exp1 ...)]
    199     [(_ (binding0 binding1 ...) exp0 exp1 ...)
     198    ((_ () exp1 ...) (let () exp1 ...))
     199    ((_ (binding0 binding1 ...) exp0 exp1 ...)
    200200     (let-values (binding0)
    201        (let*-values (binding1 ...) exp0 exp1 ...) ) ] ) )
     201       (let*-values (binding1 ...) exp0 exp1 ...)))))
    202202
    203203(define-syntax let-values
     
    233233    ((_ v (k e1 e2 ...))
    234234     (let ((x v))
    235        (if (eqv? x k) (begin e1 e2 ...)) ) )
     235       (if (eqv? x k) (begin e1 e2 ...))))
    236236    ((_ v (k e1 e2 ...) c1 c2 ...)
    237237     (let ((x v))
     
    242242(define-syntax optional
    243243  (syntax-rules ()
    244     [(_ rest default)
     244    ((_ rest default)
    245245     (let ((tmp rest))
    246246       (cond ((null? tmp) default)
    247247             ((null? (cdr tmp)) (car tmp))
    248              (else (##core#check (##sys#error (##core#immutable '"too many optional arguments") tmp)) ) ) ) ] ) )
     248             (else (##core#check (##sys#error (##core#immutable '"too many optional arguments") tmp))))))))
    249249
    250250(define-syntax :optional                ; DEPRECATED
     
    254254(define-syntax let-optionals*
    255255  (syntax-rules ()
    256     [(_ rest () body ...) (let () body ...)]
    257     [(_ rest ((var default) . more) body ...)
     256    ((_ rest () body ...) (let () body ...))
     257    ((_ rest ((var default) . more) body ...)
    258258     (let* ((tmp rest)
    259259            (var (if (null? tmp) default (car tmp)))
    260             (rest2 (if (null? tmp) '() (cdr tmp))) )
    261        (let-optionals* rest2 more body ...) ) ]
    262     [(_ rest (var) body ...) (let ((var rest)) body ...)] ) )
     260            (rest2 (if (null? tmp) '() (cdr tmp))))
     261       (let-optionals* rest2 more body ...)))
     262    ((_ rest (var) body ...) (let ((var rest)) body ...))))
    263263
    264264;; Just generates temp variables for let-optionals*
     
    279279(define-syntax define-inline
    280280  (syntax-rules ()
    281     [(_ head . body)
    282      (define head . body)] ) )
     281    ((_ head . body)
     282     (define head . body))))
    283283
    284284(define-syntax define-constant
    285285  (syntax-rules ()
    286     [(_ name val) (define name val)] ) )
     286    ((_ name val) (define name val))))
    287287
    288288(define-syntax critical-section
    289289  (syntax-rules ()
    290     [(_ body ...)
     290    ((_ body ...)
    291291     (##sys#dynamic-wind
    292292         ##sys#disable-interrupts
    293293         (lambda () body ...)
    294          ##sys#enable-interrupts) ] ) )
     294         ##sys#enable-interrupts))))
    295295
    296296(define-syntax nth-value
    297297  (syntax-rules ()
    298     [(_ i exp)
     298    ((_ i exp)
    299299     (##sys#call-with-values
    300300      (lambda () exp)
    301       (lambda lst (list-ref lst i)) ) ] ) )
     301      (lambda lst (list-ref lst i))))))
    302302
    303303(define-syntax define-record-printer
    304304  (syntax-rules ()
    305     [(_ (name var1 var2) body ...)
    306      (##sys#register-record-printer 'name (lambda (var1 var2) body ...)) ]
    307     [(_ name proc) (##sys#register-record-printer 'name proc)] ) )
     305    ((_ (name var1 var2) body ...)
     306     (##sys#register-record-printer 'name (lambda (var1 var2) body ...)))
     307    ((_ name proc) (##sys#register-record-printer 'name proc))))
    308308
    309309(define-syntax handle-exceptions
     
    321321(define-syntax condition-case
    322322  (syntax-rules ()
    323     [(_ "1" exvar kvar) (##sys#signal exvar)]
    324     [(_ "1" exvar kvar (() body ...) . more) (let () body ...)]
    325     [(_ "1" exvar kvar (var () body ...) . more) (let ([var exvar]) body ...)]
    326     [(_ "1" exvar kvar ((kind ...) body ...) . more)
     323    ((_ "1" exvar kvar) (##sys#signal exvar))
     324    ((_ "1" exvar kvar (() body ...) . more) (let () body ...))
     325    ((_ "1" exvar kvar (var () body ...) . more) (let ((var exvar)) body ...))
     326    ((_ "1" exvar kvar ((kind ...) body ...) . more)
    327327     (if (and kvar (memv 'kind kvar) ...)
    328328         (let () body ...)
    329          (condition-case "1" exvar kvar . more) ) ]
    330     [(_ "1" exvar kvar (var (kind ...) body ...) . more)
     329         (condition-case "1" exvar kvar . more)))
     330    ((_ "1" exvar kvar (var (kind ...) body ...) . more)
    331331     (if (and kvar (memv 'kind kvar) ...)
    332          (let ([var exvar]) body ...)
    333          (condition-case "1" exvar kvar . more) ) ]
    334     [(_ exp clauses ...)
     332         (let ((var exvar)) body ...)
     333         (condition-case "1" exvar kvar . more)))
     334    ((_ exp clauses ...)
    335335     (handle-exceptions exvar
    336          (let ([kvar (and (##sys#structure? exvar 'condition) (##sys#slot exvar 1))])
    337            (condition-case "1" exvar kvar clauses ...) )
    338        exp) ] ) )
     336         (let ((kvar (and (##sys#structure? exvar 'condition) (##sys#slot exvar 1))))
     337           (condition-case "1" exvar kvar clauses ...))
     338       exp))))
    339339
    340340(define-syntax define-class
    341341  (syntax-rules ()
    342     [(_ name () slots)
    343      (define-class name (<object>) slots) ]
    344     [(_ name supers slots)
    345      (define-class name supers slots <class>) ]
    346     [(_ name () slots meta)
    347      (define-class name (<object>) slots meta) ]
    348     [(_ cname (supers ...) (slots ...) meta)
    349      (define cname (make meta 'name 'cname 'direct-supers (list supers ...) 'direct-slots (list 'slots ...))) ] ) )
     342    ((_ name () slots)
     343     (define-class name (<object>) slots))
     344    ((_ name supers slots)
     345     (define-class name supers slots <class>))
     346    ((_ name () slots meta)
     347     (define-class name (<object>) slots meta))
     348    ((_ cname (supers ...) (slots ...) meta)
     349     (define cname (make meta 'name 'cname 'direct-supers (list supers ...) 'direct-slots (list 'slots ...))))))
    350350
    351351(define-syntax define-generic
    352352  (syntax-rules ()
    353     [(_ n class) (define n (make class 'name 'n))]
    354     [(_ n) (define n (make-generic 'n))] ) )
     353    ((_ n class) (define n (make class 'name 'n)))
     354    ((_ n) (define n (make-generic 'n)))))
    355355
    356356(define-syntax require-for-syntax
    357357  (syntax-rules ()
    358     [(_ names ...)
    359      (##core#require-for-syntax names ...) ] ) )
     358    ((_ names ...)
     359     (##core#require-for-syntax names ...))))
    360360
    361361(define-syntax require-extension
    362362  (syntax-rules ()
    363     [(_ names ...) (##core#require-extension 'names ...) ] ) )
     363    ((_ names ...) (##core#require-extension 'names ...))))
    364364
    365365(define-syntax use require-extension)
     
    382382
    383383    ((_ . slots-or-exprs)
    384      (cut "1" () () . slots-or-exprs))) )
     384     (cut "1" () () . slots-or-exprs))))
    385385
    386386(define-syntax cute
     
    423423  (syntax-rules ()
    424424    ((rec (NAME . VARIABLES) . BODY)
    425      (letrec ( (NAME (lambda VARIABLES . BODY)) ) NAME))
     425     (letrec ( (NAME (lambda VARIABLES . BODY))) NAME))
    426426    ((rec NAME EXPRESSION)
    427      (letrec ( (NAME EXPRESSION) ) NAME))))
     427     (letrec ( (NAME EXPRESSION)) NAME))))
    428428
    429429(define-syntax define-record
     
    452452               (lambda ,slots (,(close '##sys#make-structure) ',name ,@slots)))
    453453             (define ,(construct-name prefix name "?")
    454                (lambda (x) (##sys#structure? x ',name)) )
     454               (lambda (x) (##sys#structure? x ',name)))
    455455             ,@(let mapslots ((slots slots) (i 1))
    456456                 (if (eq? slots '())
     
    458458                     (let* ((slotname (identifier->string (##sys#slot slots 0)))
    459459                            (setr (construct-name prefix name "-" slotname "-set!"))
    460                             (getr (construct-name prefix name "-" slotname) ))
     460                            (getr (construct-name prefix name "-" slotname)))
    461461                       (cons
    462462                        `(begin
     
    464464                             (lambda (x val)
    465465                               (##core#check (##sys#check-structure x ',name))
    466                                (##sys#block-set! x ,i val) ))
     466                               (##sys#block-set! x ,i val)))
    467467                           (define ,getr
    468468                             ,(if setters
     
    470470                                    (lambda (x)
    471471                                      (##core#check (##sys#check-structure x ',name))
    472                                       (##sys#block-ref x ,i) )
     472                                      (##sys#block-ref x ,i))
    473473                                    ,setr)
    474474                                  `(lambda (x)
    475475                                     (##core#check (##sys#check-structure x ',name))
    476                                      (##sys#block-ref x ,i) ) ) ) )
    477                         (mapslots (##sys#slot slots 1) (fx+ i 1)) ) ) )))))))))
     476                                     (##sys#block-ref x ,i)))))
     477                        (mapslots (##sys#slot slots 1) (fx+ i 1)))))))))))))
    478478
    479479;; syntactic-closures uses letrec semantics for internal defines, so we
     
    485485       (and (not (null? ids))
    486486            (or (identifier=? env id env (car ids))
    487                 (memi id (cdr ids)) )))
     487                (memi id (cdr ids)))))
    488488     (define (close id)
    489489       (make-syntactic-closure env '() id))
     
    505505                        (if (memi sname vars)
    506506                            sname
    507                             '(##sys#void) ))
     507                            '(##sys#void)))
    508508                      slotnames)))
    509509            (define (,pred x) (##sys#structure? x ',t))
     
    516516                           (getr `(lambda (x)
    517517                                    (##core#check (##sys#check-structure x ',t))
    518                                     (##sys#block-ref x ,i) ) )
     518                                    (##sys#block-ref x ,i)))
    519519                           (get/set (and set setters?
    520520                                         `(set! ,(close get)
     
    523523                              `((define (,set x y)
    524524                                  (##core#check (##sys#check-structure x ',t))
    525                                   (##sys#block-set! x ,i y)) )
    526                               '() )
     525                                  (##sys#block-set! x ,i y)))
     526                              '())
    527527                        (define ,get ,(if get/set (##sys#void) getr))
    528528                        ,@(loop (cdr slots) (add1 i)
     
    555555                    ,exps
    556556                    (provide ',name)
    557                     ,@s) ) )
     557                    ,@s)))
    558558               (let ((t (caar cs))
    559                      (next (cdr cs)) )
     559                     (next (cdr cs)))
    560560                 (cond ((literal=? t 'static)  (loop (cons `(begin ,@(map close (cdar cs))) s) d next exports))
    561561                       ((literal=? t 'dynamic) (loop s (cons `(begin ,@(map close (cdar cs))) d) next exports))
    562562                       ((literal=? t 'export)  (loop s d next (append (or exports '()) (cdar cs))))
    563                        (else (syntax-error 'define-extension "invalid clause specifier" t)) ) )))))))))
     563                       (else (syntax-error 'define-extension "invalid clause specifier" t))))))))))))
    564564
    565565(define-macro (define-for-syntax head . body)
     
    569569    (if (symbol? name)
    570570        (##sys#setslot name 0 (eval body))
    571         (syntax-error 'define-for-syntax "invalid identifier" name) )
     571        (syntax-error 'define-for-syntax "invalid identifier" name))
    572572    (if ##sys#enable-runtime-macros
    573573        `(define ,name ,body)
    574         '(begin) ) ) )
     574        '(begin))))
    575575
    576576(define-syntax fluid-let
     
    596596          (swap! t v) ...))))))
    597597
    598 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    599 ;; support DSSSL-style keywords
    600 
    601 (define-syntax lambda
    602   (let-syntax ((*lambda lambda))
    603     (er-macro-transformer
    604      (lambda (form rename compare)
    605        (receive (standard-bvl body)
    606            (##sys#ria-expand-extended-lambda-list
    607             (cadr form)
    608             (cddr form)
    609             ##sys#syntax-error-hook)
    610          `(,(rename '*lambda) ,standard-bvl ,@body))))))
    611 
  • release/3/riaxpander/riaxpander.meta

    r9399 r10322  
    1818        "transform.scm"
    1919        "riaxpander-chicken-macros.scm"
     20        "riaxpander-dsssl-lambda.scm"
    2021        "transform.scm")
    2122 (license "BSD")
  • release/3/riaxpander/riaxpander.setup

    r9705 r10322  
    33         -o riaxpander.so)
    44
     5(compile -s -i -O2 -Dbootstrapping-riaxpander -Dcompile-syntax
     6         -R riaxpander riaxpander-chicken-macros.scm -d0
     7         -check-imports -emit-exports riaxpander-chicken-macros.exports
     8         -o riaxpander-chicken-macros.so)
     9
    510(install-extension 'riaxpander
    6                    '("riaxpander.so" "riaxpander-chicken-macros.scm")
    7   '((version 0.7)
     11                   '("riaxpander.so"
     12                     "riaxpander-chicken-macros.so"
     13                     "riaxpander-dsssl-lambda.scm")
     14  '((version 0.8)
    815    (documentation "riaxpander.html")
    916    (syntax)
Note: See TracChangeset for help on using the changeset viewer.