Changeset 10358 in project


Ignore:
Timestamp:
04/05/08 23:05:10 (12 years ago)
Author:
felix winkelmann
Message:

macro conversion

File:
1 edited

Legend:

Unmodified
Added
Removed
  • chicken/branches/beyond-hope/chicken-more-macros.scm

    r10353 r10358  
    304304    `(,(r 'set!-values) ,@(cdr form)))))
    305305
    306 ;*** translate to hygienic
    307 
    308 (define-macro (let-values vbindings . body)
    309   (letrec ((append* (lambda (il l)
    310                       (if (not (pair? il))
    311                           (cons il l)
    312                           (cons (car il)
    313                                 (append* (cdr il) l)))))
    314            (map* (lambda (proc l)
    315                    (cond ((null? l) '())
    316                          ((not (pair? l)) (proc l))
    317                          (else (cons (proc (car l)) (map* proc (cdr l))))))))
    318      (let* ([llists (map car vbindings)]
    319             [vars (let loop ((llists llists) (acc '()))
    320                     (if (null? llists)
    321                         acc
    322                         (let* ((llist (car llists))
    323                                (new-acc
    324                                 (cond ((list? llist) (append llist acc))
    325                                       ((pair? llist) (append* llist acc))
    326                                       (else (cons llist acc)))))
    327                           (loop (cdr llists) new-acc))))]
    328             [aliases (map (lambda (v) (cons v (gensym v))) vars)]
    329             [lookup (lambda (v) (cdr (assq v aliases)))]
    330             [llists2 (let loop ((llists llists) (acc '()))
     306(##sys#extend-macro-environment
     307 'let-values '()
     308 (##sys#er-transformer
     309  (lambda (form r c)
     310    (##sys#check-syntax 'let-values form '(_ list . _))
     311    (let ((vbindings (cadr form))
     312          (body (cddr form))
     313          (%let (r 'let))
     314          (%lambda (r 'lambda)))
     315      (letrec ((append* (lambda (il l)
     316                          (if (not (pair? il))
     317                              (cons il l)
     318                              (cons (car il)
     319                                    (append* (cdr il) l)))))
     320               (map* (lambda (proc l)
     321                       (cond ((null? l) '())
     322                             ((not (pair? l)) (proc l))
     323                             (else (cons (proc (car l)) (map* proc (cdr l))))))))
     324        (let* ([llists (map car vbindings)]
     325               [vars (let loop ((llists llists) (acc '()))
    331326                       (if (null? llists)
    332                            (reverse acc)
     327                           acc
    333328                           (let* ((llist (car llists))
    334329                                  (new-acc
    335                                    (cond ((not (pair? llist)) (cons (lookup llist) acc))
    336                                          (else (cons (map* lookup llist) acc)))))
    337                              (loop (cdr llists) new-acc))))])
    338        (let fold ([llists llists]
    339                   [exps (map (lambda (x) (cadr x)) vbindings)]
    340                   [llists2 llists2] )
    341          (cond ((null? llists)
    342                 `(let ,(map (lambda (v) (##sys#list v (lookup v))) vars) ,@body) )
    343                ((and (pair? (car llists2)) (null? (cdar llists2)))
    344                 `(let ((,(caar llists2) ,(car exps)))
    345                    ,(fold (cdr llists) (cdr exps) (cdr llists2)) ) )
    346                (else
    347                 `(##sys#call-with-values
    348                   (lambda () ,(car exps))
    349                   (lambda ,(car llists2) ,(fold (cdr llists) (cdr exps) (cdr llists2))) ) ) ) ) ) ) )
     330                                   (cond ((list? llist) (append llist acc))
     331                                         ((pair? llist) (append* llist acc))
     332                                         (else (cons llist acc)))))
     333                             (loop (cdr llists) new-acc))))]
     334               [aliases (map (lambda (v) (cons v (r (gensym v)))) vars)]
     335               [lookup (lambda (v) (cdr (assq v aliases)))]
     336               [llists2 (let loop ((llists llists) (acc '()))
     337                          (if (null? llists)
     338                              (reverse acc)
     339                              (let* ((llist (car llists))
     340                                     (new-acc
     341                                      (cond ((not (pair? llist)) (cons (lookup llist) acc))
     342                                            (else (cons (map* lookup llist) acc)))))
     343                                (loop (cdr llists) new-acc))))])
     344          (let fold ([llists llists]
     345                     [exps (map (lambda (x) (cadr x)) vbindings)]
     346                     [llists2 llists2] )
     347            (cond ((null? llists)
     348                   `(,%let ,(map (lambda (v) (##sys#list v (lookup v))) vars) ,@body) )
     349                  ((and (pair? (car llists2)) (null? (cdar llists2)))
     350                   `(,%let ((,(caar llists2) ,(car exps)))
     351                           ,(fold (cdr llists) (cdr exps) (cdr llists2)) ) )
     352                  (else
     353                   `(##sys#call-with-values
     354                     (,%lambda () ,(car exps))
     355                     (,%lambda ,(car llists2) ,(fold (cdr llists) (cdr exps) (cdr llists2))) ) ) ) ) ) ) ) ) ) )
     356
     357;*** translate to hygienic
    350358
    351359(define-macro (let*-values vbindings . body)
Note: See TracChangeset for help on using the changeset viewer.