Changeset 38670 in project for release


Ignore:
Timestamp:
05/01/20 19:42:40 (3 months ago)
Author:
juergen
Message:

procedural-macros 3.0 with define-ir-macro and define-er-macro

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

Legend:

Unmodified
Added
Removed
  • release/5/procedural-macros/tags/3.0/procedural-macros.egg

    r38312 r38670  
    55 (dependencies bindings)
    66 (author "Juergen Lorenz")
    7  (version "2.1.1")
     7 (version "3.0")
    88 (components
    99   (extension procedural-macros
  • release/5/procedural-macros/tags/3.0/procedural-macros.scm

    r38189 r38670  
    3333(module procedural-macros (
    3434  define-macro
     35  define-er-macro
     36  define-ir-macro
    3537  macro-rules
    3638  macro-let
     
    126128              )))))))
    127129
     130(define-syntax define-key-macro ;; internal
     131  (er-macro-transformer
     132    (lambda (f r c?)
     133      (let ((key (cadr f))
     134            (adjoin
     135              (lambda (sym syms)
     136                (if (memq sym syms)
     137                  syms
     138                  (cons sym syms))))
     139            (prefixed?
     140              (lambda (fix sym)
     141                (and (symbol? sym)
     142                  (let ((sfix (symbol->string fix))
     143                        (ssym (symbol->string sym)))
     144                    (let ((fixlen (string-length sfix))
     145                          (symlen (string-length ssym)))
     146                      (and (< fixlen symlen)
     147                           (string=? sfix (substring ssym 0 fixlen))))))))
     148            (%form (r 'form))
     149            (%rename (r 'rename))
     150            (%inject (r 'inject))
     151            (%compare? (r 'compare?))
     152            (%lambda (r 'lambda))
     153            (%let (r 'let))
     154            (%bind-case (r 'bind-case))
     155            (%define-syntax (r 'define-syntax))
     156            (%er-macro-transformer (r 'er-macro-transformer))
     157            (%ir-macro-transformer (r 'ir-macro-transformer))
     158            (%_ (r '_))
     159            (%define-key-macro (r 'define-key-macro))
     160            (%where (r 'where))
     161            (%key? (r 'key?))
     162            )
     163        (let ((transformer
     164                (case key
     165                  ((#:er) %er-macro-transformer)
     166                  ((#:ir) %ir-macro-transformer)))
     167              (mapper
     168                (case key
     169                  ((#:er) %rename)
     170                  ((#:ir) %inject)))
     171              (strip-prefix
     172                (lambda (fix sym)
     173                  (and (prefixed? fix sym)
     174                       (string->symbol
     175                         (substring (symbol->string sym)
     176                                    (string-length (symbol->string
     177                                                     fix)))))))
     178              (extract-prefixed
     179                (lambda (fix xss)
     180                  (let ((prefixed '()))
     181                    (let recur ((xss xss))
     182                    ;(print "PPP " prefixed)
     183                      (cond
     184                        ((pair? xss)
     185                         (let ((first (car xss)) (rest (cdr xss)))
     186                           (cond
     187                             ((pair? first)
     188                              (recur (car first))
     189                              (recur (cdr first)))
     190                             ((null? first)
     191                              (error 'define-er-macro
     192                                     "no nil in car position"))
     193                             (else
     194                              (set! prefixed
     195                                (if (prefixed? fix first)
     196                                  (adjoin first prefixed)
     197                                  prefixed))))
     198                           (recur rest)))
     199                        ((null? xss) prefixed)
     200                        (else
     201                          (recur
     202                            (if (prefixed? fix xss)
     203                              (adjoin xss prefixed)
     204                              prefixed)))))))))
     205          (let ((insert-mapped-symbols
     206                  (lambda (pat fend fix tpl) ;(fix pat tpl)
     207                    `(,pat ,fend
     208                    ;`(,(cons '_ (cdr pat)) ;pat
     209                       (,%let ,(map (lambda (t)
     210                                      `(,t (,mapper ',(strip-prefix fix t))))
     211                                                                    ;(car pat) t))))
     212                                    (extract-prefixed fix tpl));(car pat) tpl))
     213                                  ,@tpl)))))
     214(bind-case (cddr f)
     215  (((name . args) (where . fenders) prefix xpr . xprs)
     216   `(,%define-key-macro ,(cadr f)
     217      ,name ((,%_ ,@args) (,%where ,@fenders) ,prefix ,xpr ,@xprs)))
     218  (((name . args) prefix xpr . xprs)
     219   `(,%define-key-macro ,(cadr f)
     220      ,name ((,%_ ,@args) (,%where) ,prefix ,xpr ,@xprs)))
     221  ;((name . pat-fend-fix-tpls)
     222  ((name . pat-rest)
     223   (let ((pat-fend-fix-tpls
     224           ;; check for where clause
     225           (map (lambda (lst)
     226                  (cond
     227                    ((and (pair? (cadr lst))
     228                          (c? (caadr lst) %where)
     229                          (symbol? (caddr lst)))
     230                     lst)
     231                    ((and (pair? (cadr lst))
     232                          (c? (caadr lst) %where))
     233                     (error 'er/ir-macro "prefix missing"))
     234                    (else
     235                      (apply list
     236                             (car lst)
     237                             `(,%where)
     238                             (if (symbol? (cadr lst))
     239                               (cadr lst)
     240                               (error 'er/ir-macro "prefix missing"))
     241                             (cddr lst)))))
     242               pat-rest)))
     243     `(,%define-syntax ,name
     244        (,transformer
     245          (,%lambda (,%form ,mapper ,%compare?)
     246            (,%bind-case ,%form
     247              ,@(map insert-mapped-symbols
     248                  (map car pat-fend-fix-tpls)
     249                  (map (lambda (fend)
     250                         (if (null? (cdr fend))
     251                           ;; no keyword-checks
     252                           fend
     253                           ;; do keyword-checks
     254                           `(,(car fend)
     255                             ,@(map (lambda (p)
     256                                      (if (c? (car p) %key?)
     257                                        `(,%compare? ,(cadr p)
     258                                                     (,mapper ',(cadr p)))
     259                                        p))
     260                                    (cdr fend)))))
     261                       (map cadr pat-fend-fix-tpls))
     262                  (map caddr pat-fend-fix-tpls)
     263                  (map cdddr pat-fend-fix-tpls))))))))
     264    )))))))
     265
     266;;; (define-er-macro (name . args) (where . fenders) prefix xpr . xprs)
     267;;; (define-er-macro (name . args) prefix xpr . xprs)
     268;;; (define-er-macro name (pat (where . fenders) prefix xpr . xprs) . others)
     269;;; (define-er-macro name (pat prefix xpr . xprs) . others)
     270;;; -------------------------------------------------------------------------
     271;;; where fenders check for keywords via key?
     272;;; Version of define-macro, where symbols prefixed with prefix
     273;;; are automatically renamed
     274(define-syntax define-er-macro
     275  (syntax-rules (where)
     276    ((_ (name . args) (where . fenders) prefix xpr . xprs)
     277     (define-key-macro #:er (name . args) (where . fenders)
     278       prefix xpr . xprs))
     279    ((_ (name . args) prefix xpr . xprs)
     280     (define-key-macro #:er (name . args)
     281       prefix xpr . xprs))
     282    ((_ name . pat-rest)
     283     (define-key-macro #:er name . pat-rest))
     284    ))
     285
     286;;; (define-ir-macro (name . args) (where . fenders) prefix xpr . xprs)
     287;;; (define-ir-macro (name . args) prefix xpr . xprs)
     288;;; (define-ir-macro name (pat (where . fenders) prefix xpr . xprs) . others)
     289;;; (define-ir-macro name (pat prefix xpr . xprs) . others)
     290;;; -------------------------------------------------------------------------
     291;;; where fenders check for keywords via key?
     292;;; Version of define-macro, where symbols prefixed with prefix
     293;;; are automatically injected.
     294(define-syntax define-ir-macro
     295  (syntax-rules (where)
     296    ((_ (name . args) (where . fenders) prefix xpr . xprs)
     297     (define-key-macro #:ir (name . args) (where . fenders)
     298       prefix xpr . xprs))
     299    ((_ (name . args) prefix xpr . xprs)
     300     (define-key-macro #:ir (name . args)
     301       prefix xpr . xprs))
     302    ((_ name . pat-rest)
     303     (define-key-macro #:ir name . pat-rest))
     304    ))
     305
    128306;;; (macro-rules sym ... (key ...) (pat tpl) ....)
    129307;;; ----------------------------------------------
     
    183361                     (map* keys->keywords form)))
    184362                 )
    185          ;(print "XXX " (rewrite-keys f))
    186363            `(,%ir-macro-transformer
    187364               (,%lambda (,%form ,%inject ,%compare?)
     
    189366                                `(,s (,%inject ',s)))
    190367                         syms)
    191          ;(print "FFF " ,%form)
    192          ;(print "SSS " (,rewrite-keys ,%form))
    193          ;(print "TTT " ,(rewrite-keys %form))
    194368                     (,%bind-case ;,%form ,@rules)
    195369                       ;,%form
     
    211385;;; --------------------------------------------------
    212386;;; evaluates xpr ... in the context of parallel macros name ....
    213 ;(define-macro (macro-let signature-body-list xpr . xprs)
    214 ;  (with-explicit-renaming (compare? %let-syntax %macro-rules)
    215387(define-macro (macro-let signature-body-list xpr . xprs)
    216388  (with-explicit-renaming (compare? %let-syntax %macro-rules)
     
    314486      "The latter version is used if no keys are needed and nothing is"
    315487      "to be injected")
     488    (define-er-macro
     489      macro:
     490      (define-er-macro (name . args) (where . fenders) prefix xpr . xprs)
     491      (define-er-macro (name . args) prefix xpr . xprs)
     492      (define-er-macro name (pat (where . fenders) prefix xpr . xprs) . others)
     493      (define-er-macro name (pat prefix xpr . xprs) . others)
     494      "where fenders check for keywords via key? predicate."
     495      "Version of define-macro, where symbols prefixed with prefix"
     496      "are automatically renamed.")
     497    (define-ir-macro
     498      macro:
     499      (define-ir-macro (name . args) (where . fenders) prefix xpr . xprs)
     500      (define-ir-macro (name . args) prefix xpr . xprs)
     501      (define-ir-macro name (pat (where . fenders) prefix xpr . xprs) . others)
     502      (define-ir-macro name (pat prefix xpr . xprs) . others)
     503      "where fenders check for keywords via key? predicate."
     504      "Version of define-macro, where symbols prefixed with prefix"
     505      "are automatically injected.")
    316506    (macro-let
    317507      macro:
  • release/5/procedural-macros/tags/3.0/tests/run.scm

    r38189 r38670  
    88                         macro-rules
    99                         once-only)
    10                    (only checks >>)
     10                   (only checks <<)
    1111                   (only (chicken base) list-of?)
    1212                   (only bindings bind bind-case)
    1313                   )
     14
     15;;; COND AND CASE AS ER- OR IR-MACRO
     16(define-er-macro er-cond
     17  ((_ (else xpr . xprs))
     18   (where (key? else))
     19   %
     20   `(,%begin ,xpr ,@xprs))
     21  ((_ (test => xpr))
     22   (where (key? =>))
     23   %
     24   `(,%let ((,%tmp ,test))
     25      (,%if ,%tmp (,xpr ,%tmp))))
     26  ((_ (test => xpr) . clauses)
     27   (where (key? =>))
     28   %
     29   `(,%let ((,%tmp ,test))
     30      (,%if ,%tmp
     31        (,xpr ,%tmp)
     32        (,%er-cond ,@clauses))))
     33  ((_ (test))
     34   %
     35   ;`(if #f #f))
     36   test)
     37  ((_ (test) . clauses)
     38   %
     39   `(,%let ((,%tmp ,test))
     40      (,%if ,%tmp
     41        ,%tmp
     42        (,%er-cond ,@clauses))))
     43  ((_ (test xpr . xprs))
     44   %
     45   `(,%if ,test (,%begin ,xpr ,@xprs)))
     46  ((_ (test xpr . xprs) . clauses)
     47   %
     48   `(,%if ,test
     49      (,%begin ,xpr ,@xprs)
     50      (,%er-cond ,@clauses)))
     51  )
     52
     53(define-ir-macro ir-case* ; helper
     54  ((_ key (else result . results))
     55   (where (key? else))
     56   %
     57   `(begin ,result ,@results))
     58  ((_ key (keys result . results))
     59   %
     60   `(if (memv ,key ',keys)
     61      (begin ,result ,@results)))
     62  ((_ key (keys result . results) clause . clauses)
     63   %
     64   `(if (memv ,key ',keys)
     65      (begin ,result ,@results)
     66      (ir-case* ,key ,clause ,@clauses)))
     67  )
     68
     69(define-ir-macro (ir-case key clause . clauses)
     70  %
     71  ;`(let ((tmp ,key)) ; ok
     72  ;   (ir-case* tmp ,clause ,@clauses)))
     73  (let ((tmp key)) ; ok
     74    `(ir-case* ,tmp ,clause ,@clauses)))
     75
     76
     77;;; ALAMBDA AS ER- AND IR-MACRO
     78(define-ir-macro (ir-alambda args xpr . xprs)
     79  %
     80  `(letrec ((,%self (lambda ,args ,xpr ,@xprs)))
     81     ,%self))
     82
     83(define-er-macro (er-alambda args xpr . xprs)
     84  %
     85  `(,%letrec ((self (,%lambda ,args ,xpr ,@xprs)))
     86     self))
     87
     88
     89;;; NUMERIC AND VERBOSE IF
     90(define-er-macro (er-nif xpr pos zer neg)
     91  %
     92  `(,%let ((,%result ,xpr))
     93     (,%cond
     94       ((,%positive? ,%result) ,pos)
     95       ((,%negative? ,%result) ,neg)
     96       (,%else ,zer))))
     97
     98(define-er-macro er-vif
     99  ((_ test (then . xprs) (else . yprs))
     100   (where (key? then) (key? else))
     101   %
     102   `(,%if ,test (,%begin ,@xprs) (,%begin ,@yprs))))
     103
     104(define ir-case-test #f)
     105(define ir-!-test #f)
     106(define er-nif-test #f)
     107(define er-vif-test #f)
     108
     109(define-checks (Er-ir-checks verbose?)
     110  (er-cond ((> 3 2)))
     111  #t
     112  (er-cond ((> 3 2) 'greater))  ;;; wrong
     113  'greater
     114  (er-cond ((< 3 2) 'greater)
     115           (else 'unknown))
     116  'unknown
     117  (er-cond ((> 3 2) 'greater)
     118           (else 'unknown))
     119  'greater
     120  (er-cond ((> 3 2) 'greater)
     121           ((< 3 2) 'less))
     122  'greater
     123  (er-cond
     124    ((> 3 3) 'greater)
     125    ((< 3 3) 'less)
     126    (else 'equal))
     127  'equal
     128  (er-cond ((assv 'b `((a 1) (b 2) (C 3))) => cadr)
     129           (else #f))
     130  2
     131  (er-cond ((assv 'x `((a 1) (b 2) (C 3))) => cadr)
     132           (else #f))
     133  #f
     134  (set! ir-case-test
     135    (lambda (n)
     136      (ir-case n
     137        ((1 3 5 7 9) 'odd)
     138        ((0 2 4 6 8) 'even)
     139        (else 'too-large)
     140        )))
     141  (if #f #f)
     142  (ir-case-test 5)
     143  'odd
     144  (ir-case-test 2)
     145  'even
     146  (set! ir-!-test
     147    (ir-alambda (n) (if (zero? n) 1 (* n (self (- n 1))))))
     148  (if #f #f)
     149  (ir-!-test 5)
     150  120
     151  (set! er-nif-test
     152    (lambda (n)
     153      (er-nif n 'pos 'zer 'neg)))
     154  (if #f #f)
     155  (er-nif-test 0)
     156  'zer
     157  (er-nif-test 5)
     158  'pos
     159  (set! er-vif-test
     160    (lambda (n)
     161      (er-vif (odd? n) (then 'odd) (else 'even))))
     162  (if #f #f)
     163  (er-vif-test 5)
     164  'odd
     165  (er-vif-test 0)
     166  'even
     167  )
     168;(Er-ir-checks)
    14169
    15170(define counter
     
    25180(pe '(once-only (x)
    26181      `(* ,x ,x)))
     182
     183(define-macro (square x)
     184  (with-explicit-renaming (compare? %*)
     185    (once-only (x)
     186      `(,%* ,x ,x))))
     187
     188(define-macro (wrong-square x)
     189  (with-explicit-renaming (compare? %*)
     190    `(,%* ,x ,x)))
     191
     192(define-checks (Helpers verbose?)
     193  (with-renamed-symbols (identity %a %b %c) (list %a %b %c))
     194  '(a b c)
     195  (even? (wrong-square (counter)))
     196  #t
     197  (integer? (sqrt (square (counter))))
     198  #t
     199  )
     200;(Helpers)
    27201
    28202(print "\nMY-COND\n")
     
    71245(newline)
    72246
    73 (define-macro (square x)
    74   (with-explicit-renaming (compare? %*)
    75     (once-only (x)
    76       `(,%* ,x ,x))))
    77 
    78 (define-macro (wrong-square x)
    79   (with-explicit-renaming (compare? %*)
    80     `(,%* ,x ,x)))
    81 
    82 (define-test (macro-helpers?)
    83   (equal? (with-renamed-symbols (identity %a %b %c) (list %a %b %c))
    84           '(a b c))
    85   (even? (wrong-square (counter)))
    86   (integer? (sqrt (square (counter))))
    87   )
    88 
    89 ;(macro-helpers?)
    90 
    91 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    92247(define-syntax my-cond
    93248  (macro-rules (else =>)
     
    119274
    120275(define-syntax vif
    121   (macro-rules (then else) ;(#:then #:else)
     276  (macro-rules (then else)
    122277    ((_ test (then xpr . xprs))
    123278     `(if ,test
     
    151306    ((_ #f x) `(list 'false))
    152307    ((_ #f x) 'false)
    153     ((_ a b) (>> a string?)
     308    ((_ a b) (where (string? a))
    154309             `(list ,a ,b))
    155     ((_ a b) (>> a odd?)
     310    ((_ a b) (where (odd? a))
    156311             `(list ,a ,b))
    157312    ((_ a b) a)))
     
    159314(define-syntax add
    160315  (macro-rules ()
    161     ((_ x y)
    162      (>> x string?)
    163      (>> y string?)
     316    ((_ x y) (where (string? x) (string? y))
    164317     `(string-append ,x ,y))
    165     (( _ x y)
    166      (>> x integer?)
    167      (>> y integer?)
     318    (( _ x y) (where (integer? x) (integer? y))
    168319     `(+ ,x ,y))))
    169320
    170 (define x 5)
    171 
    172 (define-test (macro-rules?)
    173   (= x 5)
    174   (= (aif (<< x odd?) it) 5)
    175   (eq? (vif (odd? x) (then 'odd) (else 'even)) 'odd)
    176   (= ((alambda (n) (if (= n 1) 1 (* n (self (- n 1))))) 5)
    177      120)
    178   "LITERALS"
    179   (= (foo "foo" 1) 1)
    180   (equal? (foo "bar" 2) '("bar" 2))
    181   (equal? (foo #f 'blabla) '(false))
    182   (equal? (foo 1 2) '(1 2))
    183   (= (foo 2 3) 2)
    184   "LOW-LEVEL COND"
     321(define-checks (Rules verbose? x 5)
     322  x
     323  5
     324  (aif (<< x odd?) it)
     325  5
     326  (vif (odd? x) (then 'odd) (else 'even))
     327  'odd
     328  ((alambda (n) (if (= n 1) 1 (* n (self (- n 1))))) 5)
     329  120
     330  (foo "foo" 1)
     331  1
     332  (foo "bar" 2)
     333  '("bar" 2)
     334  (foo #f 'blabla)
     335  '(false)
     336  (foo 1 2)
     337  '(1 2)
     338  (foo 2 3)
     339  2
    185340  (my-cond ((> 3 2)))
    186   (eq? (my-cond ((> 3 2) 'greater) ((< 3 2) 'less))
    187        'greater)
    188   (eq? (my-cond
    189          ((> 3 3) 'greater)
    190          ((< 3 3) 'less)
    191          (else 'equal))
    192        'equal)
    193   (= (my-cond ((assv 'b `((a 1) (b 2) (C 3))) => cadr)
    194               (else #f))
    195      2)
    196   (not (my-cond ((assv 'x `((a 1) (b 2) (C 3))) => cadr)
    197                 (else #f)))
    198   (= (add 1 2) 3)
    199   (string=? (add "a" "b") "ab")
    200   )
    201 
    202 ;(macro-rules?)
     341  #t
     342  (my-cond ((> 3 2) 'greater) ((< 3 2) 'less))
     343  'greater
     344  (my-cond
     345    ((> 3 3) 'greater)
     346    ((< 3 3) 'less)
     347    (else 'equal))
     348  'equal
     349  (my-cond ((assv 'b `((a 1) (b 2) (C 3))) => cadr)
     350           (else #f))
     351  2
     352  (my-cond ((assv 'x `((a 1) (b 2) (C 3))) => cadr)
     353           (else #f))
     354  #f
     355  (add 1 2)
     356  3
     357  (add "a" "b")
     358  "ab"
     359  )
     360;(Rules)
    203361
    204362(define-macro (my-letrec pairs xpr . xprs)
    205363  ;(with-implicit-renaming (c?)
    206     (>> pairs (list-of? pair?))
     364    (<< pairs (list-of? pair?))
    207365    (let ((vars (map car pairs))
    208366          (vals (map cadr pairs))
     
    241399    (c? %result %positive? %negative? %let %cond %else)
    242400    `(,%let ((,%result ,xpr))
    243             (,%cond
    244               ((,%positive? ,%result) ,pos)
    245               ((,%negative? ,%result) ,neg)
    246               (,%else ,zer)))))
     401       (,%cond
     402         ((,%positive? ,%result) ,pos)
     403         ((,%negative? ,%result) ,neg)
     404         (,%else ,zer)))))
    247405
    248406(define-macro (aalambda args xpr . xprs)
     
    252410
    253411(define-macro (in what equ? . choices)
    254   ;(with-implicit-renaming (c?)
    255     (let ((insym 'in))
    256       `(let ((,insym ,what))
    257          (or ,@(map (lambda (choice) `(,equ? ,insym ,choice))
    258                     choices)))));)
     412  (let ((insym 'in))
     413    `(let ((,insym ,what))
     414       (or ,@(map (lambda (choice) `(,equ? ,insym ,choice))
     415                  choices)))))
    259416
    260417(define-macro (for (var start end) xpr . xprs)
    261   ;(with-implicit-renaming (c?)
    262     (once-only (start end)
    263       `(do ((,var ,start (add1 ,var)))
    264          ((= ,var ,end))
    265          ,xpr ,@xprs)));)
     418  (once-only (start end)
     419    `(do ((,var ,start (add1 ,var)))
     420       ((= ,var ,end))
     421       ,xpr ,@xprs)))
    266422
    267423(define-macro (freeze xpr)
    268424  `(lambda () ,xpr))
    269425
    270 (define-test (define-macro?)
    271   (equal? (let ((x 'x) (y 'y))
    272             (eswap! x y)
    273             (list x y))
    274           '(y x))
    275   (equal? (let ((x 'x) (y 'y))
    276             (iswap! x y)
    277             (list x y))
    278           '(y x))
    279   (equal? (let ((x 'x) (y 'y))
    280             (swap! x y)
    281             (list x y))
    282           '(y x))
    283   (= x 5)
    284   (= ((aalambda (n) (if (= n 1) 1 (* n (self (- n 1))))) 5) 120)
    285   (eq? (vvif (odd? x) (then 'odd) (else 'even)) 'odd)
    286   (eq? (nif 2 'positive 'zero 'negative) 'positive)
     426(define-checks (Defines verbose?  x 5)
     427  (let ((x 'x) (y 'y))
     428    (eswap! x y)
     429    (list x y))
     430  '(y x)
     431  (let ((x 'x) (y 'y))
     432    (iswap! x y)
     433    (list x y))
     434  '(y x)
     435  (let ((x 'x) (y 'y))
     436    (swap! x y)
     437    (list x y))
     438  '(y x)
     439  x
     440  5
     441  ((aalambda (n) (if (= n 1) 1 (* n (self (- n 1))))) 5)
     442  120
     443  (vvif (odd? x) (then 'odd) (else 'even))
     444  'odd
     445  (nif 2 'positive 'zero 'negative)
     446  'positive
    287447  (in 2 = 1 2 3)
    288   (not (in 5 = 1 2 3))
    289   (= ((freeze 5)) 5)
     448  #t
     449  (in 5 = 1 2 3)
     450  #f
     451  ((freeze 5))
     452  5
    290453  (let ((lst '()))
    291     (for (x 0 (counter)) (set! lst (cons x lst)))
    292     (equal? lst '(3 2 1 0)))
    293   "LETREC"
    294   (equal?
    295     (my-letrec ((o? (lambda (m) (if (zero? m) #f (e? (- m 1)))))
    296                 (e? (lambda (n) (if (zero? n) #t (o? (- n 1))))))
    297                (list (o? 95) (e? 95)))
    298     '(#t #f))
    299   )
    300 
    301 ;(define-macro?)
    302 
    303 (define-test (macrolet?)
    304   (= (macro-let (
    305       ((first lst)
    306        `(begin
    307           (>> ,lst list?)
    308           (car ,lst)))
    309       ((rest lst)
    310        `(begin
    311           (>> ,lst list?)
    312           (cdr ,lst)))
    313       )
    314       (first (rest '(1 2 3))))
    315      2)
    316   (= (macro-letrec (
    317       ((second lst) `(car (rest ,lst)))
    318       ((rest lst) `(cdr ,lst))
    319       )
    320       (second '(1 2 3)))
    321      2)
    322   (equal?
    323     (macro-letrec (
    324       ((swap1 x y)
    325        `(swap2 ,x ,y))
    326       ((swap2 x y)
    327        `(let ((tmp ,y)) (set! ,y ,x) (set! ,x tmp)))
    328       )
    329       (let ((x 'x) (y 'y))
    330         (swap1 x y)
    331         (swap2 x y)
    332         (list x y)))
    333     '(x y))
    334   (equal?
    335     (macro-let (
    336       ((swap1 x y)
    337        `(let ((tmp ,y)) (set! ,y ,x) (set! ,x tmp)))
    338       ((swap2 x y)
    339        `(let ((tmp ,y)) (set! ,y ,x) (set! ,x tmp)))
    340       )
    341       (let ((x 'x) (y 'y))
    342         (swap1 x y)
    343         (swap2 x y)
    344         (list x y)))
    345     '(x y))
    346   )
    347 
    348 ;(macrolet?)
     454    (for (x 0 4) (set! lst (cons x lst)))
     455    lst)
     456  '(3 2 1 0)
     457  (my-letrec ((o? (lambda (m) (if (zero? m) #f (e? (- m 1)))))
     458              (e? (lambda (n) (if (zero? n) #t (o? (- n 1))))))
     459             (list (o? 95) (e? 95)))
     460  '(#t #f)
     461  )
     462;(Defines)
     463
     464(define-checks (Lets verbose?)
     465  (macro-let (
     466   ((first lst)
     467    `(car (<< ,lst list?)))
     468   ((rest lst)
     469    `(cdr (<< ,lst list?)))
     470   )
     471   (first (rest '(1 2 3))))
     472  2
     473  (macro-letrec (
     474   ((second lst) `(car (rest ,lst)))
     475   ((rest lst) `(cdr ,lst))
     476   )
     477   (second '(1 2 3)))
     478  2
     479  (macro-letrec (
     480    ((swap1 x y)
     481     `(swap2 ,x ,y))
     482    ((swap2 x y)
     483     `(let ((tmp ,y)) (set! ,y ,x) (set! ,x tmp)))
     484    )
     485    (let ((x 'x) (y 'y))
     486      (swap1 x y)
     487      (swap2 x y)
     488      (list x y)))
     489  '(x y)
     490  (macro-let (
     491    ((swap1 x y)
     492     `(let ((tmp ,y)) (set! ,y ,x) (set! ,x tmp)))
     493    ((swap2 x y)
     494     `(let ((tmp ,y)) (set! ,y ,x) (set! ,x tmp)))
     495    )
     496    (let ((x 'x) (y 'y))
     497      (swap1 x y)
     498      (swap2 x y)
     499      (list x y)))
     500  '(x y)
     501  )
     502;(Lets)
    349503;
    350 (compound-test (PROCEDURAL-MACROS)
    351   (macro-helpers?)
    352   (macro-rules?)
    353   (define-macro?)
    354   (macrolet?)
    355   )
    356 ;
     504(check-all MACROS (Er-ir-checks) (Helpers) (Rules) (Defines) (Lets))
  • release/5/procedural-macros/trunk/procedural-macros.egg

    r38312 r38670  
    55 (dependencies bindings)
    66 (author "Juergen Lorenz")
    7  (version "2.1.1")
     7 (version "3.0")
    88 (components
    99   (extension procedural-macros
  • release/5/procedural-macros/trunk/procedural-macros.scm

    r38189 r38670  
    3333(module procedural-macros (
    3434  define-macro
     35  define-er-macro
     36  define-ir-macro
    3537  macro-rules
    3638  macro-let
     
    126128              )))))))
    127129
     130(define-syntax define-key-macro ;; internal
     131  (er-macro-transformer
     132    (lambda (f r c?)
     133      (let ((key (cadr f))
     134            (adjoin
     135              (lambda (sym syms)
     136                (if (memq sym syms)
     137                  syms
     138                  (cons sym syms))))
     139            (prefixed?
     140              (lambda (fix sym)
     141                (and (symbol? sym)
     142                  (let ((sfix (symbol->string fix))
     143                        (ssym (symbol->string sym)))
     144                    (let ((fixlen (string-length sfix))
     145                          (symlen (string-length ssym)))
     146                      (and (< fixlen symlen)
     147                           (string=? sfix (substring ssym 0 fixlen))))))))
     148            (%form (r 'form))
     149            (%rename (r 'rename))
     150            (%inject (r 'inject))
     151            (%compare? (r 'compare?))
     152            (%lambda (r 'lambda))
     153            (%let (r 'let))
     154            (%bind-case (r 'bind-case))
     155            (%define-syntax (r 'define-syntax))
     156            (%er-macro-transformer (r 'er-macro-transformer))
     157            (%ir-macro-transformer (r 'ir-macro-transformer))
     158            (%_ (r '_))
     159            (%define-key-macro (r 'define-key-macro))
     160            (%where (r 'where))
     161            (%key? (r 'key?))
     162            )
     163        (let ((transformer
     164                (case key
     165                  ((#:er) %er-macro-transformer)
     166                  ((#:ir) %ir-macro-transformer)))
     167              (mapper
     168                (case key
     169                  ((#:er) %rename)
     170                  ((#:ir) %inject)))
     171              (strip-prefix
     172                (lambda (fix sym)
     173                  (and (prefixed? fix sym)
     174                       (string->symbol
     175                         (substring (symbol->string sym)
     176                                    (string-length (symbol->string
     177                                                     fix)))))))
     178              (extract-prefixed
     179                (lambda (fix xss)
     180                  (let ((prefixed '()))
     181                    (let recur ((xss xss))
     182                    ;(print "PPP " prefixed)
     183                      (cond
     184                        ((pair? xss)
     185                         (let ((first (car xss)) (rest (cdr xss)))
     186                           (cond
     187                             ((pair? first)
     188                              (recur (car first))
     189                              (recur (cdr first)))
     190                             ((null? first)
     191                              (error 'define-er-macro
     192                                     "no nil in car position"))
     193                             (else
     194                              (set! prefixed
     195                                (if (prefixed? fix first)
     196                                  (adjoin first prefixed)
     197                                  prefixed))))
     198                           (recur rest)))
     199                        ((null? xss) prefixed)
     200                        (else
     201                          (recur
     202                            (if (prefixed? fix xss)
     203                              (adjoin xss prefixed)
     204                              prefixed)))))))))
     205          (let ((insert-mapped-symbols
     206                  (lambda (pat fend fix tpl) ;(fix pat tpl)
     207                    `(,pat ,fend
     208                    ;`(,(cons '_ (cdr pat)) ;pat
     209                       (,%let ,(map (lambda (t)
     210                                      `(,t (,mapper ',(strip-prefix fix t))))
     211                                                                    ;(car pat) t))))
     212                                    (extract-prefixed fix tpl));(car pat) tpl))
     213                                  ,@tpl)))))
     214(bind-case (cddr f)
     215  (((name . args) (where . fenders) prefix xpr . xprs)
     216   `(,%define-key-macro ,(cadr f)
     217      ,name ((,%_ ,@args) (,%where ,@fenders) ,prefix ,xpr ,@xprs)))
     218  (((name . args) prefix xpr . xprs)
     219   `(,%define-key-macro ,(cadr f)
     220      ,name ((,%_ ,@args) (,%where) ,prefix ,xpr ,@xprs)))
     221  ;((name . pat-fend-fix-tpls)
     222  ((name . pat-rest)
     223   (let ((pat-fend-fix-tpls
     224           ;; check for where clause
     225           (map (lambda (lst)
     226                  (cond
     227                    ((and (pair? (cadr lst))
     228                          (c? (caadr lst) %where)
     229                          (symbol? (caddr lst)))
     230                     lst)
     231                    ((and (pair? (cadr lst))
     232                          (c? (caadr lst) %where))
     233                     (error 'er/ir-macro "prefix missing"))
     234                    (else
     235                      (apply list
     236                             (car lst)
     237                             `(,%where)
     238                             (if (symbol? (cadr lst))
     239                               (cadr lst)
     240                               (error 'er/ir-macro "prefix missing"))
     241                             (cddr lst)))))
     242               pat-rest)))
     243     `(,%define-syntax ,name
     244        (,transformer
     245          (,%lambda (,%form ,mapper ,%compare?)
     246            (,%bind-case ,%form
     247              ,@(map insert-mapped-symbols
     248                  (map car pat-fend-fix-tpls)
     249                  (map (lambda (fend)
     250                         (if (null? (cdr fend))
     251                           ;; no keyword-checks
     252                           fend
     253                           ;; do keyword-checks
     254                           `(,(car fend)
     255                             ,@(map (lambda (p)
     256                                      (if (c? (car p) %key?)
     257                                        `(,%compare? ,(cadr p)
     258                                                     (,mapper ',(cadr p)))
     259                                        p))
     260                                    (cdr fend)))))
     261                       (map cadr pat-fend-fix-tpls))
     262                  (map caddr pat-fend-fix-tpls)
     263                  (map cdddr pat-fend-fix-tpls))))))))
     264    )))))))
     265
     266;;; (define-er-macro (name . args) (where . fenders) prefix xpr . xprs)
     267;;; (define-er-macro (name . args) prefix xpr . xprs)
     268;;; (define-er-macro name (pat (where . fenders) prefix xpr . xprs) . others)
     269;;; (define-er-macro name (pat prefix xpr . xprs) . others)
     270;;; -------------------------------------------------------------------------
     271;;; where fenders check for keywords via key?
     272;;; Version of define-macro, where symbols prefixed with prefix
     273;;; are automatically renamed
     274(define-syntax define-er-macro
     275  (syntax-rules (where)
     276    ((_ (name . args) (where . fenders) prefix xpr . xprs)
     277     (define-key-macro #:er (name . args) (where . fenders)
     278       prefix xpr . xprs))
     279    ((_ (name . args) prefix xpr . xprs)
     280     (define-key-macro #:er (name . args)
     281       prefix xpr . xprs))
     282    ((_ name . pat-rest)
     283     (define-key-macro #:er name . pat-rest))
     284    ))
     285
     286;;; (define-ir-macro (name . args) (where . fenders) prefix xpr . xprs)
     287;;; (define-ir-macro (name . args) prefix xpr . xprs)
     288;;; (define-ir-macro name (pat (where . fenders) prefix xpr . xprs) . others)
     289;;; (define-ir-macro name (pat prefix xpr . xprs) . others)
     290;;; -------------------------------------------------------------------------
     291;;; where fenders check for keywords via key?
     292;;; Version of define-macro, where symbols prefixed with prefix
     293;;; are automatically injected.
     294(define-syntax define-ir-macro
     295  (syntax-rules (where)
     296    ((_ (name . args) (where . fenders) prefix xpr . xprs)
     297     (define-key-macro #:ir (name . args) (where . fenders)
     298       prefix xpr . xprs))
     299    ((_ (name . args) prefix xpr . xprs)
     300     (define-key-macro #:ir (name . args)
     301       prefix xpr . xprs))
     302    ((_ name . pat-rest)
     303     (define-key-macro #:ir name . pat-rest))
     304    ))
     305
    128306;;; (macro-rules sym ... (key ...) (pat tpl) ....)
    129307;;; ----------------------------------------------
     
    183361                     (map* keys->keywords form)))
    184362                 )
    185          ;(print "XXX " (rewrite-keys f))
    186363            `(,%ir-macro-transformer
    187364               (,%lambda (,%form ,%inject ,%compare?)
     
    189366                                `(,s (,%inject ',s)))
    190367                         syms)
    191          ;(print "FFF " ,%form)
    192          ;(print "SSS " (,rewrite-keys ,%form))
    193          ;(print "TTT " ,(rewrite-keys %form))
    194368                     (,%bind-case ;,%form ,@rules)
    195369                       ;,%form
     
    211385;;; --------------------------------------------------
    212386;;; evaluates xpr ... in the context of parallel macros name ....
    213 ;(define-macro (macro-let signature-body-list xpr . xprs)
    214 ;  (with-explicit-renaming (compare? %let-syntax %macro-rules)
    215387(define-macro (macro-let signature-body-list xpr . xprs)
    216388  (with-explicit-renaming (compare? %let-syntax %macro-rules)
     
    314486      "The latter version is used if no keys are needed and nothing is"
    315487      "to be injected")
     488    (define-er-macro
     489      macro:
     490      (define-er-macro (name . args) (where . fenders) prefix xpr . xprs)
     491      (define-er-macro (name . args) prefix xpr . xprs)
     492      (define-er-macro name (pat (where . fenders) prefix xpr . xprs) . others)
     493      (define-er-macro name (pat prefix xpr . xprs) . others)
     494      "where fenders check for keywords via key? predicate."
     495      "Version of define-macro, where symbols prefixed with prefix"
     496      "are automatically renamed.")
     497    (define-ir-macro
     498      macro:
     499      (define-ir-macro (name . args) (where . fenders) prefix xpr . xprs)
     500      (define-ir-macro (name . args) prefix xpr . xprs)
     501      (define-ir-macro name (pat (where . fenders) prefix xpr . xprs) . others)
     502      (define-ir-macro name (pat prefix xpr . xprs) . others)
     503      "where fenders check for keywords via key? predicate."
     504      "Version of define-macro, where symbols prefixed with prefix"
     505      "are automatically injected.")
    316506    (macro-let
    317507      macro:
  • release/5/procedural-macros/trunk/tests/run.scm

    r38189 r38670  
    88                         macro-rules
    99                         once-only)
    10                    (only checks >>)
     10                   (only checks <<)
    1111                   (only (chicken base) list-of?)
    1212                   (only bindings bind bind-case)
    1313                   )
     14
     15;;; COND AND CASE AS ER- OR IR-MACRO
     16(define-er-macro er-cond
     17  ((_ (else xpr . xprs))
     18   (where (key? else))
     19   %
     20   `(,%begin ,xpr ,@xprs))
     21  ((_ (test => xpr))
     22   (where (key? =>))
     23   %
     24   `(,%let ((,%tmp ,test))
     25      (,%if ,%tmp (,xpr ,%tmp))))
     26  ((_ (test => xpr) . clauses)
     27   (where (key? =>))
     28   %
     29   `(,%let ((,%tmp ,test))
     30      (,%if ,%tmp
     31        (,xpr ,%tmp)
     32        (,%er-cond ,@clauses))))
     33  ((_ (test))
     34   %
     35   ;`(if #f #f))
     36   test)
     37  ((_ (test) . clauses)
     38   %
     39   `(,%let ((,%tmp ,test))
     40      (,%if ,%tmp
     41        ,%tmp
     42        (,%er-cond ,@clauses))))
     43  ((_ (test xpr . xprs))
     44   %
     45   `(,%if ,test (,%begin ,xpr ,@xprs)))
     46  ((_ (test xpr . xprs) . clauses)
     47   %
     48   `(,%if ,test
     49      (,%begin ,xpr ,@xprs)
     50      (,%er-cond ,@clauses)))
     51  )
     52
     53(define-ir-macro ir-case* ; helper
     54  ((_ key (else result . results))
     55   (where (key? else))
     56   %
     57   `(begin ,result ,@results))
     58  ((_ key (keys result . results))
     59   %
     60   `(if (memv ,key ',keys)
     61      (begin ,result ,@results)))
     62  ((_ key (keys result . results) clause . clauses)
     63   %
     64   `(if (memv ,key ',keys)
     65      (begin ,result ,@results)
     66      (ir-case* ,key ,clause ,@clauses)))
     67  )
     68
     69(define-ir-macro (ir-case key clause . clauses)
     70  %
     71  ;`(let ((tmp ,key)) ; ok
     72  ;   (ir-case* tmp ,clause ,@clauses)))
     73  (let ((tmp key)) ; ok
     74    `(ir-case* ,tmp ,clause ,@clauses)))
     75
     76
     77;;; ALAMBDA AS ER- AND IR-MACRO
     78(define-ir-macro (ir-alambda args xpr . xprs)
     79  %
     80  `(letrec ((,%self (lambda ,args ,xpr ,@xprs)))
     81     ,%self))
     82
     83(define-er-macro (er-alambda args xpr . xprs)
     84  %
     85  `(,%letrec ((self (,%lambda ,args ,xpr ,@xprs)))
     86     self))
     87
     88
     89;;; NUMERIC AND VERBOSE IF
     90(define-er-macro (er-nif xpr pos zer neg)
     91  %
     92  `(,%let ((,%result ,xpr))
     93     (,%cond
     94       ((,%positive? ,%result) ,pos)
     95       ((,%negative? ,%result) ,neg)
     96       (,%else ,zer))))
     97
     98(define-er-macro er-vif
     99  ((_ test (then . xprs) (else . yprs))
     100   (where (key? then) (key? else))
     101   %
     102   `(,%if ,test (,%begin ,@xprs) (,%begin ,@yprs))))
     103
     104(define ir-case-test #f)
     105(define ir-!-test #f)
     106(define er-nif-test #f)
     107(define er-vif-test #f)
     108
     109(define-checks (Er-ir-checks verbose?)
     110  (er-cond ((> 3 2)))
     111  #t
     112  (er-cond ((> 3 2) 'greater))  ;;; wrong
     113  'greater
     114  (er-cond ((< 3 2) 'greater)
     115           (else 'unknown))
     116  'unknown
     117  (er-cond ((> 3 2) 'greater)
     118           (else 'unknown))
     119  'greater
     120  (er-cond ((> 3 2) 'greater)
     121           ((< 3 2) 'less))
     122  'greater
     123  (er-cond
     124    ((> 3 3) 'greater)
     125    ((< 3 3) 'less)
     126    (else 'equal))
     127  'equal
     128  (er-cond ((assv 'b `((a 1) (b 2) (C 3))) => cadr)
     129           (else #f))
     130  2
     131  (er-cond ((assv 'x `((a 1) (b 2) (C 3))) => cadr)
     132           (else #f))
     133  #f
     134  (set! ir-case-test
     135    (lambda (n)
     136      (ir-case n
     137        ((1 3 5 7 9) 'odd)
     138        ((0 2 4 6 8) 'even)
     139        (else 'too-large)
     140        )))
     141  (if #f #f)
     142  (ir-case-test 5)
     143  'odd
     144  (ir-case-test 2)
     145  'even
     146  (set! ir-!-test
     147    (ir-alambda (n) (if (zero? n) 1 (* n (self (- n 1))))))
     148  (if #f #f)
     149  (ir-!-test 5)
     150  120
     151  (set! er-nif-test
     152    (lambda (n)
     153      (er-nif n 'pos 'zer 'neg)))
     154  (if #f #f)
     155  (er-nif-test 0)
     156  'zer
     157  (er-nif-test 5)
     158  'pos
     159  (set! er-vif-test
     160    (lambda (n)
     161      (er-vif (odd? n) (then 'odd) (else 'even))))
     162  (if #f #f)
     163  (er-vif-test 5)
     164  'odd
     165  (er-vif-test 0)
     166  'even
     167  )
     168;(Er-ir-checks)
    14169
    15170(define counter
     
    25180(pe '(once-only (x)
    26181      `(* ,x ,x)))
     182
     183(define-macro (square x)
     184  (with-explicit-renaming (compare? %*)
     185    (once-only (x)
     186      `(,%* ,x ,x))))
     187
     188(define-macro (wrong-square x)
     189  (with-explicit-renaming (compare? %*)
     190    `(,%* ,x ,x)))
     191
     192(define-checks (Helpers verbose?)
     193  (with-renamed-symbols (identity %a %b %c) (list %a %b %c))
     194  '(a b c)
     195  (even? (wrong-square (counter)))
     196  #t
     197  (integer? (sqrt (square (counter))))
     198  #t
     199  )
     200;(Helpers)
    27201
    28202(print "\nMY-COND\n")
     
    71245(newline)
    72246
    73 (define-macro (square x)
    74   (with-explicit-renaming (compare? %*)
    75     (once-only (x)
    76       `(,%* ,x ,x))))
    77 
    78 (define-macro (wrong-square x)
    79   (with-explicit-renaming (compare? %*)
    80     `(,%* ,x ,x)))
    81 
    82 (define-test (macro-helpers?)
    83   (equal? (with-renamed-symbols (identity %a %b %c) (list %a %b %c))
    84           '(a b c))
    85   (even? (wrong-square (counter)))
    86   (integer? (sqrt (square (counter))))
    87   )
    88 
    89 ;(macro-helpers?)
    90 
    91 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    92247(define-syntax my-cond
    93248  (macro-rules (else =>)
     
    119274
    120275(define-syntax vif
    121   (macro-rules (then else) ;(#:then #:else)
     276  (macro-rules (then else)
    122277    ((_ test (then xpr . xprs))
    123278     `(if ,test
     
    151306    ((_ #f x) `(list 'false))
    152307    ((_ #f x) 'false)
    153     ((_ a b) (>> a string?)
     308    ((_ a b) (where (string? a))
    154309             `(list ,a ,b))
    155     ((_ a b) (>> a odd?)
     310    ((_ a b) (where (odd? a))
    156311             `(list ,a ,b))
    157312    ((_ a b) a)))
     
    159314(define-syntax add
    160315  (macro-rules ()
    161     ((_ x y)
    162      (>> x string?)
    163      (>> y string?)
     316    ((_ x y) (where (string? x) (string? y))
    164317     `(string-append ,x ,y))
    165     (( _ x y)
    166      (>> x integer?)
    167      (>> y integer?)
     318    (( _ x y) (where (integer? x) (integer? y))
    168319     `(+ ,x ,y))))
    169320
    170 (define x 5)
    171 
    172 (define-test (macro-rules?)
    173   (= x 5)
    174   (= (aif (<< x odd?) it) 5)
    175   (eq? (vif (odd? x) (then 'odd) (else 'even)) 'odd)
    176   (= ((alambda (n) (if (= n 1) 1 (* n (self (- n 1))))) 5)
    177      120)
    178   "LITERALS"
    179   (= (foo "foo" 1) 1)
    180   (equal? (foo "bar" 2) '("bar" 2))
    181   (equal? (foo #f 'blabla) '(false))
    182   (equal? (foo 1 2) '(1 2))
    183   (= (foo 2 3) 2)
    184   "LOW-LEVEL COND"
     321(define-checks (Rules verbose? x 5)
     322  x
     323  5
     324  (aif (<< x odd?) it)
     325  5
     326  (vif (odd? x) (then 'odd) (else 'even))
     327  'odd
     328  ((alambda (n) (if (= n 1) 1 (* n (self (- n 1))))) 5)
     329  120
     330  (foo "foo" 1)
     331  1
     332  (foo "bar" 2)
     333  '("bar" 2)
     334  (foo #f 'blabla)
     335  '(false)
     336  (foo 1 2)
     337  '(1 2)
     338  (foo 2 3)
     339  2
    185340  (my-cond ((> 3 2)))
    186   (eq? (my-cond ((> 3 2) 'greater) ((< 3 2) 'less))
    187        'greater)
    188   (eq? (my-cond
    189          ((> 3 3) 'greater)
    190          ((< 3 3) 'less)
    191          (else 'equal))
    192        'equal)
    193   (= (my-cond ((assv 'b `((a 1) (b 2) (C 3))) => cadr)
    194               (else #f))
    195      2)
    196   (not (my-cond ((assv 'x `((a 1) (b 2) (C 3))) => cadr)
    197                 (else #f)))
    198   (= (add 1 2) 3)
    199   (string=? (add "a" "b") "ab")
    200   )
    201 
    202 ;(macro-rules?)
     341  #t
     342  (my-cond ((> 3 2) 'greater) ((< 3 2) 'less))
     343  'greater
     344  (my-cond
     345    ((> 3 3) 'greater)
     346    ((< 3 3) 'less)
     347    (else 'equal))
     348  'equal
     349  (my-cond ((assv 'b `((a 1) (b 2) (C 3))) => cadr)
     350           (else #f))
     351  2
     352  (my-cond ((assv 'x `((a 1) (b 2) (C 3))) => cadr)
     353           (else #f))
     354  #f
     355  (add 1 2)
     356  3
     357  (add "a" "b")
     358  "ab"
     359  )
     360;(Rules)
    203361
    204362(define-macro (my-letrec pairs xpr . xprs)
    205363  ;(with-implicit-renaming (c?)
    206     (>> pairs (list-of? pair?))
     364    (<< pairs (list-of? pair?))
    207365    (let ((vars (map car pairs))
    208366          (vals (map cadr pairs))
     
    241399    (c? %result %positive? %negative? %let %cond %else)
    242400    `(,%let ((,%result ,xpr))
    243             (,%cond
    244               ((,%positive? ,%result) ,pos)
    245               ((,%negative? ,%result) ,neg)
    246               (,%else ,zer)))))
     401       (,%cond
     402         ((,%positive? ,%result) ,pos)
     403         ((,%negative? ,%result) ,neg)
     404         (,%else ,zer)))))
    247405
    248406(define-macro (aalambda args xpr . xprs)
     
    252410
    253411(define-macro (in what equ? . choices)
    254   ;(with-implicit-renaming (c?)
    255     (let ((insym 'in))
    256       `(let ((,insym ,what))
    257          (or ,@(map (lambda (choice) `(,equ? ,insym ,choice))
    258                     choices)))));)
     412  (let ((insym 'in))
     413    `(let ((,insym ,what))
     414       (or ,@(map (lambda (choice) `(,equ? ,insym ,choice))
     415                  choices)))))
    259416
    260417(define-macro (for (var start end) xpr . xprs)
    261   ;(with-implicit-renaming (c?)
    262     (once-only (start end)
    263       `(do ((,var ,start (add1 ,var)))
    264          ((= ,var ,end))
    265          ,xpr ,@xprs)));)
     418  (once-only (start end)
     419    `(do ((,var ,start (add1 ,var)))
     420       ((= ,var ,end))
     421       ,xpr ,@xprs)))
    266422
    267423(define-macro (freeze xpr)
    268424  `(lambda () ,xpr))
    269425
    270 (define-test (define-macro?)
    271   (equal? (let ((x 'x) (y 'y))
    272             (eswap! x y)
    273             (list x y))
    274           '(y x))
    275   (equal? (let ((x 'x) (y 'y))
    276             (iswap! x y)
    277             (list x y))
    278           '(y x))
    279   (equal? (let ((x 'x) (y 'y))
    280             (swap! x y)
    281             (list x y))
    282           '(y x))
    283   (= x 5)
    284   (= ((aalambda (n) (if (= n 1) 1 (* n (self (- n 1))))) 5) 120)
    285   (eq? (vvif (odd? x) (then 'odd) (else 'even)) 'odd)
    286   (eq? (nif 2 'positive 'zero 'negative) 'positive)
     426(define-checks (Defines verbose?  x 5)
     427  (let ((x 'x) (y 'y))
     428    (eswap! x y)
     429    (list x y))
     430  '(y x)
     431  (let ((x 'x) (y 'y))
     432    (iswap! x y)
     433    (list x y))
     434  '(y x)
     435  (let ((x 'x) (y 'y))
     436    (swap! x y)
     437    (list x y))
     438  '(y x)
     439  x
     440  5
     441  ((aalambda (n) (if (= n 1) 1 (* n (self (- n 1))))) 5)
     442  120
     443  (vvif (odd? x) (then 'odd) (else 'even))
     444  'odd
     445  (nif 2 'positive 'zero 'negative)
     446  'positive
    287447  (in 2 = 1 2 3)
    288   (not (in 5 = 1 2 3))
    289   (= ((freeze 5)) 5)
     448  #t
     449  (in 5 = 1 2 3)
     450  #f
     451  ((freeze 5))
     452  5
    290453  (let ((lst '()))
    291     (for (x 0 (counter)) (set! lst (cons x lst)))
    292     (equal? lst '(3 2 1 0)))
    293   "LETREC"
    294   (equal?
    295     (my-letrec ((o? (lambda (m) (if (zero? m) #f (e? (- m 1)))))
    296                 (e? (lambda (n) (if (zero? n) #t (o? (- n 1))))))
    297                (list (o? 95) (e? 95)))
    298     '(#t #f))
    299   )
    300 
    301 ;(define-macro?)
    302 
    303 (define-test (macrolet?)
    304   (= (macro-let (
    305       ((first lst)
    306        `(begin
    307           (>> ,lst list?)
    308           (car ,lst)))
    309       ((rest lst)
    310        `(begin
    311           (>> ,lst list?)
    312           (cdr ,lst)))
    313       )
    314       (first (rest '(1 2 3))))
    315      2)
    316   (= (macro-letrec (
    317       ((second lst) `(car (rest ,lst)))
    318       ((rest lst) `(cdr ,lst))
    319       )
    320       (second '(1 2 3)))
    321      2)
    322   (equal?
    323     (macro-letrec (
    324       ((swap1 x y)
    325        `(swap2 ,x ,y))
    326       ((swap2 x y)
    327        `(let ((tmp ,y)) (set! ,y ,x) (set! ,x tmp)))
    328       )
    329       (let ((x 'x) (y 'y))
    330         (swap1 x y)
    331         (swap2 x y)
    332         (list x y)))
    333     '(x y))
    334   (equal?
    335     (macro-let (
    336       ((swap1 x y)
    337        `(let ((tmp ,y)) (set! ,y ,x) (set! ,x tmp)))
    338       ((swap2 x y)
    339        `(let ((tmp ,y)) (set! ,y ,x) (set! ,x tmp)))
    340       )
    341       (let ((x 'x) (y 'y))
    342         (swap1 x y)
    343         (swap2 x y)
    344         (list x y)))
    345     '(x y))
    346   )
    347 
    348 ;(macrolet?)
     454    (for (x 0 4) (set! lst (cons x lst)))
     455    lst)
     456  '(3 2 1 0)
     457  (my-letrec ((o? (lambda (m) (if (zero? m) #f (e? (- m 1)))))
     458              (e? (lambda (n) (if (zero? n) #t (o? (- n 1))))))
     459             (list (o? 95) (e? 95)))
     460  '(#t #f)
     461  )
     462;(Defines)
     463
     464(define-checks (Lets verbose?)
     465  (macro-let (
     466   ((first lst)
     467    `(car (<< ,lst list?)))
     468   ((rest lst)
     469    `(cdr (<< ,lst list?)))
     470   )
     471   (first (rest '(1 2 3))))
     472  2
     473  (macro-letrec (
     474   ((second lst) `(car (rest ,lst)))
     475   ((rest lst) `(cdr ,lst))
     476   )
     477   (second '(1 2 3)))
     478  2
     479  (macro-letrec (
     480    ((swap1 x y)
     481     `(swap2 ,x ,y))
     482    ((swap2 x y)
     483     `(let ((tmp ,y)) (set! ,y ,x) (set! ,x tmp)))
     484    )
     485    (let ((x 'x) (y 'y))
     486      (swap1 x y)
     487      (swap2 x y)
     488      (list x y)))
     489  '(x y)
     490  (macro-let (
     491    ((swap1 x y)
     492     `(let ((tmp ,y)) (set! ,y ,x) (set! ,x tmp)))
     493    ((swap2 x y)
     494     `(let ((tmp ,y)) (set! ,y ,x) (set! ,x tmp)))
     495    )
     496    (let ((x 'x) (y 'y))
     497      (swap1 x y)
     498      (swap2 x y)
     499      (list x y)))
     500  '(x y)
     501  )
     502;(Lets)
    349503;
    350 (compound-test (PROCEDURAL-MACROS)
    351   (macro-helpers?)
    352   (macro-rules?)
    353   (define-macro?)
    354   (macrolet?)
    355   )
    356 ;
     504(check-all MACROS (Er-ir-checks) (Helpers) (Rules) (Defines) (Lets))
Note: See TracChangeset for help on using the changeset viewer.