Changeset 2754 in project


Ignore:
Timestamp:
12/22/06 06:18:31 (14 years ago)
Author:
felix winkelmann
Message:

added simplify

Files:
5 added
2 edited

Legend:

Unmodified
Added
Removed
  • records/records.meta

    r2615 r2754  
    66 (license "public domain")
    77 (author "David Carlton, Aubrey Jaffer")
     8 (doc-from-wiki)
    89 (files "records.setup" "records.scm" "records.html") )
  • syntactic-closures/syntactic-closures-chicken-macros.scm

    r2728 r2754  
    235235    [(_ rest (var) body ...) (let ((var rest)) body ...)] ) )
    236236
    237 (define-macro (let-optionals arg-list var/defs . body)
    238 
    239   ;; This guy makes the END-DEF, START-DEF, PORT-DEF definitions above.
    240   ;; I wish I had a reasonable loop macro.
    241 
    242   (define (make-default-procs vars body-proc defaulter-names defs rename)
    243     (let recur ((vars (reverse vars))
    244                 (defaulter-names (reverse defaulter-names))
    245                 (defs (reverse defs))
    246                 (next-guy body-proc))
    247       (if (null? vars) '()
    248           (let ((vars (cdr vars)))
    249             `((,(car defaulter-names)
    250                (lambda ,(reverse vars)
    251                  (,next-guy ,@(reverse vars) ,(car defs))))
    252               . ,(recur vars
    253                         (cdr defaulter-names)
    254                         (cdr defs)
    255                         (car defaulter-names)))))))
    256 
    257 
    258     ;; This guy makes the (IF (NULL? REST) (PORT-DEF) ...) tree above.
    259 
    260   (define (make-if-tree vars defaulters body-proc rest rename)
    261     (let recur ((vars vars) (defaulters defaulters) (non-defaults '()))
    262       (if (null? vars)
    263           `(if (##core#check (null? ,rest))
    264                (,body-proc . ,(reverse non-defaults))
    265                (##sys#error (##core#immutable '"too many optional arguments") ,rest))
    266           (let ((v (car vars)))
    267             `(if (null? ,rest)
    268                  (,(car defaulters) . ,(reverse non-defaults))
    269                  (let ((,v (car ,rest))
    270                        (,rest (cdr ,rest)))
    271                    ,(recur (cdr vars)
    272                            (cdr defaulters)
    273                            (cons v non-defaults))))))))
    274 
    275   (##sys#check-syntax 'let-optionals var/defs '#((symbol _) 0))
    276   (##sys#check-syntax 'let-optionals body '#(_ 1))
    277   (let* ((vars (map car var/defs))
    278          (prefix-sym (lambda (prefix sym)
    279                        (string->symbol (string-append prefix (symbol->string sym)))))
    280 
    281          ;; Private vars, one for each user var.
    282          ;; We prefix the % to help keep macro-expanded code from being
    283          ;; too confusing.
    284          (vars2 (map (lambda (v) (gensym (prefix-sym "%" v)))
    285                      vars))
    286 
    287          (defs (map cadr var/defs))
    288          (body-proc (gensym 'body))
    289 
    290          ;; A private var, bound to the value of the ARG-LIST expression.
    291          (rest-var (gensym '%rest))
    292 
    293          (defaulter-names (map (lambda (var) (gensym (prefix-sym "def-" var)))
    294                                vars))
    295 
    296          (defaulters (make-default-procs vars2 body-proc
    297                                          defaulter-names defs gensym))
    298          (if-tree (make-if-tree vars2 defaulter-names body-proc
    299                                 rest-var gensym)))
    300 
    301     `(let* ((,rest-var ,arg-list)
    302             (,body-proc (lambda ,vars . ,body))
    303             . ,defaulters)
    304        ,if-tree) ) )
     237;; Just generates temp variables for let-optionals*
     238;; then binds them in one application, faster than
     239;; Shiver's let-optionals.
     240
     241(define-syntax let-optionals
     242 (syntax-rules ()
     243   ((let-optionals rest vars body)
     244    (let-optionals ("step") rest () vars body))
     245   ((let-optionals ("step") rest (tmps ...) ((var default) . vars) body)
     246    (let-optionals ("step") rest (tmps ... (var tmp default)) vars body))
     247   ((let-optionals ("step") rest ((var tmp default) ...) () body)
     248    (let-optionals* rest ((tmp default) ...)
     249      (let ((var tmp) ...)
     250        body)))
     251   ))
    305252
    306253(define-syntax define-inline
Note: See TracChangeset for help on using the changeset viewer.