Ignore:
Timestamp:
01/01/20 18:34:27 (8 weeks ago)
Author:
juergen
Message:

procedural-macros 2.0 simplified and streamlined

Location:
release/5/procedural-macros/tags/2.0
Files:
1 edited
1 copied

Legend:

Unmodified
Added
Removed
  • release/5/procedural-macros/tags/2.0/tests/run.scm

    r37432 r38044  
    1 (import scheme (chicken base)
     1(import scheme
     2        (chicken base)
     3        checks
    24        procedural-macros
    35        simple-tests)
    46(import-for-syntax (only procedural-macros
    5                          with-mapped-symbols
     7                         with-renamed-symbols
    68                         macro-rules
    79                         once-only)
     10                   (only checks >>)
    811                   (only (chicken base) list-of?)
    912                   (only bindings bind bind-case)
    1013                   )
    1114
    12 (define Counter
     15(define counter
    1316  (let ((n 0))
    1417    (lambda ()
     
    1619      n)))
    1720
    18 (define-er-macro (Square form % compare?)
    19   (let ((x (cadr form)))
    20     (once-only (x)
    21       `(* ,x ,x))))
    22 
    23 (define-er-macro-transformer (Swap! form rename compare?)
    24   (let ((x (cadr form)) (y (caddr form)))
    25     (with-mapped-symbols rename % (%tmp %let %set!)
    26       `(,%let ((,%tmp ,x))
    27          (,%set! ,x ,y)
    28          (,%set! ,y ,%tmp)))))
    29 
    30 (define-er-macro (Nif form % compare?)
    31   (bind (_ xpr pos zer neg)
    32     form
    33     `(,%let ((,%result ,xpr))
    34             (,%cond
    35               ((,%positive? ,%result) ,pos)
    36               ((,%negative? ,%result) ,neg)
    37               (,%else ,zer)))))
    38 
    39 (define-ir-macro (Vif form % compare?)
    40   (bind-case form
    41     ((_ test (key xpr . xprs))
    42      (cond
    43        ((compare? key %then)
    44         `(if ,test (begin ,xpr ,@xprs)))
    45        ((compare? key %else)
    46         `(if ,(not test) (begin ,xpr ,@xprs)))
    47        (else
    48          `(error 'Vif "syntax-error"))))
    49     ((_ test (key1 xpr . xprs) (key2 ypr . yprs))
    50      (cond
    51        ((and (compare? key1 %then)
    52              (compare? key2 %else))
    53        `(if ,test
    54           (begin ,xpr ,@xprs)
    55           (begin ,ypr ,@yprs)))
    56        ((and (compare? key1 %else)
    57              (compare? key2 %then))
    58        `(if ,test
    59           (begin ,ypr ,@yprs)
    60           (begin ,xpr ,@xprs)))
    61        (else
    62          `(error 'Vif "syntax-error"))))
    63     ))
    64 
    65 (define-ir-macro (Alambda form % compare?)
    66   (bind (_ args xpr . xprs) form
    67     `(letrec ((,%self (lambda ,args ,xpr ,@xprs)))
    68        ,%self)))
    69 
    70 (define-test (basic-macros?)
    71   (= (Square (Counter)) 1)
    72   (= (Square (Counter)) 4)
    73   (= (Square (Counter)) 9)
    74 
    75   (equal? (let ((x 'x) (y 'y))
    76             (Swap! x y)
    77             (list x y))
    78           '(y x))
    79 
    80   (eq? (Nif 5 'pos 'zer 'neg) 'pos)
    81 
    82   ;;; verbose if
    83   (eq? (Vif (positive? 5) (then 'pos)) 'pos)
    84 
    85   (equal?
    86     (map (Alambda (n)
    87            (if (zero? n)
    88              1
    89              (* n (self (- n 1)))))
    90          '(1 2 3 4 5))
    91     '(1 2 6 24 120))
    92   )
    93 
    94 (define-macro (swap! x y)
    95   `(let ((tmp ,x)) (set! ,x ,y) (set! ,y tmp)))
    96 
    97 (define-macro (nif xpr pos zer neg)
    98   `(cond
    99      ((positive? ,xpr) ,pos)
    100      ((negative? ,xpr) ,neg)
    101      (else ,zer)))
    102 
    103 (define-macro (freeze xpr)
    104   `(lambda () ,xpr))
    105 
    106 (define-syntax foo
    107   (macro-rules ()
    108     ((_ "foo" x) x)
    109     ((_ #f x) `(list 'false))
    110     ((_ #f x) 'false)
    111     ((_ a b) (where (a string?))
    112              `(list ,a ,b))
    113     ((_ a b) (where (a odd?))
    114              `(list ,a ,b))
    115     ((_ a b) a)))
    116 
    117 (define-macro (bar #() x)
    118   (where (x integer?))
    119   x)
    120 
    121 (define-macro (qux  #f)
    122   #t)
    123 
    124 (define-macro (in? what equ? . choices)
    125   (let ((insym 'in))
    126     `(let ((,insym ,what))
    127        (or ,@(map (lambda (choice) `(,equ? ,insym ,choice))
    128                   choices)))))
    129 
    130 (define-syntax vif
    131   (macro-rules (then else)
    132     ((_ test (then . xprs))
    133      `(if ,test
    134         (begin ,@xprs)))
    135     ((_ test (else . xprs))
    136      `(if ,(not test)
    137         (begin ,@xprs)))
    138     ((_ test (then . xprs) (else . yprs))
    139      `(if ,test
    140         (begin  ,@xprs)
    141         (begin  ,@yprs)))))
    142 
    143 (define (oux)
    144   (vif #t (then 'true)))
    145 
    146 (define (pux)
    147   (vif #f (else 'false)))
    148 
    149 (define-syntax my-cond
     21(print "\nWITH-RENAMED-SYMBOLS\n")
     22(pe '(with-renamed-symbols (gensym %a %b %c) 'body))
     23
     24(print "\nONCE-ONLY\n")
     25(pe '(once-only (x)
     26      `(* ,x ,x)))
     27
     28(print "\nMY-COND\n")
     29(pe '
    15030  (macro-rules (else =>)
    15131    ((_ (else xpr . xprs))
     
    16040          (my-cond ,@clauses))))
    16141    ((_ (test))
    162      `(if #f #f))
     42     ;`(if #f #f))
     43     test)
    16344    ((_ (test) . clauses)
    16445     `(let ((tmp ,test))
     
    17354        (my-cond ,@clauses)))
    17455    ))
    175 
    176 (define-macro (my-letrec pairs . body)
    177   (where (pairs (list-of? pair?)))
    178   (let ((vars (map car pairs))
    179         (vals (map cadr pairs))
    180         (aux (map (lambda (x) (gensym)) pairs)))
    181     `(let ,(map (lambda (var) `(,var #f)) vars)
    182        (let ,(map (lambda (a v) `(,a ,v)) aux vals)
    183          ,@(map (lambda (v e) `(set! ,v ,e)) vars vals)
    184          ,@body))))
    185 
    186 (define-syntax add
    187   (macro-rules () ((_ x y)
    188                    (where (x string?) (y string?))
    189                    `(string-append ,x ,y))
    190     (( _ x y)
    191      (where (x integer?) (y integer?))
    192      `(+ ,x ,y))))
    193 
    194 (define-syntax alambda
    195   (macro-rules self ()
    196     ((_ args xpr . xprs)
    197      `(letrec ((,self (lambda ,args ,xpr ,@xprs)))
    198         ,self))))
     56(newline)
     57
     58(define-macro (square x)
     59  (with-explicit-renaming (compare? %*)
     60    (once-only (x)
     61      `(,%* ,x ,x))))
     62
     63(define-macro (wrong-square x)
     64  (with-explicit-renaming (compare? %*)
     65    `(,%* ,x ,x)))
     66
     67(define-test (macro-helpers?)
     68  (equal? (with-renamed-symbols (identity %a %b %c) (list %a %b %c))
     69          '(a b c))
     70  (even? (wrong-square (counter)))
     71  (integer? (sqrt (square (counter))))
     72  )
     73
     74;(macro-helpers?)
     75
     76;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     77
     78(define-syntax my-cond
     79  (macro-rules (else =>)
     80    ((_ (else xpr . xprs))
     81     `(begin ,xpr ,@xprs))
     82    ((_ (test => xpr))
     83     `(let ((tmp ,test))
     84        (if tmp (,xpr tmp))))
     85    ((_ (test => xpr) . clauses)
     86     `(let ((tmp ,test))
     87        (if tmp
     88          (,xpr tmp)
     89          (my-cond ,@clauses))))
     90    ((_ (test))
     91     ;`(if #f #f))
     92     test)
     93    ((_ (test) . clauses)
     94     `(let ((tmp ,test))
     95        (if tmp
     96          tmp
     97          (my-cond ,@clauses))))
     98    ((_ (test xpr . xprs))
     99     `(if ,test (begin ,xpr ,@xprs)))
     100    ((_ (test xpr . xprs) . clauses)
     101     `(if ,test
     102        (begin ,xpr ,@xprs)
     103        (my-cond ,@clauses)))
     104    ))
     105
     106(define-syntax vif
     107  (macro-rules (then else)
     108    ((_ test (then xpr . xprs))
     109     `(if ,test
     110        (begin ,xpr ,@xprs)))
     111    ((_ test (else xpr . xprs))
     112     `(if ,(not test)
     113        (begin ,xpr ,@xprs)))
     114    ((_ test (then xpr . xprs) (else ypr . yprs))
     115     `(if ,test
     116        (begin ,xpr ,@xprs)
     117        (begin ,ypr ,@yprs)))))
    199118
    200119(define-syntax aif
     
    207126        (if ,it ,consequent ,alternative)))))
    208127
    209 (define (mist x)
    210   (aif ((alambda (n) (if (zero? n) 1 (* n (self (- n 1))))) x) it))
    211 
    212 (define counter ; used for side-effects
    213   (let ((state 0))
    214     (lambda ()
    215       (set! state (+ state 1))
    216       state)))
    217 
    218 (define-macro (square x) ; wrong without once-only
    219   (once-only (x)
    220     `(* ,x ,x)))
    221 
    222 (define-syntax add2
    223   (let ((id (lambda (n) n)))
    224     (macro-rules ()
    225       ((_ x)
    226        `(+ ,(id x) 2))
    227       ((_ x y)
    228        `(+ ,(id x) ,(id y) 2))
    229       )))
    230 
    231 (define-macro (for (var start end) . body)
    232   (once-only (start end)
    233     `(do ((,var ,start (add1 ,var)))
    234        ((= ,var ,end))
    235        ,@body)))
    236 
    237 (define-test (procedural-macros?)
    238   (equal? (let ((x 'x) (y 'y))
    239             (swap! x y)
    240             (list x y))
    241           '(y x))
    242 
    243   (eq? (nif 2 'positive 'zero 'negative) 'positive)
    244 
    245   (= ((freeze 5)) 5)
    246 
    247   (equal? (let ((x 'x) (y 'y)) (swap! x y) (list x y))
    248           '(y x))
    249 
     128(define-syntax alambda
     129  (macro-rules self ()
     130    ((_ args xpr . xprs)
     131     `(letrec ((,self (lambda ,args ,xpr ,@xprs)))
     132        ,self))))
     133
     134(define-syntax foo
     135  (macro-rules ()
     136    ((_ "foo" x) x)
     137    ((_ #f x) `(list 'false))
     138    ((_ #f x) 'false)
     139    ((_ a b) (>> a string?)
     140             `(list ,a ,b))
     141    ((_ a b) (>> a odd?)
     142             `(list ,a ,b))
     143    ((_ a b) a)))
     144
     145(define-syntax add
     146  (macro-rules ()
     147    ((_ x y)
     148     (>> x string?)
     149     (>> y string?)
     150     `(string-append ,x ,y))
     151    (( _ x y)
     152     (>> x integer?)
     153     (>> y integer?)
     154     `(+ ,x ,y))))
     155
     156(define x 5)
     157
     158(define-test (macro-rules?)
     159  (= x 5)
     160  (= (aif (<< x odd?) it) 5)
     161  (eq? (vif (odd? x) (then 'odd) (else 'even)) 'odd)
     162  (= ((alambda (n) (if (= n 1) 1 (* n (self (- n 1))))) 5)
     163     120)
    250164  "LITERALS"
    251165  (= (foo "foo" 1) 1)
     
    254168  (equal? (foo 1 2) '(1 2))
    255169  (= (foo 2 3) 2)
    256 
    257   (= (bar #() 5) 5)
    258 
    259   (qux #f)
    260 
    261   "IN?"
    262   (in? 2 = 1 2 3)
    263   (not (in? 5 = 1 2 3))
    264 
    265   "VERBOSE IFS"
    266   (eq? (oux) 'true)
    267   (eq? (pux) 'false)
    268 
    269170  "LOW-LEVEL COND"
    270171  (my-cond ((> 3 2)))
     
    281182  (not (my-cond ((assv 'x `((a 1) (b 2) (C 3))) => cadr)
    282183                (else #f)))
    283 
     184  "FENDERS"
     185  (= (add 1 2) 3)
     186  (string=? (add "a" "b") "ab")
     187  )
     188
     189;(macro-rules?)
     190
     191;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     192
     193(define-macro (my-letrec pairs xpr . xprs)
     194  ;(with-implicit-renaming (c?)
     195    (>> pairs (list-of? pair?))
     196    (let ((vars (map car pairs))
     197          (vals (map cadr pairs))
     198          (aux (map (lambda (x) (gensym)) pairs)))
     199      `(let ,(map (lambda (var) `(,var #f)) vars)
     200         (let ,(map (lambda (a v) `(,a ,v)) aux vals)
     201           ,@(map (lambda (v e) `(set! ,v ,e)) vars vals)
     202           ,xpr ,@xprs))));)
     203
     204(define-macro (eswap! x y)
     205  (with-explicit-renaming
     206    (compare? %let %tmp %set!)
     207     `(,%let ((,%tmp ,x))
     208        (,%set! ,x ,y)
     209        (,%set! ,y ,%tmp))))
     210
     211(define-macro (iswap! x y)
     212  (with-implicit-renaming (compare?)
     213    `(let ((tmp ,x))
     214       (set! ,x ,y)
     215       (set! ,y tmp))))
     216
     217(define-macro (swap! x y)
     218  `(let ((tmp ,x))
     219     (set! ,x ,y)
     220     (set! ,y tmp)))
     221
     222(define-macro (vvif test (then . xprs) (else . yprs))
     223  (with-explicit-renaming (compare? %then %else %if %begin %error)
     224    (if (and (compare? then %then) (compare? %else else))
     225      `(,%if ,test (,%begin ,@xprs) (,%begin ,@yprs))
     226      `(,%error 'vif "wrong keys" ',then ',else))))
     227
     228(define-macro (nif xpr pos zer neg)
     229  (with-explicit-renaming
     230    (c? %result %positive? %negative? %let %cond %else)
     231    `(,%let ((,%result ,xpr))
     232            (,%cond
     233              ((,%positive? ,%result) ,pos)
     234              ((,%negative? ,%result) ,neg)
     235              (,%else ,zer)))))
     236
     237(define-macro (aalambda args xpr . xprs)
     238  (with-implicit-renaming (compare? %self)
     239    `(letrec ((,%self (lambda ,args ,xpr ,@xprs)))
     240       ,%self)))
     241
     242(define-macro (in what equ? . choices)
     243  ;(with-implicit-renaming (c?)
     244    (let ((insym 'in))
     245      `(let ((,insym ,what))
     246         (or ,@(map (lambda (choice) `(,equ? ,insym ,choice))
     247                    choices)))));)
     248
     249(define-macro (for (var start end) xpr . xprs)
     250  ;(with-implicit-renaming (c?)
     251    (once-only (start end)
     252      `(do ((,var ,start (add1 ,var)))
     253         ((= ,var ,end))
     254         ,xpr ,@xprs)));)
     255
     256(define-macro (freeze xpr)
     257  `(lambda () ,xpr))
     258
     259(define-test (define-macro?)
     260  (equal? (let ((x 'x) (y 'y))
     261            (eswap! x y)
     262            (list x y))
     263          '(y x))
     264  (equal? (let ((x 'x) (y 'y))
     265            (iswap! x y)
     266            (list x y))
     267          '(y x))
     268  (equal? (let ((x 'x) (y 'y))
     269            (swap! x y)
     270            (list x y))
     271          '(y x))
     272  (= x 5)
     273  (= ((aalambda (n) (if (= n 1) 1 (* n (self (- n 1))))) 5) 120)
     274  (eq? (vvif (odd? x) (then 'odd) (else 'even)) 'odd)
     275  (eq? (nif 2 'positive 'zero 'negative) 'positive)
     276  (in 2 = 1 2 3)
     277  (not (in 5 = 1 2 3))
     278  (= ((freeze 5)) 5)
     279  (let ((lst '()))
     280    (for (x 0 (counter)) (set! lst (cons x lst)))
     281    (equal? lst '(3 2 1 0)))
    284282  "LETREC"
    285283  (equal?
     
    288286               (list (o? 95) (e? 95)))
    289287    '(#t #f))
    290 
    291   "GENERIC ADD"
    292   (= (add 1 2) 3)
    293   (string=? (add "x" "y") "xy")
    294 
    295   "ANAPHORIC MACROS"
    296   (equal? (map (alambda (n) (if (zero? n) 1 (* n (self (- n 1))))) '(1 2 3 4 5))
    297           '(1 2 6 24 120))
    298 
    299   (= (mist 5) 120)
    300 
    301   "ONCE-ONLY"
    302   (= (square (counter)) 1)
    303   (= (square (counter)) 4)
    304   (= (square (counter)) 9)
    305   (let ((lst '()))
    306     (for (x 0 (counter)) (set! lst (cons x lst)))
    307     (equal? lst '(3 2 1 0)))
    308 
    309   "LOCAL VARIABLES AVAILABLE IN EACH RULE"
    310   (= (add2 5) 7)
    311   (= (add2 5 7) 14)
    312 
    313 
    314   "LET AND LETREC"
     288  )
     289
     290;(define-macro?)
     291
     292;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     293
     294(define-test (macrolet?)
     295  (= (macro-let (
     296      ((first lst)
     297       `(begin
     298          (>> ,lst list?)
     299          (car ,lst)))
     300      ((rest lst)
     301       `(begin
     302          (>> ,lst list?)
     303          (cdr ,lst)))
     304      )
     305      (first (rest '(1 2 3))))
     306     2)
    315307  (= (macro-letrec (
    316        ((sec lst) `(car (res ,lst)))
    317        ((res lst) `(cdr ,lst))
    318        )
    319        (sec '(1 2 3)))
    320      2)
    321   (= (macro-let (
    322        ((fir lst) (where (lst list?)) `(car ,lst))
    323        ((res lst) (where (lst list?)) `(cdr ,lst))
    324        )
    325        (fir (res '(1 2 3))))
     308      ((second lst) `(car (rest ,lst)))
     309      ((rest lst) `(cdr ,lst))
     310      )
     311      (second '(1 2 3)))
    326312     2)
    327313  (equal?
    328     (macro-letrec (((swap1 x y)
    329                     `(swap2 ,x ,y))
    330                    ((swap2 x y)
    331                     (where (x symbol?) (y symbol?))
    332                     `(let ((tmp ,y)) (set! ,y ,x) (set! ,x tmp))))
     314    (macro-letrec (
     315      ((swap1 x y)
     316       `(swap2 ,x ,y))
     317      ((swap2 x y)
     318       `(let ((tmp ,y)) (set! ,y ,x) (set! ,x tmp)))
     319      )
    333320      (let ((x 'x) (y 'y))
    334321        (swap1 x y)
     
    337324    '(x y))
    338325  (equal?
    339     (macro-let (((swap1 x y)
    340                  `(let ((tmp ,y)) (set! ,y ,x) (set! ,x tmp)))
    341                 ((swap2 x y)
    342                  `(let ((tmp ,y)) (set! ,y ,x) (set! ,x tmp))))
     326    (macro-let (
     327      ((swap1 x y)
     328       `(let ((tmp ,y)) (set! ,y ,x) (set! ,x tmp)))
     329      ((swap2 x y)
     330       `(let ((tmp ,y)) (set! ,y ,x) (set! ,x tmp)))
     331      )
    343332      (let ((x 'x) (y 'y))
    344333        (swap1 x y)
     
    348337  )
    349338
    350 (compound-test (procedural-macros)
    351   (basic-macros?)
    352   (procedural-macros?)
    353 ) ; compound test
     339;(macrolet?)
     340
     341;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     342
     343(compound-test (PROCEDURAL-MACROS)
     344  (macro-helpers?)
     345  (macro-rules?)
     346  (define-macro?)
     347  (macrolet?)
     348  )
     349
Note: See TracChangeset for help on using the changeset viewer.