home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The World of Computer Software
/
World_Of_Computer_Software-02-386-Vol-2of3.iso
/
c
/
cr-macro.zip
/
CLASSIFY.SCM
< prev
next >
Wrap
Text File
|
1990-02-20
|
16KB
|
583 lines
; Expression classification
; Entry points (not a complete list):
; classify
; scan-body
; process-syntax-binding [for use by define-syntax]
; classify-let-syntax, classify-letrec-syntax
; bind
; bindrec
; bind-aliases
; lookup
; lookup-variable
; classify : form * env * (class * form * env -> answer) -> answer
; env = name -> binding
; binding = special + macro + variable
; special = {let-syntax, letrec-syntax, define, begin, ...}
; variable = [defined elsewhere]
; macro = transformer * env
; transformer = form * (name -> name) * (name * name -> bool) -> form
(define (classify form env cont)
(cond ((literal? form)
(cont class/literal form env))
((name? form)
(cont class/variable form env))
((compound? form)
(classify-compound form env cont))
((classified? form)
(cont (classified-class form)
(classified-form form)
(classified-env form)))
(else (syntax-error "unknown expression type" form))))
(define (classify-compound form env cont)
(let ((op-form (operator form)))
(if (name? op-form)
(let ((binding (lookup op-form env)))
(cond ((special-operator? binding)
(classify-special-form binding form env cont))
((macro? binding)
(classify-macro-application binding form env cont))
(else
(cont class/application form env))))
(cont class/application form env))))
(define (classify-special-form op form env cont)
(let ((class (special-operator-class op)))
(if (check-special-form-syntax class form)
(cont class form env)
(syntax-error "invalid special form syntax" form))))
; Macro application
(define (classify-macro-application op form env cont)
(let ((macro-env (macro-environment op)))
(with-new-color macro-env env
(lambda (rename output-env)
(let* ((compare (lambda (client-name macro-name)
(same-binding? (lookup client-name env)
(lookup macro-name macro-env))))
(new-form
((macro-transformer op) form rename compare)))
(classify new-form output-env cont))))))
; let-syntax and letrec-syntax
(define (classify-let-syntax form env cont)
(let ((bspecs (let-syntax-bspecs form)))
(classify (let-syntax-body form)
(bind (map bspec-name bspecs)
(map (lambda (bspec)
(process-syntax-binding (bspec-rhs bspec)
env))
bspecs)
env)
cont)))
(define (classify-letrec-syntax form outer-env cont)
(let ((bspecs (letrec-syntax-bspecs form)))
(classify (letrec-syntax-body form)
(bindrec (map bspec-name bspecs)
(lambda (env)
(map (lambda (bspec)
(process-syntax-binding (bspec-rhs bspec)
env))
bspecs))
outer-env)
cont)))
(define (process-syntax-binding transformer env)
(make-macro (if (procedure? transformer)
transformer
(eval-transformer transformer
(get-transformer-environment env)))
env))
(define (make-classified class form env)
(vector 'classified class form env))
(define classified?
(vector-predicate 'classified))
(define classified-class
(vector-accessor 'classified 1))
(define classified-form
(vector-accessor 'classified 2))
(define classified-env
(vector-accessor 'classified 3))
; Process internal definitions
; This code goes to considerable contortions in order to avoid using
; side effects. I think that it could be considerably simplified if
; it were less scrupulous about that.
; It could also be simplified if it were willing to expand the forms
; in the body more than once.
; There is still one bug: if a body contains more than one expression
; (following some number of definitions), and classifying the first of
; those expressions uses a name bound outside the body to a syntactic
; operator, and that name is shadowed by one of the definitions, then
; the wrong (outer) binding of that name will be used in classifying
; the body. (Example: (lambda () (define cond list) (cond 1 2) 3).)
; This can be fixed, but I've already wasted too much time on this
; problem.
(define (scan-body forms env cont)
(tracking-lookups env ; Only for error checking
(lambda (env seen-thunk)
(let ((done
(lambda (names def-forms body-forms)
(let ((seen (seen-thunk)))
(for-each (lambda (name)
(if (name-member name seen)
(syntax-error "defined name was used in expanding definition"
name)))
names))
(cont names def-forms body-forms))))
(let loop ((names '())
(def-forms '())
(forms forms))
(if (null? (cdr forms)) ;Optimization.
;; Last form must be an expression.
(done names def-forms forms)
(scan-body-form (car forms)
(re-extension-barrier env)
(lambda (more-names more-def-forms)
(loop (append more-names names)
(append more-def-forms def-forms)
(cdr forms)))
(lambda (form)
(done names
def-forms
(cons form (cdr forms)))))))))))
(define (scan-body-form form env d-cont e-cont)
(classify form env
(lambda (class form env)
(cond ((= class class/define)
(let ((extender (re-extender env)))
(d-cont (list (define-name form))
(list (lambda (env cont)
(classify (define-rhs form)
(extender env)
cont))))))
((= class class/begin)
(scan-body-begin form env d-cont e-cont))
(else
(e-cont (make-classified class form env)))))))
(define (scan-body-begin form env d-cont e-cont)
(let ((forms (begin-statements form)))
(cond ((null? forms) (d-cont '() '()))
((null? (cdr forms))
(scan-body-form (car forms) env d-cont e-cont))
(else
(scan-body-form
(car forms)
env
(lambda (names def-forms)
(let loop ((names names)
(def-forms def-forms)
(forms (cdr forms)))
(if (null? forms)
(d-cont names def-forms)
(scan-body-form
(car forms)
env
(lambda (more-names more-def-forms)
(loop (append more-names names)
(append more-def-forms def-forms)
(cdr forms)))
(lambda (form)
(syntax-error "intermixed expressions and definitions"
form))))))
(lambda (form)
(e-cont (make-classified class/begin
`(begin ,form ,@(cdr forms))
env))))))))
; Environment operations
(define (lookup name env)
((env 'lookup) name))
(define (lookup-variable name env)
(let ((binding (lookup name env)))
(if (or (special-operator? binding)
(macro? binding))
(syntax-error "syntactic keyword encountered in invalid context" name)
binding)))
(define (simple-environment lookup outer-env)
(lambda (op)
(case op
((lookup) lookup)
(else (outer-env op)))))
(define (bind names bindings outer-env)
(simple-environment
(lambda (name)
(lookup-internal name names bindings outer-env))
outer-env))
(define (bindrec names bindings-proc outer-env)
(letrec ((env (simple-environment
(lambda (name)
(lookup-internal name names (force bindings)
outer-env))
outer-env))
(bindings (delay (bindings-proc env))))
env))
(define (lookup-internal name names bindings outer-env)
(let loop ((names names) (bindings bindings))
(if (null? names)
(lookup name outer-env)
(if (same-name? name (car names))
(car bindings)
(loop (cdr names) (cdr bindings))))))
; Keep track of keyword lookups for lambda body error checking.
(define (tracking-lookups env cont)
(let ((seen '()))
(cont (simple-environment
(lambda (name)
(let ((binding (lookup name env)))
(if (or (macro? binding)
(special-operator? binding))
(set! seen (cons name seen)))
binding))
env)
(lambda () seen))))
; Make a mutable environment, for program top level and/or REP loop.
(define (make-mutable-environment transformer-env)
(let ((defined (make-table)))
(let ((lookup
(lambda (name)
(or (table-ref defined name)
(make-unbound name))))
(define!
(lambda (name binding)
(table-set! defined name binding))))
(lambda (op)
(case op
((lookup) lookup)
((define!) define!)
((transformer-environment) transformer-env)
(else (error "unknown environment operation" op)))))))
(define (environment-define! env name binding)
((env 'define!) name binding))
; Get the environment in which to evaluate transformer procedure expressions.
(define (get-transformer-environment env)
(env 'transformer-environment))
; Environment for macro output
(define (diversion-environment color macro-env client-env)
(simple-environment
(lambda (name)
(if (and (painted? name)
(same-color? (painted-color name) color))
(lookup (painted-name name) macro-env)
(lookup name client-env)))
client-env))
; Kludgiferous stuff for internal define
(define (re-extension-barrier env)
(lambda (op)
(case op
((re-extender) (lambda (env) env))
(else (env op)))))
(define (re-extendable-environment extend outer-env)
(let ((env (extend outer-env)))
(lambda (op)
(case op
((re-extender)
;; Kludge for processing internal defines
(let ((outer-extend (re-extender outer-env)))
(lambda (env-again)
(outer-extend (extend env-again)))))
(else (env op))))))
(define (re-extender env)
(env 're-extender))
; Define special operator names to be special operators.
(define (define-special-operators! env)
(for-each (lambda (name class)
(environment-define! env name (make-special-operator class)))
(list 'let-syntax 'letrec-syntax
'define-syntax '%define
'lambda 'letrec 'if
'quote 'begin 'set!)
(list class/let-syntax class/letrec-syntax
class/define-syntax class/define
class/lambda class/letrec class/if
class/quote class/begin class/set!)))
; Binding = special operator + macro + unbound + variable
; All of these can be compared using EQ?, except unbound.
(define same-binding? equal?)
; Special operators
(define (make-special-operator class)
(vector 'special class))
(define special-operator?
(vector-predicate 'special))
(define special-operator-class
(vector-accessor 'special 1))
; Macros
(define (make-macro transformer env)
(vector 'macro transformer env))
(define macro?
(vector-predicate 'macro))
(define macro-transformer
(vector-accessor 'macro 1))
(define macro-environment
(vector-accessor 'macro 2))
; Unbound
(define (make-unbound name) (vector 'unbound name))
(define unbound? (vector-predicate 'unbound))
(define unbound-name (vector-accessor 'unbound 1))
; Names, colors, painting
(define (make-painted name color)
(vector 'painted name color))
(define painted? (vector-predicate 'painted))
(define painted-name (vector-accessor 'painted 1))
(define painted-color (vector-accessor 'painted 2))
(define (name? thing)
(or (symbol? thing) (painted? thing)))
(define (unpaint thing)
(cond ((painted? thing) (unpaint (painted-name thing)))
((pair? thing)
(let ((x (unpaint (car thing)))
(y (unpaint (cdr thing))))
(if (and (eq? x (car thing))
(eq? y (cdr thing)))
thing
(cons x y))))
((vector? thing)
(let ((new (make-vector (vector-length thing))))
(let loop ((i 0) (same? #t))
(if (>= i (vector-length thing))
(if same? thing new)
(let ((x (unpaint (vector-ref thing i))))
(vector-set! new i x)
(loop (+ i 1)
(and same? (eq? x (vector-ref thing i)))))))))
(else thing)))
(define (name->symbol name)
(cond ((symbol? name) name)
((painted? name)
(string->symbol
(string-append "."
(symbol->string (name->symbol (painted-name name)))
"."
(number->string (painted-color name) '(heur)))))
(else (error "not a name" name))))
(define *color* 0)
(define (new-color)
(set! *color* (+ *color* 1))
*color*)
(define same-color? =)
(define (with-new-color macro-env client-env cont)
(let ((alist '()) ;list of name * painted
(color (new-color)))
(cont (lambda (name)
(let ((probe (assq name alist)))
(if probe
(cdr probe)
(let ((new-name (make-painted name color)))
(set! alist (cons (cons name new-name)
alist))
new-name))))
(re-extendable-environment
(lambda (client-env)
(diversion-environment color macro-env client-env))
client-env))))
(define same-name? eq?)
(define name-member memq)
(define name-assoc assq)
; Expressions
(define (literal? x)
(or (number? x) (string? x) (boolean? x) (char? x)))
(define (literal-value lit) lit)
(define compound? pair?)
(define operator car)
(define operands cdr)
; (let-syntax ((<name> <exp>)) <body>)
(define let-syntax-bspecs cadr)
(define let-syntax-body caddr)
(define (check-let-syntax exp)
(and (= (careful-length exp) 3)
(careful-every check-bspec (let-syntax-bspecs exp))))
; (letrec-syntax ((<name> <exp>)) <body>)
(define letrec-syntax-bspecs let-syntax-bspecs)
(define letrec-syntax-body let-syntax-body)
(define check-letrec-syntax check-let-syntax)
; Binding specs (<name> <exp>)
(define bspec-name car)
(define bspec-rhs cadr)
(define (check-bspec bspec)
(and (= (careful-length bspec) 2)
(name? (bspec-name bspec))))
; (define <name> <rhs>) [rhs = right-hand side]
(define define-name cadr)
(define define-rhs caddr)
(define (check-define form)
(and (= (careful-length form) 3)
(name? (define-name form))))
; (define-syntax <name> <rhs>)
(define define-syntax-name cadr)
(define define-syntax-rhs caddr)
(define (check-define-syntax form)
(and (= (careful-length form) 3)
(name? (define-syntax-name form))))
; (begin <statement>*)
(define begin-statements cdr)
(define (check-begin form)
(>= (careful-length form) 1)) ;must be a proper list
; variable reference
(define (variable-name var) var)
; application
(define application-procedure operator)
(define application-arguments operands)
; (lambda (<name>*) <body>)
(define lambda-formals cadr)
(define lambda-body cddr)
(define (check-lambda exp)
(and (>= (careful-length exp) 3)
(let recur ((formals (lambda-formals exp)))
(or (null? formals)
(name? formals)
(and (name? (car formals)) (recur (cdr formals)))))))
; (letrec ((<name> <exp>)) <body>)
(define letrec-bspecs cadr)
(define letrec-body cddr)
(define (check-letrec exp)
(and (>= (careful-length exp) 3)
(careful-every check-bspec (letrec-bspecs exp))))
; (quote <text>)
(define quotation-text cadr)
(define (check-quote exp)
(= (careful-length exp) 2))
; (if <test> <con> <alt>)
(define if-test cadr)
(define if-consequent caddr)
(define (if-alternate exp)
(let ((z (cdddr exp)))
(if (null? z) unspecified-expression (car z))))
(define unspecified-expression (list 'unspecified-value))
(define (check-if exp)
(let ((len (careful-length exp)))
(or (= len 3) (= len 4))))
; (set! <lhs> <rhs>)
(define set!-lhs cadr)
(define set!-rhs caddr)
(define (check-set! exp)
(and (= (careful-length exp) 3)
(name? (set!-lhs exp))))
;
(define (careful-length l)
(if (null? l)
0
(if (pair? l)
(+ 1 (careful-length (cdr l)))
-1)))
(define (careful-every pred l)
(if (null? l)
#t
(and (pair? l)
(pred (car l))
(careful-every pred (cdr l)))))
(define (check-special-form-syntax class form)
((vector-ref syntax-checkers class) form))
(define syntax-checkers
(let ((v (make-vector number-of-classes (lambda (form) #t))))
(vector-set! v class/lambda check-lambda)
(vector-set! v class/letrec check-letrec)
(vector-set! v class/if check-if)
(vector-set! v class/quote check-quote)
(vector-set! v class/begin check-begin)
(vector-set! v class/set! check-set!)
(vector-set! v class/let-syntax check-let-syntax)
(vector-set! v class/letrec-syntax check-letrec-syntax)
(vector-set! v class/define check-define)
(vector-set! v class/define-syntax check-define-syntax)
v))
; (put 'bind 'scheme-indent-hook nil)