Changeset 33546 in project


Ignore:
Timestamp:
07/28/16 12:53:06 (4 years ago)
Author:
juergen
Message:

procedural-macros 2.0 using bind-case

Location:
release/4/procedural-macros
Files:
5 edited
4 copied

Legend:

Unmodified
Added
Removed
  • release/4/procedural-macros/tags/2.0/procedural-macros.meta

    r32927 r33546  
    55 (license "BSD")
    66 (test-depends simple-tests)
     7 (depends bindings basic-sequences)
    78 (author "Juergen Lorenz")
    89 (files "procedural-macros.release-info" "procedural-macros.scm" "procedural-macros.setup"
  • release/4/procedural-macros/tags/2.0/procedural-macros.scm

    r33087 r33546  
    11; Author: Juergen Lorenz ; ju (at) jugilo (dot) de
    22;
    3 ; Copyright (c) 2013-2015, Juergen Lorenz
     3; Copyright (c) 2013-2016, Juergen Lorenz
    44; All rights reserved.
    55;
     
    3232
    3333#|[
    34 In his macro bible "On Lisp, p. 232" Paul Graham implemented a beautiful macro,
    35 dbind, which is roughly Common Lisp's destructuring-bind. It invokes
    36 at compile time the following three procedures in Scheme (for lists only).
    37 
    38   (define (destruc pat seq)
    39     (let loop ((pat pat) (seq seq) (n 0))
    40       (if (pair? pat)
    41         (let ((p (car pat)) (recu (loop (cdr pat) seq (+ n 1))))
    42           (if (symbol? p)
    43             (cons `(,p (list-ref ,seq ,n)) recu)
    44             (let ((g (gensym)))
    45               (cons (cons `(,g (list-ref ,seq ,n))
    46                           (loop p g 0))
    47                     recu))))
    48         (let ((tail `(list-tail ,seq ,n)))
    49           (if (null? pat)
    50             '()
    51             `((,pat ,tail)))))))
     34This library will provide some macro-writing macros, in particular
     35macro-rules and define-macro, based on explicit- and implicit-renaming.
     36The syntax of macro-rules mimics that of syntax-rules, except that it
     37allows for injected symbols before the keyword list and the templates
     38are usually quasiquoted lists. Since we use bind-case from the bindings
     39egg, this library accepts wildcards, non-symbol literals and fenders.
     40]|#
     41
     42(require-library bindings basic-sequences)
     43
     44(module procedural-macros
     45  (define-macro macro-rules macro-let macro-letrec once-only
     46   define-ir-macro-transformer define-er-macro-transformer
     47   with-mapped-symbols with-gensyms procedural-macros)
    5248 
    53   (define (dbind-ex binds body)
    54     (if (null? binds)
    55       `(begin ,@body)
    56       `(let ,(map (lambda (b) (if (pair? (car b)) (car b) b))
    57                   binds)
    58          ,(dbind-ex
    59             (mappend (lambda (b) (if (pair? (car b)) (cdr b) '()))
    60                      binds)
    61             body))))
    62 
    63   (define (mappend fn lists)
    64     (apply append (map fn lists)))
    65 
    66 Graham's code works as follows: First, destruc traverses the pattern and
    67 groups each symbol with the location of a runtime object, using gensyms
    68 to step down the pattern while grouping the gensym bound object with all
    69 pairs depending on this gensym. So, for example,
    70 
    71   (destruc '(a (b . c) . d) 'seq)
    72 
    73 will result in
    74 
    75   ((a (list-ref seq 0))
    76    ((#:g (list-ref seq 1)) (b (list-ref #:g 0)) (c (list-tail #:g 1)))
    77    (d (list-tail seq 2)))
    78 
    79 This tree is then transformed via dbind-ex into a nested let to produce
    80 dbind's result
    81 
    82   (let ((a (list-ref seq 0))
    83         (#:g (list-ref seq 1))
    84         (d (list-tail seq 2)))
    85     (let ((b (list-ref #:g 0))
    86           (c (list-tail #:g 1)))
    87       body))
    88  
    89 This library will provide some macro-writing macros, in particular
    90 macro-rules and define-macro, based on implicit-renaming and the local
    91 procedures above, without a detour over bind and friends and sequences
    92 of the bindings library. Indeed, for macro-writing macros lists are
    93 sufficient. But off course, I have to provide some extensions to
    94 Graham's code, length checks and non-symbol literals, as in the bindings
    95 egg.  Nonsymbol literals bind nothing, but match only to themselfs.
    96 Wildcards are not supplied, because they break hygiene.
    97 
    98 The last feature missing is fenders, which is important in particular
    99 for macro-rules and can easily be implemented with a where clause: A
    100 pattern matches successfully if only each pattern variable can be bound,
    101 the length checks pass, the literals match themselfs and the where
    102 clause is satisfied. If any of those conditions is hurt, the next
    103 pattern is tried.
    104 
    105 ]|#
    106 
    107 (module procedural-macros
    108   (define-macro macro-rules macro-let macro-letrec once-only with-gensyms
    109    procedural-macros)
    11049  (import scheme
    111           (only chicken print error case-lambda condition-case))
    112   (import-for-syntax
    113     (only chicken condition-case))
     50          (only bindings bind-case)
     51          (only chicken print error case-lambda))
     52
     53#|[
     54Let's start with some helpers which might be occasionally useful
     55]|#
     56
     57;;; (define-er-macro-transformer form rename compare?)
     58;;; --------------------------------------------------
     59;;; wrapper around er-macro-transformer
     60(define-syntax define-er-macro-transformer
     61  (syntax-rules ()
     62    ((_ (name form rename compare?) xpr . xprs)
     63     (define-syntax name
     64       (er-macro-transformer
     65         (lambda (form rename compare?) xpr . xprs))))))
     66
     67;;; (define-ir-macro-transformer form inject compare?)
     68;;; --------------------------------------------------
     69;;; wrapper around ir-macro-transformer
     70(define-syntax define-ir-macro-transformer
     71  (syntax-rules ()
     72    ((_ (name form inject compare?) xpr . xprs)
     73     (define-syntax name
     74       (ir-macro-transformer
     75         (lambda (form inject compare?) xpr . xprs))))))
     76
     77;;; (with-mapped-symbols mapper prefix- (prefix-x ....) xpr ....)
     78;;; -------------------------------------------------------------
     79;;; binds a series of prefixed names, prefix-x ....
     80;;; to the images of the original names, x ...., under mapper
     81;;; and evaluates xpr .... in this context
     82(define-syntax with-mapped-symbols
     83  (er-macro-transformer
     84    (lambda (form rename compare?)
     85      (let ((mapper (cadr form))
     86            (prefix (caddr form))
     87            (syms (cadddr form))
     88            (xpr (car (cddddr form)))
     89            (xprs (cdr (cddddr form)))
     90            (%let (rename 'let)))
     91        (let ((strip-prefix
     92                (lambda (sym)
     93                  (let ((len (string-length (symbol->string prefix))))
     94                    (string->symbol
     95                      (substring (symbol->string sym) len))))))
     96          `(,%let ,(map (lambda (s)
     97                          `(,s (,mapper ',(strip-prefix s))))
     98                        syms)
     99             ,xpr ,@xprs))))))
     100
     101;;; (with-gensyms (name ....) xpr ....)
     102;;; -----------------------------------
     103;;; binds name ... to (gensym 'name) ... in body xpr ...
     104(define-syntax with-gensyms
     105  (ir-macro-transformer
     106    (lambda (form inject compare?)
     107      `(let ,(map (lambda (n) `(,n (gensym ',n))) (cadr form))
     108         ,@(cddr form)))))
    114109
    115110#|[
     
    126121;;; matching process.
    127122(define-syntax macro-rules
    128   (ir-macro-transformer
    129     (lambda (f i c?)
    130       (letrec (
     123  (er-macro-transformer
     124    (lambda (f r c?)
     125      (let (
     126        (f* (let loop ((tail (cdr f)) (head '()))
     127              (if (symbol? (car tail))
     128                (loop (cdr tail) (cons (car tail) head))
     129                (cons head tail))))
    131130        (filter
    132131          (lambda (ok? lst)
    133             (let loop ((lst lst) (yes '()) (no '()))
    134               (if (null? lst)
    135                 (values (reverse yes) (reverse no))
    136                 (let ((first (car lst)) (rest (cdr lst)))
    137                   (if (ok? first)
    138                     (loop rest (cons first yes) no)
    139                     (loop rest yes (cons first no))))))))
    140         (mappend
    141           (lambda (fn lists)
    142             (apply append (map fn lists))))
     132            (compress (map ok? lst) lst)))
    143133        (flatten*
    144134          ; imported flatten doesn't work with pseudo-lists
     
    151141                (else
    152142                  (cons tree result))))))
    153         (destruc
    154           (lambda (pat seq)
    155             (let loop ((pat pat) (seq seq) (n 0))
    156               (cond
    157                 ((pair? pat)
    158                  (let ((p (car pat)) (recu (loop (cdr pat) seq (+ n 1))))
    159                    (cond
    160                      ((pair? p)
    161                       (let ((g (gensym)))
    162                         `(((,g (list-ref ,seq ,n)) ,@(loop p g 0))
    163                            ,@recu)))
    164                      ((symbol? p)
    165                         `((,p (list-ref ,seq ,n)) ,@recu));)
    166                      (else
    167                        `((,p (equal? ',p (list-ref ,seq ,n)))
    168                          ,@recu))
    169                      )))
    170                 ((symbol? pat)
    171                  `((,pat (list-tail ,seq ,n))))
    172                 ((null? pat)
    173                  `((,pat (null? (list-tail ,seq ,n)))))
    174                 (else
    175                   `((,pat (equal? ,pat (list-tail ,seq ,n)))))))
    176                 ))
    177         (dbind-ex
    178           (lambda (binds body)
    179             (if (null? binds)
    180               ;`(begin ,@body)
    181               body
    182               (call-with-values
    183                 (lambda ()
    184                   (filter (lambda (pair) (symbol? (car pair)))
    185                           (map (lambda (b) (if (pair? (car b)) (car b) b))
    186                                binds)))
    187                 (lambda (defs checks)
    188                   `(let ,defs
    189                      (if (and ,@(map cadr checks))
    190                        ,(dbind-ex
    191                           (mappend (lambda (b) (if (pair? (car b)) (cdr b) '()))
    192                                    binds)
    193                           body)
    194                        (error 'dbind-ex
    195                               "match error"
    196                               `(and ,@(map cadr ',checks))))))
    197                 ))))
     143        (%x (r 'x))
     144        (%let (r 'let))
     145        (%form (r 'form))
     146        (%where (r 'where))
     147        (%lambda (r 'lambda))
     148        (%inject (r 'inject))
     149        (%compare? (r 'compare?))
     150        (%bind-case (r 'bind-case))
     151        (%ir-macro-transformer (r 'ir-macro-transformer))
    198152        )
    199         (let ((f* (let loop ((tail (cdr f)) (head '()))
    200                     (if (symbol? (car tail))
    201                       (loop (cdr tail) (cons (car tail) head))
    202                       (cons head tail)))))
    203           (let ((syms (car f*))
    204                 (keys (cadr f*))
    205                 ;; remove leading underscore and
    206                 ;; insert empty where clause into each rule without one
    207                 ;; to simplify matters via standardization
    208                 (all-rules (map (lambda (rule)
    209                                   (let ((second (cadr rule)))
    210                                     (if (and (pair? second)
    211                                              (c? (car second) 'where))
    212                                       ;rule
    213                                       `(,(cdar rule) ,@(cdr rule))
    214                                       `(,(cdar rule) (where) ,@(cdr rule)))))
    215                                 (cddr f*)))
    216                 (gform 'form))
    217             `(ir-macro-transformer
    218                (lambda (form inject compare?)
    219                  (let ,(map (lambda (s)
    220                               `(,s (inject ',s)))
    221                             syms)
    222                    ,(let loop ((rules all-rules))
    223                       (if (null? rules)
    224                         `(error 'macro-rules
    225                                 "no rule matches"
    226                                 form
    227                                 'in
    228                                 ',(map (lambda (rule)
    229                                          `(,(cons '_ (car rule)) ; pattern
    230                                            ,(cadr rule))) ; where clause
    231                                        all-rules))
    232                         (let ((rule (car rules)))
    233                           `(condition-case
    234                              ,(dbind-ex
    235                                 (condition-case (destruc (car rule)
    236                                                          `(cdr ,gform))
    237                                   ((exn) (loop (cdr rules))))
    238                                 (let* ((pat (car rule))
    239                                        (fpat (flatten* pat))
    240                                        (kpat (filter (lambda (x)  ;;;;
    241                                                        (memq x keys))
    242                                                      fpat))
    243                                        ;; compare? keywords with its names
    244                                        (key-checks
    245                                          (map (lambda (p s)
    246                                                 `(compare? ,p ,s))
    247                                               kpat
    248                                               (map (lambda (x) `',x)
    249                                                    kpat))))
    250                                   (let* ((tpl (cdr rule))
    251                                          (fenders (cdar tpl))
    252                                          (tests
    253                                            (apply append
    254                                              (map (lambda (pair)
    255                                                     (map (lambda (p?)
    256                                                            `(,p?  ,(car pair)))
    257                                                          (cdr pair)))
    258                                                   fenders))))
    259                                     `(if (and ,@key-checks
    260                                               (or ,(null? fenders)
    261                                                   (and ,@tests)))
    262                                         ,@(cdr tpl)
    263                                         ,(loop (cdr rules))))))
    264                              ((exn) ,(loop (cdr rules))))
    265                           ))))))))))))
     153        (let ((syms (car f*))
     154              (keys (cadr f*))
     155              (rules (cddr f*)))
     156          (let* ((pats (map car rules))
     157                 (fpats (map flatten* pats))
     158                 (kpats (map (lambda (fp)
     159                               (filter (lambda (x)
     160                                         (memq x keys))
     161                                       fp))
     162                             fpats))
     163                 ;; compare? keywords with its names
     164                 (key-checks
     165                   (map (lambda (kp)
     166                          (map (lambda (p s)
     167                                 `(,p (,%lambda (,%x)
     168                                                (,%compare? ,%x ,s))))
     169                               kp
     170                               (map (lambda (x) `',x)
     171                                    kp)))
     172                        kpats))
     173                 ;; prepare where clause for each rule
     174                 ;; to check keys
     175                 (all-rules (map (lambda (rule checks)
     176                                   (let ((second (cadr rule)))
     177                                     (if (and (pair? second)
     178                                              (c? (car second) %where))
     179                                       `(,(car rule)
     180                                          (,%where ,@(cdr second) ,@checks)
     181                                          ,@(cddr rule))
     182                                       `(,(car rule)
     183                                          (,%where ,@checks)
     184                                          ,@(cdr rule)))))
     185                                 rules key-checks)))
     186            `(,%ir-macro-transformer
     187               (,%lambda (,%form ,%inject ,%compare?)
     188                 (,%let ,(map (lambda (s)
     189                           `(,s (,%inject ',s)))
     190                         syms)
     191                   (,%bind-case ,%form
     192                                ,@all-rules))))))))))
     193
    266194#|[
    267195And now a hygienic procedural version of our old friend, define-macro,
     
    272200;;; -----------------------------------------------------------
    273201;;; simple hygienic macro without injections and keywords.
    274 (define-syntax define-macro
    275   (ir-macro-transformer
    276     (lambda (form inject compare?)
    277       (let ((code (cadr form))
    278             (xpr (caddr form))
    279             (xprs (cdddr form)))
    280         `(define-syntax ,(car code)
    281            (macro-rules ()
    282              ((_ ,@(cdr code)) ,xpr ,@xprs)))))))
     202(define-er-macro-transformer (define-macro form rename compare?)
     203  (let ((code (cadr form))
     204        (xpr (caddr form))
     205        (xprs (cdddr form));)
     206        (%macro-rules (rename 'macro-rules))
     207        (%define-syntax (rename 'define-syntax)))
     208    `(,%define-syntax ,(car code)
     209       (,%macro-rules ()
     210         ((_ ,@(cdr code)) ,xpr ,@xprs)))))
    283211
    284212#|[
     
    289217
    290218;; helper for macro-let and macro-letrec
    291 (define-syntax macro
    292   (ir-macro-transformer
    293     (lambda (form inject compare?)
    294       (let ((op (cadr form))
    295             (pat-tpl-pairs (caddr form))
    296             (xpr (cadddr form))
    297             (xprs (cddddr form)))
    298         (let ((pats (map car pat-tpl-pairs))
    299               (tpls (map cdr pat-tpl-pairs)))
    300           `(,op ,(map (lambda (pat tpl)
    301                                `(,(car pat)
    302                                   (macro-rules ()
    303                                      ((_ ,@(cdr pat)) ,@tpl))))
    304                               pats tpls)
    305                        ,xpr ,@xprs))))))
     219(define-er-macro-transformer (macro-with form rename compare?)
     220  (let ((op (cadr form))
     221        (pat-tpl-pairs (caddr form))
     222        (xpr (cadddr form))
     223        (xprs (cddddr form))
     224        (%macro-rules (rename 'macro-rules)))
     225    (let ((pats (map car pat-tpl-pairs))
     226          (tpls (map cdr pat-tpl-pairs)))
     227      `(,op ,(map (lambda (pat tpl)
     228                    `(,(car pat)
     229                       (,%macro-rules ()
     230                         ((_ ,@(cdr pat)) ,@tpl))))
     231                  pats tpls)
     232                   ,xpr ,@xprs))))
    306233
    307234;;; (macro-let (((name . args) (where fender ...) .. xpr ...) ...) body ....)
    308235;;; -------------------------------------------------------------------------
    309236;;; evaluates body ... in the context of parallel macros name ....
    310 (define-syntax macro-let
    311   (ir-macro-transformer
    312     (lambda (form inject compare?)
    313       (let ((pat-tpl-pairs (cadr form))
    314             (xpr (caddr form))
    315             (xprs (cdddr form)))
    316         `(macro let-syntax ,pat-tpl-pairs ,xpr ,@xprs)))))
     237(define-er-macro-transformer (macro-let form rename compare?)
     238  (let ((pat-tpl-pairs (cadr form))
     239        (xpr (caddr form))
     240        (xprs (cdddr form));)
     241        (%macro-with (rename 'macro-with))
     242        (%let-syntax (rename 'let-syntax)))
     243    `(,%macro-with ,%let-syntax ,pat-tpl-pairs ,xpr ,@xprs)))
    317244
    318245;;; (macro-letrec (((name . args) (where fender ...) .. xpr ...) ...) body ....)
    319246;;; ----------------------------------------------------------------------------
    320247;;; evaluates body ... in the context of recursive macros name ....
    321 (define-syntax macro-letrec
    322   (ir-macro-transformer
    323     (lambda (form inject compare?)
    324       (let ((pat-tpl-pairs (cadr form))
    325             (xpr (caddr form))
    326             (xprs (cdddr form)))
    327         `(macro letrec-syntax ,pat-tpl-pairs ,xpr ,@xprs)))))
    328 
    329 ;;; (with-gensyms (name ....) xpr ....)
    330 ;;; -----------------------------------
    331 ;;; binds name ... to (gensym 'name) ... in body xpr ...
    332 (define-syntax with-gensyms
    333   (ir-macro-transformer
    334     (lambda (form inject compare?)
    335       `(let ,(map (lambda (n) `(,n (gensym ',n))) (cadr form))
    336          ,@(cddr form)))))
     248(define-er-macro-transformer (macro-letrec form rename compare?)
     249  (let ((pat-tpl-pairs (cadr form))
     250        (xpr (caddr form))
     251        (xprs (cdddr form));)
     252        (%macro-with (rename 'macro-with))
     253        (%letrec-syntax (rename 'letrec-syntax)))
     254    `(,%macro-with ,%letrec-syntax ,pat-tpl-pairs ,xpr ,@xprs)))
    337255
    338256;;; (once-only (x ....) xpr ....)
     
    342260;;; The code is more or less due to
    343261;;; P. Seibel, Practical Common Lisp, p. 102
    344 (define-syntax once-only
    345   (ir-macro-transformer
    346     (lambda (form inject compare?)
    347       (let ((names (cadr form))
    348             (body (cddr form)))
    349         (let ((gensyms (map (lambda (x) (gensym)) names)))
    350           `(let ,(map (lambda (g) `(,g (gensym))) gensyms)
    351              `(let ,(list ,@(map (lambda (g n) ``(,,g ,,n))
    352                                  gensyms names))
    353                 ,(let ,(map (lambda (n g) `(,n ,g))
    354                             names gensyms)
    355                    ,@body))))))))
     262(define-ir-macro-transformer (once-only form inject compare?)
     263  (let ((names (cadr form))
     264        (body (cddr form)))
     265    (let ((gensyms (map (lambda (x) (gensym)) names)))
     266      `(let ,(map (lambda (g) `(,g (gensym))) gensyms)
     267         `(let ,(list ,@(map (lambda (g n) ``(,,g ,,n))
     268                             gensyms names))
     269            ,(let ,(map (lambda (n g) `(,n ,g))
     270                        names gensyms)
     271               ,@body))))))
    356272
    357273;;; (procedural-macros sym ..)
     
    384300      "arguments x ... are evaluated only once and"
    385301      "from left to right in the body xpr ....")
     302    (define-er-macro-transformer
     303      macro:
     304      (define-er-macro-tansformer name form rename compare?)
     305      "wrapper around er-macro-transformer")
     306    (define-ir-macro-transformer
     307      macro:
     308      (define-ir-macro-tansformer name form rename compare?)
     309      "wrapper around ir-macro-transformer")
     310    (with-mapped-symbols
     311      macro:
     312      (with-mapped-symbols mapper prefix- (prefix-x ....) xpr ....)
     313      "binds a series of prefixed names, prefix-x ...."
     314      "to the images of the original names, x ...., under mapper"
     315      "and evaluates xpr .... in this context")
    386316    (with-gensyms
    387317      macro:
  • release/4/procedural-macros/tags/2.0/procedural-macros.setup

    r33087 r33546  
    77 'procedural-macros
    88 '("procedural-macros.so" "procedural-macros.import.so")
    9  '((version "1.1.1")))
     9 '((version "2.0")))
  • release/4/procedural-macros/tags/2.0/tests/run.scm

    r33087 r33546  
    55                   (only data-structures list-of?))
    66
     7(define-test (macros?)
     8  (check
     9    (define-macro (swap! x y)
     10      (where (x symbol?) (y symbol?))
     11      `(let ((tmp ,x))
     12         (set! ,x ,y)
     13         (set! ,y tmp)))
     14    (equal? (let ((x 'x) (y 'y))
     15              (swap! x y)
     16              (list x y))
     17            '(y x))
     18
     19    (define-macro (nif xpr pos zer neg)
     20      `(cond
     21         ((positive? ,xpr) ,pos)
     22         ((negative? ,xpr) ,neg)
     23         (else ,zer)))
     24    (eq? (nif 2 'positive 'zero 'negative) 'positive)
     25
     26    (define-macro (freeze xpr)
     27      `(lambda () ,xpr))
     28    (= ((freeze 5)) 5)
     29
     30    (define-macro (swap! x y)
     31      `(let ((tmp ,x)) (set! ,x ,y) (set! ,y tmp)))
     32    (equal? (let ((x 'x) (y 'y)) (swap! x y) (list x y))
     33            '(y x))
     34
     35    "LITERALS"
     36    (define-syntax foo
     37      (macro-rules ()
     38        ((_ "foo" x) x)
     39        ((_ #f x) `(list 'false))
     40        ((_ #f x) 'false)
     41        ((_ a b) (where (a string?))
     42                 `(list ,a ,b))
     43        ((_ a b) (where (a odd?))
     44                 `(list ,a ,b))
     45        ((_ a b) a)))
     46    (= (foo "foo" 1) 1)
     47    (equal? (foo "bar" 2) '("bar" 2))
     48    (equal? (foo #f 'blabla) '(false))
     49    (equal? (foo 1 2) '(1 2))
     50    (= (foo 2 3) 2)
     51
     52    (define-macro (bar #() x)
     53      (where (x integer?))
     54      x)
     55    (= (bar #() 5) 5)
     56
     57    (define-macro (baz '() x)
     58      (where (x integer?))
     59      x)
     60    (= (baz '() 5) 5)
     61
     62    (define-macro (qux  #f)
     63      #t)
     64    (qux #f)
     65
     66    "IN?"
     67    (define-macro (in? what equ? . choices)
     68      (let ((insym 'in))
     69        `(let ((,insym ,what))
     70           (or ,@(map (lambda (choice) `(,equ? ,insym ,choice))
     71                      choices)))))
     72    (in? 2 = 1 2 3)
     73    (not (in? 5 = 1 2 3))
     74
     75    "VERBOSE IFS"
     76    (define-syntax vif
     77      (macro-rules (then else)
     78        ((_ test (then xpr . xprs))
     79         `(if ,test
     80            (begin ,xpr ,@xprs)))
     81        ((_ test (else xpr . xprs))
     82         `(if ,(not test)
     83            (begin ,xpr ,@xprs)))
     84        ((_ test (then xpr . xprs) (else ypr . yprs))
     85         `(if ,test
     86            (begin ,xpr ,@xprs)
     87            (begin ,ypr ,@yprs)))))
     88    (define (oux)
     89      (vif #t (then 'true)))
     90    (define (pux)
     91      (vif #f (else 'false)))
     92    (eq? (oux) 'true)
     93    (eq? (pux) 'false)
     94
     95    "LOW-LEVEL COND"
     96    (define-syntax my-cond
     97      (macro-rules (else =>)
     98        ((_ (else xpr . xprs))
     99         `(begin ,xpr ,@xprs))
     100        ((_ (test => xpr))
     101         `(let ((tmp ,test))
     102            (if tmp (,xpr tmp))))
     103        ((_ (test => xpr) . clauses)
     104         `(let ((tmp ,test))
     105            (if tmp
     106              (,xpr tmp)
     107              (my-cond ,@clauses))))
     108        ((_ (test))
     109         `(if #f #f))
     110        ((_ (test) . clauses)
     111         `(let ((tmp ,test))
     112            (if tmp
     113              tmp
     114              (my-cond ,@clauses))))
     115        ((_ (test xpr . xprs))
     116         `(if ,test (begin ,xpr ,@xprs)))
     117        ((_ (test xpr . xprs) . clauses)
     118         `(if ,test
     119            (begin ,xpr ,@xprs)
     120            (my-cond ,@clauses)))
     121        ))
     122    (my-cond ((> 3 2)))
     123    (eq? (my-cond ((> 3 2) 'greater) ((< 3 2) 'less))
     124         'greater)
     125    (eq? (my-cond
     126           ((> 3 3) 'greater)
     127           ((< 3 3) 'less)
     128           (else 'equal))
     129         'equal)
     130    (= (my-cond ((assv 'b `((a 1) (b 2) (C 3))) => cadr)
     131                (else #f))
     132       2)
     133    (not (my-cond ((assv 'x `((a 1) (b 2) (C 3))) => cadr)
     134                  (else #f)))
     135
     136    "LETREC"
     137    (define-macro (my-letrec pairs . body)
     138      (where (pairs (list-of? pair?)))
     139      (let ((vars (map car pairs))
     140            (vals (map cadr pairs))
     141            (aux (map (lambda (x) (gensym)) pairs)))
     142        `(let ,(map (lambda (var) `(,var #f)) vars)
     143           (let ,(map (lambda (a v) `(,a ,v)) aux vals)
     144             ,@(map (lambda (v e) `(set! ,v ,e)) vars vals)
     145             ,@body))))
     146    (equal?
     147      (my-letrec ((o? (lambda (m) (if (zero? m) #f (e? (- m 1)))))
     148                  (e? (lambda (n) (if (zero? n) #t (o? (- n 1))))))
     149                 (list (o? 95) (e? 95)))
     150      '(#t #f))
     151
     152    "GENERIC ADD"
     153    (define-syntax add
     154      (macro-rules () ((_ x y)
     155                       (where (x string?) (y string?))
     156                       `(string-append ,x ,y))
     157        (( _ x y)
     158         (where (x integer?) (y integer?))
     159         `(+ ,x ,y))))
     160    (= (add 1 2) 3)
     161    (string=? (add "x" "y") "xy")
     162
     163    "ANAPHORIC MACROS"
     164    (define-syntax alambda
     165      (macro-rules self ()
     166        ((_ args xpr . xprs)
     167         `(letrec ((,self (lambda ,args ,xpr ,@xprs)))
     168            ,self))))
     169    (equal? (map (alambda (n) (if (zero? n) 1 (* n (self (- n 1))))) '(1 2 3 4 5))
     170            '(1 2 6 24 120))
     171
     172    (define-syntax aif
     173      (macro-rules it ()
     174        ((_ test consequent)
     175         `(let ((,it ,test))
     176            (if ,it ,consequent)))
     177        ((_ test consequent alternative)
     178         `(let ((,it ,test))
     179            (if ,it ,consequent ,alternative)))))
     180    (define (mist x)
     181      (aif ((alambda (n) (if (zero? n) 1 (* n (self (- n 1))))) x) it))
     182    (= (mist 5) 120)
     183
     184    "ONCE-ONLY"
     185    (define counter ; used for side-effects
     186      (let ((state 0))
     187        (lambda ()
     188          (set! state (+ state 1))
     189          state)))
     190    (define-macro (square x) ; wrong without once-only
     191      (once-only (x)
     192        `(* ,x ,x)))
     193    (= (square (counter)) 1)
     194    (= (square (counter)) 4)
     195    (= (square (counter)) 9)
     196    (define-macro (for (var start end) . body)
     197      (once-only (start end)
     198        `(do ((,var ,start (add1 ,var)))
     199           ((= ,var ,end))
     200           ,@body)))
     201    (let ((lst '()))
     202      (for (x 0 (counter)) (set! lst (cons x lst)))
     203      (equal? lst '(3 2 1 0)))
     204
     205    "LOCAL VARIABLES AVAILABLE IN EACH RULE"
     206    (define-syntax add2
     207      (let ((id (lambda (n) n)))
     208        (macro-rules ()
     209          ((_ x)
     210           `(+ ,(id x) 2))
     211          ((_ x y)
     212           `(+ ,(id x) ,(id y) 2))
     213          )))
     214    (= (add2 5) 7)
     215    (= (add2 5 7) 14)
     216
     217
     218    "LET AND LETREC"
     219    (= (macro-letrec (
     220         ((sec lst) `(car (res ,lst)))
     221         ((res lst) `(cdr ,lst))
     222         )
     223         (sec '(1 2 3)))
     224       2)
     225    (= (macro-let (
     226         ((fir lst) (where (lst list?)) `(car ,lst))
     227         ((res lst) (where (lst list?)) `(cdr ,lst))
     228         )
     229         (fir (res '(1 2 3))))
     230       2)
     231    (equal?
     232      (macro-letrec (((swap1 x y)
     233                      `(swap2 ,x ,y))
     234                     ((swap2 x y)
     235                      (where (x symbol?) (y symbol?))
     236                      `(let ((tmp ,y)) (set! ,y ,x) (set! ,x tmp))))
     237        (let ((x 'x) (y 'y))
     238          (swap1 x y)
     239          (swap2 x y)
     240          (list x y)))
     241      '(x y))
     242    (equal?
     243      (macro-let (((swap1 x y)
     244                   `(let ((tmp ,y)) (set! ,y ,x) (set! ,x tmp)))
     245                  ((swap2 x y)
     246                   `(let ((tmp ,y)) (set! ,y ,x) (set! ,x tmp))))
     247        (let ((x 'x) (y 'y))
     248          (swap1 x y)
     249          (swap2 x y)
     250          (list x y)))
     251      '(x y))
     252    ))
     253
    7254(compound-test (procedural-macros)
    8 
    9   (define-test (macros?)
    10     (check
    11       (define-macro (swap! x y)
    12         (where (x symbol?) (y symbol?))
    13         `(let ((tmp ,x))
    14            (set! ,x ,y)
    15            (set! ,y tmp)))
    16       (equal? (let ((x 'x) (y 'y))
    17                 (swap! x y)
    18                 (list x y))
    19               '(y x))
    20 
    21       (define-macro (nif xpr pos zer neg)
    22         `(cond
    23            ((positive? ,xpr) ,pos)
    24            ((negative? ,xpr) ,neg)
    25            (else ,zer)))
    26       (eq? (nif 2 'positive 'zero 'negative) 'positive)
    27 
    28       (define-macro (freeze xpr)
    29         `(lambda () ,xpr))
    30       (= ((freeze 5)) 5)
    31 
    32       (define-macro (swap! x y)
    33         `(let ((tmp ,x)) (set! ,x ,y) (set! ,y tmp)))
    34       (equal? (let ((x 'x) (y 'y)) (swap! x y) (list x y))
    35               '(y x))
    36 
    37       "LITERALS"
    38       (define-syntax foo
    39         (macro-rules ()
    40           ((_ "foo" x) x)
    41           ((_ #f x) `(list 'false))
    42           ((_ #f x) 'false)
    43           ((_ a b) (where (a string?))
    44            `(list ,a ,b))
    45           ((_ a b) (where (a odd?))
    46            `(list ,a ,b))
    47           ((_ a b) a)))
    48       (= (foo "foo" 1) 1)
    49       (equal? (foo "bar" 2) '("bar" 2))
    50       (equal? (foo #f 'blabla) '(false))
    51       (equal? (foo 1 2) '(1 2))
    52       (= (foo 2 3) 2)
    53 
    54       (define-macro (bar #() x)
    55         (where (x integer?))
    56         x)
    57       (= (bar #() 5) 5)
    58      
    59       (define-macro (baz '() x)
    60         (where (x integer?))
    61         x)
    62       (= (baz '() 5) 5)
    63 
    64       (define-macro (qux  #f)
    65         #t)
    66       (qux #f)
    67 
    68       "IN?"
    69       (define-macro (in? what equ? . choices)
    70         (let ((insym 'in))
    71           `(let ((,insym ,what))
    72              (or ,@(map (lambda (choice) `(,equ? ,insym ,choice))
    73                         choices)))))
    74       (in? 2 = 1 2 3)
    75       (not (in? 5 = 1 2 3))
    76 
    77       "VERBOSE IFS"
    78       (define-syntax vif
    79         (macro-rules (then else)
    80           ((_ test (then xpr . xprs))
    81            `(if ,test
    82               (begin ,xpr ,@xprs)))
    83           ((_ test (else xpr . xprs))
    84            `(if ,(not test)
    85               (begin ,xpr ,@xprs)))
    86           ((_ test (then xpr . xprs) (else ypr . yprs))
    87            `(if ,test
    88               (begin ,xpr ,@xprs)
    89               (begin ,ypr ,@yprs)))))
    90       (define (oux)
    91         (vif #t (then 'true)))
    92       (define (pux)
    93         (vif #f (else 'false)))
    94       (eq? (oux) 'true)
    95       (eq? (pux) 'false)
    96      
    97       "LOW-LEVEL COND"
    98       (define-syntax my-cond
    99         (macro-rules (else =>)
    100           ((_ (else xpr . xprs))
    101            `(begin ,xpr ,@xprs))
    102           ((_ (test => xpr))
    103            `(let ((tmp ,test))
    104               (if tmp (,xpr tmp))))
    105           ((_ (test => xpr) . clauses)
    106            `(let ((tmp ,test))
    107               (if tmp
    108                 (,xpr tmp)
    109                 (my-cond ,@clauses))))
    110           ((_ (test))
    111            `(if #f #f))
    112           ((_ (test) . clauses)
    113            `(let ((tmp ,test))
    114               (if tmp
    115                 tmp
    116                 (my-cond ,@clauses))))
    117           ((_ (test xpr . xprs))
    118            `(if ,test (begin ,xpr ,@xprs)))
    119           ((_ (test xpr . xprs) . clauses)
    120            `(if ,test
    121               (begin ,xpr ,@xprs)
    122               (my-cond ,@clauses)))
    123           ))
    124       (my-cond ((> 3 2)))
    125       (eq? (my-cond ((> 3 2) 'greater) ((< 3 2) 'less))
    126            'greater)
    127      (eq? (my-cond
    128             ((> 3 3) 'greater)
    129             ((< 3 3) 'less)
    130             (else 'equal))
    131           'equal)
    132       (= (my-cond ((assv 'b `((a 1) (b 2) (C 3))) => cadr)
    133                (else #f))
    134          2)
    135       (not (my-cond ((assv 'x `((a 1) (b 2) (C 3))) => cadr)
    136                (else #f)))
    137 
    138       "LETREC"
    139       (define-macro (my-letrec pairs . body)
    140         (where (pairs (list-of? pair?)))
    141         (let ((vars (map car pairs))
    142               (vals (map cadr pairs))
    143               (aux (map (lambda (x) (gensym)) pairs)))
    144           `(let ,(map (lambda (var) `(,var #f)) vars)
    145              (let ,(map (lambda (a v) `(,a ,v)) aux vals)
    146                ,@(map (lambda (v e) `(set! ,v ,e)) vars vals)
    147                ,@body))))
    148       (equal?
    149         (my-letrec ((o? (lambda (m) (if (zero? m) #f (e? (- m 1)))))
    150                     (e? (lambda (n) (if (zero? n) #t (o? (- n 1))))))
    151                    (list (o? 95) (e? 95)))
    152         '(#t #f))
    153 
    154       "GENERIC ADD"
    155       (define-syntax add
    156         (macro-rules () ((_ x y)
    157                          (where (x string?) (y string?))
    158                          `(string-append ,x ,y))
    159                         (( _ x y)
    160                          (where (x integer?) (y integer?))
    161                          `(+ ,x ,y))))
    162       (= (add 1 2) 3)
    163       (string=? (add "x" "y") "xy")
    164 
    165       "ANAPHORIC MACROS"
    166       (define-syntax alambda
    167         (macro-rules self ()
    168           ((_ args xpr . xprs)
    169            `(letrec ((,self (lambda ,args ,xpr ,@xprs)))
    170               ,self))))
    171       (equal? (map (alambda (n) (if (zero? n) 1 (* n (self (- n 1))))) '(1 2 3 4 5))
    172               '(1 2 6 24 120))
    173 
    174       (define-syntax aif
    175         (macro-rules it ()
    176           ((_ test consequent)
    177            `(let ((,it ,test))
    178               (if ,it ,consequent)))
    179           ((_ test consequent alternative)
    180            `(let ((,it ,test))
    181               (if ,it ,consequent ,alternative)))))
    182       (define (mist x)
    183         (aif ((alambda (n) (if (zero? n) 1 (* n (self (- n 1))))) x) it))
    184       (= (mist 5) 120)
    185 
    186       "ONCE-ONLY"
    187       (define counter ; used for side-effects
    188         (let ((state 0))
    189           (lambda ()
    190             (set! state (+ state 1))
    191             state)))
    192       (define-macro (square x) ; wrong without once-only
    193         (once-only (x)
    194           `(* ,x ,x)))
    195       (= (square (counter)) 1)
    196       (= (square (counter)) 4)
    197       (= (square (counter)) 9)
    198       (define-macro (for (var start end) . body)
    199         (once-only (start end)
    200           `(do ((,var ,start (add1 ,var)))
    201                  ((= ,var ,end))
    202                  ,@body)))
    203       (let ((lst '()))
    204         (for (x 0 (counter)) (set! lst (cons x lst)))
    205         (equal? lst '(3 2 1 0)))
    206 
    207       "LOCAL VARIABLES AVAILABLE IN EACH RULE"
    208       (define-syntax add2
    209         (let ((id (lambda (n) n)))
    210           (macro-rules ()
    211             ((_ x)
    212              `(+ ,(id x) 2))
    213             ((_ x y)
    214              `(+ ,(id x) ,(id y) 2))
    215             )))
    216       (= (add2 5) 7)
    217       (= (add2 5 7) 14)
    218       ))
    219255  (macros?)
    220256) ; compound test
  • release/4/procedural-macros/trunk/procedural-macros.meta

    r32927 r33546  
    55 (license "BSD")
    66 (test-depends simple-tests)
     7 (depends bindings basic-sequences)
    78 (author "Juergen Lorenz")
    89 (files "procedural-macros.release-info" "procedural-macros.scm" "procedural-macros.setup"
  • release/4/procedural-macros/trunk/procedural-macros.scm

    r33087 r33546  
    11; Author: Juergen Lorenz ; ju (at) jugilo (dot) de
    22;
    3 ; Copyright (c) 2013-2015, Juergen Lorenz
     3; Copyright (c) 2013-2016, Juergen Lorenz
    44; All rights reserved.
    55;
     
    3232
    3333#|[
    34 In his macro bible "On Lisp, p. 232" Paul Graham implemented a beautiful macro,
    35 dbind, which is roughly Common Lisp's destructuring-bind. It invokes
    36 at compile time the following three procedures in Scheme (for lists only).
    37 
    38   (define (destruc pat seq)
    39     (let loop ((pat pat) (seq seq) (n 0))
    40       (if (pair? pat)
    41         (let ((p (car pat)) (recu (loop (cdr pat) seq (+ n 1))))
    42           (if (symbol? p)
    43             (cons `(,p (list-ref ,seq ,n)) recu)
    44             (let ((g (gensym)))
    45               (cons (cons `(,g (list-ref ,seq ,n))
    46                           (loop p g 0))
    47                     recu))))
    48         (let ((tail `(list-tail ,seq ,n)))
    49           (if (null? pat)
    50             '()
    51             `((,pat ,tail)))))))
     34This library will provide some macro-writing macros, in particular
     35macro-rules and define-macro, based on explicit- and implicit-renaming.
     36The syntax of macro-rules mimics that of syntax-rules, except that it
     37allows for injected symbols before the keyword list and the templates
     38are usually quasiquoted lists. Since we use bind-case from the bindings
     39egg, this library accepts wildcards, non-symbol literals and fenders.
     40]|#
     41
     42(require-library bindings basic-sequences)
     43
     44(module procedural-macros
     45  (define-macro macro-rules macro-let macro-letrec once-only
     46   define-ir-macro-transformer define-er-macro-transformer
     47   with-mapped-symbols with-gensyms procedural-macros)
    5248 
    53   (define (dbind-ex binds body)
    54     (if (null? binds)
    55       `(begin ,@body)
    56       `(let ,(map (lambda (b) (if (pair? (car b)) (car b) b))
    57                   binds)
    58          ,(dbind-ex
    59             (mappend (lambda (b) (if (pair? (car b)) (cdr b) '()))
    60                      binds)
    61             body))))
    62 
    63   (define (mappend fn lists)
    64     (apply append (map fn lists)))
    65 
    66 Graham's code works as follows: First, destruc traverses the pattern and
    67 groups each symbol with the location of a runtime object, using gensyms
    68 to step down the pattern while grouping the gensym bound object with all
    69 pairs depending on this gensym. So, for example,
    70 
    71   (destruc '(a (b . c) . d) 'seq)
    72 
    73 will result in
    74 
    75   ((a (list-ref seq 0))
    76    ((#:g (list-ref seq 1)) (b (list-ref #:g 0)) (c (list-tail #:g 1)))
    77    (d (list-tail seq 2)))
    78 
    79 This tree is then transformed via dbind-ex into a nested let to produce
    80 dbind's result
    81 
    82   (let ((a (list-ref seq 0))
    83         (#:g (list-ref seq 1))
    84         (d (list-tail seq 2)))
    85     (let ((b (list-ref #:g 0))
    86           (c (list-tail #:g 1)))
    87       body))
    88  
    89 This library will provide some macro-writing macros, in particular
    90 macro-rules and define-macro, based on implicit-renaming and the local
    91 procedures above, without a detour over bind and friends and sequences
    92 of the bindings library. Indeed, for macro-writing macros lists are
    93 sufficient. But off course, I have to provide some extensions to
    94 Graham's code, length checks and non-symbol literals, as in the bindings
    95 egg.  Nonsymbol literals bind nothing, but match only to themselfs.
    96 Wildcards are not supplied, because they break hygiene.
    97 
    98 The last feature missing is fenders, which is important in particular
    99 for macro-rules and can easily be implemented with a where clause: A
    100 pattern matches successfully if only each pattern variable can be bound,
    101 the length checks pass, the literals match themselfs and the where
    102 clause is satisfied. If any of those conditions is hurt, the next
    103 pattern is tried.
    104 
    105 ]|#
    106 
    107 (module procedural-macros
    108   (define-macro macro-rules macro-let macro-letrec once-only with-gensyms
    109    procedural-macros)
    11049  (import scheme
    111           (only chicken print error case-lambda condition-case))
    112   (import-for-syntax
    113     (only chicken condition-case))
     50          (only bindings bind-case)
     51          (only chicken print error case-lambda))
     52
     53#|[
     54Let's start with some helpers which might be occasionally useful
     55]|#
     56
     57;;; (define-er-macro-transformer form rename compare?)
     58;;; --------------------------------------------------
     59;;; wrapper around er-macro-transformer
     60(define-syntax define-er-macro-transformer
     61  (syntax-rules ()
     62    ((_ (name form rename compare?) xpr . xprs)
     63     (define-syntax name
     64       (er-macro-transformer
     65         (lambda (form rename compare?) xpr . xprs))))))
     66
     67;;; (define-ir-macro-transformer form inject compare?)
     68;;; --------------------------------------------------
     69;;; wrapper around ir-macro-transformer
     70(define-syntax define-ir-macro-transformer
     71  (syntax-rules ()
     72    ((_ (name form inject compare?) xpr . xprs)
     73     (define-syntax name
     74       (ir-macro-transformer
     75         (lambda (form inject compare?) xpr . xprs))))))
     76
     77;;; (with-mapped-symbols mapper prefix- (prefix-x ....) xpr ....)
     78;;; -------------------------------------------------------------
     79;;; binds a series of prefixed names, prefix-x ....
     80;;; to the images of the original names, x ...., under mapper
     81;;; and evaluates xpr .... in this context
     82(define-syntax with-mapped-symbols
     83  (er-macro-transformer
     84    (lambda (form rename compare?)
     85      (let ((mapper (cadr form))
     86            (prefix (caddr form))
     87            (syms (cadddr form))
     88            (xpr (car (cddddr form)))
     89            (xprs (cdr (cddddr form)))
     90            (%let (rename 'let)))
     91        (let ((strip-prefix
     92                (lambda (sym)
     93                  (let ((len (string-length (symbol->string prefix))))
     94                    (string->symbol
     95                      (substring (symbol->string sym) len))))))
     96          `(,%let ,(map (lambda (s)
     97                          `(,s (,mapper ',(strip-prefix s))))
     98                        syms)
     99             ,xpr ,@xprs))))))
     100
     101;;; (with-gensyms (name ....) xpr ....)
     102;;; -----------------------------------
     103;;; binds name ... to (gensym 'name) ... in body xpr ...
     104(define-syntax with-gensyms
     105  (ir-macro-transformer
     106    (lambda (form inject compare?)
     107      `(let ,(map (lambda (n) `(,n (gensym ',n))) (cadr form))
     108         ,@(cddr form)))))
    114109
    115110#|[
     
    126121;;; matching process.
    127122(define-syntax macro-rules
    128   (ir-macro-transformer
    129     (lambda (f i c?)
    130       (letrec (
     123  (er-macro-transformer
     124    (lambda (f r c?)
     125      (let (
     126        (f* (let loop ((tail (cdr f)) (head '()))
     127              (if (symbol? (car tail))
     128                (loop (cdr tail) (cons (car tail) head))
     129                (cons head tail))))
    131130        (filter
    132131          (lambda (ok? lst)
    133             (let loop ((lst lst) (yes '()) (no '()))
    134               (if (null? lst)
    135                 (values (reverse yes) (reverse no))
    136                 (let ((first (car lst)) (rest (cdr lst)))
    137                   (if (ok? first)
    138                     (loop rest (cons first yes) no)
    139                     (loop rest yes (cons first no))))))))
    140         (mappend
    141           (lambda (fn lists)
    142             (apply append (map fn lists))))
     132            (compress (map ok? lst) lst)))
    143133        (flatten*
    144134          ; imported flatten doesn't work with pseudo-lists
     
    151141                (else
    152142                  (cons tree result))))))
    153         (destruc
    154           (lambda (pat seq)
    155             (let loop ((pat pat) (seq seq) (n 0))
    156               (cond
    157                 ((pair? pat)
    158                  (let ((p (car pat)) (recu (loop (cdr pat) seq (+ n 1))))
    159                    (cond
    160                      ((pair? p)
    161                       (let ((g (gensym)))
    162                         `(((,g (list-ref ,seq ,n)) ,@(loop p g 0))
    163                            ,@recu)))
    164                      ((symbol? p)
    165                         `((,p (list-ref ,seq ,n)) ,@recu));)
    166                      (else
    167                        `((,p (equal? ',p (list-ref ,seq ,n)))
    168                          ,@recu))
    169                      )))
    170                 ((symbol? pat)
    171                  `((,pat (list-tail ,seq ,n))))
    172                 ((null? pat)
    173                  `((,pat (null? (list-tail ,seq ,n)))))
    174                 (else
    175                   `((,pat (equal? ,pat (list-tail ,seq ,n)))))))
    176                 ))
    177         (dbind-ex
    178           (lambda (binds body)
    179             (if (null? binds)
    180               ;`(begin ,@body)
    181               body
    182               (call-with-values
    183                 (lambda ()
    184                   (filter (lambda (pair) (symbol? (car pair)))
    185                           (map (lambda (b) (if (pair? (car b)) (car b) b))
    186                                binds)))
    187                 (lambda (defs checks)
    188                   `(let ,defs
    189                      (if (and ,@(map cadr checks))
    190                        ,(dbind-ex
    191                           (mappend (lambda (b) (if (pair? (car b)) (cdr b) '()))
    192                                    binds)
    193                           body)
    194                        (error 'dbind-ex
    195                               "match error"
    196                               `(and ,@(map cadr ',checks))))))
    197                 ))))
     143        (%x (r 'x))
     144        (%let (r 'let))
     145        (%form (r 'form))
     146        (%where (r 'where))
     147        (%lambda (r 'lambda))
     148        (%inject (r 'inject))
     149        (%compare? (r 'compare?))
     150        (%bind-case (r 'bind-case))
     151        (%ir-macro-transformer (r 'ir-macro-transformer))
    198152        )
    199         (let ((f* (let loop ((tail (cdr f)) (head '()))
    200                     (if (symbol? (car tail))
    201                       (loop (cdr tail) (cons (car tail) head))
    202                       (cons head tail)))))
    203           (let ((syms (car f*))
    204                 (keys (cadr f*))
    205                 ;; remove leading underscore and
    206                 ;; insert empty where clause into each rule without one
    207                 ;; to simplify matters via standardization
    208                 (all-rules (map (lambda (rule)
    209                                   (let ((second (cadr rule)))
    210                                     (if (and (pair? second)
    211                                              (c? (car second) 'where))
    212                                       ;rule
    213                                       `(,(cdar rule) ,@(cdr rule))
    214                                       `(,(cdar rule) (where) ,@(cdr rule)))))
    215                                 (cddr f*)))
    216                 (gform 'form))
    217             `(ir-macro-transformer
    218                (lambda (form inject compare?)
    219                  (let ,(map (lambda (s)
    220                               `(,s (inject ',s)))
    221                             syms)
    222                    ,(let loop ((rules all-rules))
    223                       (if (null? rules)
    224                         `(error 'macro-rules
    225                                 "no rule matches"
    226                                 form
    227                                 'in
    228                                 ',(map (lambda (rule)
    229                                          `(,(cons '_ (car rule)) ; pattern
    230                                            ,(cadr rule))) ; where clause
    231                                        all-rules))
    232                         (let ((rule (car rules)))
    233                           `(condition-case
    234                              ,(dbind-ex
    235                                 (condition-case (destruc (car rule)
    236                                                          `(cdr ,gform))
    237                                   ((exn) (loop (cdr rules))))
    238                                 (let* ((pat (car rule))
    239                                        (fpat (flatten* pat))
    240                                        (kpat (filter (lambda (x)  ;;;;
    241                                                        (memq x keys))
    242                                                      fpat))
    243                                        ;; compare? keywords with its names
    244                                        (key-checks
    245                                          (map (lambda (p s)
    246                                                 `(compare? ,p ,s))
    247                                               kpat
    248                                               (map (lambda (x) `',x)
    249                                                    kpat))))
    250                                   (let* ((tpl (cdr rule))
    251                                          (fenders (cdar tpl))
    252                                          (tests
    253                                            (apply append
    254                                              (map (lambda (pair)
    255                                                     (map (lambda (p?)
    256                                                            `(,p?  ,(car pair)))
    257                                                          (cdr pair)))
    258                                                   fenders))))
    259                                     `(if (and ,@key-checks
    260                                               (or ,(null? fenders)
    261                                                   (and ,@tests)))
    262                                         ,@(cdr tpl)
    263                                         ,(loop (cdr rules))))))
    264                              ((exn) ,(loop (cdr rules))))
    265                           ))))))))))))
     153        (let ((syms (car f*))
     154              (keys (cadr f*))
     155              (rules (cddr f*)))
     156          (let* ((pats (map car rules))
     157                 (fpats (map flatten* pats))
     158                 (kpats (map (lambda (fp)
     159                               (filter (lambda (x)
     160                                         (memq x keys))
     161                                       fp))
     162                             fpats))
     163                 ;; compare? keywords with its names
     164                 (key-checks
     165                   (map (lambda (kp)
     166                          (map (lambda (p s)
     167                                 `(,p (,%lambda (,%x)
     168                                                (,%compare? ,%x ,s))))
     169                               kp
     170                               (map (lambda (x) `',x)
     171                                    kp)))
     172                        kpats))
     173                 ;; prepare where clause for each rule
     174                 ;; to check keys
     175                 (all-rules (map (lambda (rule checks)
     176                                   (let ((second (cadr rule)))
     177                                     (if (and (pair? second)
     178                                              (c? (car second) %where))
     179                                       `(,(car rule)
     180                                          (,%where ,@(cdr second) ,@checks)
     181                                          ,@(cddr rule))
     182                                       `(,(car rule)
     183                                          (,%where ,@checks)
     184                                          ,@(cdr rule)))))
     185                                 rules key-checks)))
     186            `(,%ir-macro-transformer
     187               (,%lambda (,%form ,%inject ,%compare?)
     188                 (,%let ,(map (lambda (s)
     189                           `(,s (,%inject ',s)))
     190                         syms)
     191                   (,%bind-case ,%form
     192                                ,@all-rules))))))))))
     193
    266194#|[
    267195And now a hygienic procedural version of our old friend, define-macro,
     
    272200;;; -----------------------------------------------------------
    273201;;; simple hygienic macro without injections and keywords.
    274 (define-syntax define-macro
    275   (ir-macro-transformer
    276     (lambda (form inject compare?)
    277       (let ((code (cadr form))
    278             (xpr (caddr form))
    279             (xprs (cdddr form)))
    280         `(define-syntax ,(car code)
    281            (macro-rules ()
    282              ((_ ,@(cdr code)) ,xpr ,@xprs)))))))
     202(define-er-macro-transformer (define-macro form rename compare?)
     203  (let ((code (cadr form))
     204        (xpr (caddr form))
     205        (xprs (cdddr form));)
     206        (%macro-rules (rename 'macro-rules))
     207        (%define-syntax (rename 'define-syntax)))
     208    `(,%define-syntax ,(car code)
     209       (,%macro-rules ()
     210         ((_ ,@(cdr code)) ,xpr ,@xprs)))))
    283211
    284212#|[
     
    289217
    290218;; helper for macro-let and macro-letrec
    291 (define-syntax macro
    292   (ir-macro-transformer
    293     (lambda (form inject compare?)
    294       (let ((op (cadr form))
    295             (pat-tpl-pairs (caddr form))
    296             (xpr (cadddr form))
    297             (xprs (cddddr form)))
    298         (let ((pats (map car pat-tpl-pairs))
    299               (tpls (map cdr pat-tpl-pairs)))
    300           `(,op ,(map (lambda (pat tpl)
    301                                `(,(car pat)
    302                                   (macro-rules ()
    303                                      ((_ ,@(cdr pat)) ,@tpl))))
    304                               pats tpls)
    305                        ,xpr ,@xprs))))))
     219(define-er-macro-transformer (macro-with form rename compare?)
     220  (let ((op (cadr form))
     221        (pat-tpl-pairs (caddr form))
     222        (xpr (cadddr form))
     223        (xprs (cddddr form))
     224        (%macro-rules (rename 'macro-rules)))
     225    (let ((pats (map car pat-tpl-pairs))
     226          (tpls (map cdr pat-tpl-pairs)))
     227      `(,op ,(map (lambda (pat tpl)
     228                    `(,(car pat)
     229                       (,%macro-rules ()
     230                         ((_ ,@(cdr pat)) ,@tpl))))
     231                  pats tpls)
     232                   ,xpr ,@xprs))))
    306233
    307234;;; (macro-let (((name . args) (where fender ...) .. xpr ...) ...) body ....)
    308235;;; -------------------------------------------------------------------------
    309236;;; evaluates body ... in the context of parallel macros name ....
    310 (define-syntax macro-let
    311   (ir-macro-transformer
    312     (lambda (form inject compare?)
    313       (let ((pat-tpl-pairs (cadr form))
    314             (xpr (caddr form))
    315             (xprs (cdddr form)))
    316         `(macro let-syntax ,pat-tpl-pairs ,xpr ,@xprs)))))
     237(define-er-macro-transformer (macro-let form rename compare?)
     238  (let ((pat-tpl-pairs (cadr form))
     239        (xpr (caddr form))
     240        (xprs (cdddr form));)
     241        (%macro-with (rename 'macro-with))
     242        (%let-syntax (rename 'let-syntax)))
     243    `(,%macro-with ,%let-syntax ,pat-tpl-pairs ,xpr ,@xprs)))
    317244
    318245;;; (macro-letrec (((name . args) (where fender ...) .. xpr ...) ...) body ....)
    319246;;; ----------------------------------------------------------------------------
    320247;;; evaluates body ... in the context of recursive macros name ....
    321 (define-syntax macro-letrec
    322   (ir-macro-transformer
    323     (lambda (form inject compare?)
    324       (let ((pat-tpl-pairs (cadr form))
    325             (xpr (caddr form))
    326             (xprs (cdddr form)))
    327         `(macro letrec-syntax ,pat-tpl-pairs ,xpr ,@xprs)))))
    328 
    329 ;;; (with-gensyms (name ....) xpr ....)
    330 ;;; -----------------------------------
    331 ;;; binds name ... to (gensym 'name) ... in body xpr ...
    332 (define-syntax with-gensyms
    333   (ir-macro-transformer
    334     (lambda (form inject compare?)
    335       `(let ,(map (lambda (n) `(,n (gensym ',n))) (cadr form))
    336          ,@(cddr form)))))
     248(define-er-macro-transformer (macro-letrec form rename compare?)
     249  (let ((pat-tpl-pairs (cadr form))
     250        (xpr (caddr form))
     251        (xprs (cdddr form));)
     252        (%macro-with (rename 'macro-with))
     253        (%letrec-syntax (rename 'letrec-syntax)))
     254    `(,%macro-with ,%letrec-syntax ,pat-tpl-pairs ,xpr ,@xprs)))
    337255
    338256;;; (once-only (x ....) xpr ....)
     
    342260;;; The code is more or less due to
    343261;;; P. Seibel, Practical Common Lisp, p. 102
    344 (define-syntax once-only
    345   (ir-macro-transformer
    346     (lambda (form inject compare?)
    347       (let ((names (cadr form))
    348             (body (cddr form)))
    349         (let ((gensyms (map (lambda (x) (gensym)) names)))
    350           `(let ,(map (lambda (g) `(,g (gensym))) gensyms)
    351              `(let ,(list ,@(map (lambda (g n) ``(,,g ,,n))
    352                                  gensyms names))
    353                 ,(let ,(map (lambda (n g) `(,n ,g))
    354                             names gensyms)
    355                    ,@body))))))))
     262(define-ir-macro-transformer (once-only form inject compare?)
     263  (let ((names (cadr form))
     264        (body (cddr form)))
     265    (let ((gensyms (map (lambda (x) (gensym)) names)))
     266      `(let ,(map (lambda (g) `(,g (gensym))) gensyms)
     267         `(let ,(list ,@(map (lambda (g n) ``(,,g ,,n))
     268                             gensyms names))
     269            ,(let ,(map (lambda (n g) `(,n ,g))
     270                        names gensyms)
     271               ,@body))))))
    356272
    357273;;; (procedural-macros sym ..)
     
    384300      "arguments x ... are evaluated only once and"
    385301      "from left to right in the body xpr ....")
     302    (define-er-macro-transformer
     303      macro:
     304      (define-er-macro-tansformer name form rename compare?)
     305      "wrapper around er-macro-transformer")
     306    (define-ir-macro-transformer
     307      macro:
     308      (define-ir-macro-tansformer name form rename compare?)
     309      "wrapper around ir-macro-transformer")
     310    (with-mapped-symbols
     311      macro:
     312      (with-mapped-symbols mapper prefix- (prefix-x ....) xpr ....)
     313      "binds a series of prefixed names, prefix-x ...."
     314      "to the images of the original names, x ...., under mapper"
     315      "and evaluates xpr .... in this context")
    386316    (with-gensyms
    387317      macro:
  • release/4/procedural-macros/trunk/procedural-macros.setup

    r33087 r33546  
    77 'procedural-macros
    88 '("procedural-macros.so" "procedural-macros.import.so")
    9  '((version "1.1.1")))
     9 '((version "2.0")))
  • release/4/procedural-macros/trunk/tests/run.scm

    r33087 r33546  
    55                   (only data-structures list-of?))
    66
     7(define-test (macros?)
     8  (check
     9    (define-macro (swap! x y)
     10      (where (x symbol?) (y symbol?))
     11      `(let ((tmp ,x))
     12         (set! ,x ,y)
     13         (set! ,y tmp)))
     14    (equal? (let ((x 'x) (y 'y))
     15              (swap! x y)
     16              (list x y))
     17            '(y x))
     18
     19    (define-macro (nif xpr pos zer neg)
     20      `(cond
     21         ((positive? ,xpr) ,pos)
     22         ((negative? ,xpr) ,neg)
     23         (else ,zer)))
     24    (eq? (nif 2 'positive 'zero 'negative) 'positive)
     25
     26    (define-macro (freeze xpr)
     27      `(lambda () ,xpr))
     28    (= ((freeze 5)) 5)
     29
     30    (define-macro (swap! x y)
     31      `(let ((tmp ,x)) (set! ,x ,y) (set! ,y tmp)))
     32    (equal? (let ((x 'x) (y 'y)) (swap! x y) (list x y))
     33            '(y x))
     34
     35    "LITERALS"
     36    (define-syntax foo
     37      (macro-rules ()
     38        ((_ "foo" x) x)
     39        ((_ #f x) `(list 'false))
     40        ((_ #f x) 'false)
     41        ((_ a b) (where (a string?))
     42                 `(list ,a ,b))
     43        ((_ a b) (where (a odd?))
     44                 `(list ,a ,b))
     45        ((_ a b) a)))
     46    (= (foo "foo" 1) 1)
     47    (equal? (foo "bar" 2) '("bar" 2))
     48    (equal? (foo #f 'blabla) '(false))
     49    (equal? (foo 1 2) '(1 2))
     50    (= (foo 2 3) 2)
     51
     52    (define-macro (bar #() x)
     53      (where (x integer?))
     54      x)
     55    (= (bar #() 5) 5)
     56
     57    (define-macro (baz '() x)
     58      (where (x integer?))
     59      x)
     60    (= (baz '() 5) 5)
     61
     62    (define-macro (qux  #f)
     63      #t)
     64    (qux #f)
     65
     66    "IN?"
     67    (define-macro (in? what equ? . choices)
     68      (let ((insym 'in))
     69        `(let ((,insym ,what))
     70           (or ,@(map (lambda (choice) `(,equ? ,insym ,choice))
     71                      choices)))))
     72    (in? 2 = 1 2 3)
     73    (not (in? 5 = 1 2 3))
     74
     75    "VERBOSE IFS"
     76    (define-syntax vif
     77      (macro-rules (then else)
     78        ((_ test (then xpr . xprs))
     79         `(if ,test
     80            (begin ,xpr ,@xprs)))
     81        ((_ test (else xpr . xprs))
     82         `(if ,(not test)
     83            (begin ,xpr ,@xprs)))
     84        ((_ test (then xpr . xprs) (else ypr . yprs))
     85         `(if ,test
     86            (begin ,xpr ,@xprs)
     87            (begin ,ypr ,@yprs)))))
     88    (define (oux)
     89      (vif #t (then 'true)))
     90    (define (pux)
     91      (vif #f (else 'false)))
     92    (eq? (oux) 'true)
     93    (eq? (pux) 'false)
     94
     95    "LOW-LEVEL COND"
     96    (define-syntax my-cond
     97      (macro-rules (else =>)
     98        ((_ (else xpr . xprs))
     99         `(begin ,xpr ,@xprs))
     100        ((_ (test => xpr))
     101         `(let ((tmp ,test))
     102            (if tmp (,xpr tmp))))
     103        ((_ (test => xpr) . clauses)
     104         `(let ((tmp ,test))
     105            (if tmp
     106              (,xpr tmp)
     107              (my-cond ,@clauses))))
     108        ((_ (test))
     109         `(if #f #f))
     110        ((_ (test) . clauses)
     111         `(let ((tmp ,test))
     112            (if tmp
     113              tmp
     114              (my-cond ,@clauses))))
     115        ((_ (test xpr . xprs))
     116         `(if ,test (begin ,xpr ,@xprs)))
     117        ((_ (test xpr . xprs) . clauses)
     118         `(if ,test
     119            (begin ,xpr ,@xprs)
     120            (my-cond ,@clauses)))
     121        ))
     122    (my-cond ((> 3 2)))
     123    (eq? (my-cond ((> 3 2) 'greater) ((< 3 2) 'less))
     124         'greater)
     125    (eq? (my-cond
     126           ((> 3 3) 'greater)
     127           ((< 3 3) 'less)
     128           (else 'equal))
     129         'equal)
     130    (= (my-cond ((assv 'b `((a 1) (b 2) (C 3))) => cadr)
     131                (else #f))
     132       2)
     133    (not (my-cond ((assv 'x `((a 1) (b 2) (C 3))) => cadr)
     134                  (else #f)))
     135
     136    "LETREC"
     137    (define-macro (my-letrec pairs . body)
     138      (where (pairs (list-of? pair?)))
     139      (let ((vars (map car pairs))
     140            (vals (map cadr pairs))
     141            (aux (map (lambda (x) (gensym)) pairs)))
     142        `(let ,(map (lambda (var) `(,var #f)) vars)
     143           (let ,(map (lambda (a v) `(,a ,v)) aux vals)
     144             ,@(map (lambda (v e) `(set! ,v ,e)) vars vals)
     145             ,@body))))
     146    (equal?
     147      (my-letrec ((o? (lambda (m) (if (zero? m) #f (e? (- m 1)))))
     148                  (e? (lambda (n) (if (zero? n) #t (o? (- n 1))))))
     149                 (list (o? 95) (e? 95)))
     150      '(#t #f))
     151
     152    "GENERIC ADD"
     153    (define-syntax add
     154      (macro-rules () ((_ x y)
     155                       (where (x string?) (y string?))
     156                       `(string-append ,x ,y))
     157        (( _ x y)
     158         (where (x integer?) (y integer?))
     159         `(+ ,x ,y))))
     160    (= (add 1 2) 3)
     161    (string=? (add "x" "y") "xy")
     162
     163    "ANAPHORIC MACROS"
     164    (define-syntax alambda
     165      (macro-rules self ()
     166        ((_ args xpr . xprs)
     167         `(letrec ((,self (lambda ,args ,xpr ,@xprs)))
     168            ,self))))
     169    (equal? (map (alambda (n) (if (zero? n) 1 (* n (self (- n 1))))) '(1 2 3 4 5))
     170            '(1 2 6 24 120))
     171
     172    (define-syntax aif
     173      (macro-rules it ()
     174        ((_ test consequent)
     175         `(let ((,it ,test))
     176            (if ,it ,consequent)))
     177        ((_ test consequent alternative)
     178         `(let ((,it ,test))
     179            (if ,it ,consequent ,alternative)))))
     180    (define (mist x)
     181      (aif ((alambda (n) (if (zero? n) 1 (* n (self (- n 1))))) x) it))
     182    (= (mist 5) 120)
     183
     184    "ONCE-ONLY"
     185    (define counter ; used for side-effects
     186      (let ((state 0))
     187        (lambda ()
     188          (set! state (+ state 1))
     189          state)))
     190    (define-macro (square x) ; wrong without once-only
     191      (once-only (x)
     192        `(* ,x ,x)))
     193    (= (square (counter)) 1)
     194    (= (square (counter)) 4)
     195    (= (square (counter)) 9)
     196    (define-macro (for (var start end) . body)
     197      (once-only (start end)
     198        `(do ((,var ,start (add1 ,var)))
     199           ((= ,var ,end))
     200           ,@body)))
     201    (let ((lst '()))
     202      (for (x 0 (counter)) (set! lst (cons x lst)))
     203      (equal? lst '(3 2 1 0)))
     204
     205    "LOCAL VARIABLES AVAILABLE IN EACH RULE"
     206    (define-syntax add2
     207      (let ((id (lambda (n) n)))
     208        (macro-rules ()
     209          ((_ x)
     210           `(+ ,(id x) 2))
     211          ((_ x y)
     212           `(+ ,(id x) ,(id y) 2))
     213          )))
     214    (= (add2 5) 7)
     215    (= (add2 5 7) 14)
     216
     217
     218    "LET AND LETREC"
     219    (= (macro-letrec (
     220         ((sec lst) `(car (res ,lst)))
     221         ((res lst) `(cdr ,lst))
     222         )
     223         (sec '(1 2 3)))
     224       2)
     225    (= (macro-let (
     226         ((fir lst) (where (lst list?)) `(car ,lst))
     227         ((res lst) (where (lst list?)) `(cdr ,lst))
     228         )
     229         (fir (res '(1 2 3))))
     230       2)
     231    (equal?
     232      (macro-letrec (((swap1 x y)
     233                      `(swap2 ,x ,y))
     234                     ((swap2 x y)
     235                      (where (x symbol?) (y symbol?))
     236                      `(let ((tmp ,y)) (set! ,y ,x) (set! ,x tmp))))
     237        (let ((x 'x) (y 'y))
     238          (swap1 x y)
     239          (swap2 x y)
     240          (list x y)))
     241      '(x y))
     242    (equal?
     243      (macro-let (((swap1 x y)
     244                   `(let ((tmp ,y)) (set! ,y ,x) (set! ,x tmp)))
     245                  ((swap2 x y)
     246                   `(let ((tmp ,y)) (set! ,y ,x) (set! ,x tmp))))
     247        (let ((x 'x) (y 'y))
     248          (swap1 x y)
     249          (swap2 x y)
     250          (list x y)))
     251      '(x y))
     252    ))
     253
    7254(compound-test (procedural-macros)
    8 
    9   (define-test (macros?)
    10     (check
    11       (define-macro (swap! x y)
    12         (where (x symbol?) (y symbol?))
    13         `(let ((tmp ,x))
    14            (set! ,x ,y)
    15            (set! ,y tmp)))
    16       (equal? (let ((x 'x) (y 'y))
    17                 (swap! x y)
    18                 (list x y))
    19               '(y x))
    20 
    21       (define-macro (nif xpr pos zer neg)
    22         `(cond
    23            ((positive? ,xpr) ,pos)
    24            ((negative? ,xpr) ,neg)
    25            (else ,zer)))
    26       (eq? (nif 2 'positive 'zero 'negative) 'positive)
    27 
    28       (define-macro (freeze xpr)
    29         `(lambda () ,xpr))
    30       (= ((freeze 5)) 5)
    31 
    32       (define-macro (swap! x y)
    33         `(let ((tmp ,x)) (set! ,x ,y) (set! ,y tmp)))
    34       (equal? (let ((x 'x) (y 'y)) (swap! x y) (list x y))
    35               '(y x))
    36 
    37       "LITERALS"
    38       (define-syntax foo
    39         (macro-rules ()
    40           ((_ "foo" x) x)
    41           ((_ #f x) `(list 'false))
    42           ((_ #f x) 'false)
    43           ((_ a b) (where (a string?))
    44            `(list ,a ,b))
    45           ((_ a b) (where (a odd?))
    46            `(list ,a ,b))
    47           ((_ a b) a)))
    48       (= (foo "foo" 1) 1)
    49       (equal? (foo "bar" 2) '("bar" 2))
    50       (equal? (foo #f 'blabla) '(false))
    51       (equal? (foo 1 2) '(1 2))
    52       (= (foo 2 3) 2)
    53 
    54       (define-macro (bar #() x)
    55         (where (x integer?))
    56         x)
    57       (= (bar #() 5) 5)
    58      
    59       (define-macro (baz '() x)
    60         (where (x integer?))
    61         x)
    62       (= (baz '() 5) 5)
    63 
    64       (define-macro (qux  #f)
    65         #t)
    66       (qux #f)
    67 
    68       "IN?"
    69       (define-macro (in? what equ? . choices)
    70         (let ((insym 'in))
    71           `(let ((,insym ,what))
    72              (or ,@(map (lambda (choice) `(,equ? ,insym ,choice))
    73                         choices)))))
    74       (in? 2 = 1 2 3)
    75       (not (in? 5 = 1 2 3))
    76 
    77       "VERBOSE IFS"
    78       (define-syntax vif
    79         (macro-rules (then else)
    80           ((_ test (then xpr . xprs))
    81            `(if ,test
    82               (begin ,xpr ,@xprs)))
    83           ((_ test (else xpr . xprs))
    84            `(if ,(not test)
    85               (begin ,xpr ,@xprs)))
    86           ((_ test (then xpr . xprs) (else ypr . yprs))
    87            `(if ,test
    88               (begin ,xpr ,@xprs)
    89               (begin ,ypr ,@yprs)))))
    90       (define (oux)
    91         (vif #t (then 'true)))
    92       (define (pux)
    93         (vif #f (else 'false)))
    94       (eq? (oux) 'true)
    95       (eq? (pux) 'false)
    96      
    97       "LOW-LEVEL COND"
    98       (define-syntax my-cond
    99         (macro-rules (else =>)
    100           ((_ (else xpr . xprs))
    101            `(begin ,xpr ,@xprs))
    102           ((_ (test => xpr))
    103            `(let ((tmp ,test))
    104               (if tmp (,xpr tmp))))
    105           ((_ (test => xpr) . clauses)
    106            `(let ((tmp ,test))
    107               (if tmp
    108                 (,xpr tmp)
    109                 (my-cond ,@clauses))))
    110           ((_ (test))
    111            `(if #f #f))
    112           ((_ (test) . clauses)
    113            `(let ((tmp ,test))
    114               (if tmp
    115                 tmp
    116                 (my-cond ,@clauses))))
    117           ((_ (test xpr . xprs))
    118            `(if ,test (begin ,xpr ,@xprs)))
    119           ((_ (test xpr . xprs) . clauses)
    120            `(if ,test
    121               (begin ,xpr ,@xprs)
    122               (my-cond ,@clauses)))
    123           ))
    124       (my-cond ((> 3 2)))
    125       (eq? (my-cond ((> 3 2) 'greater) ((< 3 2) 'less))
    126            'greater)
    127      (eq? (my-cond
    128             ((> 3 3) 'greater)
    129             ((< 3 3) 'less)
    130             (else 'equal))
    131           'equal)
    132       (= (my-cond ((assv 'b `((a 1) (b 2) (C 3))) => cadr)
    133                (else #f))
    134          2)
    135       (not (my-cond ((assv 'x `((a 1) (b 2) (C 3))) => cadr)
    136                (else #f)))
    137 
    138       "LETREC"
    139       (define-macro (my-letrec pairs . body)
    140         (where (pairs (list-of? pair?)))
    141         (let ((vars (map car pairs))
    142               (vals (map cadr pairs))
    143               (aux (map (lambda (x) (gensym)) pairs)))
    144           `(let ,(map (lambda (var) `(,var #f)) vars)
    145              (let ,(map (lambda (a v) `(,a ,v)) aux vals)
    146                ,@(map (lambda (v e) `(set! ,v ,e)) vars vals)
    147                ,@body))))
    148       (equal?
    149         (my-letrec ((o? (lambda (m) (if (zero? m) #f (e? (- m 1)))))
    150                     (e? (lambda (n) (if (zero? n) #t (o? (- n 1))))))
    151                    (list (o? 95) (e? 95)))
    152         '(#t #f))
    153 
    154       "GENERIC ADD"
    155       (define-syntax add
    156         (macro-rules () ((_ x y)
    157                          (where (x string?) (y string?))
    158                          `(string-append ,x ,y))
    159                         (( _ x y)
    160                          (where (x integer?) (y integer?))
    161                          `(+ ,x ,y))))
    162       (= (add 1 2) 3)
    163       (string=? (add "x" "y") "xy")
    164 
    165       "ANAPHORIC MACROS"
    166       (define-syntax alambda
    167         (macro-rules self ()
    168           ((_ args xpr . xprs)
    169            `(letrec ((,self (lambda ,args ,xpr ,@xprs)))
    170               ,self))))
    171       (equal? (map (alambda (n) (if (zero? n) 1 (* n (self (- n 1))))) '(1 2 3 4 5))
    172               '(1 2 6 24 120))
    173 
    174       (define-syntax aif
    175         (macro-rules it ()
    176           ((_ test consequent)
    177            `(let ((,it ,test))
    178               (if ,it ,consequent)))
    179           ((_ test consequent alternative)
    180            `(let ((,it ,test))
    181               (if ,it ,consequent ,alternative)))))
    182       (define (mist x)
    183         (aif ((alambda (n) (if (zero? n) 1 (* n (self (- n 1))))) x) it))
    184       (= (mist 5) 120)
    185 
    186       "ONCE-ONLY"
    187       (define counter ; used for side-effects
    188         (let ((state 0))
    189           (lambda ()
    190             (set! state (+ state 1))
    191             state)))
    192       (define-macro (square x) ; wrong without once-only
    193         (once-only (x)
    194           `(* ,x ,x)))
    195       (= (square (counter)) 1)
    196       (= (square (counter)) 4)
    197       (= (square (counter)) 9)
    198       (define-macro (for (var start end) . body)
    199         (once-only (start end)
    200           `(do ((,var ,start (add1 ,var)))
    201                  ((= ,var ,end))
    202                  ,@body)))
    203       (let ((lst '()))
    204         (for (x 0 (counter)) (set! lst (cons x lst)))
    205         (equal? lst '(3 2 1 0)))
    206 
    207       "LOCAL VARIABLES AVAILABLE IN EACH RULE"
    208       (define-syntax add2
    209         (let ((id (lambda (n) n)))
    210           (macro-rules ()
    211             ((_ x)
    212              `(+ ,(id x) 2))
    213             ((_ x y)
    214              `(+ ,(id x) ,(id y) 2))
    215             )))
    216       (= (add2 5) 7)
    217       (= (add2 5 7) 14)
    218       ))
    219255  (macros?)
    220256) ; compound test
Note: See TracChangeset for help on using the changeset viewer.