Changeset 34857 in project


Ignore:
Timestamp:
11/04/17 16:58:55 (4 years ago)
Author:
juergen
Message:

basic-macros 1.1 with additional macros from procedural-macros egg

Location:
release/4/basic-macros
Files:
6 edited
1 copied

Legend:

Unmodified
Added
Removed
  • release/4/basic-macros/tags/1.1/basic-macros.scm

    r34842 r34857  
    4141be captured. Destructuring can be automated with the bind macro -- a
    4242simplified version of the equally named macro in the bindings library --
    43 and renaming resp. injecting can be almost automated with the help of an
    44 auxiliary parameter, a prefix symbol, to the transformer routine.
     43and renaming resp. injecting can be almost automated with the help of
     44either the macro with-mapped-symbols or two macro-generators, which
     45replace the rename resp. inject parameter of the transformer with a
     46prefix symbol. Note, that bind or with-mapped-symbols must be used
     47for-syntax, if used in a macro body for destructuring or
     48renaming/injecting.
    4549
    4650Usually an ambituous explicit renaming macro contains a long let
    4751defining the renamed symbols -- usually prefixed with some fixed symbol
    4852constant like % -- which is then executed in the macro's body by
    49 unquoting it. Our two macros create the let automatically. The only
    50 thing you have to do is providing a prefix and using it to prefix all
    51 symbols you want renamed.
    52 
    53 Here is a simple example, the numeric if.
     53unquoting it. Both methods create the let automatically.
     54
     55Here are two simple examples, one the swap! macro, using
     56define-er-macro-transformer and with-mapped-symbols, the other numeric if,
     57using define-er-macro and and explicit prefix, %.
     58In the latter case, the macro searches its body for symbols starting
     59with this prefix, collects them in a list, removes duplicates and adds
     60the necesary let with pairs of the form
     61
     62  (%name (rename 'name)
     63
     64to the front of the body. In other words it does what you usually do by
     65hand.
     66
     67  (define-er-macro-transformer (swap! form rename compare?)
     68    (let ((x (cadr form)) (y (caddr form)))
     69      (with-mapped-symbols rename % (%tmp %let %set!)
     70        `(,%let ((,%tmp ,x))
     71           (,%set! ,x ,y)
     72           (,%set! ,y ,%tmp)))))
    5473
    5574  (define-er-macro (nif form % compare?)
     
    6685untouched.
    6786
    68 The macro searches its body for symbols starting with this prefix,
    69 collects them in a list, removes duplicates and adds the necesary let
    70 with pairs of the form
    71 
    72   (%name (rename 'name)
    73 
    74 to the front of the body. In other words it does what you usually do by
    75 hand.
    7687
    7788For implicit renaming macros the list of injected symbols is usually,
     
    271282
    272283(module basic-macros ;*
    273   (define-er-macro define-ir-macro bind bind-case once-only basic-macros)
     284  (define-syntax-rule define-er-macro-transformer define-ir-macro-transformer
     285   define-er-macro define-ir-macro bind bind-case once-only basic-macros
     286   with-mapped-symbols with-gensyms)
    274287  (import scheme basic-macro-helpers
    275288          (only chicken condition-case case-lambda print error))
     
    281294                              pseudo-list?))
    282295
     296#|[Let's start with a one syntax-rule]|#
     297
     298;;; (define-syntax-rule (name . args) xpr . xprs)
     299;;; (define-syntax-rule (name . args) (keywords . keys) xpr . xprs)
     300;;; ---------------------------------------------------------------
     301;;; simplyfies define-syntax in case there is only one rule
     302(define-syntax define-syntax-rule
     303  (syntax-rules (keywords)
     304    ((_ (name . args)
     305        (keywords key ...) xpr . xprs)
     306     (define-syntax name
     307       (syntax-rules (key ...)
     308         ((_ . args) xpr . xprs))))
     309    ((_ (name . args) xpr . xprs)
     310     (define-syntax name
     311       (syntax-rules ()
     312         ((_ . args) xpr . xprs))))))
     313
     314#|[
     315Let's start with some helpers which might be occasionally useful
     316]|#
     317
     318;;; (define-er-macro-transformer form rename compare?)
     319;;; --------------------------------------------------
     320;;; wrapper around er-macro-transformer
     321(define-syntax define-er-macro-transformer
     322  (syntax-rules ()
     323    ((_ (name form rename compare?) xpr . xprs)
     324     (define-syntax name
     325       (er-macro-transformer
     326         (lambda (form rename compare?) xpr . xprs))))))
     327
     328;;; (define-ir-macro-transformer form inject compare?)
     329;;; --------------------------------------------------
     330;;; wrapper around ir-macro-transformer
     331(define-syntax define-ir-macro-transformer
     332  (syntax-rules ()
     333    ((_ (name form inject compare?) xpr . xprs)
     334     (define-syntax name
     335       (ir-macro-transformer
     336         (lambda (form inject compare?) xpr . xprs))))))
     337
    283338#|[
    284339The following is Graham's dbind extended with  wildcards,
     
    295350;;; binds pattern variables of pat to corresponding subexpressions of
    296351;;; seq and executes body xpr . xprs in this context.
    297 (define-syntax do-bind
    298   (er-macro-transformer
    299     (lambda (form rename compare?)
     352(define-er-macro-transformer (do-bind form rename compare?)
     353;(define-syntax do-bind
     354;  (er-macro-transformer
     355;    (lambda (form rename compare?)
    300356  (let ((pat (cadr form))
    301357        (seq (caddr form))
     
    307363        (%and (rename 'and))
    308364        (%let (rename 'let))
     365        (%not (rename 'not))
     366        (%pair? (rename 'pair?))
    309367        (%begin (rename 'begin))
    310368        (%error (rename 'error))
    311369        (%equal? (rename 'equal?))
    312370        (%pseudo-ref (rename 'pseudo-ref))
    313         (%pseudo-tail (rename 'pseudo-tail))
    314         (%pseudo-null? (rename 'pseudo-null?)))
     371        (%pseudo-tail (rename 'pseudo-tail)))
    315372    (let ((body `(,%begin ,xpr ,@xprs)))
    316373      (letrec (
     
    348405                      ((null? sentinel)
    349406                       (values pairs literals
    350                                (cons `(,%pseudo-null?
    351                                         (,%pseudo-tail ,seq ,k))
     407                               (cons ;`(,%pseudo-null?
     408                                     ;   (,%pseudo-tail ,seq ,k))
     409                                     `(,%not
     410                                        (,%pair?
     411                                          (,%pseudo-tail ,seq ,k)))
    352412                                     tails)))
    353413                      ((symbol? sentinel)
     
    365425                                tails))))
    366426                  (let ((item (pseudo-ref pat k)))
    367                           ;(let loop ((pat pat) (k k))
    368                           ;  (cond
    369                           ;    ((not (pair? pat)) pat)
    370                           ;    ((= k 0) (car pat))
    371                           ;    (else (loop (cdr pat) (- k 1)))))))
    372427                    (cond
    373                       ;((symbol? item)
    374428                      ((and (symbol? item) (not (keyword? item)))
    375429                       (if (compare? item %_)
     
    409463                        "duplicate pattern variables"
    410464                        ',(map car pairs)))))
    411           ))))))
     465          ))));))
    412466
    413467;;;; (bind pat seq xpr . xprs)
     
    427481     (let ((%seq seq))
    428482       (do-bind pat %seq xpr . xprs)))))
    429 
    430 ;;;; (bind-case seq (pat xpr . xprs) ....)
    431 ;;;; -------------------------------------
    432 ;;;; Checks if seq matches patterns pat ...
    433 ;;;; in sequence, binds the pattern variables of the first matching
    434 ;;;; pattern to corresponding subexpressions of seq and executes
    435 ;;;; corresponding body xpr . xprs
    436 ;(define-syntax bind-case
    437 ;  (syntax-rules ()
    438 ;    ((_ seq)
    439 ;     (error 'bind-case `("no match for" ,seq)))
    440 ;    ((_ seq (pat xpr . xprs))
    441 ;     (bind pat seq xpr . xprs))
    442 ;    ((_ seq clause . clauses)
    443 ;     (condition-case (bind-case seq clause)
    444 ;       ((exn) (bind-case seq . clauses))))
    445 ;    ))
    446483
    447484;;; (bind-case seq (pat xpr . xprs) ...)
     
    472509;;; The code is more or less due to
    473510;;; P. Seibel, Practical Common Lisp, p. 102
    474 (define-syntax once-only
    475   (er-macro-transformer
    476     (lambda (form rename compare?)
     511;(define-syntax once-only
     512;  (er-macro-transformer
     513;    (lambda (form rename compare?)
     514(define-er-macro-transformer (once-only form rename compare?)
    477515  (let ((names (cadr form))
    478516        (body (cons (caddr form) (cdddr form)))
    479517        (%let (rename 'let))
    480518        (%list (rename 'list))
    481         ;(%gensym (rename 'gensym))
    482519        )
    483520    (let ((syms (map rename names)))
    484       ;`(,%let ,(map (lambda (g) `(,g ',g)) syms)
    485521      `(,%let ,(map (lambda (g) `(,g ,(rename `',g))) syms)
    486       ;`(,%let ,(map (lambda (g) `(,g (,rename ',g))) syms)
    487       ;`(,%let ,(map (lambda (g) `(,g (,%gensym))) syms)
    488522         `(,',%let ,(,%list ,@(map (lambda (g n) ``(,,g ,,n))
    489523                               syms names))
    490524            ,(,%let ,(map (lambda (n g) `(,n ,g))
    491525                        names syms)
    492                ,@body))))))))
    493 ;(define-syntax once-only
    494 ;  (ir-macro-transformer
    495 ;    (lambda (form inject compare?)
     526               ,@body))))));))
     527;(define-ir-macro-transformer (once-only form inject compare?)
    496528;  (let ((names (cadr form))
    497529;        (body (cons (caddr form) (cdddr form))))
     
    502534;            ,(let ,(map (lambda (n g) `(,n ,g))
    503535;                        names gensyms)
    504 ;               ,@body))))))))
     536;               ,@body))))))
    505537;
    506 ;;; (define-er-macro (name form rename-prefix compare?) xpr . xprs)
    507 ;;; ---------------------------------------------------------------
    508 ;;; defines an explicit-renaming macro name with use-form form,
    509 ;;; automatically renaming symbols starting with inject-rpefix
    510 (define-syntax define-er-macro
     538
     539;;; (define-macro-with (name form prefix compare? transformer) xpr . xprs)
     540;;; ----------------------------------------------------------------------
     541;;; internal helper
     542(define-syntax define-macro-with
    511543  (er-macro-transformer
    512544    (lambda (form rename compare?)
    513       (let ((header (cadr form))
    514             (body (cons (caddr form) (cdddr form))))
    515         (let ((name (car header))
    516               (frm (cadr header))
    517               (pre (caddr header))
    518               (cmp? (cadddr header))
    519               (ren 'rename)
    520               (%let (rename 'let))
    521               (%lambda (rename 'lambda))
    522               (%define-syntax (rename 'define-syntax))
    523               (%er-macro-transformer (rename 'er-macro-transformer)))
     545      (let (
     546        (header (cadr form))
     547        (body (cons (caddr form) (cdddr form)))
     548        )
     549        (let (
     550          (name (car header))
     551          (frm (cadr header))
     552          (pre (caddr header))
     553          (cmp? (cadddr header))
     554          (transformer (car (cddddr header)))
     555          (ren 'process)
     556          (%let (rename 'let))
     557          (%lambda (rename 'lambda))
     558          (%define-syntax (rename 'define-syntax))
     559          )
    524560          `(,%define-syntax ,name
    525              (,%er-macro-transformer
     561             (,transformer
    526562               (,%lambda (,frm ,ren ,cmp?)
    527                  ;,(declare-prefixed-syms pre ren body)))))))))
    528563                 (,%let ,(map (lambda (sym)
    529564                                `(,sym (,ren ',(sym-tail pre sym))))
     
    535570                   ,@body)))))))))
    536571
     572;;; (define-er-macro (name form rename-prefix compare?) xpr . xprs)
     573;;; ---------------------------------------------------------------
     574;;; defines an explicit-renaming macro name with use-form form,
     575;;; automatically renaming symbols starting with inject-rpefix
     576(define-syntax define-er-macro
     577  (syntax-rules ()
     578    ((_ (name form rename-prefix compare?) xpr . xprs)
     579     (define-macro-with
     580       (name form rename-prefix compare? er-macro-transformer)
     581       xpr . xprs))))
     582
    537583;;; (define-ir-macro (name form inject-prefix compare?) xpr . xprs)
    538584;;; ---------------------------------------------------------------
     
    540586;;; automatically injecting symbols starting with inject-rpefix
    541587(define-syntax define-ir-macro
     588  (syntax-rules ()
     589    ((_ (name form inject-prefix compare?) xpr . xprs)
     590     (define-macro-with
     591       (name form inject-prefix compare? ir-macro-transformer)
     592       xpr . xprs))))
     593
     594;;; (with-mapped-symbols mapper prefix- (prefix-x ....) xpr ....)
     595;;; -------------------------------------------------------------
     596;;; binds a series of prefixed names, prefix-x ....
     597;;; to the images of the original names, x ...., under mapper
     598;;; and evaluates xpr .... in this context
     599(define-syntax with-mapped-symbols
    542600  (er-macro-transformer
    543601    (lambda (form rename compare?)
    544       (let ((header (cadr form))
    545             (body (cons (caddr form) (cdddr form))))
    546         (let ((name (car header))
    547               (form (cadr header))
    548               (pre (caddr header))
    549               (cmp? (cadddr header))
    550               (inj 'inject)
    551               (%let (rename 'let))
    552               (%lambda (rename 'lambda))
    553               (%define-syntax (rename 'define-syntax))
    554               (%ir-macro-transformer (rename 'ir-macro-transformer)))
    555           `(,%define-syntax ,name
    556              (,%ir-macro-transformer
    557                (,%lambda (,form ,inj ,cmp?)
    558                  ;,(declare-prefixed-syms pre inj body)))))))))
    559                  (,%let ,(map (lambda (sym)
    560                                 `(,sym (,inj ',(sym-tail pre sym))))
    561                               (remove-duplicates
    562                                 (filter (lambda (sym)
    563                                           (and (symbol? sym)
    564                                                (sym-prepends? pre sym)))
    565                                         (pseudo-flatten body))))
    566                    ,@body)))))))))
     602      (let ((mapper (cadr form))
     603            (prefix (caddr form))
     604            (syms (cadddr form))
     605            (xpr (car (cddddr form)))
     606            (xprs (cdr (cddddr form)))
     607            (%let (rename 'let)))
     608        `(,%let ,(map (lambda (s)
     609                        `(,s (,mapper ',(sym-tail prefix s))))
     610                      syms)
     611           ,xpr ,@xprs)))))
     612
     613;;; (with-gensyms (name ....) xpr ....)
     614;;; -----------------------------------
     615;;; binds name ... to (gensym 'name) ... in body xpr ...
     616(define-syntax with-gensyms
     617  (ir-macro-transformer
     618    (lambda (form inject compare?)
     619      `(let ,(map (lambda (n) `(,n (gensym ',n))) (cadr form))
     620         ,@(cddr form)))))
     621
    567622
    568623;;; (basic-macros sym ..)
     
    571626(define basic-macros
    572627  (let ((alst '(
     628    (define-syntax-rule
     629      macro:
     630       (define-syntax-rule (name . args) xpr . xprs)
     631       (define-syntax-rule (name . args) (keywords . keys) xpr . xprs)
     632       "simplyfied version of syntax-rules,"
     633       "if there is only one rule")
    573634    (bind
    574635      macro:
     
    588649      "arguments x ... are evaluated only once and"
    589650      "from left to right in the body xpr ....")
     651    (define-er-macro-transformer
     652      macro:
     653      (define-er-macro-tansformer name form rename compare?)
     654      "wrapper around er-macro-transformer")
     655    (define-ir-macro-transformer
     656      macro:
     657      (define-ir-macro-tansformer name form inject compare?)
     658      "wrapper around ir-macro-transformer")
    590659    (define-er-macro
    591660      macro:
     
    598667      "creates an implicit-renaming macro, where all symbols"
    599668      "starting with inject-prefix are injected automatically")
     669    (with-mapped-symbols
     670      macro:
     671      (with-mapped-symbols mapper prefix- (prefix-x ....) xpr ....)
     672      "binds a series of prefixed names, prefix-x ...."
     673      "to the images of the original names, x ...., under mapper"
     674      "and evaluates xpr .... in this context")
     675    (with-gensyms
     676      macro:
     677      (with-gensyms (x ....) xpr ....)
     678      "generates a series of gensyms x .... to be used in body xpr ...")
    600679    )))
    601680    (case-lambda
     
    610689
    611690) ; module basic-macros
     691
  • release/4/basic-macros/tags/1.1/basic-macros.setup

    r34842 r34857  
    1010   "basic-macros.import.so"
    1111   "basic-macro-helpers.import.so")
    12  '((version "1.0")))
     12 '((version "1.1")))
  • release/4/basic-macros/tags/1.1/tests/run.scm

    r34842 r34857  
    1 (require-library basic-macros simple-tests)
    2 (import basic-macro-helpers basic-macros simple-tests)
    3 (import-for-syntax (only basic-macros bind bind-case once-only))
    4 
    5 (print "IIIIIIIIII ir-macro alambda")
    6 (pe '
    7   (define-ir-macro (alambda form % compare?)
    8     (bind (_ args xpr . xprs) form
    9       `(letrec ((,%self (lambda ,args ,xpr ,@xprs)))
    10          ,%self)))
    11   )
    12 
    13 (print "ALAMBDA")
    14 (pe '
    15   (alambda (n)
    16     (if (zero? n)
    17       1
    18       (* n (self (- n 1)))))
    19   )
    20 
    21 (print "EEEEEEEEEE er-macro nif")
    22 (pe '
    23   (define-er-macro (nif form % compare?)
    24     (bind (_ xpr pos zero neg) form
    25       `(,%let ((,%result ,xpr))
    26               (,%cond
    27                 ((,%positive? ,%result) 'pos)
    28                 ((,%negative? ,%result) 'neg)
    29                 (,%else 'zero)))))
    30   )
    31 
    32 (print "NIF")
    33 (pe '(nif xpr pos zero neg))
    34 
     1(require-library simple-tests basic-macros)
     2(begin-for-syntax (require-library basic-macros simple-tests))
     3(import scheme chicken basic-macro-helpers basic-macros simple-tests)
     4(import-for-syntax (only basic-macro-helpers pseudo-ref pseudo-tail))
     5
     6;(print "IIIIIIIIII ir-macro alambda")
     7;(pe '
     8;  (define-ir-macro (alambda form % compare?)
     9;    (bind (_ args xpr . xprs) form
     10;      `(letrec ((,%self (lambda ,args ,xpr ,@xprs)))
     11;         ,%self)))
     12;  )
     13;
     14;(print "ALAMBDA")
     15;(pe '
     16;  (alambda (n)
     17;    (if (zero? n)
     18;      1
     19;      (* n (self (- n 1)))))
     20;  )
     21;
     22;(print "EEEEEEEEEE er-macro nif")
     23;(pe '
     24;  (define-er-macro (nif form % compare?)
     25;    (bind (_ xpr pos zero neg) form
     26;      `(,%let ((,%result ,xpr))
     27;              (,%cond
     28;                ((,%positive? ,%result) 'pos)
     29;                ((,%negative? ,%result) 'neg)
     30;                (,%else 'zero)))))
     31;  )
     32;
     33;(print "NIF")
     34;(pe '(nif xpr pos zero neg))
     35;
    3536(define-test (pseudolists)
    3637  (check
     
    7980    (= (bind (x . #f) (cons 1 #f) x) 1)
    8081    (equal? (bind (x "y" z) '(1 "y" 2) (list x z)) '(1 2))
    81     (not (condition-case
     82    (eq? (condition-case
    8283           (bind (x . _) (list 1 2 3 4) _)
    83            ; wildcard not a variable
    84              ((exn) #f)))
    85     (not (condition-case
     84             ((exn) 'wildcard-not-a-variable))
     85         'wildcard-not-a-variable)
     86    (eq? (condition-case
    8687           (bind (x . #f) (cons 1 #t) x)
    87            ; literals don't match
    88              ((exn) #f)))
    89     (not (condition-case
     88             ((exn) 'literals-dont-match))
     89         'literals-dont-match)
     90    (eq? (condition-case
    9091           (bind (x "y" z) '(1 "q" 2) (list x z))
    91            ; literals don't match
    92              ((exn) #f)))
     92             ((exn) 'literals-dont-match))
     93         'literals-dont-match)
    9394    (equal? (bind-case '(2 2)
    9495              ((a b) (where (a even?) (b odd?)) (print 'even-odd a b))
     
    121122    ))
    122123 
     124(use-for-syntax (only basic-macros
     125                      bind
     126                      bind-case
     127                      once-only
     128                      with-mapped-symbols)) ;;;;;
     129
    123130(define-test (basic-macros)
    124131  (check
     
    135142    (= (square (counter)) 4)
    136143    (= (square (counter)) 9)
    137     (define-er-macro (swap! form % compare?)
     144
     145    (define-er-macro-transformer (swap! form rename compare?)
    138146      (let ((x (cadr form)) (y (caddr form)))
    139         `(,%let ((,%tmp ,x))
    140            (,%set! ,x ,y)
    141            (,%set! ,y ,%tmp))))
     147        (with-mapped-symbols rename % (%tmp %let %set!)
     148          `(,%let ((,%tmp ,x))
     149             (,%set! ,x ,y)
     150             (,%set! ,y ,%tmp)))))
    142151    (equal? (let ((x 'x) (y 'y))
    143152              (swap! x y)
     
    199208  (pseudolists)
    200209  (other-helpers)
    201   (bindings)
     210  ;(bindings)
    202211  (basic-macros)
    203212  )
  • release/4/basic-macros/trunk/basic-macros.scm

    r34842 r34857  
    4141be captured. Destructuring can be automated with the bind macro -- a
    4242simplified version of the equally named macro in the bindings library --
    43 and renaming resp. injecting can be almost automated with the help of an
    44 auxiliary parameter, a prefix symbol, to the transformer routine.
     43and renaming resp. injecting can be almost automated with the help of
     44either the macro with-mapped-symbols or two macro-generators, which
     45replace the rename resp. inject parameter of the transformer with a
     46prefix symbol. Note, that bind or with-mapped-symbols must be used
     47for-syntax, if used in a macro body for destructuring or
     48renaming/injecting.
    4549
    4650Usually an ambituous explicit renaming macro contains a long let
    4751defining the renamed symbols -- usually prefixed with some fixed symbol
    4852constant like % -- which is then executed in the macro's body by
    49 unquoting it. Our two macros create the let automatically. The only
    50 thing you have to do is providing a prefix and using it to prefix all
    51 symbols you want renamed.
    52 
    53 Here is a simple example, the numeric if.
     53unquoting it. Both methods create the let automatically.
     54
     55Here are two simple examples, one the swap! macro, using
     56define-er-macro-transformer and with-mapped-symbols, the other numeric if,
     57using define-er-macro and and explicit prefix, %.
     58In the latter case, the macro searches its body for symbols starting
     59with this prefix, collects them in a list, removes duplicates and adds
     60the necesary let with pairs of the form
     61
     62  (%name (rename 'name)
     63
     64to the front of the body. In other words it does what you usually do by
     65hand.
     66
     67  (define-er-macro-transformer (swap! form rename compare?)
     68    (let ((x (cadr form)) (y (caddr form)))
     69      (with-mapped-symbols rename % (%tmp %let %set!)
     70        `(,%let ((,%tmp ,x))
     71           (,%set! ,x ,y)
     72           (,%set! ,y ,%tmp)))))
    5473
    5574  (define-er-macro (nif form % compare?)
     
    6685untouched.
    6786
    68 The macro searches its body for symbols starting with this prefix,
    69 collects them in a list, removes duplicates and adds the necesary let
    70 with pairs of the form
    71 
    72   (%name (rename 'name)
    73 
    74 to the front of the body. In other words it does what you usually do by
    75 hand.
    7687
    7788For implicit renaming macros the list of injected symbols is usually,
     
    271282
    272283(module basic-macros ;*
    273   (define-er-macro define-ir-macro bind bind-case once-only basic-macros)
     284  (define-syntax-rule define-er-macro-transformer define-ir-macro-transformer
     285   define-er-macro define-ir-macro bind bind-case once-only basic-macros
     286   with-mapped-symbols with-gensyms)
    274287  (import scheme basic-macro-helpers
    275288          (only chicken condition-case case-lambda print error))
     
    281294                              pseudo-list?))
    282295
     296#|[Let's start with a one syntax-rule]|#
     297
     298;;; (define-syntax-rule (name . args) xpr . xprs)
     299;;; (define-syntax-rule (name . args) (keywords . keys) xpr . xprs)
     300;;; ---------------------------------------------------------------
     301;;; simplyfies define-syntax in case there is only one rule
     302(define-syntax define-syntax-rule
     303  (syntax-rules (keywords)
     304    ((_ (name . args)
     305        (keywords key ...) xpr . xprs)
     306     (define-syntax name
     307       (syntax-rules (key ...)
     308         ((_ . args) xpr . xprs))))
     309    ((_ (name . args) xpr . xprs)
     310     (define-syntax name
     311       (syntax-rules ()
     312         ((_ . args) xpr . xprs))))))
     313
     314#|[
     315Let's start with some helpers which might be occasionally useful
     316]|#
     317
     318;;; (define-er-macro-transformer form rename compare?)
     319;;; --------------------------------------------------
     320;;; wrapper around er-macro-transformer
     321(define-syntax define-er-macro-transformer
     322  (syntax-rules ()
     323    ((_ (name form rename compare?) xpr . xprs)
     324     (define-syntax name
     325       (er-macro-transformer
     326         (lambda (form rename compare?) xpr . xprs))))))
     327
     328;;; (define-ir-macro-transformer form inject compare?)
     329;;; --------------------------------------------------
     330;;; wrapper around ir-macro-transformer
     331(define-syntax define-ir-macro-transformer
     332  (syntax-rules ()
     333    ((_ (name form inject compare?) xpr . xprs)
     334     (define-syntax name
     335       (ir-macro-transformer
     336         (lambda (form inject compare?) xpr . xprs))))))
     337
    283338#|[
    284339The following is Graham's dbind extended with  wildcards,
     
    295350;;; binds pattern variables of pat to corresponding subexpressions of
    296351;;; seq and executes body xpr . xprs in this context.
    297 (define-syntax do-bind
    298   (er-macro-transformer
    299     (lambda (form rename compare?)
     352(define-er-macro-transformer (do-bind form rename compare?)
     353;(define-syntax do-bind
     354;  (er-macro-transformer
     355;    (lambda (form rename compare?)
    300356  (let ((pat (cadr form))
    301357        (seq (caddr form))
     
    307363        (%and (rename 'and))
    308364        (%let (rename 'let))
     365        (%not (rename 'not))
     366        (%pair? (rename 'pair?))
    309367        (%begin (rename 'begin))
    310368        (%error (rename 'error))
    311369        (%equal? (rename 'equal?))
    312370        (%pseudo-ref (rename 'pseudo-ref))
    313         (%pseudo-tail (rename 'pseudo-tail))
    314         (%pseudo-null? (rename 'pseudo-null?)))
     371        (%pseudo-tail (rename 'pseudo-tail)))
    315372    (let ((body `(,%begin ,xpr ,@xprs)))
    316373      (letrec (
     
    348405                      ((null? sentinel)
    349406                       (values pairs literals
    350                                (cons `(,%pseudo-null?
    351                                         (,%pseudo-tail ,seq ,k))
     407                               (cons ;`(,%pseudo-null?
     408                                     ;   (,%pseudo-tail ,seq ,k))
     409                                     `(,%not
     410                                        (,%pair?
     411                                          (,%pseudo-tail ,seq ,k)))
    352412                                     tails)))
    353413                      ((symbol? sentinel)
     
    365425                                tails))))
    366426                  (let ((item (pseudo-ref pat k)))
    367                           ;(let loop ((pat pat) (k k))
    368                           ;  (cond
    369                           ;    ((not (pair? pat)) pat)
    370                           ;    ((= k 0) (car pat))
    371                           ;    (else (loop (cdr pat) (- k 1)))))))
    372427                    (cond
    373                       ;((symbol? item)
    374428                      ((and (symbol? item) (not (keyword? item)))
    375429                       (if (compare? item %_)
     
    409463                        "duplicate pattern variables"
    410464                        ',(map car pairs)))))
    411           ))))))
     465          ))));))
    412466
    413467;;;; (bind pat seq xpr . xprs)
     
    427481     (let ((%seq seq))
    428482       (do-bind pat %seq xpr . xprs)))))
    429 
    430 ;;;; (bind-case seq (pat xpr . xprs) ....)
    431 ;;;; -------------------------------------
    432 ;;;; Checks if seq matches patterns pat ...
    433 ;;;; in sequence, binds the pattern variables of the first matching
    434 ;;;; pattern to corresponding subexpressions of seq and executes
    435 ;;;; corresponding body xpr . xprs
    436 ;(define-syntax bind-case
    437 ;  (syntax-rules ()
    438 ;    ((_ seq)
    439 ;     (error 'bind-case `("no match for" ,seq)))
    440 ;    ((_ seq (pat xpr . xprs))
    441 ;     (bind pat seq xpr . xprs))
    442 ;    ((_ seq clause . clauses)
    443 ;     (condition-case (bind-case seq clause)
    444 ;       ((exn) (bind-case seq . clauses))))
    445 ;    ))
    446483
    447484;;; (bind-case seq (pat xpr . xprs) ...)
     
    472509;;; The code is more or less due to
    473510;;; P. Seibel, Practical Common Lisp, p. 102
    474 (define-syntax once-only
    475   (er-macro-transformer
    476     (lambda (form rename compare?)
     511;(define-syntax once-only
     512;  (er-macro-transformer
     513;    (lambda (form rename compare?)
     514(define-er-macro-transformer (once-only form rename compare?)
    477515  (let ((names (cadr form))
    478516        (body (cons (caddr form) (cdddr form)))
    479517        (%let (rename 'let))
    480518        (%list (rename 'list))
    481         ;(%gensym (rename 'gensym))
    482519        )
    483520    (let ((syms (map rename names)))
    484       ;`(,%let ,(map (lambda (g) `(,g ',g)) syms)
    485521      `(,%let ,(map (lambda (g) `(,g ,(rename `',g))) syms)
    486       ;`(,%let ,(map (lambda (g) `(,g (,rename ',g))) syms)
    487       ;`(,%let ,(map (lambda (g) `(,g (,%gensym))) syms)
    488522         `(,',%let ,(,%list ,@(map (lambda (g n) ``(,,g ,,n))
    489523                               syms names))
    490524            ,(,%let ,(map (lambda (n g) `(,n ,g))
    491525                        names syms)
    492                ,@body))))))))
    493 ;(define-syntax once-only
    494 ;  (ir-macro-transformer
    495 ;    (lambda (form inject compare?)
     526               ,@body))))));))
     527;(define-ir-macro-transformer (once-only form inject compare?)
    496528;  (let ((names (cadr form))
    497529;        (body (cons (caddr form) (cdddr form))))
     
    502534;            ,(let ,(map (lambda (n g) `(,n ,g))
    503535;                        names gensyms)
    504 ;               ,@body))))))))
     536;               ,@body))))))
    505537;
    506 ;;; (define-er-macro (name form rename-prefix compare?) xpr . xprs)
    507 ;;; ---------------------------------------------------------------
    508 ;;; defines an explicit-renaming macro name with use-form form,
    509 ;;; automatically renaming symbols starting with inject-rpefix
    510 (define-syntax define-er-macro
     538
     539;;; (define-macro-with (name form prefix compare? transformer) xpr . xprs)
     540;;; ----------------------------------------------------------------------
     541;;; internal helper
     542(define-syntax define-macro-with
    511543  (er-macro-transformer
    512544    (lambda (form rename compare?)
    513       (let ((header (cadr form))
    514             (body (cons (caddr form) (cdddr form))))
    515         (let ((name (car header))
    516               (frm (cadr header))
    517               (pre (caddr header))
    518               (cmp? (cadddr header))
    519               (ren 'rename)
    520               (%let (rename 'let))
    521               (%lambda (rename 'lambda))
    522               (%define-syntax (rename 'define-syntax))
    523               (%er-macro-transformer (rename 'er-macro-transformer)))
     545      (let (
     546        (header (cadr form))
     547        (body (cons (caddr form) (cdddr form)))
     548        )
     549        (let (
     550          (name (car header))
     551          (frm (cadr header))
     552          (pre (caddr header))
     553          (cmp? (cadddr header))
     554          (transformer (car (cddddr header)))
     555          (ren 'process)
     556          (%let (rename 'let))
     557          (%lambda (rename 'lambda))
     558          (%define-syntax (rename 'define-syntax))
     559          )
    524560          `(,%define-syntax ,name
    525              (,%er-macro-transformer
     561             (,transformer
    526562               (,%lambda (,frm ,ren ,cmp?)
    527                  ;,(declare-prefixed-syms pre ren body)))))))))
    528563                 (,%let ,(map (lambda (sym)
    529564                                `(,sym (,ren ',(sym-tail pre sym))))
     
    535570                   ,@body)))))))))
    536571
     572;;; (define-er-macro (name form rename-prefix compare?) xpr . xprs)
     573;;; ---------------------------------------------------------------
     574;;; defines an explicit-renaming macro name with use-form form,
     575;;; automatically renaming symbols starting with inject-rpefix
     576(define-syntax define-er-macro
     577  (syntax-rules ()
     578    ((_ (name form rename-prefix compare?) xpr . xprs)
     579     (define-macro-with
     580       (name form rename-prefix compare? er-macro-transformer)
     581       xpr . xprs))))
     582
    537583;;; (define-ir-macro (name form inject-prefix compare?) xpr . xprs)
    538584;;; ---------------------------------------------------------------
     
    540586;;; automatically injecting symbols starting with inject-rpefix
    541587(define-syntax define-ir-macro
     588  (syntax-rules ()
     589    ((_ (name form inject-prefix compare?) xpr . xprs)
     590     (define-macro-with
     591       (name form inject-prefix compare? ir-macro-transformer)
     592       xpr . xprs))))
     593
     594;;; (with-mapped-symbols mapper prefix- (prefix-x ....) xpr ....)
     595;;; -------------------------------------------------------------
     596;;; binds a series of prefixed names, prefix-x ....
     597;;; to the images of the original names, x ...., under mapper
     598;;; and evaluates xpr .... in this context
     599(define-syntax with-mapped-symbols
    542600  (er-macro-transformer
    543601    (lambda (form rename compare?)
    544       (let ((header (cadr form))
    545             (body (cons (caddr form) (cdddr form))))
    546         (let ((name (car header))
    547               (form (cadr header))
    548               (pre (caddr header))
    549               (cmp? (cadddr header))
    550               (inj 'inject)
    551               (%let (rename 'let))
    552               (%lambda (rename 'lambda))
    553               (%define-syntax (rename 'define-syntax))
    554               (%ir-macro-transformer (rename 'ir-macro-transformer)))
    555           `(,%define-syntax ,name
    556              (,%ir-macro-transformer
    557                (,%lambda (,form ,inj ,cmp?)
    558                  ;,(declare-prefixed-syms pre inj body)))))))))
    559                  (,%let ,(map (lambda (sym)
    560                                 `(,sym (,inj ',(sym-tail pre sym))))
    561                               (remove-duplicates
    562                                 (filter (lambda (sym)
    563                                           (and (symbol? sym)
    564                                                (sym-prepends? pre sym)))
    565                                         (pseudo-flatten body))))
    566                    ,@body)))))))))
     602      (let ((mapper (cadr form))
     603            (prefix (caddr form))
     604            (syms (cadddr form))
     605            (xpr (car (cddddr form)))
     606            (xprs (cdr (cddddr form)))
     607            (%let (rename 'let)))
     608        `(,%let ,(map (lambda (s)
     609                        `(,s (,mapper ',(sym-tail prefix s))))
     610                      syms)
     611           ,xpr ,@xprs)))))
     612
     613;;; (with-gensyms (name ....) xpr ....)
     614;;; -----------------------------------
     615;;; binds name ... to (gensym 'name) ... in body xpr ...
     616(define-syntax with-gensyms
     617  (ir-macro-transformer
     618    (lambda (form inject compare?)
     619      `(let ,(map (lambda (n) `(,n (gensym ',n))) (cadr form))
     620         ,@(cddr form)))))
     621
    567622
    568623;;; (basic-macros sym ..)
     
    571626(define basic-macros
    572627  (let ((alst '(
     628    (define-syntax-rule
     629      macro:
     630       (define-syntax-rule (name . args) xpr . xprs)
     631       (define-syntax-rule (name . args) (keywords . keys) xpr . xprs)
     632       "simplyfied version of syntax-rules,"
     633       "if there is only one rule")
    573634    (bind
    574635      macro:
     
    588649      "arguments x ... are evaluated only once and"
    589650      "from left to right in the body xpr ....")
     651    (define-er-macro-transformer
     652      macro:
     653      (define-er-macro-tansformer name form rename compare?)
     654      "wrapper around er-macro-transformer")
     655    (define-ir-macro-transformer
     656      macro:
     657      (define-ir-macro-tansformer name form inject compare?)
     658      "wrapper around ir-macro-transformer")
    590659    (define-er-macro
    591660      macro:
     
    598667      "creates an implicit-renaming macro, where all symbols"
    599668      "starting with inject-prefix are injected automatically")
     669    (with-mapped-symbols
     670      macro:
     671      (with-mapped-symbols mapper prefix- (prefix-x ....) xpr ....)
     672      "binds a series of prefixed names, prefix-x ...."
     673      "to the images of the original names, x ...., under mapper"
     674      "and evaluates xpr .... in this context")
     675    (with-gensyms
     676      macro:
     677      (with-gensyms (x ....) xpr ....)
     678      "generates a series of gensyms x .... to be used in body xpr ...")
    600679    )))
    601680    (case-lambda
     
    610689
    611690) ; module basic-macros
     691
  • release/4/basic-macros/trunk/basic-macros.setup

    r34842 r34857  
    1010   "basic-macros.import.so"
    1111   "basic-macro-helpers.import.so")
    12  '((version "1.0")))
     12 '((version "1.1")))
  • release/4/basic-macros/trunk/tests/run.scm

    r34842 r34857  
    1 (require-library basic-macros simple-tests)
    2 (import basic-macro-helpers basic-macros simple-tests)
    3 (import-for-syntax (only basic-macros bind bind-case once-only))
    4 
    5 (print "IIIIIIIIII ir-macro alambda")
    6 (pe '
    7   (define-ir-macro (alambda form % compare?)
    8     (bind (_ args xpr . xprs) form
    9       `(letrec ((,%self (lambda ,args ,xpr ,@xprs)))
    10          ,%self)))
    11   )
    12 
    13 (print "ALAMBDA")
    14 (pe '
    15   (alambda (n)
    16     (if (zero? n)
    17       1
    18       (* n (self (- n 1)))))
    19   )
    20 
    21 (print "EEEEEEEEEE er-macro nif")
    22 (pe '
    23   (define-er-macro (nif form % compare?)
    24     (bind (_ xpr pos zero neg) form
    25       `(,%let ((,%result ,xpr))
    26               (,%cond
    27                 ((,%positive? ,%result) 'pos)
    28                 ((,%negative? ,%result) 'neg)
    29                 (,%else 'zero)))))
    30   )
    31 
    32 (print "NIF")
    33 (pe '(nif xpr pos zero neg))
    34 
     1(require-library simple-tests basic-macros)
     2(begin-for-syntax (require-library basic-macros simple-tests))
     3(import scheme chicken basic-macro-helpers basic-macros simple-tests)
     4(import-for-syntax (only basic-macro-helpers pseudo-ref pseudo-tail))
     5
     6;(print "IIIIIIIIII ir-macro alambda")
     7;(pe '
     8;  (define-ir-macro (alambda form % compare?)
     9;    (bind (_ args xpr . xprs) form
     10;      `(letrec ((,%self (lambda ,args ,xpr ,@xprs)))
     11;         ,%self)))
     12;  )
     13;
     14;(print "ALAMBDA")
     15;(pe '
     16;  (alambda (n)
     17;    (if (zero? n)
     18;      1
     19;      (* n (self (- n 1)))))
     20;  )
     21;
     22;(print "EEEEEEEEEE er-macro nif")
     23;(pe '
     24;  (define-er-macro (nif form % compare?)
     25;    (bind (_ xpr pos zero neg) form
     26;      `(,%let ((,%result ,xpr))
     27;              (,%cond
     28;                ((,%positive? ,%result) 'pos)
     29;                ((,%negative? ,%result) 'neg)
     30;                (,%else 'zero)))))
     31;  )
     32;
     33;(print "NIF")
     34;(pe '(nif xpr pos zero neg))
     35;
    3536(define-test (pseudolists)
    3637  (check
     
    7980    (= (bind (x . #f) (cons 1 #f) x) 1)
    8081    (equal? (bind (x "y" z) '(1 "y" 2) (list x z)) '(1 2))
    81     (not (condition-case
     82    (eq? (condition-case
    8283           (bind (x . _) (list 1 2 3 4) _)
    83            ; wildcard not a variable
    84              ((exn) #f)))
    85     (not (condition-case
     84             ((exn) 'wildcard-not-a-variable))
     85         'wildcard-not-a-variable)
     86    (eq? (condition-case
    8687           (bind (x . #f) (cons 1 #t) x)
    87            ; literals don't match
    88              ((exn) #f)))
    89     (not (condition-case
     88             ((exn) 'literals-dont-match))
     89         'literals-dont-match)
     90    (eq? (condition-case
    9091           (bind (x "y" z) '(1 "q" 2) (list x z))
    91            ; literals don't match
    92              ((exn) #f)))
     92             ((exn) 'literals-dont-match))
     93         'literals-dont-match)
    9394    (equal? (bind-case '(2 2)
    9495              ((a b) (where (a even?) (b odd?)) (print 'even-odd a b))
     
    121122    ))
    122123 
     124(use-for-syntax (only basic-macros
     125                      bind
     126                      bind-case
     127                      once-only
     128                      with-mapped-symbols)) ;;;;;
     129
    123130(define-test (basic-macros)
    124131  (check
     
    135142    (= (square (counter)) 4)
    136143    (= (square (counter)) 9)
    137     (define-er-macro (swap! form % compare?)
     144
     145    (define-er-macro-transformer (swap! form rename compare?)
    138146      (let ((x (cadr form)) (y (caddr form)))
    139         `(,%let ((,%tmp ,x))
    140            (,%set! ,x ,y)
    141            (,%set! ,y ,%tmp))))
     147        (with-mapped-symbols rename % (%tmp %let %set!)
     148          `(,%let ((,%tmp ,x))
     149             (,%set! ,x ,y)
     150             (,%set! ,y ,%tmp)))))
    142151    (equal? (let ((x 'x) (y 'y))
    143152              (swap! x y)
     
    199208  (pseudolists)
    200209  (other-helpers)
    201   (bindings)
     210  ;(bindings)
    202211  (basic-macros)
    203212  )
Note: See TracChangeset for help on using the changeset viewer.