diff options
Diffstat (limited to 'mbe.scm')
| -rw-r--r-- | mbe.scm | 72 |
1 files changed, 35 insertions, 37 deletions
@@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; @@ -18,7 +18,7 @@ ;each case. ;;; revised Dec. 6, 1993 to R4RS syntax (if not semantics). -;;; revised Mar. 2 1994 for SLIB (jaffer@ai.mit.edu). +;;; revised Mar. 2 1994 for SLIB (agj @ alum.mit.edu). ;;; corrections, Apr. 24, 1997. ;;; corr., Jan. 30, 1999. (mflatt@cs.rice.edu, dorai@cs.rice.edu) @@ -27,9 +27,8 @@ ;;; defmacro. (require 'common-list-functions) ;nconc, some, every -;(require 'rev2-procedures) ;append! alternate for nconc (require 'rev4-optional-procedures) ;list-tail -(require 'defmacroexpand) +(require 'defmacroexpand) ;defmacro:expand* (define hyg:rassq (lambda (k al) @@ -401,43 +400,42 @@ (define mbe:ellipsis? (lambda (x) (and (pair? x) (pair? (cdr x)) (eq? (cadr x) '...)))) +;@ +(define macro:eval slib:eval) +(define macro:load slib:load) +(define macro:expand defmacro:expand*) -;define-syntax - +;@ define-syntax (defmacro define-syntax (macro-name syn-rules) (if (or (not (pair? syn-rules)) - (not (eq? (car syn-rules) 'syntax-rules))) - (slib:error 'define-syntax 'not-an-r4rs-high-level-macro - macro-name syn-rules) - (let ((keywords (cons macro-name (cadr syn-rules))) - (clauses (cddr syn-rules))) - `(defmacro ,macro-name macro-arg - (let ((macro-arg (cons ',macro-name macro-arg)) - (keywords ',keywords)) - (cond ,@(map - (lambda (clause) - (let ((in-pattern (car clause)) + (not (eq? (car syn-rules) 'syntax-rules))) + (slib:error 'define-syntax 'not-an-r4rs-high-level-macro + macro-name syn-rules) + (let ((keywords (cons macro-name (cadr syn-rules))) + (clauses (cddr syn-rules))) + `(defmacro ,macro-name macro-arg + (let ((macro-arg (cons ',macro-name macro-arg)) + (keywords ',keywords)) + (cond ,@(map + (lambda (clause) + (let ((in-pattern (car clause)) (out-pattern (cadr clause))) - `((mbe:matches-pattern? ',in-pattern macro-arg - keywords) + `((mbe:matches-pattern? ',in-pattern macro-arg + keywords) (let ((tagged-out-pattern+alist - (hyg:tag - ',out-pattern - (nconc (hyg:flatten ',in-pattern) - keywords) '()))) + (hyg:tag + ',out-pattern + (nconc (hyg:flatten ',in-pattern) + keywords) '()))) (hyg:untag - (mbe:expand-pattern - (car tagged-out-pattern+alist) - (mbe:get-bindings ',in-pattern macro-arg - keywords) - keywords) - (cdr tagged-out-pattern+alist) - '()))))) - clauses) - (else (slib:error ',macro-name 'no-matching-clause - ',clauses)))))))) + (mbe:expand-pattern + (car tagged-out-pattern+alist) + (mbe:get-bindings ',in-pattern macro-arg + keywords) + keywords) + (cdr tagged-out-pattern+alist) + '()))))) + clauses) + (else (slib:error ',macro-name 'no-matching-clause + ',clauses)))))))) -(define macro:eval slib:eval) -(define macro:load slib:load) -(provide 'macro) -;eof |