Switch branches/tags
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
305 lines (288 sloc) 9.06 KB
;;; cogen-macro
;;; macro expansion using syntax-rules
;;; copyright © 1997, 1998 by Peter Thiemann
;;; non-commercial use is free as long as the original copright notice
;;; remains intact
(define repeated?
(lambda (pattern)
(and (syntax-pair? (syntax-cdr pattern))
(syntax-eq-symbol? '... (cadr pattern) (empty-boxed-env)))))
;;; an environment maps a pattern variable to (multiplicity value)
;;; where multiplicity indicates the nesting depth of list constructors
;;; in value, i.e., value = list^multiplicity (primitive value)
;;; ATTENTION: pattern and template may also contain marks!
;;; match <pattern> against <subject>
;;; treating <literals> as literal symbols
;;; returns #f if matching fails, otherwise an environment as described above
;;; needs the call time symbol table <symtab>
(define (build-env pattern subject literals symtab*)
(lambda (exit)
(lambda ()
(exit #f)))
(lambda (binding . bindings) ;not empty
`(,(car binding)
,(+ 1 (cadr binding))
,(map caddr (cons binding bindings)))))
(lambda (pattern)
((null? pattern)
((symbol? pattern)
(if (memq pattern literals)
`((,pattern 0 ()))))
((pair? pattern)
(if (repeated? pattern)
(map (lambda (binding)
`(,(car binding) ,(+ 1 (cadr binding)) ()))
(build-empty-env (car pattern)))
(append (build-empty-env (car pattern))
(build-empty-env (cdr pattern)))))
(let loop ((pattern pattern) (subject subject))
((syntax-null? pattern)
(if (syntax-null? subject)
((syntax-symbol? pattern)
(if (syntax-memq pattern literals symtab*)
(if (syntax-eq-symbol? pattern subject symtab*) '() (fail))
`((,pattern 0 ,subject))))
((syntax-pair? pattern)
(if (repeated? pattern)
(if (syntax-list? subject)
(if (syntax-null? subject)
(build-empty-env pattern)
(apply map combine
(syntax-map (lambda (car-subject)
(loop (syntax-car pattern) car-subject))
(if (syntax-pair? subject)
(append (loop (syntax-car pattern) (syntax-car subject))
(loop (syntax-cdr pattern) (syntax-cdr subject)))
((syntax-vector? pattern)
(if (syntax-vector? subject)
(loop (syntax-vector->list pattern) (syntax-vector->list subject))
(if (syntax-eq? pattern subject)
(define (instantiate template env literals symtab*)
(define (instantiate-internal template level env)
(lambda (template penv)
((syntax-null? template)
((syntax-symbol? template)
(let ((found (syntax-assoc template penv symtab*)))
(if found
(let ((found (syntax-assoc template env symtab*)))
(if found
(cons found penv)
((syntax-pair? template)
(pattern-vars (syntax-car template)
(pattern-vars (syntax-cdr template) penv)))
(let loop ((template template))
((syntax-null? template)
((syntax-symbol? template)
(let ((found (syntax-assoc template env symtab*)))
(if (zero? (cadr found))
(caddr found)
(error "template multiplicity error (bad nesting of ...s)" template)))
((syntax-memq template literals symtab*)
(else ;a free variable
((syntax-pair? template)
(if (repeated? template)
(let ((penv (pattern-vars (syntax-car template) '())))
(if (null? penv)
(error "cannot determine replication (too many ...s)" template)
(map (lambda (new-env)
(instantiate-internal (syntax-car template)
(+ 1 level)
(apply map
(lambda values
(map (lambda (pentry value)
`(,(car pentry)
,(- (cadr pentry) 1)
penv values))
(map caddr penv)))))
(loop (syntax-cdr (syntax-cdr template)))))
(cons (loop (syntax-car template))
(loop (syntax-cdr template)))))
((syntax-vector? template)
(list->vector (loop (syntax-vector->list template))))
(instantiate-internal template 0 env))
(define SCHEME-POP-MARK (list(string->symbol "Scheme-Pop-Mark")))
(define (syntax-make-env-mark exp env)
(if (syntax-pop-mark? exp)
(list SCHEME-POP-MARK exp env)))
(define (syntax-marked-env exp)
(caddr exp))
(define (syntax-make-pop-mark exp)
(list SCHEME-POP-MARK exp))
(define (syntax-marked-exp exp)
(cadr exp))
(define (syntax-pop-mark? exp)
(and (pair? exp) (eq? (car exp) SCHEME-POP-MARK)))
(define (syntax-null? exp)
(null? (syntax-strip exp)))
(define (syntax-symbol? exp)
(symbol? (syntax-strip exp)))
(define (syntax-pair? exp)
(pair? (syntax-strip exp)))
(define (syntax-list? exp)
(list? (syntax-strip exp)))
(define (syntax-vector? exp)
(vector? (syntax-strip exp)))
(define (syntax-eq? pat exp)
(let ((stripped-exp (syntax-strip exp)))
(or (eq? pat stripped-exp)
(equal? pat stripped-exp))))
(define (syntax-memq x literals symtab*)
(let loop ((literals literals))
(and (pair? literals)
(or (syntax-eq-symbol? x (car literals) symtab*)
(loop (cdr literals))))))
(define (syntax-assoc x alist symtab*)
(let loop ((alist alist))
(and (pair? alist)
(let ((apair (car alist)))
(if (syntax-eq-symbol? x (car apair) symtab*)
(loop (cdr alist)))))))
(define (syntax-lookup-symbol exp symtab*)
(if (syntax-pop-mark? exp)
(syntax-lookup-symbol (syntax-marked-exp exp)
(syntax-marked-env exp))
(or (apply-boxed-env symtab* exp (lambda () #f))
(define (syntax-eq-symbol? pat exp symtab*)
(and (syntax-symbol? pat)
(syntax-symbol? exp)
(eq? (syntax-lookup-symbol pat symtab*)
(syntax-lookup-symbol exp symtab*))))
(define (syntax-eq-symbol?-obsolete pat exp symtab*)
(let loop ((exp exp) (symtab* symtab*))
(if (syntax-pop-mark? exp)
(loop (syntax-marked-exp exp) (syntax-marked-env exp))
(and (symbol? exp)
(let ((found (apply-boxed-env symtab* exp (lambda () #f))))
(and (not found)
(eq? pat exp)))))))
(define (syntax-map f exp)
(let loop ((exp exp) (mark (lambda (x) x)))
(if (syntax-pop-mark? exp)
(loop (syntax-marked-exp exp)
(let ((env (syntax-marked-env exp)))
(lambda (x) (mark (syntax-make-env-mark x env)))))
(map (lambda (e) (f (mark e))) exp))))
(define (syntax-vector->list exp)
(let loop ((exp exp) (mark (lambda (x) x)))
(if (syntax-pop-mark? exp)
(loop (syntax-marked-exp exp)
(let ((env (syntax-marked-env exp)))
(lambda (x) (mark (syntax-make-env-mark x env)))))
(map mark (vector->list exp)))))
(define (syntax-car exp)
(if (syntax-pop-mark? exp)
(syntax-make-env-mark (syntax-car (syntax-marked-exp exp))
(syntax-marked-env exp))
(car exp)))
(define (syntax-cdr exp)
(if (syntax-pop-mark? exp)
(syntax-make-env-mark (syntax-cdr (syntax-marked-exp exp))
(syntax-marked-env exp))
(cdr exp)))
(define (syntax-depth exp)
((syntax-pop-mark? exp)
(+ 1 (syntax-depth (syntax-marked-exp exp))))
((pair? exp)
(max (syntax-depth (car exp))
(syntax-depth (cdr exp))))
(define (syntax-strip exp)
(if (syntax-pop-mark? exp)
(syntax-strip (syntax-marked-exp exp))
(define (syntax-strip-recursively exp)
(let loop ((exp exp))
(let ((stripped (syntax-strip exp)))
((pair? stripped)
(cons (loop (car exp)) (loop (cdr exp))))
;;; parser for syntax-rules
;;; <exp> is (syntax-rules ...)
;;; <exp> -> transformer or #f
(define (parse-syntax-rules exp symtab*)
((syntax-eq-symbol? 'syntax-rules (car exp) symtab*)
(let* ((rest (syntax-cdr exp))
(literals (syntax-map (lambda (x) x) (syntax-car rest)))
(rules (syntax-cdr rest)))
(syntax-rules-transformer literals
(lambda () (error "No match for macro call" exp)))))
(define (syntax-rules-transformer literals rules fail)
(lambda (exp dynamic-symtab*) ;<<- transformer
(let loop ((rules rules))
(if (syntax-null? rules)
(let* ((rule (syntax-car rules))
(stripped-rule (syntax-strip rule)))
((and (list? stripped-rule) (= 2 (length stripped-rule)))
(let ((env (build-env (syntax-cdr (syntax-car rule))
(syntax-cdr exp)
literals dynamic-symtab*)))
(if env
(instantiate (syntax-car (syntax-cdr rule)) env
(loop (syntax-cdr rules)))))
((eq? stripped-rule 'else)
;; avoid recursive application
(cons (syntax-make-env-mark (syntax-strip (syntax-car exp))
(syntax-cdr exp)))
(display "syntax-rules: syntax error in ")
(display stripped-rule)