Changeset 29964 in project


Ignore:
Timestamp:
10/26/13 13:43:38 (8 years ago)
Author:
juergen
Message:

macro-rules added

Location:
release/4/list-bindings
Files:
3 edited
4 copied

Legend:

Unmodified
Added
Removed
  • release/4/list-bindings/tags/1.7/list-bindings.scm

    r29858 r29964  
    4040(module list-bindings
    4141  (export list-bindings bind-define bind-set! bind bindable? bind-lambda
    42           bind-case bind-case-lambda bind/cc bind-let bind-let*
    43           define-syntax-rule define-macro let-macro letrec-macro)
     42          bind-case bind/cc bind-let bind-let* define-syntax-rule
     43          define-macro let-macro letrec-macro (macro-rules strip))
    4444  (import scheme
    4545          (only chicken condition-case error)
     
    154154         (error 'bind-case (format #f "template ~s doesn't match any of the patterns ~s"
    155155                                   seq '(pat0 pat1 ...))))))))
    156 
    157 ;;; (bind-case-lambda (pat  xpr . xprs) ....)
    158 ;;; -----------------------------------------
    159 ;;; combination of lambda and bind-case
    160 (define-syntax bind-case-lambda
    161   (syntax-rules ()
    162     ((_ (pat xpr . xprs))
    163      (lambda (x) (bind pat x xpr . xprs)))
    164     ((_ clause . clauses)
    165      (lambda (x)
    166        (bind-case x clause . clauses)))))
    167 
    168156
    169157#|[
     
    538526           ,@body)))))
    539527
     528;;; (macro-rules sym ... (suffix suffixed-keyword ...)
     529;;;   (pat0 tpl0) (pat1 tpl1) ...)
     530;;; --------------------------------------------------
     531;;; where sym ... are injected non-hygienig symbols, the keyword-list is
     532;;; either empty or of the form (? sym? ...) with a predicates sym? ...
     533;;; checking for their own names with the suffix ? stripped, pat0 pat1
     534;;; ... are like syntax-rules patterns, but tpl0 tpl1 ... evaluate to
     535;;; quasiquoted templates.
     536(define-syntax macro-rules
     537  (ir-macro-transformer
     538    (lambda (f i c?)
     539      ;; head is list of injected syms, tail starts with keyword-list
     540      (let (
     541        (tail-head
     542          (call-with-values
     543            (lambda ()
     544              (let loop ((tail (cdr f)) (head '()))
     545                (if (or (null? tail) (list? (car tail)))
     546                  (values tail head)
     547                  (loop (cdr tail) (cons (car tail) head)))))
     548            list))
     549        )
     550        (let ((tail (car tail-head)) (head (cadr tail-head)))
     551          (let ((keywords (car tail)) (rule (cadr tail)) (rules (cddr tail)))
     552            (let (
     553              (keyword-query (lambda (skey)
     554                               `(,skey (lambda (x)
     555                                         (compare? x
     556                                                   (strip ',(car keywords)
     557                                                          ',skey))))))
     558              (inject-it (lambda (h) `(,h (inject ',h))))
     559              )
     560              (cond
     561                ((and (null? head) (null? keywords))
     562                 ; no injected symbols, no additional keywords
     563                 `(ir-macro-transformer
     564                    (lambda (form inject compare?)
     565                      (bind-case form ,rule ,@rules))))
     566                ((null? head)
     567                 ; no injected symbols
     568                 `(ir-macro-transformer
     569                    (lambda (form inject compare?)
     570                      (let ,(map keyword-query
     571                                 (cdr keywords))
     572                        (bind-case form ,rule ,@rules)))))
     573                ((null? keywords)
     574                 ;; no additional keywords
     575                 `(ir-macro-transformer
     576                    (lambda (form inject compare?)
     577                      (let ,(map inject-it head)
     578                        (bind-case form ,rule ,@rules)))))
     579                (else
     580                  `(ir-macro-transformer
     581                     (lambda (form inject compare?)
     582                       (let ,(append
     583                               (map inject-it head)
     584                               (map keyword-query (cdr keywords)))
     585                         (bind-case form ,rule ,@rules)))))))))))))
     586  ;; unfortunately, this simpler implementation doesn't work because of
     587  ;; two ellipses at the same nesting level
     588  ;  (syntax-rules ()
     589  ;    ((_ injected-sym ... (suffix suffixed-keyword ...)
     590  ;        ((pat0 tpl0)
     591  ;        (pat1 tpl1)
     592  ;        ...)
     593  ;     (ir-macro-transformer
     594  ;         (lambda (form inject compare?)
     595  ;           (let ((injected-sym (inject 'injected-sym))
     596  ;                 ...
     597  ;                 (suffixed-keyword
     598  ;                   (lambda (x) (compare? x (strip suffix
     599  ;                                                  suffixed-keyword))))
     600  ;                 ...)
     601  ;             (bind-case form
     602  ;               (pat0 tpl0) (pat1 tpl1) ...)))))
     603  ;    ((_ sym ... () (pat0 tpl0) (pat1 tpl1) ...)
     604  ;     (ir-macro-transformer sym ... (suffix) (pat0 tpl0) (pat1 tpl1) ...))
     605  ;    ))
     606
     607(define (strip s skey)
     608  (let ((s-str (symbol->string s))
     609        (skey-str (symbol->string skey)))
     610    (string->symbol
     611      (substring skey-str 0 (- (string-length skey-str)
     612                               (string-length s-str))))))
     613
    540614;;; (define-syntax-rule (macro-code) tpl)
    541615;;; -------------------------------------
     
    551625(define (list-bindings)
    552626  '(bind-define bind-set! bind bind-lambda bind-let* bind-let bind-case bindable? bind/cc
    553     define-macro let-macro letrec-macro define-syntax-rule))
     627    macro-rules define-macro let-macro letrec-macro define-syntax-rule))
    554628
    555629) ; module list-bindings
     630
  • release/4/list-bindings/tags/1.7/list-bindings.setup

    r29858 r29964  
    77 'list-bindings
    88 '("list-bindings.so" "list-bindings.import.so")
    9  '((version "1.6")))
     9 '((version "1.7")))
    1010
  • release/4/list-bindings/tags/1.7/tests/run.scm

    r29858 r29964  
    55(require-library simple-tests list-bindings)
    66(import simple-tests list-bindings)
     7(import-for-syntax (only list-bindings macro-rules))
    78
    89(compound-test ("LIST-BINDINGS")
     
    4344              ((x (y z)) (list x y z)))
    4445            '(1 (2 . 3)))
    45     (equal? ((bind-case-lambda
    46                ((a (b . c) . d) (list a b c d))
    47                ((e . f) (list e f)))
    48              '(1 2 3 4 5))
    49             '(1 (2 3 4 5)))
    50 
    5146    (equal?
    5247      (letrec ((my-map
     
    127122              (list ((efreeze 3)) ((ifreeze 5))))
    128123            '(3 5))
     124    (define-syntax if-then-
     125      (macro-rules (? then? else?)
     126        ((_ test then-pair)
     127         (if (and (pair? then-pair) (then? (car then-pair)))
     128           `(if ,test
     129              (begin ,@(cdr then-pair)))
     130           `(error 'if-then- "syntax-error")))
     131        ((_ test then-pair else-pair)
     132         (if (and (pair? then-pair) (then? (car then-pair))
     133                  (pair? else-pair) (else? (car else-pair)))
     134           `(if ,test
     135              (begin ,@(cdr then-pair))
     136              (begin ,@(cdr else-pair)))
     137           `(error 'if-then- "syntax-error")))))
     138    (define (quux x)
     139      (if-then- (odd? x) (then "odd") (else "even")))
     140    (equal? (quux 3) "odd")
     141    (equal? (quux 4) "even")
     142    (define-syntax aif
     143      (macro-rules it ()
     144        ((_ test consequent . alternative)
     145         (if (null? alternative)
     146          `(let ((,it ,test))
     147             (if ,it ,consequent))
     148          `(let ((,it ,test))
     149             (if ,it ,consequent ,(car alternative)))))))
     150    (define (mist x) (aif (! x) it))
     151    (= (mist 5) 120)
    129152    (define-syntax-rule (freeze x) (lambda () x))
    130153    (= ((freeze 25)) 25)
  • release/4/list-bindings/trunk/list-bindings.scm

    r29858 r29964  
    4040(module list-bindings
    4141  (export list-bindings bind-define bind-set! bind bindable? bind-lambda
    42           bind-case bind-case-lambda bind/cc bind-let bind-let*
    43           define-syntax-rule define-macro let-macro letrec-macro)
     42          bind-case bind/cc bind-let bind-let* define-syntax-rule
     43          define-macro let-macro letrec-macro (macro-rules strip))
    4444  (import scheme
    4545          (only chicken condition-case error)
     
    154154         (error 'bind-case (format #f "template ~s doesn't match any of the patterns ~s"
    155155                                   seq '(pat0 pat1 ...))))))))
    156 
    157 ;;; (bind-case-lambda (pat  xpr . xprs) ....)
    158 ;;; -----------------------------------------
    159 ;;; combination of lambda and bind-case
    160 (define-syntax bind-case-lambda
    161   (syntax-rules ()
    162     ((_ (pat xpr . xprs))
    163      (lambda (x) (bind pat x xpr . xprs)))
    164     ((_ clause . clauses)
    165      (lambda (x)
    166        (bind-case x clause . clauses)))))
    167 
    168156
    169157#|[
     
    538526           ,@body)))))
    539527
     528;;; (macro-rules sym ... (suffix suffixed-keyword ...)
     529;;;   (pat0 tpl0) (pat1 tpl1) ...)
     530;;; --------------------------------------------------
     531;;; where sym ... are injected non-hygienig symbols, the keyword-list is
     532;;; either empty or of the form (? sym? ...) with a predicates sym? ...
     533;;; checking for their own names with the suffix ? stripped, pat0 pat1
     534;;; ... are like syntax-rules patterns, but tpl0 tpl1 ... evaluate to
     535;;; quasiquoted templates.
     536(define-syntax macro-rules
     537  (ir-macro-transformer
     538    (lambda (f i c?)
     539      ;; head is list of injected syms, tail starts with keyword-list
     540      (let (
     541        (tail-head
     542          (call-with-values
     543            (lambda ()
     544              (let loop ((tail (cdr f)) (head '()))
     545                (if (or (null? tail) (list? (car tail)))
     546                  (values tail head)
     547                  (loop (cdr tail) (cons (car tail) head)))))
     548            list))
     549        )
     550        (let ((tail (car tail-head)) (head (cadr tail-head)))
     551          (let ((keywords (car tail)) (rule (cadr tail)) (rules (cddr tail)))
     552            (let (
     553              (keyword-query (lambda (skey)
     554                               `(,skey (lambda (x)
     555                                         (compare? x
     556                                                   (strip ',(car keywords)
     557                                                          ',skey))))))
     558              (inject-it (lambda (h) `(,h (inject ',h))))
     559              )
     560              (cond
     561                ((and (null? head) (null? keywords))
     562                 ; no injected symbols, no additional keywords
     563                 `(ir-macro-transformer
     564                    (lambda (form inject compare?)
     565                      (bind-case form ,rule ,@rules))))
     566                ((null? head)
     567                 ; no injected symbols
     568                 `(ir-macro-transformer
     569                    (lambda (form inject compare?)
     570                      (let ,(map keyword-query
     571                                 (cdr keywords))
     572                        (bind-case form ,rule ,@rules)))))
     573                ((null? keywords)
     574                 ;; no additional keywords
     575                 `(ir-macro-transformer
     576                    (lambda (form inject compare?)
     577                      (let ,(map inject-it head)
     578                        (bind-case form ,rule ,@rules)))))
     579                (else
     580                  `(ir-macro-transformer
     581                     (lambda (form inject compare?)
     582                       (let ,(append
     583                               (map inject-it head)
     584                               (map keyword-query (cdr keywords)))
     585                         (bind-case form ,rule ,@rules)))))))))))))
     586  ;; unfortunately, this simpler implementation doesn't work because of
     587  ;; two ellipses at the same nesting level
     588  ;  (syntax-rules ()
     589  ;    ((_ injected-sym ... (suffix suffixed-keyword ...)
     590  ;        ((pat0 tpl0)
     591  ;        (pat1 tpl1)
     592  ;        ...)
     593  ;     (ir-macro-transformer
     594  ;         (lambda (form inject compare?)
     595  ;           (let ((injected-sym (inject 'injected-sym))
     596  ;                 ...
     597  ;                 (suffixed-keyword
     598  ;                   (lambda (x) (compare? x (strip suffix
     599  ;                                                  suffixed-keyword))))
     600  ;                 ...)
     601  ;             (bind-case form
     602  ;               (pat0 tpl0) (pat1 tpl1) ...)))))
     603  ;    ((_ sym ... () (pat0 tpl0) (pat1 tpl1) ...)
     604  ;     (ir-macro-transformer sym ... (suffix) (pat0 tpl0) (pat1 tpl1) ...))
     605  ;    ))
     606
     607(define (strip s skey)
     608  (let ((s-str (symbol->string s))
     609        (skey-str (symbol->string skey)))
     610    (string->symbol
     611      (substring skey-str 0 (- (string-length skey-str)
     612                               (string-length s-str))))))
     613
    540614;;; (define-syntax-rule (macro-code) tpl)
    541615;;; -------------------------------------
     
    551625(define (list-bindings)
    552626  '(bind-define bind-set! bind bind-lambda bind-let* bind-let bind-case bindable? bind/cc
    553     define-macro let-macro letrec-macro define-syntax-rule))
     627    macro-rules define-macro let-macro letrec-macro define-syntax-rule))
    554628
    555629) ; module list-bindings
     630
  • release/4/list-bindings/trunk/list-bindings.setup

    r29858 r29964  
    77 'list-bindings
    88 '("list-bindings.so" "list-bindings.import.so")
    9  '((version "1.6")))
     9 '((version "1.7")))
    1010
  • release/4/list-bindings/trunk/tests/run.scm

    r29858 r29964  
    55(require-library simple-tests list-bindings)
    66(import simple-tests list-bindings)
     7(import-for-syntax (only list-bindings macro-rules))
    78
    89(compound-test ("LIST-BINDINGS")
     
    4344              ((x (y z)) (list x y z)))
    4445            '(1 (2 . 3)))
    45     (equal? ((bind-case-lambda
    46                ((a (b . c) . d) (list a b c d))
    47                ((e . f) (list e f)))
    48              '(1 2 3 4 5))
    49             '(1 (2 3 4 5)))
    50 
    5146    (equal?
    5247      (letrec ((my-map
     
    127122              (list ((efreeze 3)) ((ifreeze 5))))
    128123            '(3 5))
     124    (define-syntax if-then-
     125      (macro-rules (? then? else?)
     126        ((_ test then-pair)
     127         (if (and (pair? then-pair) (then? (car then-pair)))
     128           `(if ,test
     129              (begin ,@(cdr then-pair)))
     130           `(error 'if-then- "syntax-error")))
     131        ((_ test then-pair else-pair)
     132         (if (and (pair? then-pair) (then? (car then-pair))
     133                  (pair? else-pair) (else? (car else-pair)))
     134           `(if ,test
     135              (begin ,@(cdr then-pair))
     136              (begin ,@(cdr else-pair)))
     137           `(error 'if-then- "syntax-error")))))
     138    (define (quux x)
     139      (if-then- (odd? x) (then "odd") (else "even")))
     140    (equal? (quux 3) "odd")
     141    (equal? (quux 4) "even")
     142    (define-syntax aif
     143      (macro-rules it ()
     144        ((_ test consequent . alternative)
     145         (if (null? alternative)
     146          `(let ((,it ,test))
     147             (if ,it ,consequent))
     148          `(let ((,it ,test))
     149             (if ,it ,consequent ,(car alternative)))))))
     150    (define (mist x) (aif (! x) it))
     151    (= (mist 5) 120)
    129152    (define-syntax-rule (freeze x) (lambda () x))
    130153    (= ((freeze 25)) 25)
Note: See TracChangeset for help on using the changeset viewer.