summaryrefslogtreecommitdiffstats
path: root/Macro.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:26 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:26 -0800
commitdeda2c0fd8689349fea2a900199a76ff7ecb319e (patch)
treec9726d54a0806a9b0c75e6c82db8692aea0053cf /Macro.scm
parent3278b75942bdbe706f7a0fba87729bb1e935b68b (diff)
downloadscm-deda2c0fd8689349fea2a900199a76ff7ecb319e.tar.gz
scm-deda2c0fd8689349fea2a900199a76ff7ecb319e.zip
Import Upstream version 5d6upstream/5d6
Diffstat (limited to 'Macro.scm')
-rw-r--r--Macro.scm449
1 files changed, 283 insertions, 166 deletions
diff --git a/Macro.scm b/Macro.scm
index 0ddccc1..911098b 100644
--- a/Macro.scm
+++ b/Macro.scm
@@ -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)))))