Changeset 10353 in project


Ignore:
Timestamp:
04/04/08 15:06:11 (12 years ago)
Author:
felix winkelmann
Message:

converted some macros

File:
1 edited

Legend:

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

    r10351 r10353  
    203203                          (##sys#void) ) ) ) ) )))
    204204
    205 ;*** translate to hygienic
    206 
    207 (define-macro (eval-when situations . body)
    208    (let ([e #f]
    209          [c #f]
    210          [l #f]
    211          [body `(begin ,@body)] )
    212      (let loop ([ss situations])
    213        (if (pair? ss)
    214            (begin
    215              (case (##sys#slot ss 0)
    216                [(eval) (set! e #t)]
    217                [(load run-time) (set! l #t)]
    218                [(compile compile-time) (set! c #t)]
    219                [else (##sys#error "invalid situation specifier" (##sys#slot ss 0))] )
    220              (loop (##sys#slot ss 1)) ) ) )
    221      (if (memq '#:compiling ##sys#features)
    222          (cond [(and c l) `(##core#compiletimetoo ,body)]
    223                [c `(##core#compiletimeonly ,body)]
    224                [l body]
    225                [else '(##core#undefined)] )
    226          (if e
    227              body
    228              '(##core#undefined) ) ) ) )
    229 
    230 (define-macro (parameterize bindings . body)
    231      (##sys#check-syntax 'parameterize bindings '#((_ _) 0))
    232      (let* ([swap (gensym)]
     205(##sys#extend-macro-environment
     206 'eval-when '()
     207 (##sys#er-transformer
     208  (lambda (form r c)
     209    (##sys#check-syntax 'eval-when form '#(_ 2))
     210    (let* ((situations (cadr form))
     211           (%body (r 'begin))
     212           (body `(,%begin ,@(cddr form)))
     213           (e #f)
     214           (c #f)
     215           (l #f))
     216      (let loop ([ss situations])
     217        (if (pair? ss)
     218            (begin
     219              (case (##sys#slot ss 0)
     220                [(eval) (set! e #t)]
     221                [(load run-time) (set! l #t)]
     222                [(compile compile-time) (set! c #t)]
     223                [else (##sys#error "invalid situation specifier" (##sys#slot ss 0))] )
     224              (loop (##sys#slot ss 1)) ) ) )
     225      (if (memq '#:compiling ##sys#features)
     226          (cond [(and c l) `(##core#compiletimetoo ,body)]
     227                [c `(##core#compiletimeonly ,body)]
     228                [l body]
     229                [else '(##core#undefined)] )
     230          (if e
     231              body
     232              '(##core#undefined) ) ) ) ) ) )
     233
     234(##sys#extend-macro-environment
     235 'parameterize '()
     236 (##sys#er-transformer
     237  (lambda (form r c)
     238    (##sys#check-syntax 'parameterize form '#(_ 2))
     239     (let* ((bindings (cadr form))
     240            (body (cddr form))
     241            (swap (r 'swap))
     242            (%let (r 'let))
     243            (%lambda (r 'lambda))
    233244            [params (##sys#map car bindings)]
    234245            [vals (##sys#map cadr bindings)]
    235             [aliases (##sys#map (lambda (z) (gensym)) params)]
    236             [aliases2 (##sys#map (lambda (z) (gensym)) params)] )
    237        `(let ,(##sys#append (map ##sys#list aliases params) (map ##sys#list aliases2 vals))
    238           (let ((,swap (lambda ()
    239                          ,@(map (lambda (a a2) `(let ((t (,a))) (,a ,a2) (##core#set! ,a2 t)))
    240                                 aliases aliases2) ) ) )
    241             (##sys#dynamic-wind
    242                 ,swap
    243                 (lambda () ,@body)
    244                 ,swap) ) ) ) )
    245 
    246 (define-macro (when test . body)
    247    `(if ,test (begin ,@body)) )
    248 
    249 (define-macro (unless test . body)
    250    `(if ,test (##core#undefined) (begin ,@body)) )
    251 
    252 (define-macro (set!-values vars exp)
    253   (##sys#check-syntax 'set!-values/define-values vars '#(symbol 0))
    254   (cond ((null? vars)
    255          ;; may this be simply "exp"?
    256          `(##sys#call-with-values (lambda () ,exp) (lambda () (##core#undefined))) )
    257         ((null? (cdr vars))
    258          `(##core#set! ,(car vars) ,exp))
    259         (else
    260          (let ([aliases (map gensym vars)])
    261            `(##sys#call-with-values
    262              (lambda () ,exp)
    263              (lambda ,aliases
    264                ,@(map (lambda (v a) `(##core#set! ,v ,a)) vars aliases) ) ) ) ) ) )
    265 
    266 (define-macro (define-values vars exp)
    267   `(set!-values ,vars ,exp) )
     246            [aliases (##sys#map (lambda (z) (r (gensym))) params)]
     247            [aliases2 (##sys#map (lambda (z) (r (gensym))) params)] )
     248       `(,%let ,(##sys#append (map ##sys#list aliases params) (map ##sys#list aliases2 vals))
     249          (,%let ((,swap (,%lambda ()
     250                                   ,@(map (lambda (a a2)
     251                                            `(,%let ((t (,a))) (,a ,a2)
     252                                                    (##core#set! ,a2 t)))
     253                                          aliases aliases2) ) ) )
     254                 (##sys#dynamic-wind
     255                  ,swap
     256                  (,%lambda () ,@body)
     257                  ,swap) ) ) ) )))
     258
     259(##sys#extend-macro-environment
     260 'when '()
     261 (##sys#er-transformer
     262  (lambda (form r c)
     263    (##sys#check-syntax 'when form '#(_ 2))
     264    `(,(r 'if) ,(cadr form)
     265      (,(r 'begin) ,@(cddr form))))))
     266
     267(##sys#extend-macro-environment
     268 'unless '()
     269 (##sys#er-transformer
     270  (lambda (form r c)
     271    (##sys#check-syntax 'unless form '#(_ 2))
     272    `(,(r 'if) ,(cadr form)
     273      (##core#undefined)
     274      (,(r 'begin) ,@(cddr form))))))
     275
     276(##sys#extend-macro-environment
     277 'set!-values '()
     278 (##sys#er-transformer
     279  (lambda (form r c)
     280    (##sys#check-syntax 'set!-values form '(_ #(symbol 0) _))
     281    (let ((vars (cadr form))
     282          (exp (caddr form))
     283          (%lambda (r 'lambda)))
     284      (cond ((null? vars)
     285             ;; may this be simply "exp"?
     286             `(##sys#call-with-values
     287               (,%lambda () ,exp)
     288               (,%lambda () (##core#undefined))) )
     289            ((null? (cdr vars))
     290             `(##core#set! ,(car vars) ,exp))
     291            (else
     292             (let ([aliases (map gensym vars)])
     293               `(##sys#call-with-values
     294                 (,%lambda () ,exp)
     295                 (,%lambda ,aliases
     296                           ,@(map (lambda (v a)
     297                                    `(##core#set! ,v ,a))
     298                                  vars aliases) ) ) ) ) ) ))))
     299
     300(##sys#extend-macro-environment
     301 'define-values '()
     302 (##sys#er-transformer
     303  (lambda (form r c)
     304    `(,(r 'set!-values) ,@(cdr form)))))
     305
     306;*** translate to hygienic
    268307
    269308(define-macro (let-values vbindings . body)
Note: See TracChangeset for help on using the changeset viewer.