Changeset 16107 in project


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

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

Location:
chicken/branches/dsssl-delegate
Files:
3 edited

Legend:

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

    r15830 r16107  
    641641                             (set!-values
    642642                              (llist obody)
    643                               (##sys#expand-extended-lambda-list
    644                                llist obody ##sys#error se) ) )
     643                              (##sys#expand-extended-lambda-list llist obody ##sys#error se #f) ) )
    645644                           (decompose-lambda-list
    646645                            llist
  • chicken/branches/dsssl-delegate/eval.scm

    r15972 r16107  
    499499                              (set!-values
    500500                               (llist body)
    501                                (##sys#expand-extended-lambda-list
    502                                 llist body ##sys#syntax-error-hook se) ) )
     501                               (##sys#expand-extended-lambda-list llist body ##sys#syntax-error-hook se #f) ) )
    503502                            (##sys#decompose-lambda-list
    504503                             llist
  • 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.