Changeset 38044 in project


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

procedural-macros 2.0 simplified and streamlined

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

Legend:

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

    r37895 r38044  
    22 (category lang-exts)
    33 (license "BSD")
    4  (test-dependencies bindings simple-tests)
     4 (test-dependencies simple-tests checks)
    55 (dependencies bindings)
    66 (author "Juergen Lorenz")
    7  (version "1.1")
     7 (version "2.0")
    88 (components
    9    (extension procedural-macros
    10      (modules basic-macros
    11               procedural-macros)))
     9   (extension procedural-macros)))
    1210)
    1311
  • release/5/procedural-macros/tags/2.0/procedural-macros.scm

    r37895 r38044  
    3131; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
    3232
     33(module procedural-macros (
     34  define-macro
     35  macro-rules
     36  macro-let
     37  macro-letrec
     38  once-only
     39  with-renamed-symbols
     40  with-gensyms
     41  procedural-macros
     42  )
     43
     44(import scheme
     45        bindings
     46        (only (chicken base) print error case-lambda))
     47(import-for-syntax (only bindings bind bind-case)
     48                   (only (chicken keyword) string->keyword))
     49
     50;;; (define-macro signature
     51;;;   (with-renaming (compare? . %syms)
     52;;;     xpr . xprs))
     53;;; (define-macro signature
     54;;;   xpr . xprs)
     55;;; ---------------------------------
     56;;; where with-renaming is either
     57;;; with-implicit- or with-explicit-renaming.
     58;;; If not given and no keys are needed, with-implict-renaming is used.
     59;;; Defines an explicit- or implicit-renaming macro name
     60;;; with use-form signature.
     61(define-syntax define-macro
     62  (er-macro-transformer
     63    (lambda (f r c?)
     64      (let ((signature (cadr f))
     65            ;(transformer (caddr f)))
     66            (first (caddr f))
     67            (%compare? (r 'compare?))
     68            (%with-explicit-renaming (r 'with-explicit-renaming))
     69            (%with-implicit-renaming (r 'with-implicit-renaming))
     70            )
     71        (let ((transformer
     72                (cond
     73                  ((c? (car first) %with-explicit-renaming)
     74                   first)
     75                  ((c? (car first) %with-implicit-renaming)
     76                   first)
     77                  (else
     78                    `(,%with-implicit-renaming (,%compare?)
     79                                               ,@(cddr f))))))
     80          ;(print "TTT " transformer)
     81          (let ((with-renaming (car transformer))
     82                (symbols (cadr transformer))
     83                (xpr (caddr transformer))
     84                (xprs (cdddr transformer))
     85                (%let (r 'let))
     86                (%cdr (r 'cdr))
     87                (%bind (r 'bind))
     88                (%lambda (r 'lambda))
     89                (%form (r 'form))
     90                (%rename (r 'rename))
     91                (%inject (r 'inject))
     92                (%er-macro-transformer (r 'er-macro-transformer))
     93                (%ir-macro-transformer (r 'ir-macro-transformer))
     94                (%define-syntax (r 'define-syntax))
     95                (%with-renaming (r 'with-renaming))
     96                )
     97            (let ((transform
     98                    (cond
     99                      ((c? with-renaming %with-explicit-renaming)
     100                       %rename)
     101                      ((c? with-renaming %with-implicit-renaming)
     102                       %inject)
     103                      (else
     104                        (error "invalid renaming type" with-renaming))))
     105                  (macro-transformer
     106                    (cond
     107                      ((c? with-renaming %with-explicit-renaming)
     108                       %er-macro-transformer)
     109                      ((c? with-renaming %with-implicit-renaming)
     110                       %ir-macro-transformer)
     111                      (else
     112                        (error "invalid renaming type" with-renaming))))
     113                  )
     114              `(,%define-syntax ,(car signature)
     115                 (,macro-transformer
     116                   (,%lambda (,%form ,transform ,%compare?)
     117                     (,%bind ,(cdr signature) (,%cdr ,%form)
     118                       (,%let ((,(car symbols) ,%compare?)
     119                               ,@(map (lambda (s)
     120                                        `(,s (,transform
     121                                               ',(string->symbol
     122                                                   (substring
     123                                                     (symbol->string s) 1)))))
     124                                      (cdr symbols)))
     125                         ,xpr ,@xprs)))))
     126              )))))))
     127
     128;;; (macro-rules sym ... (key ...) (pat tpl) ....)
     129;;; ----------------------------------------------
     130;;; where sym ... are injected non-hygienic symbols, key ... are
     131;;; additional keywords, pat ....  are nested lambda-lists without
     132;;; spezial meaning of ellipses and tpl .... usually evaluate to
     133;;; quasiquoted templates. To be imported for syntax.
     134;;; The implementation transfforms keys to keywords and uses bind-case's
     135;;; property to match equal literals.
     136(define-syntax macro-rules
     137  (er-macro-transformer
     138    (lambda (f r c?)
     139      (receive (syms tail)
     140        (let loop ((tail (cdr f)) (head '()))
     141          (if (symbol? (car tail))
     142            (loop (cdr tail) (cons (car tail) head))
     143            (values (reverse head) tail)))
     144        (let ((keys (car tail))
     145              (rules (cdr tail))
     146              (%let (r 'let))
     147              (%form (r 'form))
     148              (%lambda (r 'lambda))
     149              (%inject (r 'inject))
     150              (%compare? (r 'compare?))
     151              (%bind-case (r 'bind-case))
     152              (%ir-macro-transformer (r 'ir-macro-transformer))
     153              (map*
     154                (lambda (fn tree)
     155                  (let recur ((tree tree))
     156                    (cond
     157                      ((pair? tree)
     158                       (cons (recur (car tree))
     159                             (recur (cdr tree))))
     160                      ((symbol? tree) (fn tree))
     161                      (else tree)))))
     162              (symbol->keyword
     163                (lambda (sym)
     164                  (string->keyword (symbol->string sym))))
     165              (memp
     166                (lambda (ok? lst)
     167                  (let loop ((lst lst))
     168                    (cond
     169                      ((null? lst) #f)
     170                      ((ok? (car lst)) lst)
     171                      (else (loop (cdr lst)))))))
     172              )
     173          (let* ((keys->keywords
     174                  (lambda (sym)
     175                    (let ((syms (memp (lambda (x)
     176                                        (c? x (r sym)))
     177                                      keys)))
     178                      (if syms
     179                        (symbol->keyword (car syms))
     180                        ;(symbol->string (car syms))
     181                        sym))))
     182                 (rewrite-keys
     183                   (lambda (form)
     184                     (map* keys->keywords form))))
     185            `(,%ir-macro-transformer
     186               (,%lambda (,%form ,%inject ,%compare?)
     187                 (,%let ,(map (lambda (s)
     188                                `(,s (,%inject ',s)))
     189                         syms)
     190               ;(print "FFF " ,%form)
     191               ;(print "SSS " (,rewrite-keys ,%form))
     192                     (,%bind-case ;,%form ,@rules)
     193                       ;,%form
     194                       (,rewrite-keys ,%form)
     195                       ,@(map (lambda (c d)
     196                                (cons (rewrite-keys c)
     197                                      d))
     198                              (map car rules) (map cdr rules))))))
     199            )))))) 
     200
     201
    33202#|[
    34 Chicken provides two procedural macro-systems, implicit and explicit
    35 renaming macros. In both you have to destructure the use-form yourself
    36 and provide for the renaming or injecting of names which could or should
    37 be captured. Destructuring can be automated with the bind macro -- a
    38 simplified version of the equally named macro in the bindings library --
    39 and renaming resp. injecting can be almost automated with the help of
    40 either the macro with-mapped-symbols or two macro-generators, which
    41 replace the rename resp. inject parameter of the transformer with a
    42 prefix symbol. Note, that bind or with-mapped-symbols must be used
    43 for-syntax, if used in a macro body for destructuring or
    44 renaming/injecting.
    45 
    46 Usually an ambituous explicit renaming macro contains a long let
    47 defining the renamed symbols -- usually prefixed with some fixed symbol
    48 constant like % -- which is then executed in the macro's body by
    49 unquoting it. Both methods create the let automatically.
    50 
    51 Here are two simple examples, one the swap! macro, using
    52 define-er-macro-transformer and with-mapped-symbols, the other numeric if,
    53 using define-er-macro and and explicit prefix, %.
    54 In the latter case, the macro searches its body for symbols starting
    55 with this prefix, collects them in a list, removes duplicates and adds
    56 the necesary let with pairs of the form
    57 
    58   (%name (rename 'name)
    59 
    60 to the front of the body. In other words it does what you usually do by
    61 hand.
    62 
    63   (define-er-macro-transformer (swap! form rename compare?)
    64     (let ((x (cadr form)) (y (caddr form)))
    65       (with-mapped-symbols rename % (%tmp %let %set!)
    66         `(,%let ((,%tmp ,x))
    67            (,%set! ,x ,y)
    68            (,%set! ,y ,%tmp)))))
    69 
    70   (define-er-macro (nif form % compare?)
    71     (bind (_ xpr pos zer neg) form
    72       `(,%let ((,%result ,xpr))
    73          (,%cond
    74            ((,%positive? ,%result) ,pos)
    75            ((,%negative? ,%result) ,neg)
    76            (,%else ,zer)))))
    77 
    78 Note, that one of the standard arguments of an er-macro-transformer,
    79 rename, is replaced by the prefix, which characterize the symbols in the
    80 body to be renamed. The other arguments, form and compare?, remain
    81 untouched.
    82 
    83 
    84 For implicit renaming macros the list of injected symbols is usually,
    85 but not allways, short, even empty for nif. Of course, the generated let
    86 replaces rename with inject in this case.
    87 For example, here is a version of alambda, an anaphoric version of
    88 lambda, which injects the name self:
    89 
    90   (define-ir-macro (alambda form % compare?)
    91     (bind (_ args xpr . xprs) form
    92       `(letrec ((,%self (lambda ,args ,xpr ,@xprs)))
    93          ,%self)))
    94 
     203Now follow the local versions of define-macro, macro-let and
     204macro-letrec.
    95205]|#
    96 (declare (unit procedural-macros))
    97 
    98 (module basic-macros
    99   (define-syntax-rule
    100    define-er-macro-transformer
    101    define-ir-macro-transformer
    102    define-er-macro
    103    define-ir-macro
    104    once-only
    105    with-mapped-symbols
    106    with-gensyms
    107    basic-macros
    108    )
    109   (import scheme
    110           ;(only bindings bind-case)
    111           (only (chicken condition) condition-case)
    112           (only (chicken base) case-lambda print error))
    113   (import-for-syntax (only bindings bind-case))
    114 
    115 #|[Let's start with a one syntax-rule]|#
    116 
    117 ;;; (define-syntax-rule (name . args) xpr . xprs)
    118 ;;; (define-syntax-rule (name . args) (keywords . keys) xpr . xprs)
    119 ;;; ---------------------------------------------------------------
    120 ;;; simplyfies define-syntax in case there is only one rule
    121 (define-syntax define-syntax-rule
    122   (syntax-rules (keywords)
    123     ((_ (name . args)
    124         (keywords key ...) xpr . xprs)
    125      (define-syntax name
    126        (syntax-rules (key ...)
    127          ((_ . args) xpr . xprs))))
    128     ((_ (name . args) xpr . xprs)
    129      (define-syntax name
    130        (syntax-rules ()
    131          ((_ . args) xpr . xprs))))))
    132 
    133 #|[
    134 Let's start with some helpers which might be occasionally useful
    135 ]|#
    136 
    137 ;;; (define-er-macro-transformer form rename compare?)
     206
     207;;; (macro-let (((signature body) ...) ...) xpr ....)
    138208;;; --------------------------------------------------
    139 ;;; wrapper around er-macro-transformer
    140 (define-syntax define-er-macro-transformer
    141   (syntax-rules ()
    142     ((_ (name form rename compare?) xpr . xprs)
    143      (define-syntax name
    144        (er-macro-transformer
    145          (lambda (form rename compare?) xpr . xprs))))))
    146 
    147 ;;; (define-ir-macro-transformer form inject compare?)
    148 ;;; --------------------------------------------------
    149 ;;; wrapper around ir-macro-transformer
    150 (define-syntax define-ir-macro-transformer
    151   (syntax-rules ()
    152     ((_ (name form inject compare?) xpr . xprs)
    153      (define-syntax name
    154        (ir-macro-transformer
    155          (lambda (form inject compare?) xpr . xprs))))))
     209;;; evaluates xpr ... in the context of parallel macros name ....
     210;(define-macro (macro-let signature-body-list xpr . xprs)
     211;  (with-explicit-renaming (compare? %let-syntax %macro-rules)
     212(define-macro (macro-let signature-body-list xpr . xprs)
     213  (with-explicit-renaming (compare? %let-syntax %macro-rules)
     214    (let ((signatures (map car signature-body-list))
     215          (bodies (map cdr signature-body-list)))
     216      `(,%let-syntax ,(map (lambda (sig body)
     217                                `(,(car sig)
     218                                  (,%macro-rules _ ()
     219                                    (,(cons '_ (cdr sig)) ,@body))))
     220                             signatures bodies)
     221         ,xpr ,@xprs))))
     222
     223;;; (macro-letrec (((signature body) ...) ...) xpr ....)
     224;;; ----------------------------------------------------
     225;;; evaluates xpr ... in the context of recursive macros name ....
     226(define-macro (macro-letrec signature-body-list xpr . xprs)
     227  (with-explicit-renaming (compare? %letrec-syntax %macro-rules)
     228    (let ((signatures (map car signature-body-list))
     229          (bodies (map cdr signature-body-list)))
     230      `(,%letrec-syntax ,(map (lambda (sig body)
     231                                `(,(car sig)
     232                                  (,%macro-rules _ ()
     233                                    (,(cons '_ (cdr sig)) ,@body))))
     234                             signatures bodies)
     235         ,xpr ,@xprs))))
    156236
    157237;;; (once-only (x ....) xpr ....)
     
    161241;;; The code is more or less due to
    162242;;; P. Seibel, Practical Common Lisp, p. 102
    163 ;(define-syntax once-only
    164 ;  (er-macro-transformer
    165 ;    (lambda (form rename compare?)
    166 (define-er-macro-transformer (once-only form rename compare?)
    167   (let ((names (cadr form))
    168         (body (cons (caddr form) (cdddr form)))
    169         (%let (rename 'let))
    170         (%list (rename 'list))
    171         )
    172     (let ((syms (map rename names)))
    173       `(,%let ,(map (lambda (g) `(,g ,(rename `',g))) syms)
    174          `(,',%let ,(,%list ,@(map (lambda (g n) ``(,,g ,,n))
    175                                syms names))
    176             ,(,%let ,(map (lambda (n g) `(,n ,g))
    177                         names syms)
    178                ,@body))))));))
    179 ;(define-ir-macro-transformer (once-only form inject compare?)
    180 ;  (let ((names (cadr form))
    181 ;        (body (cons (caddr form) (cdddr form))))
    182 ;    (let ((gensyms (map (lambda (x) (gensym)) names)))
    183 ;      `(let ,(map (lambda (g) `(,g (gensym))) gensyms)
    184 ;         `(let ,(list ,@(map (lambda (g n) ``(,,g ,,n))
    185 ;                             gensyms names))
    186 ;            ,(let ,(map (lambda (n g) `(,n ,g))
    187 ;                        names gensyms)
    188 ;               ,@body))))))
    189 ;
    190 
    191 ;;; (define-macro-with (name form prefix compare? transformer) xpr . xprs)
    192 ;;; ----------------------------------------------------------------------
    193 ;;; internal helper
    194 (define-syntax define-macro-with
     243(define-syntax once-only
    195244  (er-macro-transformer
    196245    (lambda (form rename compare?)
    197       (let (
    198         (header (cadr form))
    199         (body (cons (caddr form) (cdddr form)))
    200         (pseudo-flatten
    201           (lambda (tree)
    202             ; imported flatten doesn't work with pseudo-lists
    203             (let loop ((tree tree) (result '()))
    204               (cond
    205                 ((pair? tree)
    206                  (loop (car tree) (loop (cdr tree) result)))
    207                 ((null? tree) result)
    208                 (else
    209                   (cons tree result))))))
    210         (adjoin
    211           (lambda (obj lst)
    212             (if (member obj lst) lst (cons obj lst))))
    213         (sym-tail
    214           (lambda (pre sym)
    215             (let ((spre (symbol->string pre))
    216                   (ssym (symbol->string sym)))
    217               (let ((prelen (string-length spre))
    218                     (symlen (string-length ssym)))
    219                 (string->symbol (substring ssym prelen))))))
    220         (sym-prepends?
    221           (lambda (pre sym)
    222             (let ((spre (symbol->string pre))
    223                   (ssym (symbol->string sym)))
    224               (let ((prelen (string-length spre))
    225                     (symlen (string-length ssym)))
    226                 (and (< prelen symlen)
    227                      (equal? (string->list spre)
    228                              (string->list
    229                                (substring ssym 0 prelen))))))))
    230         )
    231         (let (
    232           (name (car header))
    233           (frm (cadr header))
    234           (pre (caddr header))
    235           (cmp? (cadddr header))
    236           (transformer (car (cddddr header)))
    237           (ren 'process)
    238           (%let (rename 'let))
    239           (%lambda (rename 'lambda))
    240           (%define-syntax (rename 'define-syntax))
    241           (flat-body (pseudo-flatten body))
    242           (remove-duplicates
    243             (lambda (lst)
    244               (let loop ((lst lst) (result '()))
    245                 (if (null? lst)
    246                   (reverse result)
    247                   (loop (cdr lst) (adjoin (car lst) result))))))
    248           )
    249           `(,%define-syntax ,name
    250              (,transformer
    251                (,%lambda (,frm ,ren ,cmp?)
    252                  (,%let ,(map (lambda (sym)
    253                                 `(,sym (,ren ',(sym-tail pre sym))))
    254                               (remove-duplicates
    255                                 (compress
    256                                   (map (lambda (sym)
    257                                          (and (symbol? sym)
    258                                               (sym-prepends? pre sym)))
    259                                        flat-body)
    260                                   flat-body)))
    261                                 ;(filter
    262                                 ;  (lambda (sym)
    263                                 ;          (and (symbol? sym)
    264                                 ;               (sym-prepends? pre sym)))
    265                                 ;        (pseudo-flatten body))))
    266                    ,@body)))))))))
    267 
    268 ;;; (define-er-macro (name form rename-prefix compare?) xpr . xprs)
    269 ;;; ---------------------------------------------------------------
    270 ;;; defines an explicit-renaming macro name with use-form form,
    271 ;;; automatically renaming symbols starting with inject-rpefix
    272 (define-syntax define-er-macro
    273   (syntax-rules ()
    274     ((_ (name form rename-prefix compare?) xpr . xprs)
    275      (define-macro-with
    276        (name form rename-prefix compare? er-macro-transformer)
    277        xpr . xprs))))
    278 
    279 ;;; (define-ir-macro (name form inject-prefix compare?) xpr . xprs)
    280 ;;; ---------------------------------------------------------------
    281 ;;; defines an implicit-renaming macro name with use-form form,
    282 ;;; automatically injecting symbols starting with inject-rpefix
    283 (define-syntax define-ir-macro
    284   (syntax-rules ()
    285     ((_ (name form inject-prefix compare?) xpr . xprs)
    286      (define-macro-with
    287        (name form inject-prefix compare? ir-macro-transformer)
    288        xpr . xprs))))
    289 
    290 ;;; (with-mapped-symbols mapper prefix- (prefix-x ....) xpr ....)
    291 ;;; -------------------------------------------------------------
    292 ;;; binds a series of prefixed names, prefix-x ....
    293 ;;; to the images of the original names, x ...., under mapper
    294 ;;; and evaluates xpr .... in this context
    295 (define-syntax with-mapped-symbols
     246      (let ((syms (cadr form))
     247            (xpr (caddr form))
     248            (xprs (cdddr form)))
     249        (let ((%syms (map rename syms))
     250              (%let (rename 'let))
     251              (%list (rename 'list)))
     252          `(,%let ,(map (lambda (g) `(,g ,(rename `',g))) %syms)
     253             `(,',%let ,(,%list ,@(map (lambda (g n) ``(,,g ,,n))
     254                                   %syms syms))
     255                ,(,%let ,(map (lambda (n g) `(,n ,g))
     256                            syms %syms)
     257                   ,xpr ,@xprs))))))))
     258
     259;;; (with-renamed-symbols (renamer . %syms) xpr . xprs)
     260;;; ---------------------------------------------------
     261(define-syntax with-renamed-symbols
    296262  (er-macro-transformer
    297263    (lambda (form rename compare?)
    298       (let ((mapper (cadr form))
    299             (prefix (caddr form))
    300             (syms (cadddr form))
    301             (xpr (car (cddddr form)))
    302             (xprs (cdr (cddddr form)))
    303             (%let (rename 'let))
    304             (sym-tail
    305               (lambda (pre sym)
    306                 (let ((spre (symbol->string pre))
    307                       (ssym (symbol->string sym)))
    308                   (let ((prelen (string-length spre))
    309                         (symlen (string-length ssym)))
    310                     (string->symbol (substring ssym prelen)))))))
    311         `(,%let ,(map (lambda (s)
    312                         `(,s (,mapper ',(sym-tail prefix s))))
    313                       syms)
    314            ,xpr ,@xprs)))))
     264      (let ((syms (cadr form))
     265            (xpr (caddr form))
     266            (xprs (cdddr form))
     267            )
     268        (let ((renamer (car syms))
     269              (%syms (cdr syms))
     270              (%let (rename 'let))
     271              )
     272          `(,%let ,(map (lambda (s)
     273                          ;`(,(symbol-append prefix s) (,renamer ',s)))
     274                          `(,s (,renamer
     275                            ',(string->symbol
     276                               (substring (symbol->string s) 1)))))
     277                        %syms)
     278             ,xpr ,@xprs))))))
    315279
    316280;;; (with-gensyms (name ....) xpr ....)
     
    323287         ,@(cddr form)))))
    324288
    325 
    326 ;;; (basic-macros sym ..)
    327 ;;; ---------------------
    328 ;;; documentation procedure.
    329 (define basic-macros
    330   (let ((alst '(
    331     (define-syntax-rule
    332       macro:
    333        (define-syntax-rule (name . args) xpr . xprs)
    334        (define-syntax-rule (name . args) (keywords . keys) xpr . xprs)
    335        "simplyfied version of syntax-rules,"
    336        "if there is only one rule")
    337 ;;;    (bind
    338 ;;;      macro:
    339 ;;;      (bind pat seq (where fender ...) .. xpr ....)
    340 ;;;      "a variant of Common Lisp's destructuring-bind"
    341 ;;;      "where pat and seq are a nested pseudo-lists and"
    342 ;;;      "optional fenders of the form (x x? ...) are checked"
    343 ;;;      "before evaluating the body xpr ...")
    344 ;;;    (bind-case
    345 ;;;      macro:
    346 ;;;      (bind-case seq (pat (where fender ...) .. xpr ...) ....)
    347 ;;;      "matches a nested pseudo-list seq against nested pseudo-lists"
    348 ;;;      "pat ... with optional fenders ... in sequence in a case regime")
    349     (once-only
    350       macro:
    351       (once-only (x ....) xpr ....)
    352       "arguments x ... are evaluated only once and"
    353       "from left to right in the body xpr ....")
    354     (define-er-macro-transformer
    355       macro:
    356       (define-er-macro-tansformer name form rename compare?)
    357       "wrapper around er-macro-transformer")
    358     (define-ir-macro-transformer
    359       macro:
    360       (define-ir-macro-tansformer name form inject compare?)
    361       "wrapper around ir-macro-transformer")
    362     (define-er-macro
    363       macro:
    364       (define-er-macro name form rename-prefix compare?)
    365       "creates an explicit-renaming macro, where all symbols"
    366       "starting with rename-prefix are renamed automatically")
    367     (define-ir-macro
    368       macro:
    369       (define-ir-macro name form inject-prefix compare?)
    370       "creates an implicit-renaming macro, where all symbols"
    371       "starting with inject-prefix are injected automatically")
    372     (with-mapped-symbols
    373       macro:
    374       (with-mapped-symbols mapper prefix- (prefix-x ....) xpr ....)
    375       "binds a series of prefixed names, prefix-x ...."
    376       "to the images of the original names, x ...., under mapper"
    377       "and evaluates xpr .... in this context")
    378     (with-gensyms
    379       macro:
    380       (with-gensyms (x ....) xpr ....)
    381       "generates a series of gensyms x .... to be used in body xpr ...")
    382     )))
    383     (case-lambda
    384       (()
    385        (map car alst))
    386       ((sym)
    387        (let ((lst (assq sym alst)))
    388          (if lst
    389            (for-each print (cdr lst))
    390            (error 'basic-macros
    391                   "not exported" sym)))))))
    392 
    393 ) ; module basic-macros
    394 
    395 #|[
    396 This module will provide some macro-writing macros, in particular
    397 macro-rules and define-macro, based on explicit- and implicit-renaming.
    398 The syntax of macro-rules mimics that of syntax-rules, except that it
    399 allows for injected symbols before the keyword list and the templates
    400 are usually quasiquoted lists. Since we use bind-case from the bindings
    401 egg, this library accepts wildcards, non-symbol literals and fenders.
    402 ]|#
    403 
    404 (module procedural-macros
    405   (procedural-macros
    406     define-macro
    407     (macro-rules bind-case)
    408     macro-let
    409     macro-letrec
    410     ;basic-macros
    411     once-only
    412     define-ir-macro-transformer
    413     define-er-macro-transformer
    414     define-ir-macro
    415     define-er-macro
    416     with-mapped-symbols
    417     with-gensyms)
    418  
    419   (import scheme
    420           basic-macros
    421           (only (chicken base) print error case-lambda)
    422           (only bindings bind-case))
    423   (import-for-syntax (only (chicken base) compress))
    424 
    425 #|[
    426 The workhorse of the library is the following macro, a procedural
    427 version of syntax-rules, but without its limitations.
    428 ]|#
    429 
    430 ;;; (macro-rules sym ... (key ...) (pat tpl) ...)
    431 ;;; (macro-rules sym ... (key ...) (pat (where fender ...) tpl) ...)
    432 ;;; ----------------------------------------------------------------
    433 ;;; where sym ... are injected non-hygienig symbols, key ... are
    434 ;;; additional keywords, pat ....  are nested lambda-lists without
    435 ;;; spezial meaning of ellipses and tpl .... usually evaluate to
    436 ;;; quasiquoted templates. The optional fenders belong to the pattern
    437 ;;; matching process.
    438 (define-er-macro-transformer (macro-rules f r c?)
    439   (let (
    440     (f* (let loop ((tail (cdr f)) (head '()))
    441           (if (symbol? (car tail))
    442             (loop (cdr tail) (cons (car tail) head))
    443             (cons head tail))))
    444     (%x (r 'x))
    445     (%let (r 'let))
    446     (%form (r 'form))
    447     (%where (r 'where))
    448     (%lambda (r 'lambda))
    449     (%inject (r 'inject))
    450     (%compare? (r 'compare?))
    451     (%bind-case (r 'bind-case))
    452     (%ir-macro-transformer (r 'ir-macro-transformer))
    453     )
    454     (let ((syms (car f*))
    455           (keys (cadr f*))
    456           (rules (cddr f*))
    457           (pseudo-flatten
    458             (lambda (tree)
    459               ; imported flatten doesn't work with pseudo-lists
    460               (let loop ((tree tree) (result '()))
    461                 (cond
    462                   ((pair? tree)
    463                    (loop (car tree) (loop (cdr tree) result)))
    464                   ((null? tree) result)
    465                   (else
    466                     (cons tree result))))))
    467           )
    468       (let* ((pats (map car rules))
    469              (fpats (map pseudo-flatten pats))
    470              (kpats (map (lambda (fp)
    471                            ;(filter (lambda (x)
    472                            ;          (memq x keys))
    473                            ;        fp))
    474                            (compress
    475                              (map (lambda (x) (memq x keys)) fp)
    476                              fp))
    477                          fpats))
    478              ;; compare? keywords with its names
    479              (key-checks
    480                (map (lambda (kp)
    481                       (map (lambda (p s)
    482                              `(,p (,%lambda (,%x)
    483                                             (,%compare? ,%x ,s))))
    484                            kp
    485                            (map (lambda (x) `',x)
    486                                 kp)))
    487                     kpats))
    488              ;; prepare where clause for each rule
    489              ;; to check keys
    490              (all-rules (map (lambda (rule checks)
    491                                (let ((second (cadr rule)))
    492                                  (if (and (pair? second)
    493                                           (c? (car second) %where))
    494                                    `(,(car rule)
    495                                       (,%where ,@(cdr second) ,@checks)
    496                                       ,@(cddr rule))
    497                                    `(,(car rule)
    498                                       (,%where ,@checks)
    499                                       ,@(cdr rule)))))
    500                              rules key-checks)))
    501         `(,%ir-macro-transformer
    502            (,%lambda (,%form ,%inject ,%compare?)
    503              (,%let ,(map (lambda (s)
    504                        `(,s (,%inject ',s)))
    505                      syms)
    506                (,%bind-case ,%form
    507                             ,@all-rules))))))))
    508 
    509 #|[
    510 And now a procedural version of our old friend, define-macro,
    511 which is hygienic, if now injections are provided.
    512 ]|#
    513 
    514 ;;; (define-macro (name . args)
    515 ;;;   (where (x . xs) ...)
    516 ;;;   xpr . xprs)
    517 ;;; ----------------------------------- 
    518 ;;; where xs is either a list of predicates, thus providing fenders,
    519 ;;; or a singleton containing one of the symbols keyword or injection
    520 ;;; to provide keyword arguments or nonhygienic macros
    521 (define-er-macro-transformer (define-macro form rename compare?)
    522   (let ((code (cadr form))
    523         (xpr (caddr form))
    524         (xprs (cdddr form))
    525         (%where (rename 'where))
    526         (%keyword (rename 'keyword))
    527         (%injection (rename 'injection))
    528         (%define-macro (rename 'define-macro))
    529         (%macro-rules (rename 'macro-rules))
    530         (%define-syntax (rename 'define-syntax)))
    531     (let ((name (car code)) (args (cdr code)))
    532       (if (and (pair? xpr)
    533                (compare? (car xpr) %where)
    534                (not (null? xprs)))
    535         (let ((clauses (cdr xpr)))
    536           (let (
    537             (fenders
    538               (compress
    539                 (map (lambda (clause)
    540                        (or (null? (cdr clause))
    541                            (and (not (compare? (cadr clause) %keyword))
    542                                 (not (compare? (cadr clause) %injection)))))
    543                   clauses)
    544                 clauses))
    545               ;(filter (lambda (clause)
    546               ;          (or (null? (cdr clause))
    547               ;              (and (not (compare? (cadr clause) %keyword))
    548               ;                   (not (compare? (cadr clause) %injection)))))
    549               ;       clauses))
    550             (keywords
    551               (compress
    552                 (map (lambda (clause)
    553                        (and (not (null? (cdr clause)))
    554                             (compare? (cadr clause) %keyword)))
    555                      clauses)
    556                 clauses))
    557               ;(filter (lambda (clause)
    558               ;          (and (not (null? (cdr clause)))
    559               ;               (compare? (cadr clause) %keyword)))
    560               ;        clauses))
    561             (injections
    562               (compress
    563                 (map (lambda (clause)
    564                        (and (not (null? (cdr clause)))
    565                             (compare? (cadr clause) %injection)))
    566                      clauses)
    567                 clauses))
    568               ;(filter
    569               ;  (lambda (clause)
    570               ;          (and (not (null? (cdr clause)))
    571               ;               (compare? (cadr clause) %injection)))
    572               ;        clauses))
    573             )
    574             (let (
    575               (keywords
    576                 (if (null? keywords)
    577                   keywords
    578                   (map car keywords)))
    579               (injections
    580                 (if (null? injections)
    581                   injections
    582                   (map car injections)))
    583               )
    584               `(,%define-syntax ,name
    585                  (,%macro-rules ,@injections ,keywords
    586                    ((_ ,@args) (where ,@fenders) ,@xprs))))))
    587         `(,%define-syntax ,name
    588            (,%macro-rules ()
    589              ((_ ,@args) ,xpr ,@xprs)))))))
    590 
    591 #|[
    592 Now follow the local versions of define-macro, macro-let and
    593 macro-letrec. Since the syntax of both is identical, they are
    594 implemented by means of a helper macro.
    595 ]|#
    596 
    597 ;; helper for macro-let and macro-letrec
    598 (define-er-macro-transformer (macro-with form rename compare?)
    599   (let ((op (cadr form))
    600         (pat-tpl-pairs (caddr form))
    601         (xpr (cadddr form))
    602         (xprs (cddddr form))
    603         (%macro-rules (rename 'macro-rules)))
    604     (let ((pats (map car pat-tpl-pairs))
    605           (tpls (map cdr pat-tpl-pairs)))
    606       `(,op ,(map (lambda (pat tpl)
    607                     `(,(car pat)
    608                        (,%macro-rules ()
    609                          ((_ ,@(cdr pat)) ,@tpl))))
    610                   pats tpls)
    611                    ,xpr ,@xprs))))
    612 
    613 ;;; (macro-let (((name . args) (where fender ...) .. xpr ...) ...) body ....)
    614 ;;; -------------------------------------------------------------------------
    615 ;;; evaluates body ... in the context of parallel macros name ....
    616 (define-er-macro-transformer (macro-let form rename compare?)
    617   (let ((pat-tpl-pairs (cadr form))
    618         (xpr (caddr form))
    619         (xprs (cdddr form));)
    620         (%macro-with (rename 'macro-with))
    621         (%let-syntax (rename 'let-syntax)))
    622     `(,%macro-with ,%let-syntax ,pat-tpl-pairs ,xpr ,@xprs)))
    623 
    624 ;;; (macro-letrec (((name . args) (where fender ...) .. xpr ...) ...) body ....)
    625 ;;; ----------------------------------------------------------------------------
    626 ;;; evaluates body ... in the context of recursive macros name ....
    627 (define-er-macro-transformer (macro-letrec form rename compare?)
    628   (let ((pat-tpl-pairs (cadr form))
    629         (xpr (caddr form))
    630         (xprs (cdddr form));)
    631         (%macro-with (rename 'macro-with))
    632         (%letrec-syntax (rename 'letrec-syntax)))
    633     `(,%macro-with ,%letrec-syntax ,pat-tpl-pairs ,xpr ,@xprs)))
    634 
    635289;;; (procedural-macros sym ..)
    636290;;; --------------------------
     
    640294    (macro-rules
    641295      macro:
    642       (macro-rules literal ... (keyword ...) (pat (where fender ...) .. tpl) ....)
     296      (macro-rules literal ... (keyword ...) (pat tpl) ....)
    643297      "procedural version of syntax-rules"
    644298      "with optional injected literals"
    645       "and quasiquoted templates")
     299      "and quasiquoted templates"
     300      "To be imported for syntax")
    646301    (define-macro
    647302      macro:
    648       (define-macro (name . args) (where (x . xs) ...) .. xpr ....)
    649       "a version of macro-rules with only one rule"
    650       "xs is either a list of predicates, thus providing fenders"
    651       "or a singleton containing one of the symbols keyword or"
    652       "injection, providing keyword parameters or nonhygienic macros")
     303      (define-macro (name . args) (with-renaming (compare? %x ...) xpr ....))
     304      (define-macro (name . args) xpr ....)
     305      "where with-renaming is one of with-explicit- or with-implicit-renaming"
     306      "and %x ... is the symbol x prefixed with one letter only."
     307      "Defines an explicit- or implicit-renaming macro name,"
     308      "automatically destructuring args with bind and creating local bindings"
     309      "for compare? and %x ... to x ... renamed or injected respectively,"
     310      "evaluating xpr ... in this context."
     311      "The latter version is used if no keys are needed and nothing is"
     312      "to be injected")
    653313    (macro-let
    654314      macro:
    655       (macro-let (((name . args) (where fender ...) .. xpr ...) ...) body ....)
     315      (macro-let (((name args) xpr ...) ...) body ....)
    656316      "evaluates body ... in the context of parallel macros name ....")
    657317    (macro-letrec
    658318      macro:
    659       (macro-letrec (((name . args) (where fender ...) .. xpr ...) ...) body ....)
     319      (macro-letrec (((name args) xpr ...) ...) body ....)
    660320      "evaluates body ... in the context of recursive macros name ....")
    661321    (once-only
     
    663323      (once-only (x ....) xpr ....)
    664324      "arguments x ... are evaluated only once and"
    665       "from left to right in the body xpr ....")
    666     (define-er-macro-transformer
    667       macro:
    668       (define-er-macro-tansformer name form rename compare?)
    669       "wrapper around er-macro-transformer")
    670     (define-ir-macro-transformer
    671       macro:
    672       (define-ir-macro-tansformer name form inject compare?)
    673       "wrapper around ir-macro-transformer")
    674     (define-er-macro
    675       macro:
    676       (define-er-macro name form rename-prefix compare?)
    677       "creates an explicit-renaming macro, where all symbols"
    678       "starting with rename-prefix are renamed automatically")
    679     (define-ir-macro
    680       macro:
    681       (define-ir-macro name form inject-prefix compare?)
    682       "creates an implicit-renaming macro, where all symbols"
    683       "starting with inject-prefix are injected automatically")
    684     (with-mapped-symbols
    685       macro:
    686       (with-mapped-symbols mapper prefix- (prefix-x ....) xpr ....)
    687       "binds a series of prefixed names, prefix-x ...."
    688       "to the images of the original names, x ...., under mapper"
    689       "and evaluates xpr .... in this context")
     325      "from left to right in the body xpr ...."
     326      "To be imported for syntax")
     327    (with-renamed-symbols
     328      macro:
     329      (with-renamed-symbols (renamer %x ....) xpr ....)
     330      "binds a series of names prefixed with one letter, e.g. %,
     331      %x .... to the images of the original names, x ....,"
     332      "under renamer and evaluates xpr .... in this context"
     333      "To be imported for syntax")
    690334    (with-gensyms
    691335      macro:
    692336      (with-gensyms (x ....) xpr ....)
    693       "generates a series of gensyms x .... to be used in body xpr ...")
     337      "binds x ... to (gensym 'x) ... in body xpr ...")
     338    (procedural-macros
     339      procedure:
     340      "documaentation procedure: returns the list of exported symbols"
     341      "if called with no arguments, or the documentation of its only"
     342      "symbol argument")
    694343    )))
    695344    (case-lambda
     
    702351           (error 'procedural-macros
    703352                  "not exported" sym)))))))
    704 ) ; procedural-macros
    705 
     353
     354) ; module procedural-macros
     355
  • release/5/procedural-macros/tags/2.0/tests/run.scm

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

    r37895 r38044  
    22 (category lang-exts)
    33 (license "BSD")
    4  (test-dependencies bindings simple-tests)
     4 (test-dependencies simple-tests checks)
    55 (dependencies bindings)
    66 (author "Juergen Lorenz")
    7  (version "1.1")
     7 (version "2.0")
    88 (components
    9    (extension procedural-macros
    10      (modules basic-macros
    11               procedural-macros)))
     9   (extension procedural-macros)))
    1210)
    1311
  • release/5/procedural-macros/trunk/procedural-macros.scm

    r37895 r38044  
    3131; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
    3232
     33(module procedural-macros (
     34  define-macro
     35  macro-rules
     36  macro-let
     37  macro-letrec
     38  once-only
     39  with-renamed-symbols
     40  with-gensyms
     41  procedural-macros
     42  )
     43
     44(import scheme
     45        bindings
     46        (only (chicken base) print error case-lambda))
     47(import-for-syntax (only bindings bind bind-case)
     48                   (only (chicken keyword) string->keyword))
     49
     50;;; (define-macro signature
     51;;;   (with-renaming (compare? . %syms)
     52;;;     xpr . xprs))
     53;;; (define-macro signature
     54;;;   xpr . xprs)
     55;;; ---------------------------------
     56;;; where with-renaming is either
     57;;; with-implicit- or with-explicit-renaming.
     58;;; If not given and no keys are needed, with-implict-renaming is used.
     59;;; Defines an explicit- or implicit-renaming macro name
     60;;; with use-form signature.
     61(define-syntax define-macro
     62  (er-macro-transformer
     63    (lambda (f r c?)
     64      (let ((signature (cadr f))
     65            ;(transformer (caddr f)))
     66            (first (caddr f))
     67            (%compare? (r 'compare?))
     68            (%with-explicit-renaming (r 'with-explicit-renaming))
     69            (%with-implicit-renaming (r 'with-implicit-renaming))
     70            )
     71        (let ((transformer
     72                (cond
     73                  ((c? (car first) %with-explicit-renaming)
     74                   first)
     75                  ((c? (car first) %with-implicit-renaming)
     76                   first)
     77                  (else
     78                    `(,%with-implicit-renaming (,%compare?)
     79                                               ,@(cddr f))))))
     80          ;(print "TTT " transformer)
     81          (let ((with-renaming (car transformer))
     82                (symbols (cadr transformer))
     83                (xpr (caddr transformer))
     84                (xprs (cdddr transformer))
     85                (%let (r 'let))
     86                (%cdr (r 'cdr))
     87                (%bind (r 'bind))
     88                (%lambda (r 'lambda))
     89                (%form (r 'form))
     90                (%rename (r 'rename))
     91                (%inject (r 'inject))
     92                (%er-macro-transformer (r 'er-macro-transformer))
     93                (%ir-macro-transformer (r 'ir-macro-transformer))
     94                (%define-syntax (r 'define-syntax))
     95                (%with-renaming (r 'with-renaming))
     96                )
     97            (let ((transform
     98                    (cond
     99                      ((c? with-renaming %with-explicit-renaming)
     100                       %rename)
     101                      ((c? with-renaming %with-implicit-renaming)
     102                       %inject)
     103                      (else
     104                        (error "invalid renaming type" with-renaming))))
     105                  (macro-transformer
     106                    (cond
     107                      ((c? with-renaming %with-explicit-renaming)
     108                       %er-macro-transformer)
     109                      ((c? with-renaming %with-implicit-renaming)
     110                       %ir-macro-transformer)
     111                      (else
     112                        (error "invalid renaming type" with-renaming))))
     113                  )
     114              `(,%define-syntax ,(car signature)
     115                 (,macro-transformer
     116                   (,%lambda (,%form ,transform ,%compare?)
     117                     (,%bind ,(cdr signature) (,%cdr ,%form)
     118                       (,%let ((,(car symbols) ,%compare?)
     119                               ,@(map (lambda (s)
     120                                        `(,s (,transform
     121                                               ',(string->symbol
     122                                                   (substring
     123                                                     (symbol->string s) 1)))))
     124                                      (cdr symbols)))
     125                         ,xpr ,@xprs)))))
     126              )))))))
     127
     128;;; (macro-rules sym ... (key ...) (pat tpl) ....)
     129;;; ----------------------------------------------
     130;;; where sym ... are injected non-hygienic symbols, key ... are
     131;;; additional keywords, pat ....  are nested lambda-lists without
     132;;; spezial meaning of ellipses and tpl .... usually evaluate to
     133;;; quasiquoted templates. To be imported for syntax.
     134;;; The implementation transfforms keys to keywords and uses bind-case's
     135;;; property to match equal literals.
     136(define-syntax macro-rules
     137  (er-macro-transformer
     138    (lambda (f r c?)
     139      (receive (syms tail)
     140        (let loop ((tail (cdr f)) (head '()))
     141          (if (symbol? (car tail))
     142            (loop (cdr tail) (cons (car tail) head))
     143            (values (reverse head) tail)))
     144        (let ((keys (car tail))
     145              (rules (cdr tail))
     146              (%let (r 'let))
     147              (%form (r 'form))
     148              (%lambda (r 'lambda))
     149              (%inject (r 'inject))
     150              (%compare? (r 'compare?))
     151              (%bind-case (r 'bind-case))
     152              (%ir-macro-transformer (r 'ir-macro-transformer))
     153              (map*
     154                (lambda (fn tree)
     155                  (let recur ((tree tree))
     156                    (cond
     157                      ((pair? tree)
     158                       (cons (recur (car tree))
     159                             (recur (cdr tree))))
     160                      ((symbol? tree) (fn tree))
     161                      (else tree)))))
     162              (symbol->keyword
     163                (lambda (sym)
     164                  (string->keyword (symbol->string sym))))
     165              (memp
     166                (lambda (ok? lst)
     167                  (let loop ((lst lst))
     168                    (cond
     169                      ((null? lst) #f)
     170                      ((ok? (car lst)) lst)
     171                      (else (loop (cdr lst)))))))
     172              )
     173          (let* ((keys->keywords
     174                  (lambda (sym)
     175                    (let ((syms (memp (lambda (x)
     176                                        (c? x (r sym)))
     177                                      keys)))
     178                      (if syms
     179                        (symbol->keyword (car syms))
     180                        ;(symbol->string (car syms))
     181                        sym))))
     182                 (rewrite-keys
     183                   (lambda (form)
     184                     (map* keys->keywords form))))
     185            `(,%ir-macro-transformer
     186               (,%lambda (,%form ,%inject ,%compare?)
     187                 (,%let ,(map (lambda (s)
     188                                `(,s (,%inject ',s)))
     189                         syms)
     190               ;(print "FFF " ,%form)
     191               ;(print "SSS " (,rewrite-keys ,%form))
     192                     (,%bind-case ;,%form ,@rules)
     193                       ;,%form
     194                       (,rewrite-keys ,%form)
     195                       ,@(map (lambda (c d)
     196                                (cons (rewrite-keys c)
     197                                      d))
     198                              (map car rules) (map cdr rules))))))
     199            )))))) 
     200
     201
    33202#|[
    34 Chicken provides two procedural macro-systems, implicit and explicit
    35 renaming macros. In both you have to destructure the use-form yourself
    36 and provide for the renaming or injecting of names which could or should
    37 be captured. Destructuring can be automated with the bind macro -- a
    38 simplified version of the equally named macro in the bindings library --
    39 and renaming resp. injecting can be almost automated with the help of
    40 either the macro with-mapped-symbols or two macro-generators, which
    41 replace the rename resp. inject parameter of the transformer with a
    42 prefix symbol. Note, that bind or with-mapped-symbols must be used
    43 for-syntax, if used in a macro body for destructuring or
    44 renaming/injecting.
    45 
    46 Usually an ambituous explicit renaming macro contains a long let
    47 defining the renamed symbols -- usually prefixed with some fixed symbol
    48 constant like % -- which is then executed in the macro's body by
    49 unquoting it. Both methods create the let automatically.
    50 
    51 Here are two simple examples, one the swap! macro, using
    52 define-er-macro-transformer and with-mapped-symbols, the other numeric if,
    53 using define-er-macro and and explicit prefix, %.
    54 In the latter case, the macro searches its body for symbols starting
    55 with this prefix, collects them in a list, removes duplicates and adds
    56 the necesary let with pairs of the form
    57 
    58   (%name (rename 'name)
    59 
    60 to the front of the body. In other words it does what you usually do by
    61 hand.
    62 
    63   (define-er-macro-transformer (swap! form rename compare?)
    64     (let ((x (cadr form)) (y (caddr form)))
    65       (with-mapped-symbols rename % (%tmp %let %set!)
    66         `(,%let ((,%tmp ,x))
    67            (,%set! ,x ,y)
    68            (,%set! ,y ,%tmp)))))
    69 
    70   (define-er-macro (nif form % compare?)
    71     (bind (_ xpr pos zer neg) form
    72       `(,%let ((,%result ,xpr))
    73          (,%cond
    74            ((,%positive? ,%result) ,pos)
    75            ((,%negative? ,%result) ,neg)
    76            (,%else ,zer)))))
    77 
    78 Note, that one of the standard arguments of an er-macro-transformer,
    79 rename, is replaced by the prefix, which characterize the symbols in the
    80 body to be renamed. The other arguments, form and compare?, remain
    81 untouched.
    82 
    83 
    84 For implicit renaming macros the list of injected symbols is usually,
    85 but not allways, short, even empty for nif. Of course, the generated let
    86 replaces rename with inject in this case.
    87 For example, here is a version of alambda, an anaphoric version of
    88 lambda, which injects the name self:
    89 
    90   (define-ir-macro (alambda form % compare?)
    91     (bind (_ args xpr . xprs) form
    92       `(letrec ((,%self (lambda ,args ,xpr ,@xprs)))
    93          ,%self)))
    94 
     203Now follow the local versions of define-macro, macro-let and
     204macro-letrec.
    95205]|#
    96 (declare (unit procedural-macros))
    97 
    98 (module basic-macros
    99   (define-syntax-rule
    100    define-er-macro-transformer
    101    define-ir-macro-transformer
    102    define-er-macro
    103    define-ir-macro
    104    once-only
    105    with-mapped-symbols
    106    with-gensyms
    107    basic-macros
    108    )
    109   (import scheme
    110           ;(only bindings bind-case)
    111           (only (chicken condition) condition-case)
    112           (only (chicken base) case-lambda print error))
    113   (import-for-syntax (only bindings bind-case))
    114 
    115 #|[Let's start with a one syntax-rule]|#
    116 
    117 ;;; (define-syntax-rule (name . args) xpr . xprs)
    118 ;;; (define-syntax-rule (name . args) (keywords . keys) xpr . xprs)
    119 ;;; ---------------------------------------------------------------
    120 ;;; simplyfies define-syntax in case there is only one rule
    121 (define-syntax define-syntax-rule
    122   (syntax-rules (keywords)
    123     ((_ (name . args)
    124         (keywords key ...) xpr . xprs)
    125      (define-syntax name
    126        (syntax-rules (key ...)
    127          ((_ . args) xpr . xprs))))
    128     ((_ (name . args) xpr . xprs)
    129      (define-syntax name
    130        (syntax-rules ()
    131          ((_ . args) xpr . xprs))))))
    132 
    133 #|[
    134 Let's start with some helpers which might be occasionally useful
    135 ]|#
    136 
    137 ;;; (define-er-macro-transformer form rename compare?)
     206
     207;;; (macro-let (((signature body) ...) ...) xpr ....)
    138208;;; --------------------------------------------------
    139 ;;; wrapper around er-macro-transformer
    140 (define-syntax define-er-macro-transformer
    141   (syntax-rules ()
    142     ((_ (name form rename compare?) xpr . xprs)
    143      (define-syntax name
    144        (er-macro-transformer
    145          (lambda (form rename compare?) xpr . xprs))))))
    146 
    147 ;;; (define-ir-macro-transformer form inject compare?)
    148 ;;; --------------------------------------------------
    149 ;;; wrapper around ir-macro-transformer
    150 (define-syntax define-ir-macro-transformer
    151   (syntax-rules ()
    152     ((_ (name form inject compare?) xpr . xprs)
    153      (define-syntax name
    154        (ir-macro-transformer
    155          (lambda (form inject compare?) xpr . xprs))))))
     209;;; evaluates xpr ... in the context of parallel macros name ....
     210;(define-macro (macro-let signature-body-list xpr . xprs)
     211;  (with-explicit-renaming (compare? %let-syntax %macro-rules)
     212(define-macro (macro-let signature-body-list xpr . xprs)
     213  (with-explicit-renaming (compare? %let-syntax %macro-rules)
     214    (let ((signatures (map car signature-body-list))
     215          (bodies (map cdr signature-body-list)))
     216      `(,%let-syntax ,(map (lambda (sig body)
     217                                `(,(car sig)
     218                                  (,%macro-rules _ ()
     219                                    (,(cons '_ (cdr sig)) ,@body))))
     220                             signatures bodies)
     221         ,xpr ,@xprs))))
     222
     223;;; (macro-letrec (((signature body) ...) ...) xpr ....)
     224;;; ----------------------------------------------------
     225;;; evaluates xpr ... in the context of recursive macros name ....
     226(define-macro (macro-letrec signature-body-list xpr . xprs)
     227  (with-explicit-renaming (compare? %letrec-syntax %macro-rules)
     228    (let ((signatures (map car signature-body-list))
     229          (bodies (map cdr signature-body-list)))
     230      `(,%letrec-syntax ,(map (lambda (sig body)
     231                                `(,(car sig)
     232                                  (,%macro-rules _ ()
     233                                    (,(cons '_ (cdr sig)) ,@body))))
     234                             signatures bodies)
     235         ,xpr ,@xprs))))
    156236
    157237;;; (once-only (x ....) xpr ....)
     
    161241;;; The code is more or less due to
    162242;;; P. Seibel, Practical Common Lisp, p. 102
    163 ;(define-syntax once-only
    164 ;  (er-macro-transformer
    165 ;    (lambda (form rename compare?)
    166 (define-er-macro-transformer (once-only form rename compare?)
    167   (let ((names (cadr form))
    168         (body (cons (caddr form) (cdddr form)))
    169         (%let (rename 'let))
    170         (%list (rename 'list))
    171         )
    172     (let ((syms (map rename names)))
    173       `(,%let ,(map (lambda (g) `(,g ,(rename `',g))) syms)
    174          `(,',%let ,(,%list ,@(map (lambda (g n) ``(,,g ,,n))
    175                                syms names))
    176             ,(,%let ,(map (lambda (n g) `(,n ,g))
    177                         names syms)
    178                ,@body))))));))
    179 ;(define-ir-macro-transformer (once-only form inject compare?)
    180 ;  (let ((names (cadr form))
    181 ;        (body (cons (caddr form) (cdddr form))))
    182 ;    (let ((gensyms (map (lambda (x) (gensym)) names)))
    183 ;      `(let ,(map (lambda (g) `(,g (gensym))) gensyms)
    184 ;         `(let ,(list ,@(map (lambda (g n) ``(,,g ,,n))
    185 ;                             gensyms names))
    186 ;            ,(let ,(map (lambda (n g) `(,n ,g))
    187 ;                        names gensyms)
    188 ;               ,@body))))))
    189 ;
    190 
    191 ;;; (define-macro-with (name form prefix compare? transformer) xpr . xprs)
    192 ;;; ----------------------------------------------------------------------
    193 ;;; internal helper
    194 (define-syntax define-macro-with
     243(define-syntax once-only
    195244  (er-macro-transformer
    196245    (lambda (form rename compare?)
    197       (let (
    198         (header (cadr form))
    199         (body (cons (caddr form) (cdddr form)))
    200         (pseudo-flatten
    201           (lambda (tree)
    202             ; imported flatten doesn't work with pseudo-lists
    203             (let loop ((tree tree) (result '()))
    204               (cond
    205                 ((pair? tree)
    206                  (loop (car tree) (loop (cdr tree) result)))
    207                 ((null? tree) result)
    208                 (else
    209                   (cons tree result))))))
    210         (adjoin
    211           (lambda (obj lst)
    212             (if (member obj lst) lst (cons obj lst))))
    213         (sym-tail
    214           (lambda (pre sym)
    215             (let ((spre (symbol->string pre))
    216                   (ssym (symbol->string sym)))
    217               (let ((prelen (string-length spre))
    218                     (symlen (string-length ssym)))
    219                 (string->symbol (substring ssym prelen))))))
    220         (sym-prepends?
    221           (lambda (pre sym)
    222             (let ((spre (symbol->string pre))
    223                   (ssym (symbol->string sym)))
    224               (let ((prelen (string-length spre))
    225                     (symlen (string-length ssym)))
    226                 (and (< prelen symlen)
    227                      (equal? (string->list spre)
    228                              (string->list
    229                                (substring ssym 0 prelen))))))))
    230         )
    231         (let (
    232           (name (car header))
    233           (frm (cadr header))
    234           (pre (caddr header))
    235           (cmp? (cadddr header))
    236           (transformer (car (cddddr header)))
    237           (ren 'process)
    238           (%let (rename 'let))
    239           (%lambda (rename 'lambda))
    240           (%define-syntax (rename 'define-syntax))
    241           (flat-body (pseudo-flatten body))
    242           (remove-duplicates
    243             (lambda (lst)
    244               (let loop ((lst lst) (result '()))
    245                 (if (null? lst)
    246                   (reverse result)
    247                   (loop (cdr lst) (adjoin (car lst) result))))))
    248           )
    249           `(,%define-syntax ,name
    250              (,transformer
    251                (,%lambda (,frm ,ren ,cmp?)
    252                  (,%let ,(map (lambda (sym)
    253                                 `(,sym (,ren ',(sym-tail pre sym))))
    254                               (remove-duplicates
    255                                 (compress
    256                                   (map (lambda (sym)
    257                                          (and (symbol? sym)
    258                                               (sym-prepends? pre sym)))
    259                                        flat-body)
    260                                   flat-body)))
    261                                 ;(filter
    262                                 ;  (lambda (sym)
    263                                 ;          (and (symbol? sym)
    264                                 ;               (sym-prepends? pre sym)))
    265                                 ;        (pseudo-flatten body))))
    266                    ,@body)))))))))
    267 
    268 ;;; (define-er-macro (name form rename-prefix compare?) xpr . xprs)
    269 ;;; ---------------------------------------------------------------
    270 ;;; defines an explicit-renaming macro name with use-form form,
    271 ;;; automatically renaming symbols starting with inject-rpefix
    272 (define-syntax define-er-macro
    273   (syntax-rules ()
    274     ((_ (name form rename-prefix compare?) xpr . xprs)
    275      (define-macro-with
    276        (name form rename-prefix compare? er-macro-transformer)
    277        xpr . xprs))))
    278 
    279 ;;; (define-ir-macro (name form inject-prefix compare?) xpr . xprs)
    280 ;;; ---------------------------------------------------------------
    281 ;;; defines an implicit-renaming macro name with use-form form,
    282 ;;; automatically injecting symbols starting with inject-rpefix
    283 (define-syntax define-ir-macro
    284   (syntax-rules ()
    285     ((_ (name form inject-prefix compare?) xpr . xprs)
    286      (define-macro-with
    287        (name form inject-prefix compare? ir-macro-transformer)
    288        xpr . xprs))))
    289 
    290 ;;; (with-mapped-symbols mapper prefix- (prefix-x ....) xpr ....)
    291 ;;; -------------------------------------------------------------
    292 ;;; binds a series of prefixed names, prefix-x ....
    293 ;;; to the images of the original names, x ...., under mapper
    294 ;;; and evaluates xpr .... in this context
    295 (define-syntax with-mapped-symbols
     246      (let ((syms (cadr form))
     247            (xpr (caddr form))
     248            (xprs (cdddr form)))
     249        (let ((%syms (map rename syms))
     250              (%let (rename 'let))
     251              (%list (rename 'list)))
     252          `(,%let ,(map (lambda (g) `(,g ,(rename `',g))) %syms)
     253             `(,',%let ,(,%list ,@(map (lambda (g n) ``(,,g ,,n))
     254                                   %syms syms))
     255                ,(,%let ,(map (lambda (n g) `(,n ,g))
     256                            syms %syms)
     257                   ,xpr ,@xprs))))))))
     258
     259;;; (with-renamed-symbols (renamer . %syms) xpr . xprs)
     260;;; ---------------------------------------------------
     261(define-syntax with-renamed-symbols
    296262  (er-macro-transformer
    297263    (lambda (form rename compare?)
    298       (let ((mapper (cadr form))
    299             (prefix (caddr form))
    300             (syms (cadddr form))
    301             (xpr (car (cddddr form)))
    302             (xprs (cdr (cddddr form)))
    303             (%let (rename 'let))
    304             (sym-tail
    305               (lambda (pre sym)
    306                 (let ((spre (symbol->string pre))
    307                       (ssym (symbol->string sym)))
    308                   (let ((prelen (string-length spre))
    309                         (symlen (string-length ssym)))
    310                     (string->symbol (substring ssym prelen)))))))
    311         `(,%let ,(map (lambda (s)
    312                         `(,s (,mapper ',(sym-tail prefix s))))
    313                       syms)
    314            ,xpr ,@xprs)))))
     264      (let ((syms (cadr form))
     265            (xpr (caddr form))
     266            (xprs (cdddr form))
     267            )
     268        (let ((renamer (car syms))
     269              (%syms (cdr syms))
     270              (%let (rename 'let))
     271              )
     272          `(,%let ,(map (lambda (s)
     273                          ;`(,(symbol-append prefix s) (,renamer ',s)))
     274                          `(,s (,renamer
     275                            ',(string->symbol
     276                               (substring (symbol->string s) 1)))))
     277                        %syms)
     278             ,xpr ,@xprs))))))
    315279
    316280;;; (with-gensyms (name ....) xpr ....)
     
    323287         ,@(cddr form)))))
    324288
    325 
    326 ;;; (basic-macros sym ..)
    327 ;;; ---------------------
    328 ;;; documentation procedure.
    329 (define basic-macros
    330   (let ((alst '(
    331     (define-syntax-rule
    332       macro:
    333        (define-syntax-rule (name . args) xpr . xprs)
    334        (define-syntax-rule (name . args) (keywords . keys) xpr . xprs)
    335        "simplyfied version of syntax-rules,"
    336        "if there is only one rule")
    337 ;;;    (bind
    338 ;;;      macro:
    339 ;;;      (bind pat seq (where fender ...) .. xpr ....)
    340 ;;;      "a variant of Common Lisp's destructuring-bind"
    341 ;;;      "where pat and seq are a nested pseudo-lists and"
    342 ;;;      "optional fenders of the form (x x? ...) are checked"
    343 ;;;      "before evaluating the body xpr ...")
    344 ;;;    (bind-case
    345 ;;;      macro:
    346 ;;;      (bind-case seq (pat (where fender ...) .. xpr ...) ....)
    347 ;;;      "matches a nested pseudo-list seq against nested pseudo-lists"
    348 ;;;      "pat ... with optional fenders ... in sequence in a case regime")
    349     (once-only
    350       macro:
    351       (once-only (x ....) xpr ....)
    352       "arguments x ... are evaluated only once and"
    353       "from left to right in the body xpr ....")
    354     (define-er-macro-transformer
    355       macro:
    356       (define-er-macro-tansformer name form rename compare?)
    357       "wrapper around er-macro-transformer")
    358     (define-ir-macro-transformer
    359       macro:
    360       (define-ir-macro-tansformer name form inject compare?)
    361       "wrapper around ir-macro-transformer")
    362     (define-er-macro
    363       macro:
    364       (define-er-macro name form rename-prefix compare?)
    365       "creates an explicit-renaming macro, where all symbols"
    366       "starting with rename-prefix are renamed automatically")
    367     (define-ir-macro
    368       macro:
    369       (define-ir-macro name form inject-prefix compare?)
    370       "creates an implicit-renaming macro, where all symbols"
    371       "starting with inject-prefix are injected automatically")
    372     (with-mapped-symbols
    373       macro:
    374       (with-mapped-symbols mapper prefix- (prefix-x ....) xpr ....)
    375       "binds a series of prefixed names, prefix-x ...."
    376       "to the images of the original names, x ...., under mapper"
    377       "and evaluates xpr .... in this context")
    378     (with-gensyms
    379       macro:
    380       (with-gensyms (x ....) xpr ....)
    381       "generates a series of gensyms x .... to be used in body xpr ...")
    382     )))
    383     (case-lambda
    384       (()
    385        (map car alst))
    386       ((sym)
    387        (let ((lst (assq sym alst)))
    388          (if lst
    389            (for-each print (cdr lst))
    390            (error 'basic-macros
    391                   "not exported" sym)))))))
    392 
    393 ) ; module basic-macros
    394 
    395 #|[
    396 This module will provide some macro-writing macros, in particular
    397 macro-rules and define-macro, based on explicit- and implicit-renaming.
    398 The syntax of macro-rules mimics that of syntax-rules, except that it
    399 allows for injected symbols before the keyword list and the templates
    400 are usually quasiquoted lists. Since we use bind-case from the bindings
    401 egg, this library accepts wildcards, non-symbol literals and fenders.
    402 ]|#
    403 
    404 (module procedural-macros
    405   (procedural-macros
    406     define-macro
    407     (macro-rules bind-case)
    408     macro-let
    409     macro-letrec
    410     ;basic-macros
    411     once-only
    412     define-ir-macro-transformer
    413     define-er-macro-transformer
    414     define-ir-macro
    415     define-er-macro
    416     with-mapped-symbols
    417     with-gensyms)
    418  
    419   (import scheme
    420           basic-macros
    421           (only (chicken base) print error case-lambda)
    422           (only bindings bind-case))
    423   (import-for-syntax (only (chicken base) compress))
    424 
    425 #|[
    426 The workhorse of the library is the following macro, a procedural
    427 version of syntax-rules, but without its limitations.
    428 ]|#
    429 
    430 ;;; (macro-rules sym ... (key ...) (pat tpl) ...)
    431 ;;; (macro-rules sym ... (key ...) (pat (where fender ...) tpl) ...)
    432 ;;; ----------------------------------------------------------------
    433 ;;; where sym ... are injected non-hygienig symbols, key ... are
    434 ;;; additional keywords, pat ....  are nested lambda-lists without
    435 ;;; spezial meaning of ellipses and tpl .... usually evaluate to
    436 ;;; quasiquoted templates. The optional fenders belong to the pattern
    437 ;;; matching process.
    438 (define-er-macro-transformer (macro-rules f r c?)
    439   (let (
    440     (f* (let loop ((tail (cdr f)) (head '()))
    441           (if (symbol? (car tail))
    442             (loop (cdr tail) (cons (car tail) head))
    443             (cons head tail))))
    444     (%x (r 'x))
    445     (%let (r 'let))
    446     (%form (r 'form))
    447     (%where (r 'where))
    448     (%lambda (r 'lambda))
    449     (%inject (r 'inject))
    450     (%compare? (r 'compare?))
    451     (%bind-case (r 'bind-case))
    452     (%ir-macro-transformer (r 'ir-macro-transformer))
    453     )
    454     (let ((syms (car f*))
    455           (keys (cadr f*))
    456           (rules (cddr f*))
    457           (pseudo-flatten
    458             (lambda (tree)
    459               ; imported flatten doesn't work with pseudo-lists
    460               (let loop ((tree tree) (result '()))
    461                 (cond
    462                   ((pair? tree)
    463                    (loop (car tree) (loop (cdr tree) result)))
    464                   ((null? tree) result)
    465                   (else
    466                     (cons tree result))))))
    467           )
    468       (let* ((pats (map car rules))
    469              (fpats (map pseudo-flatten pats))
    470              (kpats (map (lambda (fp)
    471                            ;(filter (lambda (x)
    472                            ;          (memq x keys))
    473                            ;        fp))
    474                            (compress
    475                              (map (lambda (x) (memq x keys)) fp)
    476                              fp))
    477                          fpats))
    478              ;; compare? keywords with its names
    479              (key-checks
    480                (map (lambda (kp)
    481                       (map (lambda (p s)
    482                              `(,p (,%lambda (,%x)
    483                                             (,%compare? ,%x ,s))))
    484                            kp
    485                            (map (lambda (x) `',x)
    486                                 kp)))
    487                     kpats))
    488              ;; prepare where clause for each rule
    489              ;; to check keys
    490              (all-rules (map (lambda (rule checks)
    491                                (let ((second (cadr rule)))
    492                                  (if (and (pair? second)
    493                                           (c? (car second) %where))
    494                                    `(,(car rule)
    495                                       (,%where ,@(cdr second) ,@checks)
    496                                       ,@(cddr rule))
    497                                    `(,(car rule)
    498                                       (,%where ,@checks)
    499                                       ,@(cdr rule)))))
    500                              rules key-checks)))
    501         `(,%ir-macro-transformer
    502            (,%lambda (,%form ,%inject ,%compare?)
    503              (,%let ,(map (lambda (s)
    504                        `(,s (,%inject ',s)))
    505                      syms)
    506                (,%bind-case ,%form
    507                             ,@all-rules))))))))
    508 
    509 #|[
    510 And now a procedural version of our old friend, define-macro,
    511 which is hygienic, if now injections are provided.
    512 ]|#
    513 
    514 ;;; (define-macro (name . args)
    515 ;;;   (where (x . xs) ...)
    516 ;;;   xpr . xprs)
    517 ;;; ----------------------------------- 
    518 ;;; where xs is either a list of predicates, thus providing fenders,
    519 ;;; or a singleton containing one of the symbols keyword or injection
    520 ;;; to provide keyword arguments or nonhygienic macros
    521 (define-er-macro-transformer (define-macro form rename compare?)
    522   (let ((code (cadr form))
    523         (xpr (caddr form))
    524         (xprs (cdddr form))
    525         (%where (rename 'where))
    526         (%keyword (rename 'keyword))
    527         (%injection (rename 'injection))
    528         (%define-macro (rename 'define-macro))
    529         (%macro-rules (rename 'macro-rules))
    530         (%define-syntax (rename 'define-syntax)))
    531     (let ((name (car code)) (args (cdr code)))
    532       (if (and (pair? xpr)
    533                (compare? (car xpr) %where)
    534                (not (null? xprs)))
    535         (let ((clauses (cdr xpr)))
    536           (let (
    537             (fenders
    538               (compress
    539                 (map (lambda (clause)
    540                        (or (null? (cdr clause))
    541                            (and (not (compare? (cadr clause) %keyword))
    542                                 (not (compare? (cadr clause) %injection)))))
    543                   clauses)
    544                 clauses))
    545               ;(filter (lambda (clause)
    546               ;          (or (null? (cdr clause))
    547               ;              (and (not (compare? (cadr clause) %keyword))
    548               ;                   (not (compare? (cadr clause) %injection)))))
    549               ;       clauses))
    550             (keywords
    551               (compress
    552                 (map (lambda (clause)
    553                        (and (not (null? (cdr clause)))
    554                             (compare? (cadr clause) %keyword)))
    555                      clauses)
    556                 clauses))
    557               ;(filter (lambda (clause)
    558               ;          (and (not (null? (cdr clause)))
    559               ;               (compare? (cadr clause) %keyword)))
    560               ;        clauses))
    561             (injections
    562               (compress
    563                 (map (lambda (clause)
    564                        (and (not (null? (cdr clause)))
    565                             (compare? (cadr clause) %injection)))
    566                      clauses)
    567                 clauses))
    568               ;(filter
    569               ;  (lambda (clause)
    570               ;          (and (not (null? (cdr clause)))
    571               ;               (compare? (cadr clause) %injection)))
    572               ;        clauses))
    573             )
    574             (let (
    575               (keywords
    576                 (if (null? keywords)
    577                   keywords
    578                   (map car keywords)))
    579               (injections
    580                 (if (null? injections)
    581                   injections
    582                   (map car injections)))
    583               )
    584               `(,%define-syntax ,name
    585                  (,%macro-rules ,@injections ,keywords
    586                    ((_ ,@args) (where ,@fenders) ,@xprs))))))
    587         `(,%define-syntax ,name
    588            (,%macro-rules ()
    589              ((_ ,@args) ,xpr ,@xprs)))))))
    590 
    591 #|[
    592 Now follow the local versions of define-macro, macro-let and
    593 macro-letrec. Since the syntax of both is identical, they are
    594 implemented by means of a helper macro.
    595 ]|#
    596 
    597 ;; helper for macro-let and macro-letrec
    598 (define-er-macro-transformer (macro-with form rename compare?)
    599   (let ((op (cadr form))
    600         (pat-tpl-pairs (caddr form))
    601         (xpr (cadddr form))
    602         (xprs (cddddr form))
    603         (%macro-rules (rename 'macro-rules)))
    604     (let ((pats (map car pat-tpl-pairs))
    605           (tpls (map cdr pat-tpl-pairs)))
    606       `(,op ,(map (lambda (pat tpl)
    607                     `(,(car pat)
    608                        (,%macro-rules ()
    609                          ((_ ,@(cdr pat)) ,@tpl))))
    610                   pats tpls)
    611                    ,xpr ,@xprs))))
    612 
    613 ;;; (macro-let (((name . args) (where fender ...) .. xpr ...) ...) body ....)
    614 ;;; -------------------------------------------------------------------------
    615 ;;; evaluates body ... in the context of parallel macros name ....
    616 (define-er-macro-transformer (macro-let form rename compare?)
    617   (let ((pat-tpl-pairs (cadr form))
    618         (xpr (caddr form))
    619         (xprs (cdddr form));)
    620         (%macro-with (rename 'macro-with))
    621         (%let-syntax (rename 'let-syntax)))
    622     `(,%macro-with ,%let-syntax ,pat-tpl-pairs ,xpr ,@xprs)))
    623 
    624 ;;; (macro-letrec (((name . args) (where fender ...) .. xpr ...) ...) body ....)
    625 ;;; ----------------------------------------------------------------------------
    626 ;;; evaluates body ... in the context of recursive macros name ....
    627 (define-er-macro-transformer (macro-letrec form rename compare?)
    628   (let ((pat-tpl-pairs (cadr form))
    629         (xpr (caddr form))
    630         (xprs (cdddr form));)
    631         (%macro-with (rename 'macro-with))
    632         (%letrec-syntax (rename 'letrec-syntax)))
    633     `(,%macro-with ,%letrec-syntax ,pat-tpl-pairs ,xpr ,@xprs)))
    634 
    635289;;; (procedural-macros sym ..)
    636290;;; --------------------------
     
    640294    (macro-rules
    641295      macro:
    642       (macro-rules literal ... (keyword ...) (pat (where fender ...) .. tpl) ....)
     296      (macro-rules literal ... (keyword ...) (pat tpl) ....)
    643297      "procedural version of syntax-rules"
    644298      "with optional injected literals"
    645       "and quasiquoted templates")
     299      "and quasiquoted templates"
     300      "To be imported for syntax")
    646301    (define-macro
    647302      macro:
    648       (define-macro (name . args) (where (x . xs) ...) .. xpr ....)
    649       "a version of macro-rules with only one rule"
    650       "xs is either a list of predicates, thus providing fenders"
    651       "or a singleton containing one of the symbols keyword or"
    652       "injection, providing keyword parameters or nonhygienic macros")
     303      (define-macro (name . args) (with-renaming (compare? %x ...) xpr ....))
     304      (define-macro (name . args) xpr ....)
     305      "where with-renaming is one of with-explicit- or with-implicit-renaming"
     306      "and %x ... is the symbol x prefixed with one letter only."
     307      "Defines an explicit- or implicit-renaming macro name,"
     308      "automatically destructuring args with bind and creating local bindings"
     309      "for compare? and %x ... to x ... renamed or injected respectively,"
     310      "evaluating xpr ... in this context."
     311      "The latter version is used if no keys are needed and nothing is"
     312      "to be injected")
    653313    (macro-let
    654314      macro:
    655       (macro-let (((name . args) (where fender ...) .. xpr ...) ...) body ....)
     315      (macro-let (((name args) xpr ...) ...) body ....)
    656316      "evaluates body ... in the context of parallel macros name ....")
    657317    (macro-letrec
    658318      macro:
    659       (macro-letrec (((name . args) (where fender ...) .. xpr ...) ...) body ....)
     319      (macro-letrec (((name args) xpr ...) ...) body ....)
    660320      "evaluates body ... in the context of recursive macros name ....")
    661321    (once-only
     
    663323      (once-only (x ....) xpr ....)
    664324      "arguments x ... are evaluated only once and"
    665       "from left to right in the body xpr ....")
    666     (define-er-macro-transformer
    667       macro:
    668       (define-er-macro-tansformer name form rename compare?)
    669       "wrapper around er-macro-transformer")
    670     (define-ir-macro-transformer
    671       macro:
    672       (define-ir-macro-tansformer name form inject compare?)
    673       "wrapper around ir-macro-transformer")
    674     (define-er-macro
    675       macro:
    676       (define-er-macro name form rename-prefix compare?)
    677       "creates an explicit-renaming macro, where all symbols"
    678       "starting with rename-prefix are renamed automatically")
    679     (define-ir-macro
    680       macro:
    681       (define-ir-macro name form inject-prefix compare?)
    682       "creates an implicit-renaming macro, where all symbols"
    683       "starting with inject-prefix are injected automatically")
    684     (with-mapped-symbols
    685       macro:
    686       (with-mapped-symbols mapper prefix- (prefix-x ....) xpr ....)
    687       "binds a series of prefixed names, prefix-x ...."
    688       "to the images of the original names, x ...., under mapper"
    689       "and evaluates xpr .... in this context")
     325      "from left to right in the body xpr ...."
     326      "To be imported for syntax")
     327    (with-renamed-symbols
     328      macro:
     329      (with-renamed-symbols (renamer %x ....) xpr ....)
     330      "binds a series of names prefixed with one letter, e.g. %,
     331      %x .... to the images of the original names, x ....,"
     332      "under renamer and evaluates xpr .... in this context"
     333      "To be imported for syntax")
    690334    (with-gensyms
    691335      macro:
    692336      (with-gensyms (x ....) xpr ....)
    693       "generates a series of gensyms x .... to be used in body xpr ...")
     337      "binds x ... to (gensym 'x) ... in body xpr ...")
     338    (procedural-macros
     339      procedure:
     340      "documaentation procedure: returns the list of exported symbols"
     341      "if called with no arguments, or the documentation of its only"
     342      "symbol argument")
    694343    )))
    695344    (case-lambda
     
    702351           (error 'procedural-macros
    703352                  "not exported" sym)))))))
    704 ) ; procedural-macros
    705 
     353
     354) ; module procedural-macros
     355
  • release/5/procedural-macros/trunk/tests/run.scm

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