Ignore:
Timestamp:
09/29/09 09:20:48 (10 years ago)
Author:
felix
Message:

delegation function argument for ##sys#expand-extended-lambda-list

File:
1 edited

Legend:

Unmodified
Added
Removed
  • chicken/branches/dsssl-delegate/expand.scm

    r16055 r16107  
    410410  (let ([reverse reverse]
    411411        [gensym gensym] )
    412     (lambda (llist0 body errh se)
     412    (lambda (llist0 body errh se delegate)
     413      ;; if `delegate' is non-#f, call it with body, required, rest, optional and keyword
     414      ;; arguments to produce a new body
    413415      (define (err msg) (errh msg llist0))
    414416      (define (->keyword s) (string->keyword (##sys#slot s 1)))
     
    421423            (%let-optionals* (macro-alias 'let-optionals* se))
    422424            (%let (macro-alias 'let se)))
    423         (let loop ([mode 0]             ; req=0, opt=1, rest=2, key=3, end=4
     425        (let loop ([mode 0]       ; req=0, opt=1, rest=2, key=3, end=4
    424426                   [req '()]
    425427                   [opt '()]
     
    427429                   [llist llist0] )
    428430          (cond [(null? llist)
    429                  (values
    430                   (if rvar (##sys#append (reverse req) rvar) (reverse req))
    431                   (let ([body
    432                          (if (null? key)
    433                              body
    434                              `((,%let*
    435                                 ,(map (lambda (k)
    436                                         (let ([s (car k)])
    437                                           `(,s (##sys#get-keyword
    438                                                 ',(->keyword s) ,rvar
    439                                                 ,@(if (pair? (cdr k))
    440                                                       `((,%lambda () ,@(cdr k)))
    441                                                       '() ) ) ) ) )
    442                                       (reverse key) )
    443                                 ,@body) ) ) ] )
    444                     (cond [(null? opt) body]
    445                           [(and (not hasrest) (null? key) (null? (cdr opt)))
    446                            `((,%let
    447                               ([,(caar opt) (,%opt ,rvar ,(cadar opt))])
    448                               ,@body) ) ]
    449                           [(and (not hasrest) (null? key))
    450                            `((,%let-optionals
    451                               ,rvar ,(reverse opt) ,@body))]
    452                           [else
    453                            `((,%let-optionals*
    454                               ,rvar ,(##sys#append (reverse opt) (list (or hasrest rvar)))
    455                               ,@body))] ) ) ) ]
     431                 (let ((vars (if rvar (##sys#append (reverse req) rvar) (reverse req)))
     432                       (body (if delegate
     433                                 (delegate body req hasrest (reverse opt) (reverse key))
     434                                 body) ) )
     435                   (values
     436                    vars
     437                    (let ([body
     438                           (if (null? key)
     439                               body
     440                               `((,%let*
     441                                  ,(map (lambda (k)
     442                                          (let ([s (car k)])
     443                                            `(,s (##sys#get-keyword
     444                                                  ',(->keyword s) ,rvar
     445                                                  ,@(if (pair? (cdr k))
     446                                                        `((,%lambda () ,@(cdr k)))
     447                                                        '() ) ) ) ) )
     448                                        (reverse key) )
     449                                  ,@body) ) ) ] )
     450                      (cond [(null? opt) body]
     451                            [(and (not hasrest) (null? key) (null? (cdr opt)))
     452                             `((,%let
     453                                ([,(caar opt) (,%opt ,rvar ,(cadar opt))])
     454                                ,@body) ) ]
     455                            [(and (not hasrest) (null? key))
     456                             `((,%let-optionals
     457                                ,rvar ,(reverse opt) ,@body))]
     458                            [else
     459                             `((,%let-optionals*
     460                                ,rvar ,(##sys#append (reverse opt) (list (or hasrest rvar)))
     461                                ,@body))] ) ) ) ) ]
    456462                [(symbol? llist)
    457463                 (if (fx> mode 2)
     
    477483                          (if (and (pair? r) (symbol? (car r)))
    478484                              (begin
    479                                 (if (not rvar) (set! rvar (car r)))
     485                                (unless rvar (set! rvar (car r)))
    480486                                (set! hasrest (car r))
    481487                                (loop 2 req opt '() (cdr r)) )
     
    483489                          (err "`#!rest' argument marker in wrong context") ) ]
    484490                     [(#!key)
    485                       (if (not rvar) (set! rvar (macro-alias 'tmp se)))
     491                      (unless rvar (set! rvar (macro-alias 'tmp se)))
    486492                      (if (fx<= mode 3)
    487493                          (loop 3 req opt '() r)
     
    10171023               (##sys#check-syntax 'define head '(symbol . lambda-list))
    10181024               (##sys#check-syntax 'define body '#(_ 1))
    1019                (##sys#register-export (car head) (##sys#current-module))
    1020                `(##core#set!
    1021                  ,(car head)
    1022                  (,(r 'lambda) ,(cdr head) ,@body))) ) ) ) ) ) )
     1025               (loop
     1026                `(,(car head)
     1027                  (,(r 'lambda) ,(cdr head) ,@body))) ) ) ) ) ) ) )
    10231028
    10241029(##sys#extend-macro-environment
Note: See TracChangeset for help on using the changeset viewer.