826 lines
23 KiB
Scheme
826 lines
23 KiB
Scheme
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
|
|
|
|
; Syntactic stuff: transforms and operators.
|
|
|
|
|
|
(define usual-operator-type
|
|
(procedure-type any-arguments-type value-type #f))
|
|
|
|
; --------------------
|
|
; Operators (= special operators and primitives)
|
|
|
|
(define-record-type operator :operator
|
|
(make-operator type nargs uid name)
|
|
operator?
|
|
(type operator-type set-operator-type!)
|
|
(nargs operator-nargs)
|
|
(uid operator-uid)
|
|
(name operator-name))
|
|
|
|
(define-record-discloser :operator
|
|
(lambda (s)
|
|
(list 'operator
|
|
(operator-name s)
|
|
(type->sexp (operator-type s) #t))))
|
|
|
|
(define (get-operator name . type-option)
|
|
(let ((type (if (null? type-option) #f (car type-option)))
|
|
(probe (table-ref operators-table name)))
|
|
(if (operator? probe)
|
|
(let ((previous-type (operator-type probe)))
|
|
(cond ((not type))
|
|
((symbol? type) ; 'leaf or 'internal
|
|
(if (not (eq? type previous-type))
|
|
(warn "operator type inconsistency" name type previous-type)))
|
|
((subtype? type previous-type) ;Improvement
|
|
(set-operator-type! probe type))
|
|
((not (subtype? previous-type type))
|
|
(warn "operator type inconsistency"
|
|
name
|
|
(type->sexp previous-type 'foo)
|
|
(type->sexp type 'foo))))
|
|
probe)
|
|
(let* ((uid *operator-uid*)
|
|
(type (or type usual-operator-type))
|
|
(op (make-operator type
|
|
(if (and (not (symbol? type))
|
|
(fixed-arity-procedure-type? type))
|
|
(procedure-type-arity type)
|
|
#f)
|
|
uid
|
|
name)))
|
|
(if (>= uid number-of-operators)
|
|
(warn "too many operators" (operator-name op) (operator-type op)))
|
|
(set! *operator-uid* (+ *operator-uid* 1))
|
|
(table-set! operators-table (operator-name op) op)
|
|
(vector-set! the-operators uid op)
|
|
op))))
|
|
|
|
(define *operator-uid* 0)
|
|
|
|
(define operators-table (make-table))
|
|
|
|
(define number-of-operators 200) ;Fixed-size limits bad, but speed good
|
|
(define the-operators (make-vector number-of-operators #f))
|
|
|
|
; --------------------
|
|
; Operator tables (for fast dispatch)
|
|
|
|
(define (make-operator-table default . mumble-option)
|
|
(let ((v (make-vector number-of-operators default)))
|
|
(if (not (null? mumble-option))
|
|
(define-usual-suspects v (car mumble-option)))
|
|
v))
|
|
|
|
(define operator-table-ref vector-ref)
|
|
|
|
(define (operator-lookup table op)
|
|
(operator-table-ref table (operator-uid op)))
|
|
|
|
(define (operator-define! table name proc-or-type . proc-option)
|
|
(if (null? proc-option)
|
|
(vector-set! table ;Obsolescent
|
|
(operator-uid (if (pair? name)
|
|
(get-operator (car name) (cadr name))
|
|
(get-operator name)))
|
|
proc-or-type)
|
|
(vector-set! table
|
|
(operator-uid (get-operator name proc-or-type))
|
|
(car proc-option))))
|
|
|
|
; --------------------
|
|
; Nodes
|
|
|
|
; A node is an annotated expression (or definition or other form).
|
|
; The FORM component of a node is an S-expression of the same form as
|
|
; the S-expression representation of the expression. E.g. for
|
|
; literals, the form is the literal value; for variables the form is
|
|
; the variable name; for IF expressions the form is a 4-element list
|
|
; (ignored test con alt). Nodes also have a tag identifying what kind
|
|
; of node it is (literal, variable, if, etc.) and a property list.
|
|
|
|
(define-record-type node :node
|
|
(really-make-node uid form plist)
|
|
node?
|
|
(uid node-operator-id)
|
|
(form node-form)
|
|
(plist node-plist set-node-plist!))
|
|
|
|
(define-record-discloser :node
|
|
(lambda (n) (list (operator-name (node-operator n)) (node-form n))))
|
|
|
|
(define (make-node operator form)
|
|
(really-make-node (operator-uid operator) form '()))
|
|
|
|
(define (node-ref node key)
|
|
(let ((probe (assq key (node-plist node))))
|
|
(if probe (cdr probe) #f)))
|
|
|
|
(define (node-set! node key value) ;gross
|
|
(if value
|
|
(let ((probe (assq key (node-plist node))))
|
|
(if probe
|
|
(set-cdr! probe value)
|
|
(set-node-plist! node (cons (cons key value) (node-plist node)))))
|
|
(let loop ((l (node-plist node)) (prev #f))
|
|
(cond ((null? l) 'lose)
|
|
((eq? key (caar l))
|
|
(if prev
|
|
(set-cdr! prev (cdr l))
|
|
(set-node-plist! node (cdr l))))
|
|
(else (loop (cdr l) l))))))
|
|
|
|
(define (node-operator node)
|
|
(vector-ref the-operators (node-operator-id node)))
|
|
|
|
|
|
(define (node-predicate name . type-option)
|
|
(let ((id (operator-uid (apply get-operator name type-option))))
|
|
(lambda (node)
|
|
(= (node-operator-id node) id))))
|
|
|
|
(define (make-similar-node node form)
|
|
(if (equal? form (node-form node))
|
|
node
|
|
(make-node (node-operator node) form)))
|
|
|
|
; --------------------
|
|
; Generated names
|
|
|
|
; Generated names make lexically-scoped macros work. They're the same
|
|
; as what Alan Bawden and Chris Hanson call "aliases". The parent
|
|
; field is always another name (perhaps generated). The parent chain
|
|
; provides an access path to the name's binding, should one ever be
|
|
; needed. That is: If name M is bound to a transform T that generates
|
|
; name G as an alias for name N, then M is (generated-parent-name G),
|
|
; so we can get the binding of G by accessing the binding of N in T's
|
|
; environment of closure, and we get T by looking up M in the
|
|
; environment in which M is *used*.
|
|
|
|
(define-record-type generated :generated
|
|
(make-generated symbol token env parent-name)
|
|
generated?
|
|
(symbol generated-symbol)
|
|
(token generated-token)
|
|
(env generated-env)
|
|
(parent-name generated-parent-name))
|
|
|
|
(define-record-discloser :generated
|
|
(lambda (name)
|
|
(list 'generated (generated-symbol name) (generated-uid name))))
|
|
|
|
(define (generate-name symbol env parent-name) ;for opt/inline.scm
|
|
(make-generated symbol (cons #f #f) env parent-name)) ;foo
|
|
|
|
(define (generated-uid g)
|
|
(let ((t (generated-token g)))
|
|
(or (car t)
|
|
(let ((uid *generated-uid*))
|
|
(set! *generated-uid* (+ *generated-uid* 1))
|
|
(set-car! t uid)
|
|
uid))))
|
|
|
|
(define *generated-uid* 0)
|
|
|
|
(define (name->symbol name)
|
|
(if (symbol? name)
|
|
name
|
|
(string->symbol (string-append (symbol->string (generated-symbol name))
|
|
"##"
|
|
(number->string (generated-uid name))))))
|
|
|
|
(define (name-hash name)
|
|
(cond ((symbol? name)
|
|
(string-hash (symbol->string name)))
|
|
((generated? name)
|
|
(name-hash (generated-symbol name)))
|
|
(else (error "invalid name" name))))
|
|
|
|
|
|
; Used by QUOTE to turn generated names back into symbols
|
|
|
|
(define (desyntaxify thing)
|
|
(cond ((or (boolean? thing) (null? thing) (number? thing)
|
|
(symbol? thing) (char? thing))
|
|
thing)
|
|
((string? thing)
|
|
(make-immutable! thing))
|
|
((generated? thing) (desyntaxify (generated-symbol thing)))
|
|
((pair? thing)
|
|
(make-immutable!
|
|
(let ((x (desyntaxify (car thing)))
|
|
(y (desyntaxify (cdr thing))))
|
|
(if (and (eq? x (car thing))
|
|
(eq? y (cdr thing)))
|
|
thing
|
|
(cons x y)))))
|
|
((vector? thing)
|
|
(make-immutable!
|
|
(let ((new (make-vector (vector-length thing) #f)))
|
|
(let loop ((i 0) (same? #t))
|
|
(if (>= i (vector-length thing))
|
|
(if same? thing new)
|
|
(let ((x (desyntaxify (vector-ref thing i))))
|
|
(vector-set! new i x)
|
|
(loop (+ i 1)
|
|
(and same? (eq? x (vector-ref thing i))))))))))
|
|
((operator? thing)
|
|
(warn "operator in quotation" thing)
|
|
(operator-name thing)) ;Foo
|
|
(else
|
|
(warn "invalid datum in quotation" thing)
|
|
thing)))
|
|
|
|
; --------------------
|
|
; Transforms
|
|
|
|
; A transform represents a source-to-source rewrite rule: either a
|
|
; macro or an in-line procedure.
|
|
|
|
(define-record-type transform :transform
|
|
(really-make-transform xformer env type aux-names source id)
|
|
transform?
|
|
(xformer transform-procedure)
|
|
(env transform-env)
|
|
(type transform-type)
|
|
(aux-names transform-aux-names)
|
|
(source transform-source) ;for reification
|
|
(id transform-id))
|
|
|
|
(define (make-transform thing env type source id)
|
|
(let ((type (if (or (pair? type) (symbol? type))
|
|
(sexp->type type #t)
|
|
type)))
|
|
(make-immutable!
|
|
(if (pair? thing)
|
|
(really-make-transform (car thing) env type (cdr thing) source id)
|
|
(really-make-transform thing env type #f source id)))))
|
|
|
|
(define-record-discloser :transform
|
|
(lambda (m) (list 'transform (transform-id m))))
|
|
|
|
(define (maybe-transform t exp env-of-use)
|
|
(let* ((token (cons #f #f))
|
|
(new-env (bind-aliases token t env-of-use))
|
|
(rename (make-name-generator (transform-env t)
|
|
token
|
|
(node-form (car exp))))
|
|
(compare
|
|
(lambda (name1 name2)
|
|
(or (eqv? name1 name2)
|
|
(and (name? name1)
|
|
(name? name2)
|
|
(same-denotation? (lookup new-env name1)
|
|
(lookup new-env name2)))))))
|
|
(values ((transform-procedure t) exp rename compare)
|
|
new-env
|
|
token)))
|
|
|
|
(define (bind-aliases token t env-of-use)
|
|
(let ((env-of-definition (transform-env t)))
|
|
(if (procedure? env-of-definition)
|
|
(lambda (name)
|
|
(if (and (generated? name)
|
|
(eq? (generated-token name) token))
|
|
(lookup env-of-definition (generated-symbol name))
|
|
(lookup env-of-use name)))
|
|
env-of-use))) ;Lose
|
|
|
|
(define (make-name-generator env token parent-name)
|
|
(let ((alist '())) ;list of (symbol . generated)
|
|
(lambda (symbol)
|
|
(if (symbol? symbol)
|
|
(let ((probe (assq symbol alist)))
|
|
(if probe
|
|
(cdr probe)
|
|
(let ((new-name (make-generated symbol token env parent-name)))
|
|
(set! alist (cons (cons symbol new-name)
|
|
alist))
|
|
new-name)))
|
|
(error "non-symbol argument to rename procedure"
|
|
symbol parent-name)))))
|
|
|
|
(define (same-denotation? x y)
|
|
(or (equal? x y)
|
|
(and (binding? x)
|
|
(binding? y)
|
|
(eq? (binding-place x) (binding-place y)))))
|
|
|
|
|
|
; --------------------
|
|
; Bindings: the things that are usually returned by LOOKUP.
|
|
|
|
; Representation is #(type place operator-or-transform-or-#f).
|
|
; For top-level bindings, place is usually a location.
|
|
|
|
(define binding? vector?)
|
|
(define (binding-type b) (vector-ref b 0))
|
|
(define (binding-place b) (vector-ref b 1))
|
|
(define (binding-static b) (vector-ref b 2))
|
|
|
|
(define (set-binding-place! b place) (vector-set! b 1 place))
|
|
|
|
(define (make-binding type place static)
|
|
(let ((b (make-vector 3 place)))
|
|
(vector-set! b 0 type)
|
|
(vector-set! b 2 static)
|
|
b))
|
|
|
|
(define (clobber-binding! b type place static)
|
|
(vector-set! b 0 type)
|
|
(if place
|
|
(set-binding-place! b place))
|
|
(vector-set! b 2 static))
|
|
|
|
; Return a binding that's similar to the given one, but has its type
|
|
; replaced with the given type.
|
|
|
|
(define (impose-type type b integrate?)
|
|
(if (or (eq? type syntax-type)
|
|
(not (binding? b)))
|
|
b
|
|
(make-binding (if (eq? type undeclared-type)
|
|
(let ((type (binding-type b)))
|
|
(if (variable-type? type)
|
|
(variable-value-type type)
|
|
type))
|
|
type)
|
|
(binding-place b)
|
|
(if integrate?
|
|
(binding-static b)
|
|
#f))))
|
|
|
|
; Return a binding that's similar to the given one, but has any
|
|
; procedure integration or other unnecesary static information
|
|
; removed. But don't remove static information for macros (or
|
|
; structures, interfaces, etc.)
|
|
|
|
(define (forget-integration b)
|
|
(if (and (binding-static b)
|
|
(subtype? (binding-type b) any-values-type))
|
|
(make-binding (binding-type b)
|
|
(binding-place b)
|
|
#f)
|
|
b))
|
|
|
|
; --------------------
|
|
; Expression classifier. Returns a node.
|
|
|
|
(define (classify form env)
|
|
(cond ((node? form)
|
|
(if (and (name-node? form)
|
|
(not (node-ref form 'binding)))
|
|
(classify-name (node-form form) env)
|
|
form))
|
|
((name? form)
|
|
(classify-name form env))
|
|
((pair? form)
|
|
(let ((op-node (classify (car form) env)))
|
|
(if (name-node? op-node)
|
|
(let ((probe (node-ref op-node 'binding)))
|
|
(if (binding? probe)
|
|
(let ((s (binding-static probe)))
|
|
(cond ((operator? s)
|
|
(classify-operator-form s op-node form env))
|
|
((and (transform? s)
|
|
(eq? (binding-type probe) syntax-type))
|
|
;; Non-syntax transforms (i.e. procedure
|
|
;; integrations) get done by MAYBE-TRANSFORM-CALL.
|
|
(classify-macro-application
|
|
s (cons op-node (cdr form)) env))
|
|
(else
|
|
(classify-call op-node form env))))
|
|
(classify-call op-node form env)))
|
|
(classify-call op-node form env))))
|
|
((literal? form)
|
|
(classify-literal form))
|
|
;; ((qualified? form) ...)
|
|
(else
|
|
(classify (syntax-error "invalid expression" form) env))))
|
|
|
|
(define call-node? (node-predicate 'call 'internal))
|
|
(define name-node? (node-predicate 'name 'leaf))
|
|
|
|
(define classify-literal
|
|
(let ((op (get-operator 'literal 'leaf)))
|
|
(lambda (exp)
|
|
(make-node op exp))))
|
|
|
|
(define classify-call
|
|
(let ((operator/call (get-operator 'call 'internal)))
|
|
(lambda (proc-node exp env)
|
|
(make-node operator/call
|
|
(if (eq? proc-node (car exp))
|
|
exp ;+++
|
|
(cons proc-node (cdr exp)))))))
|
|
|
|
; An environment is a procedure that takes a name and returns one of
|
|
; the following:
|
|
;
|
|
; 1. A binding record.
|
|
; 2. A node, which is taken to be a substitution for the name.
|
|
; 3. Another name, meaning that the first name is unbound. The name
|
|
; returned will be a symbol even if the original name was generated.
|
|
;
|
|
; In case 1, CLASSIFY caches the binding as the node's BINDING property.
|
|
; In case 2, it simply returns the node.
|
|
|
|
(define (classify-name name env)
|
|
(let ((binding (lookup env name)))
|
|
(if (node? binding)
|
|
binding
|
|
(let ((node (make-node operator/name name)))
|
|
(if (not (unbound? binding))
|
|
(node-set! node 'binding binding))
|
|
node))))
|
|
|
|
(define operator/name (get-operator 'name 'leaf))
|
|
|
|
; Expand a macro or in-line procedure application.
|
|
|
|
(define (classify-macro-application t form env-of-use)
|
|
(classify-transform-application
|
|
t form env-of-use
|
|
(lambda ()
|
|
(classify (syntax-error "use of macro doesn't match definition"
|
|
(cons (schemify (car form) env-of-use)
|
|
(desyntaxify (cdr form))))
|
|
env-of-use))))
|
|
|
|
|
|
(define classify-transform-application
|
|
(let ((operator/with-aliases (get-operator 'with-aliases syntax-type)))
|
|
(lambda (t form env-of-use lose)
|
|
(call-with-values (lambda () (maybe-transform t form env-of-use))
|
|
(lambda (new-form new-env token)
|
|
(cond ((eq? new-form form)
|
|
(lose))
|
|
((eq? new-env env-of-use)
|
|
(classify new-form new-env))
|
|
(else
|
|
(make-node operator/with-aliases
|
|
`(with-aliases ,(car form)
|
|
,token
|
|
,new-form)))))))))
|
|
|
|
(define (maybe-transform-call proc-node node env)
|
|
(if (name-node? proc-node)
|
|
(let ((b (or (node-ref proc-node 'binding)
|
|
(lookup env (node-form proc-node)))))
|
|
(if (binding? b)
|
|
(let ((s (binding-static b)))
|
|
(cond ((transform? s)
|
|
(classify-transform-application s
|
|
(node-form node)
|
|
env
|
|
(lambda () node)))
|
|
;; ((operator? s) (make-node s (node-form node)))
|
|
(else node)))
|
|
node))
|
|
node))
|
|
|
|
|
|
; --------------------
|
|
; Specialist classifiers for particular operators
|
|
|
|
(define (classify-operator-form op op-node form env)
|
|
((operator-table-ref classifiers (operator-uid op))
|
|
op op-node form env))
|
|
|
|
(define classifiers
|
|
(make-operator-table (lambda (op op-node form env)
|
|
(if (let ((nargs (operator-nargs op)))
|
|
(or (not nargs)
|
|
(= nargs (length (cdr form)))))
|
|
(make-node op (cons op-node (cdr form)))
|
|
(classify-call op-node form env)))))
|
|
|
|
(define (define-classifier name proc)
|
|
(operator-define! classifiers name syntax-type proc))
|
|
|
|
; Remove generated names from quotations.
|
|
|
|
(define-classifier 'quote
|
|
(lambda (op op-node exp env)
|
|
(make-node op (list op-node (desyntaxify (cadr exp))))))
|
|
|
|
; Convert one-armed IF to two-armed IF.
|
|
|
|
(define-classifier 'if
|
|
(lambda (op op-node exp env)
|
|
(make-node op
|
|
(cons op-node
|
|
(if (null? (cdddr exp))
|
|
(append (cdr exp) (list (unspecific-node)))
|
|
(cdr exp))))))
|
|
|
|
(define unspecific-node
|
|
(let ((op (get-operator 'unspecific
|
|
(proc () unspecific-type))))
|
|
(lambda ()
|
|
(make-node op '(unspecific)))))
|
|
|
|
; Rewrite (define (name . vars) body ...)
|
|
; as (define foo (lambda vars body ...)).
|
|
|
|
(define-classifier 'define
|
|
(let ((operator/lambda (get-operator 'lambda syntax-type))
|
|
(operator/unassigned (get-operator 'unassigned
|
|
(proc () value-type)))) ;foo
|
|
(lambda (op op-node form env)
|
|
(let ((pat (cadr form)))
|
|
(make-node op
|
|
(cons op-node
|
|
(if (pair? pat)
|
|
(list (car pat)
|
|
(make-node operator/lambda
|
|
`(lambda ,(cdr pat)
|
|
,@(cddr form))))
|
|
(list pat
|
|
(if (null? (cddr form))
|
|
(make-node operator/unassigned
|
|
`(unassigned))
|
|
(caddr form))))))))))
|
|
|
|
;(define (make-define-node op op-node lhs rhs)
|
|
; (make-node op (list op-node lhs rhs)))
|
|
|
|
(define define-node? (node-predicate 'define))
|
|
(define define-syntax-node? (node-predicate 'define-syntax syntax-type))
|
|
|
|
|
|
; For the module system:
|
|
|
|
(define-classifier 'structure-ref
|
|
(lambda (op op-node form env)
|
|
(let ((struct-node (classify (cadr form) env))
|
|
(lose (lambda ()
|
|
(classify (syntax-error "invalid structure reference" form)
|
|
env))))
|
|
(if (and (name? (caddr form))
|
|
(name-node? struct-node))
|
|
(let ((b (node-ref struct-node 'binding)))
|
|
(if (and (binding? b) (binding-static b)) ; (structure? ...)
|
|
(classify (generate-name (desyntaxify (caddr form))
|
|
(binding-static b)
|
|
(node-form struct-node))
|
|
env)
|
|
(lose)))
|
|
(lose)))))
|
|
|
|
; Magical Scheme 48 internal thing, mainly for use by the
|
|
; DEFINE-PACKAGE macro.
|
|
|
|
(define-classifier '%file-name%
|
|
(let ((operator/quote (get-operator 'quote syntax-type)))
|
|
(lambda (op op-node form env)
|
|
(make-node operator/quote `',(get-funny env funny-name/source-file-name)))))
|
|
|
|
(define funny-name/source-file-name
|
|
(string->symbol ".source-file-name."))
|
|
|
|
(define (bind-source-file-name filename env)
|
|
(if filename
|
|
(bind1 funny-name/source-file-name
|
|
(make-binding syntax-type #f filename)
|
|
env)
|
|
env))
|
|
|
|
|
|
; To do:
|
|
; Check syntax of others special forms
|
|
|
|
; --------------------
|
|
; Environments
|
|
|
|
(define (lookup env name)
|
|
(env name))
|
|
|
|
(define (bind1 name binding env)
|
|
(lambda (a-name)
|
|
(if (eq? a-name name)
|
|
binding
|
|
(lookup env a-name))))
|
|
|
|
; corollary
|
|
|
|
(define (bind names bindings env)
|
|
(cond ((null? names) env)
|
|
(else
|
|
(bind1 (car names)
|
|
(car bindings)
|
|
(bind (cdr names) (cdr bindings) env)))))
|
|
|
|
(define (bindrec names env->bindings env)
|
|
(set! env (bind names
|
|
(env->bindings (lambda (a-name) (env a-name)))
|
|
env))
|
|
env)
|
|
|
|
|
|
; --------------------
|
|
; Utilities
|
|
|
|
(define (literal? exp)
|
|
(or (number? exp) (char? exp) (string? exp) (boolean? exp)))
|
|
|
|
(define (number-of-required-args formals)
|
|
(do ((l formals (cdr l))
|
|
(i 0 (+ i 1)))
|
|
((not (pair? l)) i)))
|
|
|
|
(define (n-ary? formals)
|
|
(cond ((null? formals) #f)
|
|
((pair? formals) (n-ary? (cdr formals)))
|
|
(else #t)))
|
|
|
|
(define (normalize-formals formals)
|
|
(cond ((null? formals) '())
|
|
((pair? formals)
|
|
(cons (car formals) (normalize-formals (cdr formals))))
|
|
(else (list formals))))
|
|
|
|
|
|
(define (syntax? d)
|
|
(cond ((operator? d)
|
|
(eq? (operator-type d) syntax-type))
|
|
((transform? d)
|
|
(eq? (transform-type d) syntax-type))
|
|
(else #f)))
|
|
|
|
(define (name? thing)
|
|
(or (symbol? thing)
|
|
(generated? thing)))
|
|
|
|
(define unbound? name?)
|
|
|
|
|
|
; --------------------
|
|
; LET-SYNTAX and friends
|
|
|
|
(define (define-usual-suspects table mumble)
|
|
|
|
(operator-define! table 'let-syntax syntax-type
|
|
(mumble (lambda (node env)
|
|
(let* ((form (node-form node))
|
|
(specs (cadr form)))
|
|
(values (caddr form)
|
|
(bind (map car specs)
|
|
(map (lambda (spec)
|
|
(make-binding syntax-type
|
|
(list 'let-syntax)
|
|
(process-syntax (cadr spec)
|
|
env
|
|
(car spec)
|
|
env)))
|
|
specs)
|
|
env))))))
|
|
|
|
(operator-define! table 'letrec-syntax syntax-type
|
|
(mumble (lambda (node env)
|
|
(let* ((form (node-form node))
|
|
(specs (cadr form)))
|
|
(values (caddr form)
|
|
(bindrec (map car specs)
|
|
(lambda (new-env)
|
|
(map (lambda (spec)
|
|
(make-binding
|
|
syntax-type
|
|
(list 'letrec-syntax)
|
|
(process-syntax (cadr spec)
|
|
new-env
|
|
(car spec)
|
|
new-env)))
|
|
specs))
|
|
env))))))
|
|
|
|
(operator-define! table 'with-aliases syntax-type
|
|
(mumble (lambda (node env)
|
|
(let ((form (node-form node)))
|
|
(values (cadddr form)
|
|
(bind-aliases (caddr form)
|
|
(binding-static
|
|
(node-ref (cadr form) 'binding))
|
|
env)))))))
|
|
|
|
(define (process-syntax form env name env-or-whatever)
|
|
(let ((eval+env (force (reflective-tower env))))
|
|
(make-transform ((car eval+env) form (cdr eval+env))
|
|
env-or-whatever syntax-type form name)))
|
|
|
|
(define (get-funny env name)
|
|
(let ((binding (lookup env name)))
|
|
(if (binding? binding)
|
|
(binding-static binding)
|
|
#f)))
|
|
|
|
; An environment's "reflective tower" is a promise that is expected to
|
|
; deliver, when forced, a pair (eval . env).
|
|
|
|
(define funny-name/reflective-tower
|
|
(string->symbol ".reflective-tower."))
|
|
|
|
(define (reflective-tower env)
|
|
(or (get-funny env funny-name/reflective-tower)
|
|
(error "environment has no environment for syntax" env)))
|
|
|
|
|
|
; --------------------
|
|
; The horror of internal defines
|
|
|
|
; The continuation argument to SCAN-BODY takes two arguments: a list
|
|
; of definition nodes, and a list of other things (nodes and
|
|
; expressions).
|
|
|
|
(define (scan-body forms env cont)
|
|
(if (or (null? forms)
|
|
(null? (cdr forms)))
|
|
(cont '() forms) ;+++ tiny compiler speedup?
|
|
(scan-body-forms forms env '()
|
|
(lambda (defs exps env)
|
|
(cont defs exps)))))
|
|
|
|
(define (scan-body-forms forms env defs cont)
|
|
(if (null? forms)
|
|
(cont defs '() env)
|
|
(let ((node (classify (car forms) env))
|
|
(forms (cdr forms)))
|
|
(cond ((define-node? node)
|
|
(scan-body-forms forms
|
|
(let ((name (cadr (node-form node))))
|
|
(bind1 name
|
|
;; Shadow, and don't cache lookup
|
|
(make-node operator/name name)
|
|
env))
|
|
(cons node defs)
|
|
cont))
|
|
((begin-node? node)
|
|
(scan-body-forms (cdr (node-form node))
|
|
env
|
|
defs
|
|
(lambda (new-defs exps env)
|
|
(cond ((null? exps)
|
|
(scan-body-forms forms
|
|
env
|
|
new-defs
|
|
cont))
|
|
((eq? new-defs defs)
|
|
(cont defs
|
|
(append exps forms)
|
|
env))
|
|
(else (body-lossage node env))))))
|
|
(else
|
|
(cont defs (cons node forms) env))))))
|
|
|
|
(define (body-lossage node env)
|
|
(syntax-error "definitions and expressions intermixed"
|
|
(schemify node env)))
|
|
|
|
|
|
(define begin-node? (node-predicate 'begin syntax-type))
|
|
|
|
; --------------------
|
|
; Variable types
|
|
|
|
(define (variable-type type)
|
|
(list 'variable type))
|
|
|
|
(define (variable-type? type)
|
|
(and (pair? type) (eq? (car type) 'variable)))
|
|
(define variable-value-type cadr)
|
|
|
|
; Used in two places:
|
|
; 1. GET-LOCATION checks to see if the context of use (either variable
|
|
; reference or assignment) is compatible with the declared type.
|
|
; 2. CHECK-STRUCTURE checks to see if the reconstructed type is compatible
|
|
; with any type declared in the interface.
|
|
|
|
(define (compatible-types? have-type want-type)
|
|
(if (variable-type? want-type)
|
|
(and (variable-type? have-type)
|
|
(same-type? (variable-value-type have-type)
|
|
(variable-value-type want-type)))
|
|
(meet? (if (variable-type? have-type)
|
|
(variable-value-type have-type)
|
|
have-type)
|
|
want-type)))
|
|
|
|
|
|
; Usual type for Scheme variables.
|
|
|
|
(define usual-variable-type (variable-type value-type))
|
|
|
|
|
|
(define undeclared-type ':undeclared) ;cf. really-export macro
|
|
|
|
|
|
; Associate a reader (parser) with an environment.
|
|
|
|
(define funny-name/reader (string->symbol ".reader."))
|
|
|
|
;(define (set-package-reader! p reader)
|
|
; (package-define-funny! p funny-name/reader reader))
|
|
|
|
(define (environment-reader env)
|
|
(or (get-funny env funny-name/reader) read))
|