Changeset 10351 in project


Ignore:
Timestamp:
04/04/08 13:55:21 (12 years ago)
Author:
felix winkelmann
Message:

some macros converted, fix in body-canonicalization

Location:
chicken/branches/beyond-hope
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • chicken/branches/beyond-hope/TODO

    r10290 r10351  
    11TODO for macro/module system                                    -*- Outline -*-
    22
    3 * reimplement all default macros hygienically
    4 
    5 * test interaction of hygienic and non-hygienic macros
    6 * fix problem of using lowlevel macros with hygienically introduced bindings
    7   (define-syntax foo
    8     (syntax-rules ()
    9       ((_ x) (let ((tmp x)) (assert tmp "fail")))))   ; "tmp" not seen when
    10                                                       ; expanding assert
     3* reimplement macros from chicken-more-macros hygienically
    114
    125* test hygiene
  • chicken/branches/beyond-hope/chicken-more-macros.scm

    r10345 r10351  
    148148                   '() ) ) ) ) )) )
    149149
     150(##sys#extend-macro-environment
     151 'ensure
     152 '()
     153 (##sys#er-transformer
     154  (lambda (form r c)
     155    (##sys#check-syntax 'ensure form '#(_ 3))
     156    (let ((pred (cadr form))
     157          (exp (caddr form))
     158          (args (cdddr form))
     159          (tmp (r 'tmp))
     160          (%let (r 'let))
     161          (%if (r 'if)) )
     162      `(,%let ([,tmp ,exp])
     163              (,%if (##core#check (,pred ,tmp))
     164                    ,tmp
     165                    (##sys#signal-hook
     166                     #:type-error
     167                     ,@(if (pair? args)
     168                           args
     169                           `((##core#immutable '"argument has incorrect type")
     170                             ,tmp ',pred) ) ) ) ) ) ) ) )
     171
     172(##sys#extend-macro-environment
     173 'fluid-let '()
     174 (##sys#er-transformer
     175  (lambda (form r c)
     176    (##sys#check-syntax 'fluid-let form '(_ #((symbol _) 0) . _))
     177     (let* ((clauses (cadr form))
     178           (body (cddr form))
     179           (ids (##sys#map car clauses))
     180           (new-tmps (##sys#map (lambda (x) (r (gensym))) clauses))
     181           (old-tmps (##sys#map (lambda (x) (r (gensym))) clauses))
     182           (%let (r 'let))
     183           (%lambda (r 'lambda)))
     184       `(,%let (,@(map ##sys#list new-tmps (##sys#map cadr clauses))
     185                ,@(map ##sys#list old-tmps
     186                       (let loop ((n (length clauses)))
     187                         (if (eq? n 0)
     188                             '()
     189                             (cons #f (loop (fx- n 1))) ) ) ) )
     190               (##sys#dynamic-wind
     191                (,%lambda ()
     192                          ,@(map (lambda (ot id) `(##core#set! ,ot ,id))
     193                                 old-tmps ids)
     194                          ,@(map (lambda (id nt) `(##core#set! ,id ,nt))
     195                                 ids new-tmps)
     196                          (##sys#void) )
     197                (,%lambda () ,@body)
     198                (,%lambda ()
     199                          ,@(map (lambda (nt id) `(##core#set! ,nt ,id))
     200                                 new-tmps ids)
     201                          ,@(map (lambda (id ot) `(##core#set! ,id ,ot))
     202                                 ids old-tmps)
     203                          (##sys#void) ) ) ) ) )))
     204
    150205;*** translate to hygienic
    151 
    152 (define-macro (ensure pred exp . args)
    153    (let ([tmp (gensym)])
    154      `(let ([,tmp ,exp])
    155         (if (##core#check (,pred ,tmp))
    156             ,tmp
    157             (##sys#signal-hook
    158              #:type-error
    159              ,@(if (pair? args)
    160                    args
    161                    `((##core#immutable '"argument has incorrect type") ,tmp ',pred) ) ) ) ) ) )
    162 
    163 (define-macro (fluid-let clauses . body)
    164      (##sys#check-syntax 'fluid-let clauses '#((symbol _) 0))
    165      (let ((ids (##sys#map car clauses))
    166            (new-tmps (##sys#map (lambda (x) (gensym)) clauses))
    167            (old-tmps (##sys#map (lambda (x) (gensym)) clauses)))
    168        `(let (,@(map ##sys#list new-tmps (##sys#map cadr clauses))
    169               ,@(map ##sys#list old-tmps
    170                      (let loop ((n (length clauses)))
    171                        (if (eq? n 0)
    172                            '()
    173                            (cons #f (loop (fx- n 1))) ) ) ) )
    174           (##sys#dynamic-wind
    175               (lambda ()
    176                 ,@(map (lambda (ot id) `(##core#set! ,ot ,id))
    177                        old-tmps ids)
    178                 ,@(map (lambda (id nt) `(##core#set! ,id ,nt))
    179                        ids new-tmps)
    180                 (##sys#void) )
    181               (lambda () ,@body)
    182               (lambda ()
    183                 ,@(map (lambda (nt id) `(##core#set! ,nt ,id))
    184                        new-tmps ids)
    185                 ,@(map (lambda (id ot) `(##core#set! ,id ,ot))
    186                        ids old-tmps)
    187                 (##sys#void) ) ) ) ) )
    188206
    189207(define-macro (eval-when situations . body)
  • chicken/branches/beyond-hope/csi.scm

    r10176 r10351  
    249249                        ((x)
    250250                         (let ([x (read)])
    251                            (pretty-print (macroexpand x))
     251                           (pretty-print (##sys#strip-syntax (macroexpand x)))
    252252                           (##sys#void) ) )
    253253                        ((p)
  • chicken/branches/beyond-hope/expand.scm

    r10345 r10351  
    344344                    (if (and (pair? x)
    345345                             (let ((d (car x)))
    346                                (or (eq? (or (lookup d se) d) 'define)
    347                                    (eq? (or (lookup d se) d) 'define-values))))
     346                               (and (symbol? d)
     347                                    (or (eq? (or (lookup d se) d) 'define)
     348                                        (eq? (or (lookup d se) d) 'define-values)))) )
    348349                        (cons
    349350                         (macro-alias 'begin se)
Note: See TracChangeset for help on using the changeset viewer.