#|[ Author: Juergen Lorenz ju (at) jugilo (dot) de Copyright (c) 2013, Juergen Lorenz All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. Neither the name of the author nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ]|# #|[ First a helper module, which might be useful not only in low-level-macros. ]|# (module macro-helpers (export macro-helpers bind-exception destruc dbind-ex dbind-lit dbind-len filter flatten memp mappend plength pnull? plist-ref plist-tail prefixed-with? strip-prefix strip-suffix extract adjoin remove-duplicates) (import scheme (only chicken receive signal gensym make-property-condition make-composite-condition)) (define (macro-helpers) '(bind-exception destruc dbind-ex dbind-lit dbind-len filter flatten memp mappend plength pnull? plist-ref plist-tail prefixed-with? strip-prefix strip-suffix extract adjoin remove-duplicates)) (define (bind-exception loc msg . args) (make-composite-condition (make-property-condition 'exn 'location `(,loc) 'message msg 'arguments (apply list args)) (make-property-condition 'bind 'location `(,loc) 'message msg 'arguments (apply list args)))) ;;;; pseudolists (define (pnull? xpr) (or (null? xpr) (not (pair? xpr)))) (define (plist? xpr) (or (pnull? xpr) (pair? xpr))) (define (plength pl) (let loop ((pl pl) (len 0)) (if (pnull? pl) len (loop (cdr pl) (+ len 1))))) (define (plist-tail pl n) (cond ((or (negative? n) (> n (plength pl))) (signal (bind-exception 'plist-tail "out of range" pl n))) ((zero? n) pl) (else (plist-tail (cdr pl) (- n 1))))) (define (plist-ref pl n) (cond ((or (negative? n) (>= n (plength pl))) (signal (bind-exception 'plist-ref "out of range" pl n))) ((zero? n) (car pl)) (else (plist-ref (cdr pl) (- n 1))))) ;;;; other helpers (define (prefixed-with? pre) (lambda (id) (let ((pre-str (symbol->string pre)) (id-str (symbol->string id))) (let ((pre-len (string-length pre-str))) (and (< pre-len (string-length id-str)) (string=? pre-str (substring id-str 0 pre-len))))))) (define (strip-prefix pre id) (string->symbol (substring (symbol->string id) (string-length (symbol->string pre))))) (define (strip-suffix suf id) (let ((sufstring (symbol->string suf)) (idstring (symbol->string id))) (string->symbol (substring idstring 0 (- (string-length idstring) (string-length sufstring)))))) (define (extract ok? tree) (remove-duplicates (filter ok? (flatten tree)))) (define (substitute* old new tree) (let loop ((tree tree)) (cond ((pair? tree) (cons (loop (car tree)) (loop (cdr tree)))) ((null? tree) tree) ((and (symbol? tree) (eq? tree old)) new) (else tree)))) (define (memp ok? lst) (let loop ((lst lst)) (if (null? lst) #f (if (ok? (car lst)) lst (loop (cdr lst)))))) (define (filter ok? lst) (let loop ((lst lst) (yes '()) (no '())) (if (null? lst) (values (reverse yes) (reverse no)) (let ((first (car lst)) (rest (cdr lst))) (if (ok? first) (loop rest (cons first yes) no) (loop rest yes (cons first no))))))) (define (flatten tree) (let loop ((tree tree) (result '())) (cond ((null? tree) result) ((not (pair? tree)) (cons tree result)) (else (loop (car tree) (loop (cdr tree) result)))))) (define (remove-duplicates lst) (let loop ((lst lst) (result '())) (if (null? lst) (reverse result) (loop (cdr lst) (adjoin (car lst) result))))) (define (adjoin obj lst) (if (member obj lst) lst (cons obj lst))) (define (length-check pat seq) (if (list? pat) `(= ,(plength pat) (plength ,seq)) `(<= ,(plength pat) (plength ,seq)))) (define (mappend fn lists) ; mapcan in CL (apply append (map fn lists))) #|[ Graham's implementation of dbind, cf. On Lisp, p. 232, (define-syntax dbind (ir-macro-transformer (lambda (form inject compare?) (let ((pat (cadr form)) (seq (caddr form)) (xpr (cadddr form)) (xprs (cddddr form)) (gseq (gensym))) `(let ((,gseq ,seq)) ,(dbind-ex (destruc pat gseq) xpr . xprs)))))) uses the following two helpers, destruc and dbind-ex. (define (destruc pat seq) (let loop ((pat pat) (seq seq) (n 0)) (if (pair? pat) (let ((p (car pat)) (recu (loop (cdr pat) seq (+ n 1)))) (if (symbol? p) (cons `(,p (list-ref ,seq ,n)) recu) (let ((g (gensym))) (cons (cons `(,g (list-ref ,seq ,n)) (loop p g 0)) recu)))) (let ((tail `(list-tail ,seq ,n))) (if (null? pat) '() `((,pat ,tail))))))) (define (dbind-ex binds body) (define (mappend fn lists) (apply append (map fn lists))) (if (null? binds) `(begin ,@body) `(let ,(map (lambda (b) (if (pair? (car b)) (car b) b)) binds) ,(dbind-ex (mappend (lambda (b) (if (pair? (car b)) (cdr b) '())) binds) body)))) They are quite simple, but we'll have to modify them by two reasons. First, they don't check seq's length. So (dbind (a) '(1 2) a) will happily return 1 without complaining. This might be ok for dbind itself and bind, but it will cause problems for bind-case. Second, it can't cope with literals. So (dbind (a "a") '(1 "a") a) would fail because (let (("a" 1)) ...) fails miserably. Again, literals are not really needed in dbind and bind, but in bind-case and macro-rules they are essential. To cope with these problems, the version of destruc below will return three values, each of which is handled by its own routine, dbind-ex, dbind-lit and dbind-len respectively. Another addition to dbind is to allow for fenders: The first expression in the body can impose restrictions on the bound identifiers. ]|# (define (destruc pat seq) (let loop ((pat pat) (seq seq) (n 0)) (if (pair? pat) (let ((p (car pat))) (call-with-values (lambda () (loop (cdr pat) seq (+ n 1))) (lambda (rec-ex rec-lit rec-len) (if (pair? p) (let ((g (gensym)) (v `(plist-ref ,seq ,n))) (call-with-values (lambda () (loop p g 0)) (lambda (g-ex g-lit g-len) (values (cons (cons `(,g (plist-ref ,seq ,n)) g-ex) rec-ex) (cons (cons `(,g (plist-ref ,seq ,n)) g-lit) rec-lit) (append (substitute* g v g-len) rec-len))))) (if (symbol? p) (values (cons `(,p (plist-ref ,seq ,n)) rec-ex) rec-lit rec-len) (values rec-ex (cons `(,p (plist-ref ,seq ,n)) rec-lit) rec-len)))))) (let ((tail `(plist-tail ,seq ,n))) (if (null? pat) ; ok (values '() '() `(,(length-check pat tail))) (if (symbol? pat) (values `((,pat ,tail)) '() `(,(length-check pat tail))) (values '() `((,pat ,tail)) `(,(length-check pat tail))))))))) ;; to be called with destruc's first return value (define (dbind-ex binds body) (if (null? binds) `(if ,(car body) (begin ,@(cdr body)) (signal (bind-exception 'dbind-ex "fenders not passed" ',(car body)))) `(let ,(map (lambda (b) (if (pair? (car b)) (car b) b)) binds) ,(dbind-ex (mappend (lambda (b) (if (pair? (car b)) (cdr b) '())) binds) body)))) ;; to be called with destruc's second return value (define (dbind-lit literals) (if (null? literals) #t (let ((pairs (map (lambda (b) (if (pair? (car b)) (car b) b)) literals))) (receive (syms lits) (filter (lambda (p) (symbol? (car p))) pairs) `(let ,syms (if (and ,@(map (lambda (s) (cons 'equal? s)) lits)) ,(dbind-lit (mappend (lambda (b) (if (pair? (car b)) (cdr b) '())) literals)) (signal (bind-exception 'dbind-lit "literals don't match" ',lits)))))))) ;; to be called with destruc's third return value (define (dbind-len length-checks) `(and ,@length-checks)) ;;; Please note, that these four helpers needn't care for renaming, ;;; since we'll implement dbind as an implicit renaming macro, which ;;; does the renaming automatically behind the scene. Even the gensym ;;; could be avoided by the same reason. But I prefer to have differnt ;;; names for repeated calls of a renaming procedure, which is ;;; guaranteed by gensym but violated by rename. ) ; module macro-helpers #|[ Low-level-macros made easy ========================== As an application of our binding macros, especially bind and bind-case, we will now provide macros define-macro, letrec-macro and let-macro as well as macro-rules to make writing low-level macros easy. ]|# (module low-level-macros (export low-level-macros bind bind-case dbind macro-rules define-macro let-macro letrec-macro once-only with-gensyms define-syntax-rule) (import scheme (only macro-helpers bind-exception) (only chicken condition-case print current-exception-handler make-property-condition condition-predicate get-condition-property signal abort)) (reexport (only macro-helpers bind-exception plength plist-ref plist-tail)) ;destruc dbind-ex dbind-lit dbind-len)) (import-for-syntax (only macro-helpers extract plength plist-tail plist-ref prefixed-with? strip-prefix destruc dbind-len dbind-lit dbind-ex) (only chicken receive condition-case)) (define (low-level-macros) '(bind-exception bind bind-case macro-rules define-macro let-macro letrec-macro once-only with-gensyms define-syntax-rule bind-exception plength plist-ref plist-tail)) ;;; set parameter current-exception-handler to handle bind-exceptions (current-exception-handler (let ((old-handler (current-exception-handler))) (lambda (var) (if ((condition-predicate 'bind) var) (begin (display "Error: ") (print (get-condition-property var 'bind 'location)) (print (get-condition-property var 'bind 'message)) (for-each print (get-condition-property var 'bind 'arguments)) (abort (make-property-condition 'exn 'message "exception-handler returned"))) (old-handler var))))) #|[ Now we'll extend Graham's dbind, allowing non-symbols in the patterns, which must be equal to the corresponding values in the template for a match. This is the reason, why we needed an additional helper, dbind-lit besides dbind-ex as well as a destruc, which returns two values. Since Graham's code doesn't check the length of the seq argument, still another helper is used, matchable? ]|# (define-syntax dbind (ir-macro-transformer (lambda (form inject compare?) (let ((pat (cadr form)) (seq (caddr form)) (body (cdddr form)) (gseq (gensym 'seq))) `(let ((,gseq ,seq)) ,(receive (symbols literals checks) (destruc pat gseq) `(if ,(dbind-len checks) (if ,(dbind-lit literals) ,(dbind-ex symbols body) (signal (bind-exception 'dbind "literals don't match" ',literals))) (signal (bind-exception 'dbind "not matchable" ',pat ,gseq))))))))) ; ,(call-with-values ; (lambda () (destruc pat gseq)) ; (lambda (symbols literals checks) ; `(if ,(dbind-len checks) ; (if ,(dbind-lit literals) ; ,(dbind-ex symbols body) ; (signal ; (bind-exception 'dbind ; "literals don't match" ; ',literals))) ; (signal (bind-exception 'dbind ; "not matchable" ; ',pat ,gseq)))))))))) #|[ The following two macros are simplyfied versions of equally named macros from the bindings module, restricting sequences to lists and pseudolists. This is sufficient for destructuring macro-arguments. The first is a variant of Common Lisp's destructuring-bind. ]|# ;;; (bind pat seq (where . fenders) .. xpr . xprs) ;;; ---------------------------------------------- ;;; binds pattern variables of pat to corresponding subexpressions of ;;; seq and executes tthe body xpr . xprs in this context. If a where ;;; expression is supplied, all fenders must return #t for seq to be ;;; successfully bound. (define-syntax bind (syntax-rules (where) ((_ pat seq (where . fenders) xpr . xprs) (dbind pat seq (and . fenders) xpr . xprs)) ((_ pat seq xpr . xprs) (dbind pat seq #t xpr . xprs)))) ;; old version which doesn't handle match of literals ;(define-syntax bind ; (syntax-rules (where) ; ((_ pat seq (where . fenders) xpr . xprs) ; (bind pat seq ; (if (and . fenders) ; (begin xpr . xprs) ; (signal (bind-exception pat seq . fenders))))) ; ((_ (a . b) seq xpr . xprs) ; (let ((seq1 seq)) ; (if (pair? seq1) ; (bind a (car seq1) ; (bind b (cdr seq1) xpr . xprs)) ; (signal (bind-exception (a . b) seq1))))) ; ((_ () seq xpr . xprs) ; (let ((seq1 seq)) ; (if (null? seq1) ; (let () xpr . xprs) ; (signal (bind-exception () seq1))))) ; ((_ a seq xpr . xprs) ; (let ((seq1 seq)) ; (let ((a seq1)) xpr . xprs))))) #|[ The following macro does more or less the same what the match macro from the matchable package does, for example (bind-case '(1 (2 3)) ((x y) (where (list? y)) (list x y)) ((x (y . z)) (list x y z)) ((x (y z)) (list x y z))) ;-> '(1 2 (3)) or, to give a more realistic example, mapping: (define (my-map fn lst) (bind-case lst (() '()) ((x . xs) (cons (fn x) (my-map fn xs))))) ]|# ;;; (bind-case seq (pat (where . fenders) .. xpr . xprs) ....) ;;; ---------------------------------------------------------- ;;; Checks if seq matches pattern pat [satisfying fenders] .... ;;; in sequence, binds the pattern variables of the first matching ;;; pattern to corresponding subexpressions of seq and executes ;;; corresponding body xpr . xprs (define-syntax bind-case (syntax-rules (where) ((_ seq (pat (where . fenders) xpr . xprs) . clauses) (condition-case (dbind pat seq (and . fenders) xpr . xprs) ;(condition-case (bind pat seq (where . fenders) xpr . xprs) ((exn bind) (bind-case seq . clauses)))) ((_ seq (pat xpr . xprs) . clauses) (condition-case (dbind pat seq #t xpr . xprs) ;(condition-case (bind pat seq xpr . xprs) ((exn bind) (bind-case seq . clauses)))) ((_ seq) (signal (bind-exception 'bind-case "no rule matches" seq))) )) ;;; (define-macro (name . args) ;;; [(with-inject-prefix pre | (with-rename-prefix pre)] ;;; [(with-keywords (x y ...)] ;;; . body))) ;;; ---------------------------------------------------------------------------- (define-syntax define-macro (ir-macro-transformer (lambda (f i c?) (let ((pat (cadr f)) (body (caddr f))) (let ( (type (cond ((c? (car body) 'with-rename-prefix) 'er) ((c? (car body) 'with-inject-prefix) 'ir) (else 'no))) ) (let ( (transformer (case type ((er) 'er-macro-transformer) (else 'ir-macro-transformer))) (rename-or-inject (case type ((er) 'rename) (else 'inject))) (body (case type ((no) body) (else (caddr body)))) (pre (case type ((no) #f) (else (cadr body)))) (process (lambda (p keys) (map (lambda (x y) `(compare? ,x ,y)) (extract (lambda (a) (memq a keys)) (cdr p)) (map (lambda (b) `',b) (extract (lambda (a) (memq a keys)) (cdr p)))))) ) (let ((keywords? (c? (car body) 'with-keywords))) (cond ((and pre keywords?) (let ((keywords (cadr body)) (body (caddr body))) `(define-syntax ,(car pat) (,transformer (lambda (form ,rename-or-inject compare?) (condition-case (dbind ,(cdr pat) (cdr form) (and ,@(process (cdr pat) keywords)) (let ,(map (lambda (s) `(,s (,rename-or-inject ',(strip-prefix (i pre) (i s))))) (extract (prefixed-with? (i pre)) body)) ,body)) ((exn bind) (signal (bind-exception 'define-macro "no match"))))))))) (pre `(define-syntax ,(car pat) (,transformer (lambda (form ,rename-or-inject compare?) (condition-case (dbind ,(cdr pat) (cdr form) #t (let ,(map (lambda (s) `(,s (,rename-or-inject ',(strip-prefix (i pre) (i s))))) (extract (prefixed-with? (i pre)) body)) ,body)) ((exn bind) (signal (bind-exception 'define-macro "no match")))))))) (keywords? (let ((keywords (cadr body)) (body (caddr body))) `(define-syntax ,(car pat) (ir-macro-transformer (lambda (form inject compare?) (condition-case (dbind ,(cdr pat) (cdr form) (and ,@(process (cdr pat) keywords)) ,body) ((exn bind) (signal (bind-exception 'define-macro "no match"))))))))) (else `(define-syntax ,(car pat) (ir-macro-transformer (lambda (form inject compare?) (condition-case (dbind ,(cdr pat) (cdr form) #t ,body) ((exn bind) (signal (bind-exception 'define-macro "no match")))))))))))))))) ;;; (letrec-macro ((macro-code tpl) ...) . body) ;;; -------------------------------------------- ;;; defines local macros by binding recursively macro-codes to templates ;;; and evaluating body in this context. (define-syntax letrec-macro (er-macro-transformer (lambda (f r c?) (let ((binds (cadr f)) (body (cddr f)) (%letrec-syntax (r 'letrec-syntax))) `(,%letrec-syntax ,(map (lambda (m) `(,(cadr m) ,(caddr m))) (map (lambda (b) (expand `(define-macro ,@b))) binds)) ,@body))))) ;;; (let-macro ((macro-code tpl) ...) . body) ;;; ----------------------------------------- ;;; defines local macros by binding in parallel macro-codes to templates ;;; and evaluating body in this context. (define-syntax let-macro (er-macro-transformer (lambda (f r c?) (let ((binds (cadr f)) (body (cddr f)) (%let-syntax (r 'let-syntax))) `(,%let-syntax ,(map (lambda (m) `(,(cadr m) ,(caddr m))) (map (lambda (b) (expand `(define-macro ,@b))) binds)) ,@body))))) ;;; (macro-rules sym ... (keyword ...) ;;; (pat0 tpl0) (pat1 tpl1) ...) ;;; ---------------------------------- ;;; where sym ... are injected non-hygienig symbols, keyword ... are ;;; additionl keywords, pat0 pat1 ... are nested lambda-lists without ;;; spezial meaning of ellipses and tpl0 tpl1 ... evaluate to ;;; quasiquoted templates. (define-syntax macro-rules (ir-macro-transformer (lambda (f i c?) ;; head is list of injected syms, tail starts with keyword-list (receive (tail head) (let loop ((tail (cdr f)) (head '())) (if (list? (car tail)) ; keyword list (values tail head) (loop (cdr tail) (cons (car tail) head)))) (let ((keywords (car tail)) (rules (cdr tail)) (inject-sym (lambda (h) `(,h (inject ',h))))) (if (null? rules) `(signal (bind-exception 'macro-rules "no rule matches")) (let* ( (extract-keywords (lambda (r) (extract (lambda (y) (memq y keywords)) r))) (process-rule ;;; bind-case (lambda (r) `(,(car r) (where ,@(map (lambda (p s) `(compare? ,p ,s)) (extract-keywords (cadar r)) ;(cdr r)(cadar r) (map (lambda (x) `',x) (extract-keywords (cadar r))))) ,(cadr r)))) ) (cond ((and (null? head) (null? keywords)) ; no injected symbols, no additional keywords `(ir-macro-transformer (lambda (form inject compare?) (bind-case form ,@rules)))) ((null? head) ; no injected symbols `(ir-macro-transformer (lambda (form inject compare?) (bind-case form ,@(map process-rule rules))))) ((null? keywords) ;; no additional keywords `(ir-macro-transformer (lambda (form inject compare?) (let ,(map inject-sym head) (bind-case form ,@rules))))) (else ; both injected symbols and additional keywords `(ir-macro-transformer (lambda (form inject compare?) (let ,(map inject-sym head) (bind-case form ,@(map process-rule rules)))))))))))))) ;(define-syntax macro-rules ; (ir-macro-transformer ; (lambda (f i c?) ; ;; head becomes list of injected syms, tail starts with keyword-list ; (receive (tail head) ; (let loop ((tail (cdr f)) (head '())) ; (if (list? (car tail)) ; keyword list ; (values tail head) ; (loop (cdr tail) (cons (car tail) head)))) ; (let ((inject-sym (lambda (h) `(,h (inject ',h))))) ; ;(let ((keywords (car tail)) ; ; (rule (cdadr tail)) ; ; (rules (map cdr (cddr tail)))) ; (let ((keywords (car tail)) (rules (cdr tail))) ; (if (null? rules) ; `(signal (bind-exception 'macro-rules "no rule matches")) ; ;(let ((keywords (car tail)) (rule (cadr tail)) (rules (cddr tail))) ; ;(print "rule " rule) ; ;(print "head " head) ; ;(print "tail " tail) ; ;(print "keywords " keywords) ; ;(print "car rule " (car rule)) ; ;(print "cdr rule " (cdr rule)) ; ;(print "cdar rule " (cdar rule)) ; ;(print "cadr rule " (cadr rule)) ; ;(print "cadar rule " (cadar rule)) ; ;(print "rules " rules) ; (let* ( ; (extract-keywords ; (lambda (r) (extract (lambda (y) (memq y keywords)) r))) ; (process-rule ;;; bind-case ; (lambda (r) ; `(,(car r) ; (where ,@(map (lambda (p s) `(compare? ,p ,s)) ; (extract-keywords (cadar r)) ;(cdr r)(cadar r) ; (map (lambda (x) `',x) ; (extract-keywords (cadar r))))) ; ,(cadr r)))) ; (process ;;; dbind ; (lambda (p keys) ; (map (lambda (x y) `(compare? ,x ,y)) ; (extract (lambda (a) (memq a keys)) (cdr p)) ; (map (lambda (b) `',b) ; (extract (lambda (a) (memq a keys)) (cdr p)))))) ; ) ; (cond ; ((and (null? head) (null? keywords)) ; ; no injected symbols, no additional keywords ; `(ir-macro-transformer ; (lambda (form inject compare?) ; ;(bind-case (cdr form) ,(cdr rule) ,@(map cdr rules))))) ; (condition-case ; (dbind ,(cdaar rules) (cdr form) #t ,@(cdar rules)) ; ;(dbind ,(cdar rule) (cdr form) #t ,@(cdr rule)) ; ;(dbind ,(car rule) form #t ,@(cdr rule)) ; ((exn); bind) ; ;(if ,(null? rules) ; ; (signal (bind-exception 'macro-rules ; ; "no rule matches")) ; (macro-rules () ,@(cdr rules))))))) ; ;(macro-rules () ,@rules))))))) ; ;(bind-case ;(cdr form) ; ; form ; ; ,rule ,@rules)))) ; ((null? head) ; ; no injected symbols ; `(ir-macro-transformer ; (lambda (form inject compare?) ; ;(print "wwww " ',(car rule)) ; ;(print "xxxx " ',keywords) ; ;(print "yyyy " ',(extract-keywords (car rule))) ; ;(bind-case (cdr form) ; ; ,(process-rule (cdr rule)) ; ; ,@(map process-rule (map cdr rules)))))) ; (condition-case ; (dbind ,(cdaar rules) (cdr form) ; ;(dbind ,(cdar rule) (cdr form) ; ;(dbind ,(car rule) form ; (and ,@(process (caar rules) keywords)) ; ;(and ,@(process (car rule) keywords)) ; ,@(cdar rules)) ; ;,@(cdr rule)) ; ((exn); bind) ; ;(if ,(null? rules) ; ; (signal (bind-exception 'macro-rules ; ; "no rule matches")) ; (macro-rules ,keywords ; ;,@(map process-rule rules))))))) ; ,@(cdr rules))))))) ; ;,@rules))))))) ; ;(bind-case ;(cdr form) ; ; form ; ; ,(process-rule rule) ; ; ,@(map process-rule rules))))) ; ((null? keywords) ; ;; no additional keywords ; `(ir-macro-transformer ; (lambda (form inject compare?) ; (let ,(map inject-sym head) ; ;(bind-case (cdr form) ,(cdr rule) ,@(map cdr rules)))))) ; (condition-case ; (dbind ,(cdaar rules) (cdr form) #t ,@(cdar rules)) ; ;(dbind ,(cdar rule) (cdr form) #t ,@(cdr rule)) ; ;(dbind ,(car rule) form #t ,@(cdr rule)) ; ((exn); bind) ; ;(if ,(null? rules) ; ; (signal (bind-exception 'macro-rules ; ; "no rule matches")) ; (macro-rules ,@head () ,@(cdr rules)))))))) ; ;(macro-rules ,@head () ,@rules)))))))) ; ;(bind-case ;(cdr form) ; ; form ; ; ,rule ,@rules))))) ; (else ; ; both injected syms and keywords ; `(ir-macro-transformer ; (lambda (form inject compare?) ; (let ,(map inject-sym head) ; ;(bind-case form ; ; ,(process-rule (cdr rule)) ; ; ,@(map process-rule (map cdr rules))))))))))))))) ; (condition-case ; (dbind ,(cdaar rules) (cdr form) ; ;(dbind ,(cdar rule) (cdr form) ; ;(dbind ,(car rule) form ; (and ,@(process (caar rules) keywords)) ; ;(and ,@(process (car rule) keywords)) ; ,@(cdar rules)) ; ;,@(cdr rule)) ; ((exn); bind) ; ;(if ,(null? rules) ; ; (signal (bind-exception 'macro-rules ; ; "no rule matches")) ; (macro-rules ,@head ,keywords ; ;,@(map process-rule rules)))))))))))))))) ; ,@(cdr rules)))))))))))))))) ) ; ;,@rules)))))))))))))))) ) ; ;(bind-case ;(cdr form) ; ; form ; ; ,(process-rule rule) ; ; ,@(map process-rule rules)))))))))))))) #|[ The following three macros are here for convenience. The first two are of great help in writing low-level-macros, the last ony simplifies high-level macros without additional keywords and only one rule - it's defined in miscmacros as well. ]|# ;;; (once-only (x ...) . body) ;;; -------------------------- ;;; macro-arguments x ... are only evaluated once and from left to right (define-syntax once-only ; ok (er-macro-transformer (lambda (form rename compare?) (let ((names (cadr form)) (body (cddr form)) (%let (rename 'let)) (%list (rename 'list)) (%gensym (rename 'gensym))) (let ((gensyms (map gensym names))) `(,%let ,(map (lambda (g) `(,g (,%gensym))) gensyms) (,%list ',%let ,(cons %list (map (lambda (g n) `(,%list ,g ,n)) gensyms names)) (,%let ,(map (lambda (n g) `(,n ,g)) names gensyms) ,@body)))))))) ;;; (with-gensyms (name ...) . body) ;;; -------------------------------- ;;; binds name ... to (gensym 'name) ... in body (define-syntax with-gensyms (ir-macro-transformer (lambda (form inject compare?) `(let ,(map (lambda (n) `(,n (gensym ',n))) (cadr form)) ,@(cddr form))))) ;;; (define-syntax-rule (macro-code) tpl) ;;; ------------------------------------- ;;; simplyfies define-syntax in case there are no auxiliary keywords ;;; and only one syntax-rule. (define-syntax define-syntax-rule (syntax-rules () ((_ (name . args) tpl) (define-syntax name (syntax-rules () ((_ . args) tpl)))))) ) ; module low-level-macros ;(use simple-tests) ;(import macro-helpers low-level-macros) ;(import-for-syntax (only low-level-macros macro-rules bind-case))