Changeset 10970 in project for release/4/miscmacros


Ignore:
Timestamp:
06/01/08 01:28:47 (12 years ago)
Author:
Jim Ursetto
Message:

miscmacros: hygienify

Location:
release/4/miscmacros
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • release/4/miscmacros/miscmacros.scm

    r6563 r10970  
    11;;;; miscmacros.scm
    22
     3(module miscmacros
     4  (modify-location
     5   let/cc until
     6   repeat while repeat* if* while*
     7   dotimes push! pop! inc! dec! exchange! modify!
     8   begin0
     9   define-optionals define-parameter define-enum
     10   ignore-values ignore-errors)
     11
     12  (import scheme)
     13  ;; No effect -- caller must import these manually.
     14  ;; (import (only chicken
     15  ;;               when unless handle-exceptions let-optionals make-parameter
     16  ;;               add1 sub1))
     17
    318;;; Modify locations, T-like:
    419
    5 (cond-expand (syntax-case
    6 
    7 (define-syntax (modify-location x)
    8   (syntax-case x ()
    9     ((_ (loc ...) proc)
    10      (with-syntax (((tmp ...) (generate-temporaries #'(loc ...))))
    11        #'(let ((tmp loc) ...)
    12            (proc (lambda () (tmp ...))
    13                  (lambda (x) (set! (tmp ...) x)))) ) )
    14     ((_ loc proc)
    15      #'(proc (lambda () loc)
    16              (lambda (x) (set! loc x)) ) ) ) )
    17 
    18 )(else
    19 
    20 (define-macro (modify-location loc proc)
    21   (let ((x (gensym)))
    22     (if (atom? loc)
    23         `(,proc (lambda () ,loc)
    24                 (lambda (,x) (set! ,loc ,x)) )
    25         (let ((tmps (map (lambda _ (gensym)) loc)))
    26           `(let ,(map list tmps loc)
    27              (,proc (lambda () ,tmps)
    28                     (lambda (,x) (set! ,tmps ,x))))) ) ) )
    29 
    30 ) )
     20;; syntax-case implementation -- unused
     21;;   (define-syntax (modify-location x)
     22;;     (syntax-case x ()
     23;;       ((_ (loc ...) proc)
     24;;        (with-syntax (((tmp ...) (generate-temporaries #'(loc ...))))
     25;;          #'(let ((tmp loc) ...)
     26;;              (proc (lambda () (tmp ...))
     27;;                    (lambda (x) (set! (tmp ...) x)))) ) )
     28;;       ((_ loc proc)
     29;;        #'(proc (lambda () loc)
     30;;                (lambda (x) (set! loc x)) ) ) ) )
     31
     32  (define-syntax modify-location
     33    (lambda (f r c)
     34      (##sys#check-syntax 'modify-location f '(_ _ _))
     35      (let ((loc (cadr f))
     36            (proc (caddr f))
     37            (%lambda (r 'lambda))
     38            (%set! (r 'set!))
     39            (%let (r 'let))
     40            (x (r 'x)))                 ; a temporary
     41        (if (atom? loc)
     42            `(,proc (,%lambda () ,loc)
     43                    (,%lambda (,x) (,%set! ,loc ,x)))
     44            (let ((tmps (map (lambda _ (r (gensym))) loc)))
     45              `(,%let ,(map list tmps loc)
     46                      (,proc (,%lambda () ,tmps)
     47                             (,%lambda (,x) (,%set! ,tmps ,x)))))))))
    3148
    3249;; evaluates body with an explicit exit continuation
    3350;;
    34 (define-macro (let/cc K . BODY)
    35   `(call-with-current-continuation (lambda (,K) ,@BODY)))
     51  (define-syntax let/cc
     52    (syntax-rules ()
     53      ((let/cc k e0 e1 ...)
     54       (call-with-current-continuation
     55        (lambda (k) e0 e1 ...)))))
    3656
    3757;; loop while expression false
    3858;;
    39 (define-macro (until TEST . BODY)
    40   (let ([LOOP-TAG (gensym)])
    41     `(let ,LOOP-TAG ()
    42       (unless ,TEST
    43         ,@BODY
    44         (,LOOP-TAG)))))
    45 
    46 ;; repeat body n times
    47 ;;
    48 (define-macro (repeat N . BODY)
    49   (let ([CTR-VAR (gensym)]
    50         [LOOP-TAG (gensym)])
    51     `(let ,LOOP-TAG ([,CTR-VAR ,N])
    52       (when (< 0 ,CTR-VAR)
    53         ,@BODY
    54         (,LOOP-TAG (sub1 ,CTR-VAR))))))
    55 
    56 ;; repeat body n times, w/ countdown n bound to 'it'
    57 ;;
    58 (define-macro (repeat* N . BODY)
    59   (let ([LOOP-TAG (gensym)])
    60     `(let ,LOOP-TAG ([it ,N])
    61       (when (< 0 it)
    62         ,@BODY
    63         (,LOOP-TAG (sub1 it))))))
    64 
    65 ;; repeat body n times, w/ countup n bound to "var"
    66 ;;
    67 (define-macro (dotimes NV . BODY)
    68   (if (and (list? NV) (eqv? 2 (length NV)))
    69                 (let ([V (car NV)]
    70                                         [N (cadr NV)]
    71                                         [N-VAR (gensym)]
    72                                         [LOOP-TAG (gensym)])
    73                         `(let ,LOOP-TAG ([,V 0] [,N-VAR ,N])
    74                                 (when (< ,V ,N-VAR)
    75                                         ,@BODY
    76                                         (,LOOP-TAG (add1 ,V) ,N-VAR) ) ) )
    77                 (syntax-error 'dotimes "not a binding form" NV) ) )
    78 
    79 (define-macro (while x . xs)
    80   (let ([var (gensym)])
    81     `(let ,var ()
    82         (when ,x (let () ,@xs (,var))) ) ) )
    83 
    84 (define-macro (while* x . xs)
    85   (let ([LBL (gensym)])
    86     `(let ,LBL ()
    87         (if* ,x (let () ,@xs (,LBL))) ) ) )
    88 
    89 (define-macro (if* x y . z)
    90   (let ([var (gensym)])
    91     `(let ([,var ,x])
    92        (if ,var
    93            (let ([it ,var])
    94              ,y)
    95            ,@z) ) ) )
    96 
    97 (define-macro (push! x y)
    98   `(modify-location
    99     ,y
    100     (lambda (get set) (set (cons ,x (get))) ) ) )
    101 
    102 (define-macro (pop! x)
    103   (let ([var (gensym)]
    104         (var2 (gensym)) )
    105     `(modify-location
    106       ,x
    107       (lambda (get set)
    108         (let* ([,var (get)]
    109                (,var2 (car ,var)) )
    110           (set (cdr ,var))
    111           ,var2) ) ) ) )
    112 
    113 (define-macro (ignore-errors . xs)
    114   `(handle-exceptions _ #f ,@xs) )
    115 
    116 (define-macro (begin0 x1 . xs)
    117   (let ([var (gensym)])
    118     `(##sys#call-with-values
    119       (lambda () ,x1)
    120       (lambda ,var
    121         (begin ,@xs (apply ##sys#values ,var) ) ) ) ) )
    122 
    123 (define-macro (define-optionals vars args)
    124   `(begin
    125      ,@(map (lambda (b) `(define ,(car b) #f)) vars)
    126      ,(let ([aliases (map (lambda (b) (gensym (car b))) vars)])
    127         `(let-optionals ,args ,(map (lambda (b a) (cons a (cdr b))) vars aliases)
    128            ,@(map (lambda (b a) `(set! ,(car b) ,a)) vars aliases) ) ) ) )
    129 
    130 (define-macro (define-parameter name . more)
    131   (let-optionals* more ([init '(void)] more)
    132     `(define ,name
    133        (make-parameter ,init ,@more) ) ) )
    134 
    135 (define-macro (inc! v)
    136   `(modify-location
    137     ,v
    138     (lambda (get set) (set (add1 (get))))))
    139 
    140 (define-macro (dec! v)
    141   `(modify-location
    142     ,v
    143     (lambda (get set) (set (sub1 (get))))))
    144 
    145 (define-macro (exchange! x y)
    146   (let ((tmp (gensym))
    147         (g1 (gensym))
    148         (g2 (gensym))
    149         (s1 (gensym))
    150         (s2 (gensym)) )
    151     `(modify-location
    152       ,x
    153       (lambda (,g1 ,s1)
    154         (modify-location
    155          ,y
    156          (lambda (,g2 ,s2)
    157            (let ((,tmp (,g1)))
    158              (,s1 (,g2))
    159              (,s2 ,tmp) ) ) ) ) ) ) )
    160 
    161 (define-macro (modify! x proc)
    162   (let ((get (gensym))
    163         (set (gensym)) )
    164     `(modify-location
    165       ,x
    166       (lambda (,get ,set) (,set (,proc (,get)))))) )
    167 
    168 (define-macro (ignore-values exp)
    169   `(##sys#call-with-values (lambda () ,exp) (lambda _ (##sys#void))) )
    170 
     59  (define-syntax until
     60    (syntax-rules ()
     61      ((until test body ...)
     62       (let loop ()
     63         (unless test
     64           body ...
     65           (loop))))))
     66
     67  (define-syntax repeat
     68    (syntax-rules ()
     69      ((repeat n body ...)
     70       (let loop ((i n))
     71         (when (< 0 i)
     72           body ...
     73           (loop (sub1 i)))))))
     74
     75  (define-syntax while
     76    (syntax-rules ()
     77      ((while test body ...)
     78       (let loop ()
     79         (if test
     80             (begin
     81               body ...
     82               (loop)))))))
     83
     84;; repeat body n times, w/ countdown n bound to 'it' hygienically
     85;;   (define-syntax repeat*
     86;;     (syntax-rules ()
     87;;       ((repeat* (it n) body ...)
     88;;        (let loop ((it n))
     89;;          (when (< 0 it)
     90;;            body ...
     91;;            (loop (sub1 it)))))))
     92
     93;; ;; if*: like if, but bind result of pred to 'it' hygienically
     94;;   (define-syntax if*
     95;;     (syntax-rules ()
     96;;       ((if* (it pred) cons . alt)
     97;;        (let ((val pred))
     98;;          (if val
     99;;              (let ((it val))
     100;;                cons)
     101;;              . alt)))))
     102
     103;; ;; while*: like while, but bind result of test to 'it' hygienically
     104;;   (define-syntax while*
     105;;     (syntax-rules ()
     106;;       ((while* (it test) body ...)
     107;;        (let loop ()
     108;;          (if* (it test)
     109;;               (begin body ... (loop)))))))
     110
     111;; repeat*, if*, while*: versions which break hygiene to assign to 'it'
     112(define-syntax repeat*
     113  (lambda (f r c)
     114    (##sys#check-syntax 'repeat* f '(_ _ . _))
     115    (let ((loop (r 'loop))
     116          (n (cadr f))
     117          (body (cddr f)))
     118      `(,(r 'let) ,loop ((it ,n))
     119        (,(r 'when) (,(r '<) 0 it)
     120         ,@body
     121         (,loop (,(r '-) it 1)))))))
     122(define-syntax if*
     123  (lambda (f r c)
     124    (##sys#check-syntax 'if* f '(_ _ _ . _))
     125    (let ((x (cadr f))
     126          (y (caddr f))
     127          (z (cdddr f))
     128          (var (r 'var)))
     129      `(,(r 'let) ((,var ,x))
     130        (,(r 'if) ,var
     131         (,(r 'let) ((it ,var))
     132          ,y)
     133         ,@z)))))
     134(define-syntax while*
     135  (lambda (f r c)
     136    (##sys#check-syntax 'while* f '(_ _ . _))
     137    (let ((test (cadr f))
     138          (body (cddr f)))
     139      `(,(r 'let) ,(r 'loop) ()
     140        (,(r 'if*) ,test
     141         (,(r 'begin)
     142          ,@body
     143          (,(r 'loop)) ))))))
     144
     145;; repeat body n times, w/ countup n bound to v
     146  (define-syntax dotimes
     147    (syntax-rules ()
     148      ((dotimes (v n) body ...)
     149       (let loop ((v 0) (nv n))
     150         (if (< v nv)
     151             (begin
     152               body ...
     153               (loop (add1 v) nv)))))))
     154
     155  (define-syntax push!
     156    (syntax-rules ()
     157      ((push! x loc)
     158       (modify-location loc
     159                        (lambda (get set)
     160                          (set (cons x (get))))))))
     161
     162  (define-syntax pop!
     163    (syntax-rules ()
     164      ((pop! loc)
     165       (modify-location loc
     166                        (lambda (get set)
     167                          (let* ((var (get))
     168                                 (var2 (car var)))
     169                            (set (cdr var))
     170                            var2))))))
     171
     172  (define-syntax inc!
     173    (syntax-rules ()
     174      ((inc! loc)
     175       (modify-location loc
     176                        (lambda (get set)
     177                          (set (add1 (get))))))))
     178
     179  (define-syntax dec!
     180    (syntax-rules ()
     181      ((dec! loc)
     182       (modify-location loc
     183                        (lambda (get set)
     184                          (set (sub1 (get))))))))
     185
     186  (define-syntax exchange!
     187    (syntax-rules ()
     188      ((exchange! x y)
     189       (modify-location
     190        x
     191        (lambda (get1 set1)
     192          (modify-location
     193           y
     194           (lambda (get2 set2)
     195             (let ((tmp (get1)))
     196               (set1 (get2))
     197               (set2 tmp)))))))))
     198
     199  (define-syntax modify!
     200    (syntax-rules ()
     201      ((modify! loc proc)
     202       (modify-location loc
     203                        (lambda (get set)
     204                          (set (proc (get))))))))
     205
     206  (define-syntax begin0
     207    (syntax-rules ()
     208      ((_ e0 e1 ...)
     209       (##sys#call-with-values
     210        (lambda () e0)
     211        (lambda var
     212          (begin
     213            e1 ...
     214            (apply ##sys#values var)))))))
     215
     216  (define-syntax define-optionals
     217    (lambda (f r c)
     218      (let ((vars (cadr f))
     219            (args (caddr f)))
     220        (##sys#check-syntax 'define-optionals f '(_ #(#(_ 2 2) 1) _))
     221        `(,(r 'begin)
     222          ,@(map (lambda (b) `(,(r 'define) ,(car b) #f)) vars)
     223          ,(let ([aliases (map (lambda (b) (r (car b))) vars)])
     224             `(,(r 'let-optionals) ,args
     225               ,(map (lambda (b a) (cons a (cdr b))) vars aliases)
     226               ,@(map (lambda (b a) `(,(r 'set!) ,(car b) ,a)) vars aliases) ) ) ))) )
     227
     228  (define-syntax define-parameter
     229    (syntax-rules ()
     230      ((define-parameter name value guard)
     231       (define name (make-parameter value guard)))
     232      ((define-parameter name value)
     233       (define name (make-parameter value)))
     234      ((define-parameter name)
     235       (define name (make-parameter (void))))))
     236
     237  (define-syntax ignore-values
     238    (syntax-rules ()
     239      ((ignore-values exp)
     240       (##sys#call-with-values (lambda () exp)
     241                               (lambda _ (##sys#void))))))
     242
     243  (define-syntax ignore-errors
     244    (syntax-rules ()
     245      ((ignore-errors body ...)
     246       (handle-exceptions _ #f body ...))))
    171247
    172248;;; The following is courtesy of Alex Shinn:
    173249
    174 (define-macro (define-enum ->int ->sym . vars)
    175   (define (enumerate vars)
    176     (let loop ((n 0) (enums '()) (vars vars))
    177       (if (null? vars)
    178           (reverse enums)
    179           (let ((n (if (pair? (car vars))
    180                        (cadar vars)
    181                        n)))
    182             (loop (+ n 1)
    183                   (cons n enums)
    184                   (cdr vars))))))
    185   (let ((ints (enumerate vars))
    186         (vars (map (lambda (v) (if (pair? v) (car v) v)) vars)))
    187     `(begin
    188        ,@(map (lambda (x i) `(define-constant ,x ,i)) vars ints)
    189        (define (,->int sym)
    190          (case sym ,@(map (lambda (x i) `((,x) ,i)) vars ints) (else #f)))
    191        (define (,->sym int)
    192          (switch int ,@(map (lambda (x i) `(,i ',x)) vars ints) (else #f))))))
     250  (define-syntax define-enum
     251    (lambda (f r c)
     252      (define (enumerate vars)
     253        (let loop ((n 0) (enums '()) (vars vars))
     254          (if (null? vars)
     255              (reverse enums)
     256              (let ((n (if (pair? (car vars))
     257                           (cadar vars)
     258                           n)))
     259                (loop (+ n 1)
     260                      (cons n enums)
     261                      (cdr vars))))))
     262      (##sys#check-syntax 'define-enum f '(_ _ _ . _))
     263      (let ((->int (cadr f))
     264            (->sym (caddr f))
     265            (vars (cdddr f)))
     266        (let ((ints (enumerate vars))
     267              (vars (map (lambda (v) (if (pair? v) (car v) v)) vars)))
     268          `(,(r 'begin)
     269            ,@(map (lambda (x i)
     270                     `(,(r 'define-constant) ,x ,i))
     271                   vars ints)
     272            (,(r 'define) (,->int ,(r 'sym))
     273             (,(r 'case) ,(r 'sym)
     274              ,@(map (lambda (x i)
     275                       `((,x) ,i))
     276                     vars ints)
     277              (,(r 'else) #f)))
     278            (,(r 'define) (,->sym ,(r 'int))
     279             (,(r 'case) ,(r 'int)
     280              ,@(map (lambda (x i)
     281                       `((,i) ',x))
     282                     vars ints)
     283              (,(r 'else) #f)))))))))
  • release/4/miscmacros/miscmacros.setup

    r6565 r10970  
     1(compile -s -d0 miscmacros.scm -j miscmacros)
     2
    13(install-extension 'miscmacros
    2         '("miscmacros.scm" "miscmacros.html")
    3         '((syntax) (version 2.5) (documentation "miscmacros.html")))
     4        '("miscmacros.import.scm" "miscmacros.html")
     5        '((syntax) (version 2.6b) (documentation "miscmacros.html")))
    46
Note: See TracChangeset for help on using the changeset viewer.