Changeset 34877 in project


Ignore:
Timestamp:
11/07/17 16:25:17 (2 years ago)
Author:
juergen
Message:

procedural-macros 2.1 replaces dependency on bindings with basic-macros

Location:
release/4/procedural-macros
Files:
8 edited
1 copied

Legend:

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

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

    r33546 r34877  
    11; Author: Juergen Lorenz ; ju (at) jugilo (dot) de
    22;
    3 ; Copyright (c) 2013-2016, Juergen Lorenz
     3; Copyright (c) 2013-2017, Juergen Lorenz
    44; All rights reserved.
    55;
     
    4040]|#
    4141
    42 (require-library bindings basic-sequences)
     42(require-library basic-macros)
    4343
    4444(module procedural-macros
    45   (define-macro macro-rules macro-let macro-letrec once-only
    46    define-ir-macro-transformer define-er-macro-transformer
    47    with-mapped-symbols with-gensyms procedural-macros)
     45  (define-macro macro-rules macro-let macro-letrec)
    4846 
    4947  (import scheme
    50           (only bindings bind-case)
     48          (only basic-macros bind-case define-er-macro-transformer)
    5149          (only chicken print error case-lambda))
    52 
    53 #|[
    54 Let's start with some helpers which might be occasionally useful
    55 ]|#
    56 
    57 ;;; (define-er-macro-transformer form rename compare?)
    58 ;;; --------------------------------------------------
    59 ;;; wrapper around er-macro-transformer
    60 (define-syntax define-er-macro-transformer
    61   (syntax-rules ()
    62     ((_ (name form rename compare?) xpr . xprs)
    63      (define-syntax name
    64        (er-macro-transformer
    65          (lambda (form rename compare?) xpr . xprs))))))
    66 
    67 ;;; (define-ir-macro-transformer form inject compare?)
    68 ;;; --------------------------------------------------
    69 ;;; wrapper around ir-macro-transformer
    70 (define-syntax define-ir-macro-transformer
    71   (syntax-rules ()
    72     ((_ (name form inject compare?) xpr . xprs)
    73      (define-syntax name
    74        (ir-macro-transformer
    75          (lambda (form inject compare?) xpr . xprs))))))
    76 
    77 ;;; (with-mapped-symbols mapper prefix- (prefix-x ....) xpr ....)
    78 ;;; -------------------------------------------------------------
    79 ;;; binds a series of prefixed names, prefix-x ....
    80 ;;; to the images of the original names, x ...., under mapper
    81 ;;; and evaluates xpr .... in this context
    82 (define-syntax with-mapped-symbols
    83   (er-macro-transformer
    84     (lambda (form rename compare?)
    85       (let ((mapper (cadr form))
    86             (prefix (caddr form))
    87             (syms (cadddr form))
    88             (xpr (car (cddddr form)))
    89             (xprs (cdr (cddddr form)))
    90             (%let (rename 'let)))
    91         (let ((strip-prefix
    92                 (lambda (sym)
    93                   (let ((len (string-length (symbol->string prefix))))
    94                     (string->symbol
    95                       (substring (symbol->string sym) len))))))
    96           `(,%let ,(map (lambda (s)
    97                           `(,s (,mapper ',(strip-prefix s))))
    98                         syms)
    99              ,xpr ,@xprs))))))
    100 
    101 ;;; (with-gensyms (name ....) xpr ....)
    102 ;;; -----------------------------------
    103 ;;; binds name ... to (gensym 'name) ... in body xpr ...
    104 (define-syntax with-gensyms
    105   (ir-macro-transformer
    106     (lambda (form inject compare?)
    107       `(let ,(map (lambda (n) `(,n (gensym ',n))) (cadr form))
    108          ,@(cddr form)))))
     50  (import-for-syntax (only basic-macro-helpers filter pseudo-flatten))
     51
     52  (reexport (only basic-macros
     53                  once-only
     54                  define-ir-macro-transformer
     55                  define-er-macro-transformer
     56                  define-ir-macro
     57                  define-er-macro
     58                  with-mapped-symbols
     59                  with-gensyms
     60                  ))
    10961
    11062#|[
     
    11365]|#
    11466
    115 ;;; (macro-rules sym ... (key ...) (pat (where fender ...) .. tpl) ....)
    116 ;;; --------------------------------------------------------------------
     67;;; (macro-rules sym ... (key ...) (pat tpl) ...)
     68;;; (macro-rules sym ... (key ...) (pat (where fender ...) tpl) ...)
     69;;; ----------------------------------------------------------------
    11770;;; where sym ... are injected non-hygienig symbols, key ... are
    11871;;; additional keywords, pat ....  are nested lambda-lists without
     
    12073;;; quasiquoted templates. The optional fenders belong to the pattern
    12174;;; matching process.
    122 (define-syntax macro-rules
    123   (er-macro-transformer
    124     (lambda (f r c?)
    125       (let (
    126         (f* (let loop ((tail (cdr f)) (head '()))
    127               (if (symbol? (car tail))
    128                 (loop (cdr tail) (cons (car tail) head))
    129                 (cons head tail))))
    130         (filter
    131           (lambda (ok? lst)
    132             (compress (map ok? lst) lst)))
    133         (flatten*
    134           ; imported flatten doesn't work with pseudo-lists
    135           (lambda (tree)
    136             (let loop ((tree tree) (result '()))
    137               (cond
    138                 ((pair? tree)
    139                  (loop (car tree) (loop (cdr tree) result)))
    140                 ((null? tree) result)
    141                 (else
    142                   (cons tree result))))))
    143         (%x (r 'x))
    144         (%let (r 'let))
    145         (%form (r 'form))
    146         (%where (r 'where))
    147         (%lambda (r 'lambda))
    148         (%inject (r 'inject))
    149         (%compare? (r 'compare?))
    150         (%bind-case (r 'bind-case))
    151         (%ir-macro-transformer (r 'ir-macro-transformer))
    152         )
    153         (let ((syms (car f*))
    154               (keys (cadr f*))
    155               (rules (cddr f*)))
    156           (let* ((pats (map car rules))
    157                  (fpats (map flatten* pats))
    158                  (kpats (map (lambda (fp)
    159                                (filter (lambda (x)
    160                                          (memq x keys))
    161                                        fp))
    162                              fpats))
    163                  ;; compare? keywords with its names
    164                  (key-checks
    165                    (map (lambda (kp)
    166                           (map (lambda (p s)
    167                                  `(,p (,%lambda (,%x)
    168                                                 (,%compare? ,%x ,s))))
    169                                kp
    170                                (map (lambda (x) `',x)
    171                                     kp)))
    172                         kpats))
    173                  ;; prepare where clause for each rule
    174                  ;; to check keys
    175                  (all-rules (map (lambda (rule checks)
    176                                    (let ((second (cadr rule)))
    177                                      (if (and (pair? second)
    178                                               (c? (car second) %where))
    179                                        `(,(car rule)
    180                                           (,%where ,@(cdr second) ,@checks)
    181                                           ,@(cddr rule))
    182                                        `(,(car rule)
    183                                           (,%where ,@checks)
    184                                           ,@(cdr rule)))))
    185                                  rules key-checks)))
    186             `(,%ir-macro-transformer
    187                (,%lambda (,%form ,%inject ,%compare?)
    188                  (,%let ,(map (lambda (s)
    189                            `(,s (,%inject ',s)))
    190                          syms)
    191                    (,%bind-case ,%form
    192                                 ,@all-rules))))))))))
     75(define-er-macro-transformer (macro-rules f r c?)
     76  (let (
     77    (f* (let loop ((tail (cdr f)) (head '()))
     78          (if (symbol? (car tail))
     79            (loop (cdr tail) (cons (car tail) head))
     80            (cons head tail))))
     81    (%x (r 'x))
     82    (%let (r 'let))
     83    (%form (r 'form))
     84    (%where (r 'where))
     85    (%lambda (r 'lambda))
     86    (%inject (r 'inject))
     87    (%compare? (r 'compare?))
     88    (%bind-case (r 'bind-case))
     89    (%ir-macro-transformer (r 'ir-macro-transformer))
     90    )
     91    (let ((syms (car f*))
     92          (keys (cadr f*))
     93          (rules (cddr f*)))
     94      (let* ((pats (map car rules))
     95             (fpats (map pseudo-flatten pats))
     96             (kpats (map (lambda (fp)
     97                           (filter (lambda (x)
     98                                     (memq x keys))
     99                                   fp))
     100                         fpats))
     101             ;; compare? keywords with its names
     102             (key-checks
     103               (map (lambda (kp)
     104                      (map (lambda (p s)
     105                             `(,p (,%lambda (,%x)
     106                                            (,%compare? ,%x ,s))))
     107                           kp
     108                           (map (lambda (x) `',x)
     109                                kp)))
     110                    kpats))
     111             ;; prepare where clause for each rule
     112             ;; to check keys
     113             (all-rules (map (lambda (rule checks)
     114                               (let ((second (cadr rule)))
     115                                 (if (and (pair? second)
     116                                          (c? (car second) %where))
     117                                   `(,(car rule)
     118                                      (,%where ,@(cdr second) ,@checks)
     119                                      ,@(cddr rule))
     120                                   `(,(car rule)
     121                                      (,%where ,@checks)
     122                                      ,@(cdr rule)))))
     123                             rules key-checks)))
     124        `(,%ir-macro-transformer
     125           (,%lambda (,%form ,%inject ,%compare?)
     126             (,%let ,(map (lambda (s)
     127                       `(,s (,%inject ',s)))
     128                     syms)
     129               (,%bind-case ,%form
     130                            ,@all-rules))))))))
    193131
    194132#|[
    195 And now a hygienic procedural version of our old friend, define-macro,
    196 accepting fenders in where clauses.
     133And now a procedural version of our old friend, define-macro,
     134which is hygienic, if now injections are provided.
    197135]|#
    198136
    199 ;;; (define-macro (name . args) (where fender ...) .. xpr ....)
    200 ;;; -----------------------------------------------------------
    201 ;;; simple hygienic macro without injections and keywords.
     137;;; (define-macro (name . args)
     138;;;   (where (x . xs) ...)
     139;;;   xpr . xprs)
     140;;; ----------------------------------- 
     141;;; where xs is either a list of predicates, thus providing fenders,
     142;;; or a singleton containing one of the symbols keyword or injection
     143;;; to provide keyword arguments or nonhygienic macros
    202144(define-er-macro-transformer (define-macro form rename compare?)
    203145  (let ((code (cadr form))
    204146        (xpr (caddr form))
    205         (xprs (cdddr form));)
     147        (xprs (cdddr form))
     148        (%where (rename 'where))
     149        (%keyword (rename 'keyword))
     150        (%injection (rename 'injection))
     151        (%define-macro (rename 'define-macros))
    206152        (%macro-rules (rename 'macro-rules))
    207153        (%define-syntax (rename 'define-syntax)))
    208     `(,%define-syntax ,(car code)
    209        (,%macro-rules ()
    210          ((_ ,@(cdr code)) ,xpr ,@xprs)))))
     154    (let ((name (car code)) (args (cdr code)))
     155      (if (and (pair? xpr)
     156               (compare? (car xpr) %where)
     157               (not (null? xprs)))
     158        (let ((clauses (cdr xpr)))
     159          (let (
     160            (fenders
     161              (filter (lambda (clause)
     162                        (or (null? (cdr clause))
     163                            (and (not (compare? (cadr clause) %keyword))
     164                                 (not (compare? (cadr clause) %injection)))))
     165                      clauses))
     166            (keywords
     167              (filter (lambda (clause)
     168                        (and (not (null? (cdr clause)))
     169                             (compare? (cadr clause) %keyword)))
     170                      clauses))
     171            (injections
     172              (filter (lambda (clause)
     173                        (and (not (null? (cdr clause)))
     174                             (compare? (cadr clause) %injection)))
     175                      clauses))
     176            )
     177            (let (
     178              (keywords
     179                (if (null? keywords)
     180                  keywords
     181                  (map car keywords)))
     182              (injections
     183                (if (null? injections)
     184                  injections
     185                  (map car injections)))
     186              )
     187              `(,%define-syntax ,name
     188                 (,%macro-rules ,@injections ,keywords
     189                   ((_ ,@args) (where ,@fenders) ,@xprs))))))
     190        `(,%define-syntax ,name
     191           (,%macro-rules ()
     192             ((_ ,@args) ,xpr ,@xprs)))))))
    211193
    212194#|[
     
    254236    `(,%macro-with ,%letrec-syntax ,pat-tpl-pairs ,xpr ,@xprs)))
    255237
    256 ;;; (once-only (x ....) xpr ....)
    257 ;;; -----------------------------
    258 ;;; macro-arguments x .... are only evaluated once and from left to
    259 ;;; right in the body xpr ....
    260 ;;; The code is more or less due to
    261 ;;; P. Seibel, Practical Common Lisp, p. 102
    262 (define-ir-macro-transformer (once-only form inject compare?)
    263   (let ((names (cadr form))
    264         (body (cddr form)))
    265     (let ((gensyms (map (lambda (x) (gensym)) names)))
    266       `(let ,(map (lambda (g) `(,g (gensym))) gensyms)
    267          `(let ,(list ,@(map (lambda (g n) ``(,,g ,,n))
    268                              gensyms names))
    269             ,(let ,(map (lambda (n g) `(,n ,g))
    270                         names gensyms)
    271                ,@body))))))
    272 
    273238;;; (procedural-macros sym ..)
    274 ;;; -----------------------
     239;;; --------------------------
    275240;;; documentation procedure.
    276241(define procedural-macros
     
    284249    (define-macro
    285250      macro:
    286       (define-macro (name . args) (where fender ...) .. xpr ....)
     251      (define-macro (name . args) (where (x . xs) ...) .. xpr ....)
    287252      "a version of macro-rules with only one rule"
    288       "no injected symbols and no keywords")
     253      "xs is either a list of predicates, thus providing fenders"
     254      "or a singleton containing one of the symbols keyword or"
     255      "injection, providing keyword parameters or nonhygienic macros")
    289256    (macro-let
    290257      macro:
     
    306273    (define-ir-macro-transformer
    307274      macro:
    308       (define-ir-macro-tansformer name form rename compare?)
     275      (define-ir-macro-tansformer name form inject compare?)
    309276      "wrapper around ir-macro-transformer")
     277    (define-er-macro
     278      macro:
     279      (define-er-macro name form rename-prefix compare?)
     280      "creates an explicit-renaming macro, where all symbols"
     281      "starting with rename-prefix are renamed automatically")
     282    (define-ir-macro
     283      macro:
     284      (define-ir-macro name form inject-prefix compare?)
     285      "creates an implicit-renaming macro, where all symbols"
     286      "starting with inject-prefix are injected automatically")
    310287    (with-mapped-symbols
    311288      macro:
  • release/4/procedural-macros/tags/2.1/procedural-macros.setup

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

    r33546 r34877  
    5555    (= (bar #() 5) 5)
    5656
    57     (define-macro (baz '() x)
    58       (where (x integer?))
    59       x)
    60     (= (baz '() 5) 5)
    61 
    6257    (define-macro (qux  #f)
    6358      #t)
     
    7671    (define-syntax vif
    7772      (macro-rules (then else)
    78         ((_ test (then xpr . xprs))
     73        ((_ test (then . xprs))
    7974         `(if ,test
    80             (begin ,xpr ,@xprs)))
    81         ((_ test (else xpr . xprs))
     75            (begin ,@xprs)))
     76        ((_ test (else . xprs))
    8277         `(if ,(not test)
    83             (begin ,xpr ,@xprs)))
    84         ((_ test (then xpr . xprs) (else ypr . yprs))
     78            (begin ,@xprs)))
     79        ((_ test (then . xprs) (else . yprs))
    8580         `(if ,test
    86             (begin ,xpr ,@xprs)
    87             (begin ,ypr ,@yprs)))))
     81            (begin ,@xprs)
     82            (begin ,@yprs)))))
    8883    (define (oux)
    8984      (vif #t (then 'true)))
  • release/4/procedural-macros/trunk/procedural-macros.meta

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

    r33546 r34877  
    11; Author: Juergen Lorenz ; ju (at) jugilo (dot) de
    22;
    3 ; Copyright (c) 2013-2016, Juergen Lorenz
     3; Copyright (c) 2013-2017, Juergen Lorenz
    44; All rights reserved.
    55;
     
    4040]|#
    4141
    42 (require-library bindings basic-sequences)
     42(require-library basic-macros)
    4343
    4444(module procedural-macros
    45   (define-macro macro-rules macro-let macro-letrec once-only
    46    define-ir-macro-transformer define-er-macro-transformer
    47    with-mapped-symbols with-gensyms procedural-macros)
     45  (define-macro macro-rules macro-let macro-letrec)
    4846 
    4947  (import scheme
    50           (only bindings bind-case)
     48          (only basic-macros bind-case define-er-macro-transformer)
    5149          (only chicken print error case-lambda))
    52 
    53 #|[
    54 Let's start with some helpers which might be occasionally useful
    55 ]|#
    56 
    57 ;;; (define-er-macro-transformer form rename compare?)
    58 ;;; --------------------------------------------------
    59 ;;; wrapper around er-macro-transformer
    60 (define-syntax define-er-macro-transformer
    61   (syntax-rules ()
    62     ((_ (name form rename compare?) xpr . xprs)
    63      (define-syntax name
    64        (er-macro-transformer
    65          (lambda (form rename compare?) xpr . xprs))))))
    66 
    67 ;;; (define-ir-macro-transformer form inject compare?)
    68 ;;; --------------------------------------------------
    69 ;;; wrapper around ir-macro-transformer
    70 (define-syntax define-ir-macro-transformer
    71   (syntax-rules ()
    72     ((_ (name form inject compare?) xpr . xprs)
    73      (define-syntax name
    74        (ir-macro-transformer
    75          (lambda (form inject compare?) xpr . xprs))))))
    76 
    77 ;;; (with-mapped-symbols mapper prefix- (prefix-x ....) xpr ....)
    78 ;;; -------------------------------------------------------------
    79 ;;; binds a series of prefixed names, prefix-x ....
    80 ;;; to the images of the original names, x ...., under mapper
    81 ;;; and evaluates xpr .... in this context
    82 (define-syntax with-mapped-symbols
    83   (er-macro-transformer
    84     (lambda (form rename compare?)
    85       (let ((mapper (cadr form))
    86             (prefix (caddr form))
    87             (syms (cadddr form))
    88             (xpr (car (cddddr form)))
    89             (xprs (cdr (cddddr form)))
    90             (%let (rename 'let)))
    91         (let ((strip-prefix
    92                 (lambda (sym)
    93                   (let ((len (string-length (symbol->string prefix))))
    94                     (string->symbol
    95                       (substring (symbol->string sym) len))))))
    96           `(,%let ,(map (lambda (s)
    97                           `(,s (,mapper ',(strip-prefix s))))
    98                         syms)
    99              ,xpr ,@xprs))))))
    100 
    101 ;;; (with-gensyms (name ....) xpr ....)
    102 ;;; -----------------------------------
    103 ;;; binds name ... to (gensym 'name) ... in body xpr ...
    104 (define-syntax with-gensyms
    105   (ir-macro-transformer
    106     (lambda (form inject compare?)
    107       `(let ,(map (lambda (n) `(,n (gensym ',n))) (cadr form))
    108          ,@(cddr form)))))
     50  (import-for-syntax (only basic-macro-helpers filter pseudo-flatten))
     51
     52  (reexport (only basic-macros
     53                  once-only
     54                  define-ir-macro-transformer
     55                  define-er-macro-transformer
     56                  define-ir-macro
     57                  define-er-macro
     58                  with-mapped-symbols
     59                  with-gensyms
     60                  ))
    10961
    11062#|[
     
    11365]|#
    11466
    115 ;;; (macro-rules sym ... (key ...) (pat (where fender ...) .. tpl) ....)
    116 ;;; --------------------------------------------------------------------
     67;;; (macro-rules sym ... (key ...) (pat tpl) ...)
     68;;; (macro-rules sym ... (key ...) (pat (where fender ...) tpl) ...)
     69;;; ----------------------------------------------------------------
    11770;;; where sym ... are injected non-hygienig symbols, key ... are
    11871;;; additional keywords, pat ....  are nested lambda-lists without
     
    12073;;; quasiquoted templates. The optional fenders belong to the pattern
    12174;;; matching process.
    122 (define-syntax macro-rules
    123   (er-macro-transformer
    124     (lambda (f r c?)
    125       (let (
    126         (f* (let loop ((tail (cdr f)) (head '()))
    127               (if (symbol? (car tail))
    128                 (loop (cdr tail) (cons (car tail) head))
    129                 (cons head tail))))
    130         (filter
    131           (lambda (ok? lst)
    132             (compress (map ok? lst) lst)))
    133         (flatten*
    134           ; imported flatten doesn't work with pseudo-lists
    135           (lambda (tree)
    136             (let loop ((tree tree) (result '()))
    137               (cond
    138                 ((pair? tree)
    139                  (loop (car tree) (loop (cdr tree) result)))
    140                 ((null? tree) result)
    141                 (else
    142                   (cons tree result))))))
    143         (%x (r 'x))
    144         (%let (r 'let))
    145         (%form (r 'form))
    146         (%where (r 'where))
    147         (%lambda (r 'lambda))
    148         (%inject (r 'inject))
    149         (%compare? (r 'compare?))
    150         (%bind-case (r 'bind-case))
    151         (%ir-macro-transformer (r 'ir-macro-transformer))
    152         )
    153         (let ((syms (car f*))
    154               (keys (cadr f*))
    155               (rules (cddr f*)))
    156           (let* ((pats (map car rules))
    157                  (fpats (map flatten* pats))
    158                  (kpats (map (lambda (fp)
    159                                (filter (lambda (x)
    160                                          (memq x keys))
    161                                        fp))
    162                              fpats))
    163                  ;; compare? keywords with its names
    164                  (key-checks
    165                    (map (lambda (kp)
    166                           (map (lambda (p s)
    167                                  `(,p (,%lambda (,%x)
    168                                                 (,%compare? ,%x ,s))))
    169                                kp
    170                                (map (lambda (x) `',x)
    171                                     kp)))
    172                         kpats))
    173                  ;; prepare where clause for each rule
    174                  ;; to check keys
    175                  (all-rules (map (lambda (rule checks)
    176                                    (let ((second (cadr rule)))
    177                                      (if (and (pair? second)
    178                                               (c? (car second) %where))
    179                                        `(,(car rule)
    180                                           (,%where ,@(cdr second) ,@checks)
    181                                           ,@(cddr rule))
    182                                        `(,(car rule)
    183                                           (,%where ,@checks)
    184                                           ,@(cdr rule)))))
    185                                  rules key-checks)))
    186             `(,%ir-macro-transformer
    187                (,%lambda (,%form ,%inject ,%compare?)
    188                  (,%let ,(map (lambda (s)
    189                            `(,s (,%inject ',s)))
    190                          syms)
    191                    (,%bind-case ,%form
    192                                 ,@all-rules))))))))))
     75(define-er-macro-transformer (macro-rules f r c?)
     76  (let (
     77    (f* (let loop ((tail (cdr f)) (head '()))
     78          (if (symbol? (car tail))
     79            (loop (cdr tail) (cons (car tail) head))
     80            (cons head tail))))
     81    (%x (r 'x))
     82    (%let (r 'let))
     83    (%form (r 'form))
     84    (%where (r 'where))
     85    (%lambda (r 'lambda))
     86    (%inject (r 'inject))
     87    (%compare? (r 'compare?))
     88    (%bind-case (r 'bind-case))
     89    (%ir-macro-transformer (r 'ir-macro-transformer))
     90    )
     91    (let ((syms (car f*))
     92          (keys (cadr f*))
     93          (rules (cddr f*)))
     94      (let* ((pats (map car rules))
     95             (fpats (map pseudo-flatten pats))
     96             (kpats (map (lambda (fp)
     97                           (filter (lambda (x)
     98                                     (memq x keys))
     99                                   fp))
     100                         fpats))
     101             ;; compare? keywords with its names
     102             (key-checks
     103               (map (lambda (kp)
     104                      (map (lambda (p s)
     105                             `(,p (,%lambda (,%x)
     106                                            (,%compare? ,%x ,s))))
     107                           kp
     108                           (map (lambda (x) `',x)
     109                                kp)))
     110                    kpats))
     111             ;; prepare where clause for each rule
     112             ;; to check keys
     113             (all-rules (map (lambda (rule checks)
     114                               (let ((second (cadr rule)))
     115                                 (if (and (pair? second)
     116                                          (c? (car second) %where))
     117                                   `(,(car rule)
     118                                      (,%where ,@(cdr second) ,@checks)
     119                                      ,@(cddr rule))
     120                                   `(,(car rule)
     121                                      (,%where ,@checks)
     122                                      ,@(cdr rule)))))
     123                             rules key-checks)))
     124        `(,%ir-macro-transformer
     125           (,%lambda (,%form ,%inject ,%compare?)
     126             (,%let ,(map (lambda (s)
     127                       `(,s (,%inject ',s)))
     128                     syms)
     129               (,%bind-case ,%form
     130                            ,@all-rules))))))))
    193131
    194132#|[
    195 And now a hygienic procedural version of our old friend, define-macro,
    196 accepting fenders in where clauses.
     133And now a procedural version of our old friend, define-macro,
     134which is hygienic, if now injections are provided.
    197135]|#
    198136
    199 ;;; (define-macro (name . args) (where fender ...) .. xpr ....)
    200 ;;; -----------------------------------------------------------
    201 ;;; simple hygienic macro without injections and keywords.
     137;;; (define-macro (name . args)
     138;;;   (where (x . xs) ...)
     139;;;   xpr . xprs)
     140;;; ----------------------------------- 
     141;;; where xs is either a list of predicates, thus providing fenders,
     142;;; or a singleton containing one of the symbols keyword or injection
     143;;; to provide keyword arguments or nonhygienic macros
    202144(define-er-macro-transformer (define-macro form rename compare?)
    203145  (let ((code (cadr form))
    204146        (xpr (caddr form))
    205         (xprs (cdddr form));)
     147        (xprs (cdddr form))
     148        (%where (rename 'where))
     149        (%keyword (rename 'keyword))
     150        (%injection (rename 'injection))
     151        (%define-macro (rename 'define-macros))
    206152        (%macro-rules (rename 'macro-rules))
    207153        (%define-syntax (rename 'define-syntax)))
    208     `(,%define-syntax ,(car code)
    209        (,%macro-rules ()
    210          ((_ ,@(cdr code)) ,xpr ,@xprs)))))
     154    (let ((name (car code)) (args (cdr code)))
     155      (if (and (pair? xpr)
     156               (compare? (car xpr) %where)
     157               (not (null? xprs)))
     158        (let ((clauses (cdr xpr)))
     159          (let (
     160            (fenders
     161              (filter (lambda (clause)
     162                        (or (null? (cdr clause))
     163                            (and (not (compare? (cadr clause) %keyword))
     164                                 (not (compare? (cadr clause) %injection)))))
     165                      clauses))
     166            (keywords
     167              (filter (lambda (clause)
     168                        (and (not (null? (cdr clause)))
     169                             (compare? (cadr clause) %keyword)))
     170                      clauses))
     171            (injections
     172              (filter (lambda (clause)
     173                        (and (not (null? (cdr clause)))
     174                             (compare? (cadr clause) %injection)))
     175                      clauses))
     176            )
     177            (let (
     178              (keywords
     179                (if (null? keywords)
     180                  keywords
     181                  (map car keywords)))
     182              (injections
     183                (if (null? injections)
     184                  injections
     185                  (map car injections)))
     186              )
     187              `(,%define-syntax ,name
     188                 (,%macro-rules ,@injections ,keywords
     189                   ((_ ,@args) (where ,@fenders) ,@xprs))))))
     190        `(,%define-syntax ,name
     191           (,%macro-rules ()
     192             ((_ ,@args) ,xpr ,@xprs)))))))
    211193
    212194#|[
     
    254236    `(,%macro-with ,%letrec-syntax ,pat-tpl-pairs ,xpr ,@xprs)))
    255237
    256 ;;; (once-only (x ....) xpr ....)
    257 ;;; -----------------------------
    258 ;;; macro-arguments x .... are only evaluated once and from left to
    259 ;;; right in the body xpr ....
    260 ;;; The code is more or less due to
    261 ;;; P. Seibel, Practical Common Lisp, p. 102
    262 (define-ir-macro-transformer (once-only form inject compare?)
    263   (let ((names (cadr form))
    264         (body (cddr form)))
    265     (let ((gensyms (map (lambda (x) (gensym)) names)))
    266       `(let ,(map (lambda (g) `(,g (gensym))) gensyms)
    267          `(let ,(list ,@(map (lambda (g n) ``(,,g ,,n))
    268                              gensyms names))
    269             ,(let ,(map (lambda (n g) `(,n ,g))
    270                         names gensyms)
    271                ,@body))))))
    272 
    273238;;; (procedural-macros sym ..)
    274 ;;; -----------------------
     239;;; --------------------------
    275240;;; documentation procedure.
    276241(define procedural-macros
     
    284249    (define-macro
    285250      macro:
    286       (define-macro (name . args) (where fender ...) .. xpr ....)
     251      (define-macro (name . args) (where (x . xs) ...) .. xpr ....)
    287252      "a version of macro-rules with only one rule"
    288       "no injected symbols and no keywords")
     253      "xs is either a list of predicates, thus providing fenders"
     254      "or a singleton containing one of the symbols keyword or"
     255      "injection, providing keyword parameters or nonhygienic macros")
    289256    (macro-let
    290257      macro:
     
    306273    (define-ir-macro-transformer
    307274      macro:
    308       (define-ir-macro-tansformer name form rename compare?)
     275      (define-ir-macro-tansformer name form inject compare?)
    309276      "wrapper around ir-macro-transformer")
     277    (define-er-macro
     278      macro:
     279      (define-er-macro name form rename-prefix compare?)
     280      "creates an explicit-renaming macro, where all symbols"
     281      "starting with rename-prefix are renamed automatically")
     282    (define-ir-macro
     283      macro:
     284      (define-ir-macro name form inject-prefix compare?)
     285      "creates an implicit-renaming macro, where all symbols"
     286      "starting with inject-prefix are injected automatically")
    310287    (with-mapped-symbols
    311288      macro:
  • release/4/procedural-macros/trunk/procedural-macros.setup

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

    r33546 r34877  
    5555    (= (bar #() 5) 5)
    5656
    57     (define-macro (baz '() x)
    58       (where (x integer?))
    59       x)
    60     (= (baz '() 5) 5)
    61 
    6257    (define-macro (qux  #f)
    6358      #t)
     
    7671    (define-syntax vif
    7772      (macro-rules (then else)
    78         ((_ test (then xpr . xprs))
     73        ((_ test (then . xprs))
    7974         `(if ,test
    80             (begin ,xpr ,@xprs)))
    81         ((_ test (else xpr . xprs))
     75            (begin ,@xprs)))
     76        ((_ test (else . xprs))
    8277         `(if ,(not test)
    83             (begin ,xpr ,@xprs)))
    84         ((_ test (then xpr . xprs) (else ypr . yprs))
     78            (begin ,@xprs)))
     79        ((_ test (then . xprs) (else . yprs))
    8580         `(if ,test
    86             (begin ,xpr ,@xprs)
    87             (begin ,ypr ,@yprs)))))
     81            (begin ,@xprs)
     82            (begin ,@yprs)))))
    8883    (define (oux)
    8984      (vif #t (then 'true)))
Note: See TracChangeset for help on using the changeset viewer.