diff options
Diffstat (limited to 'Macro.scm')
| -rw-r--r-- | Macro.scm | 449 |
1 files changed, 283 insertions, 166 deletions
@@ -15,26 +15,26 @@ ;; the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. ;; ;; As a special exception, the Free Software Foundation gives permission -;; for additional uses of the text contained in its release of GUILE. +;; for additional uses of the text contained in its release of SCM. ;; -;; The exception is that, if you link the GUILE library with other files +;; The exception is that, if you link the SCM library with other files ;; to produce an executable, this does not by itself cause the ;; resulting executable to be covered by the GNU General Public License. ;; Your use of that executable is in no way restricted on account of -;; linking the GUILE library code into it. +;; linking the SCM library code into it. ;; ;; This exception does not however invalidate any other reasons why ;; the executable file might be covered by the GNU General Public License. ;; ;; This exception applies only to the code released by the -;; Free Software Foundation under the name GUILE. If you copy +;; Free Software Foundation under the name SCM. If you copy ;; code from other Free Software Foundation releases into a copy of -;; GUILE, as the General Public License permits, the exception does +;; SCM, as the General Public License permits, the exception does ;; not apply to the code that you add in this way. To avoid misleading ;; anyone as to the status of such modified files, you must delete ;; this exception notice from them. ;; -;; If you write modifications of your own for GUILE, it is your choice +;; If you write modifications of your own for SCM, it is your choice ;; whether to permit this exception to apply to your modifications. ;; If you do not wish that, delete this exception notice. @@ -56,12 +56,19 @@ ;; We keep local copies of these standard special forms, otherwise, ;; redefining them before they are memoized below can lead to ;; infinite recursion. - (@let-syntax ((lambda (the-macro lambda)) + (let-syntax ((lambda (the-macro lambda)) + (begin (the-macro begin)) + (quote (the-macro quote)) (let (the-macro let)) - (cond (the-macro cond)) - (if (the-macro if)) + (let* (the-macro let*)) + (letrec (the-macro letrec)) (and (the-macro and)) - (or (the-macro or))) + (or (the-macro or)) + (delay (the-macro delay)) + (do (the-macro do)) + (case (the-macro case)) + (cond (the-macro cond)) + (quasiquote (the-macro quasiquote))) (let ((var-rtd (make-record-type '? '(name rank))) (e-pat-rtd (make-record-type '... '(pattern vars))) (rule-rtd (make-record-type 'rule '(pattern inserted template)))) @@ -83,7 +90,8 @@ (define ellipsis-pattern->pattern (record-accessor e-pat-rtd 'pattern)) (define ellipsis-pattern->vars (record-accessor e-pat-rtd 'vars)) - (define rule (record-constructor rule-rtd '(pattern inserted template))) + (define make-rule + (record-constructor rule-rtd '(pattern inserted template))) (define rule->pattern (record-accessor rule-rtd 'pattern)) (define rule->inserted (record-accessor rule-rtd 'inserted)) (define rule->template (record-accessor rule-rtd 'template)) @@ -92,6 +100,12 @@ (if (null? y) x (append x y))) + (define (append-if pred x y) + (let recur ((x x)) + (cond ((null? x) y) + ((pred (car x)) (cons (car x) (recur (cdr x)))) + (else (recur (cdr x)))))) + (define ellipsis? (let (($... (renamed-identifier '... #f))) (lambda (x env) @@ -108,111 +122,130 @@ (duplicates? (cdr vars))))) (define (compile-pattern literals rule-exp env-def) - (let recur ((pat (cdar rule-exp)) - (vars '()) - (rank 0) - (k (lambda (compiled vars) - (let ((dup (duplicates? (map car vars)))) - (if dup - (error - "syntax-rules: duplicate pattern variable:" - dup " in rule " rule-exp))) - (apply rule - compiled - (rewrite-template - (cadr rule-exp) vars env-def))))) + (define (compile1 pat vars rank ell? k) (cond ((null? pat) (k pat vars)) ((identifier? pat) - (let ((lit (memq pat literals))) - (if lit - (k (renamed-identifier pat env-def) vars) - (let ((var (pattern-variable pat rank))) - (k var (cons (cons pat var) vars)))))) - ((pair? pat) - (if (and (pair? (cdr pat)) - (ellipsis? (cadr pat) env-def) - (or (null? (cddr pat)) - (error "bad ellipsis:" pat))) - (if (ellipsis? (car pat) env-def) - (recur (car pat) vars rank k) - (recur (car pat) '() (+ rank 1) - (lambda (comp1 vars1) - (k (list - (ellipsis-pattern comp1 (map cdr vars1))) - (append2 vars1 vars))))) - (recur (car pat) '() rank - (lambda (comp1 vars1) - (recur (cdr pat) vars rank - (lambda (comp2 vars2) - (k (cons comp1 comp2) - (append2 vars1 vars2)))))))) + (if (or (memq pat literals) + (and (not ell?) (ellipsis? pat env-def))) + (k (renamed-identifier pat env-def) vars) + (let ((var (pattern-variable pat rank))) + (k var (cons (cons pat var) vars))))) ((vector? pat) - (recur (vector->list pat) vars rank - (lambda (comp vars) - (k (list->vector comp) vars)))) - (else - (k pat vars))))) + (compile1 (vector->list pat) vars rank ell? + (lambda (comp vars) + (k (list->vector comp) vars)))) + ((not (pair? pat)) + (k pat vars)) + ((and ell? (ellipsis? (car pat) env-def)) + (or (and (pair? (cdr pat)) + (null? (cddr pat))) + (error "bad ellipsis quote:" pat)) + (compile1 (cadr pat) vars rank #f k)) + ((and ell? + (pair? (cdr pat)) + (ellipsis? (cadr pat) env-def)) + (or (null? (cddr pat)) + (error "bad ellipsis:" pat)) + (compile1 + (car pat) '() (+ rank 1) ell? + (lambda (comp1 vars1) + (k (list + (ellipsis-pattern comp1 (map cdr vars1))) + (append2 vars1 vars))))) + (else ; pat is a pair + (compile1 + (car pat) '() rank ell? + (lambda (comp1 vars1) + (compile1 + (cdr pat) vars rank ell? + (lambda (comp2 vars2) + (k (cons comp1 comp2) + (append2 vars1 vars2))))))))) + (let ((pat (car rule-exp)) + (tmpl (cadr rule-exp))) + (if (identifier? pat) + (apply make-rule #f (rewrite-template tmpl '() env-def)) + (compile1 + (cdr pat) '() 0 #t + (lambda (compiled vars) + (let ((dup (duplicates? (map car vars)))) + (if dup + (error + "syntax-rules: duplicate pattern variable:" + dup " in rule " rule-exp) + (apply make-rule + (cons #f compiled) + (rewrite-template tmpl vars env-def))))))))) (define (rewrite-template template vars env-def) - (let recur ((tmpl template) - (rank 0) - (inserted '()) - (k (lambda (compiled inserted opened) - (list inserted compiled)))) + (let rewrite1 ((tmpl template) + (rank 0) + (inserted '()) + (ell? #t) + (k (lambda (compiled inserted opened) + (list inserted compiled)))) (cond ((null? tmpl) (k tmpl '() '())) ((identifier? tmpl) (let ((v (assq tmpl vars))) - (if v - (cond ((= rank (pattern-variable->rank (cdr v))) - (k (cdr v) '() (list (cdr v)))) - ((> rank (pattern-variable->rank (cdr v))) - (k (cdr v) '() '())) - (else - (error "pattern variable rank mismatch:" tmpl - " in " template))) - (k tmpl (list tmpl) '())))) - ((pair? tmpl) - (if (and (pair? (cdr tmpl)) - (ellipsis? (cadr tmpl) env-def)) - (if (and (ellipsis? (car tmpl) env-def) - (or (null? (cddr tmpl)) - (error "bad ellipsis:" tmpl))) - ;; (... ...) escape - (k (car tmpl) (list (car tmpl)) '()) - (recur (car tmpl) (+ rank 1) '() - (lambda (comp1 ins1 op1) - (if (null? op1) - (error "Bad ellipsis:" - tmpl " in template " template)) - (recur (cddr tmpl) rank inserted - (lambda (comp2 ins2 op2) - (k (cons - (ellipsis-pattern comp1 op1) - comp2) - (append2 ins1 ins2) - (append2 op1 op2))))))) - (recur (car tmpl) rank '() - (lambda (comp1 ins1 op1) - (recur (cdr tmpl) rank inserted - (lambda (comp2 ins2 op2) - (k (cons comp1 comp2) - (append2 ins1 ins2) - (append2 op1 op2)))))))) + (cond ((not v) + (k tmpl (list tmpl) '())) + ((zero? (pattern-variable->rank (cdr v))) + (k (cdr v) '() '())) + ((>= rank (pattern-variable->rank (cdr v))) + (k (cdr v) '() (list (cdr v)))) + (else + (error "pattern variable rank mismatch:" tmpl + " in " template))))) ((vector? tmpl) - (recur (vector->list tmpl) rank inserted - (lambda (compiled inserted opened) - (k (list->vector compiled) inserted opened)))) - (else - (k tmpl '() '()))))) - + (rewrite1 + (vector->list tmpl) rank inserted ell? + (lambda (compiled inserted opened) + (k (list->vector compiled) inserted opened)))) + ((not (pair? tmpl)) + (k tmpl '() '())) + ((and ell? (ellipsis? (car tmpl) env-def)) + ;; (... ...) escape + (or (and (pair? (cdr tmpl)) + (null? (cddr tmpl))) + (error "Bad ellpsis quote:" tmpl + " in template " template)) + (rewrite1 (cadr tmpl) rank inserted #f k)) + ((and ell? + (pair? (cdr tmpl)) + (ellipsis? (cadr tmpl) env-def)) + (rewrite1 + (car tmpl) (+ rank 1) '() ell? + (lambda (comp1 ins1 op1) + (if (null? op1) + (error "Bad ellipsis:" tmpl + " in template " template)) + (rewrite1 + (cddr tmpl) rank inserted ell? + (lambda (comp2 ins2 op2) + (k (cons (ellipsis-pattern comp1 op1) + comp2) + (append2 ins1 ins2) + (append-if (lambda (op) + (> (pattern-variable->rank op) + rank)) + op1 op2))))))) + (else ; tmpl is a pair + (rewrite1 + (car tmpl) rank '() ell? + (lambda (comp1 ins1 op1) + (rewrite1 + (cdr tmpl) rank inserted ell? + (lambda (comp2 ins2 op2) + (k (cons comp1 comp2) + (append2 ins1 ins2) + (append2 op1 op2)))))))))) ;;; Match EXP to RULE, returning alist of variable bindings or #f. (define (match rule exp env-use) - (let recur ((r (rule->pattern rule)) - (x (cdr exp))) + (define (match1 r x) (cond ((null? r) (and (null? x) '())) ((pair? r) @@ -220,8 +253,8 @@ (and (list? x) (let ((pat (ellipsis-pattern->pattern (car r)))) - (let match1 ((x x) - (vals '())) + (let match-list ((x x) + (vals '())) (if (null? x) (if (null? vals) (map list (ellipsis-pattern->vars (car r))) @@ -230,14 +263,14 @@ (map (lambda (al) (map cdr al)) (reverse vals))))) - (let ((val (recur pat (car x)))) + (let ((val (match1 pat (car x)))) (and val - (match1 (cdr x) (cons val vals)))))))) + (match-list (cdr x) (cons val vals)))))))) (and (pair? x) - (let ((v1 (recur (car r) (car x)))) + (let ((v1 (match1 (car r) (car x)))) (and v1 - (let ((v2 (recur (cdr r) (cdr x)))) + (let ((v2 (match1 (cdr r) (cdr x)))) (and v2 (append2 v1 v2)))))))) ((identifier? r) ;literal (and (identifier? x) (identifier-equal? r x env-use) '())) @@ -245,16 +278,30 @@ (list (cons r x))) ((vector? r) (and (vector? x) - (recur (vector->list r) (vector->list x)))) + (match1 (vector->list r) (vector->list x)))) (else - (and (equal? r x) '()))))) + (and (equal? r x) '())))) + (let ((pat (rule->pattern rule))) + (if (pair? pat) + (and (pair? exp) + (match1 (cdr pat) (cdr exp))) + (if (pair? exp) #f '())))) + + (define (substitute-in-template x-use rule vars env-def) + (define (length-error pats vals) + (apply error + "syntax-rules: pattern variable length mismatch:\n" + x-use + (map (lambda (name val) + `(,(pattern-variable->name + name) -> ,val)) + pats vals))) - (define (substitute-in-template rule vars env-def) (let ((ins (map (lambda (id) (cons id (renamed-identifier id env-def))) (rule->inserted rule)))) - (let recur ((tmpl (rule->template rule)) - (vars vars)) + (let subst1 ((tmpl (rule->template rule)) + (vars vars)) (cond ((null? tmpl) tmpl) ((pair? tmpl) @@ -269,62 +316,75 @@ (if (pair? es) (if (= n (length (car es))) (check (cdr es)) - (error "syntax-rules: pattern variable length mismatch:")))) + (length-error enames evals)))) (append! (map (lambda (eval) - (recur etmpl - (append! - (map cons enames eval) - vars))) + (subst1 etmpl + (append! + (map cons enames eval) + vars))) (apply map list evals)) - (recur (cdr tmpl) vars))) - (cons (recur (car tmpl) vars) - (recur (cdr tmpl) vars)))) + (subst1 (cdr tmpl) vars))) + (cons (subst1 (car tmpl) vars) + (subst1 (cdr tmpl) vars)))) ((identifier? tmpl) (let ((a (assq tmpl ins))) (if a (cdr a) tmpl))) ((pattern-variable? tmpl) (@copy-tree (cdr (assq tmpl vars)))) ((vector? tmpl) - (list->vector (recur (vector->list tmpl) vars))) + (list->vector (subst1 (vector->list tmpl) vars))) (else tmpl))))) ;; MACRO:COMPILE-SYNTAX-RULES (lambda (x-def env-def) - (or (and (list? x-def) - (< 2 (length x-def)) - (list? (cadr x-def))) - (error "Malformed syntax-rules:" x-def)) - (let ((literals (cadr x-def))) - (for-each (lambda (x) - (or (identifier? x) - (error "Bad literals list:" x-def))) - literals) - (let ((rules (map (lambda (rule-expr) - (or (and (list? rule-expr) - (= 2 (length rule-expr)) - (pair? (car rule-expr))) - (error "Bad rule:" rule-expr)) - (compile-pattern literals rule-expr env-def)) - (cddr x-def)))) + (let ((x-def (remove-line-numbers! x-def))) + (or (and (list? x-def) + (< 2 (length x-def)) + (list? (cadr x-def))) + (error "Malformed syntax-rules:" x-def)) + (let ((literals (cadr x-def))) + (for-each (lambda (x) + (or (identifier? x) + (error "Bad literals list:" x-def))) + literals) + (let ((rules (map (lambda (rule-expr) + (or (and (list? rule-expr) + (= 2 (length rule-expr)) + (let ((pat (car rule-expr))) + (or (pair? pat) + (identifier? pat)))) + (error "Bad rule:" rule-expr)) + (compile-pattern literals rule-expr env-def)) + (cddr x-def)))) - (lambda (x-use env-use) - (let loop ((rules rules)) - (cond ((null? rules) - (error "macro use does not match definition:" - x-use)) - ((match (car rules) x-use env-use) - => (lambda (vars) - (substitute-in-template (car rules) vars env-def))) - (else - (loop (cdr rules)))))))))))) + (lambda (x-use env-use) + ;;FIXME We should use the line numbers. + (let ((x-use (remove-line-numbers! x-use))) + (let loop ((rules rules)) + (cond ((null? rules) + (error "macro use does not match definition:" + x-use)) + ((match (car rules) x-use env-use) + => (lambda (vars) + (substitute-in-template + x-use (car rules) vars env-def))) + (else + (loop (cdr rules)))))))))))))) -(define syntax-rules +(define-syntax syntax-rules (procedure->syntax (lambda (expr env-def) - (procedure->memoizing-macro - (macro:compile-syntax-rules expr env-def))))) + (let ((transformer (macro:compile-syntax-rules expr env-def))) + (let loop ((rules (cddr expr))) + (cond ((null? rules) + (procedure->memoizing-macro transformer)) + ((identifier? (caar rules)) + (procedure->identifier-macro transformer)) + (else + (loop (cdr rules))))))))) + ;; Explicit renaming macro facility, as in ;; W. Clinger, "Hygienic Macros Through Explicit Renaming" @@ -358,22 +418,79 @@ (lambda (exp env-def) `(,?transformer ,(cadr exp) (,?syntax-quote ,env-def)))))) -(define define-syntax - (syntax-rules () - ((define-syntax ?name ?val) - (define ?name (the-macro ?val))))) - -(define-syntax let-syntax - (syntax-rules () ((let-syntax ((?name ?val) ...) . ?body) - (@let-syntax - ((?name (the-macro ?val)) ...) . ?body)))) - -(define-syntax letrec-syntax - (syntax-rules () ((letrec-syntax ((?name ?val) ...) . ?body) - (@letrec-syntax - ((?name (the-macro ?val)) ...) . ?body)))) - -;; MACRO:EXPAND would require substantial work. (define macro:load load) (define macro:eval eval) +(define (macro:expand . args) + (load (in-vicinity (implementation-vicinity) "Macexp")) + (apply macro:expand args)) (provide 'macro) + +;; These are not part of the SYNTAX-RULES implementation, but I see +;; no better place to put them: + +;; A debugging utility macro that is easy to grep for. +(define-syntax @print + (syntax-rules (quote) + ((_ '?arg) + (begin (display '?arg) + (newline))) + ((_ ?arg) + (begin (display '?arg) + (display " => ") + (let ((x ?arg)) + (write x) + (newline) + x))) + ((_ ?arg1 ?arg ...) + (begin + (@print ?arg1) + (begin + (display " ") + (@print ?arg)) + ...)))) + +(define-syntax @pprint + (syntax-rules (quote) + ((_ '?arg) + (begin (display '?arg) + (newline))) + ((_ ?arg) + (begin (display '?arg) + (display " => ") + (let ((x ?arg)) + (pprint x) + (newline) + x))) + ((_ ?arg1 ?arg ...) + (begin + (@pprint ?arg1) + (begin + (display " ") + (@pprint ?arg)) + ...)))) + +;; Better run time error reporting than the version in Init*.scm, +;; also only takes a given car or cdr once. +(define-syntax destructuring-bind + (syntax-rules () + ((_ "PARSE-LLIST" () ?val ?body ?err) + (if (null? ?val) ?body (?err '() ?val))) + ((_ "PARSE-LLIST" (?name1 . ?rest) ?val ?body ?err) + (if (pair? ?val) + (let ((carv (car ?val)) + (cdrv (cdr ?val))) + (destructuring-bind "PARSE-LLIST" ?name1 carv + (destructuring-bind "PARSE-LLIST" ?rest cdrv ?body ?err) + ?err)) + (?err '(?name1 . ?rest) ?val))) + ((_ "PARSE-LLIST" ?name ?val ?body ?err) + (let ((?name ?val)) ?body)) + ((_ ?llist ?val ?body1 ?body ...) + (let ((err (lambda (pat val) + (slib:error 'destructuring-bind '?llist + val "does not match" pat))) + (val ?val)) + (destructuring-bind "PARSE-LLIST" ?llist val + ;;Use LET to allow internal DEFINE in body. + (let () ?body1 ?body ...) + err))))) |