scsh-0.6/scheme/bcomp/syntax.scm

629 lines
18 KiB
Scheme

; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
; Macro expansion.
;----------------
; Scanning for definitions.
;
; Returns a list of forms expanded to the point needed to distinguish
; definitions from other forms. Definitions and syntax definitions are
; added to ENV.
(define (scan-forms forms env)
(let loop ((forms forms) (expanded '()))
(if (null? forms)
(reverse expanded)
(let ((form (expand-head (car forms) env))
(more-forms (cdr forms)))
(cond ((define? form)
(loop more-forms
(cons (scan-define form env) expanded)))
((define-syntax? form)
(loop more-forms
(append (scan-define-syntax form env)
expanded)))
((begin? form)
(loop (append (cdr form) more-forms)
expanded))
(else
(loop more-forms (cons form expanded))))))))
(define (expand-scanned-form form env)
(if (define? form)
(expand-define form env)
(expand form env)))
(define (scan-define form env)
(let ((new-form (destructure-define form)))
(if new-form
(begin
(environment-define! env (cadr new-form) usual-variable-type)
new-form)
(syntax-error "ill-formed definition" form))))
(define (expand-define form env)
(make-node operator/define
(list (car form)
(expand (cadr form) env)
(expand (caddr form) env))))
(define (scan-define-syntax form env)
(if (and (or (this-long? form 3)
(this-long? form 4)) ; may have name list for reifier
(name? (cadr form)))
(let ((name (cadr form))
(source (caddr form))
(package (extract-package-from-environment env)))
(environment-define! env
name
syntax-type
(process-syntax (if (null? (cdddr form))
source
`(cons ,source ',(cadddr form)))
env
name
package))
'())
`(,(syntax-error "ill-formed syntax definition" form))))
; This is used by the ,expand command.
(define (expand-form form env)
(let loop ((forms (list form)) (expanded '()))
(if (null? forms)
(if (= (length expanded) 1)
(car expanded)
(make-node operator/begin (cons 'begin (reverse expanded))))
(let ((form (expand-head (car forms) env))
(more-forms (cdr forms)))
(cond ((define? form)
(loop more-forms
(cons (expand-define form env) expanded)))
((define-syntax? form)
(loop more-forms
(cons (make-node operator/define-syntax
(list (car form)
(expand (cadr form) env)
(make-node operator/quote
`',(caddr form))))
expanded)))
((begin? form)
(loop (append (cdr form) more-forms)
expanded))
(else
(loop more-forms
(cons (expand form env) expanded))))))))
;----------------
; Looking for definitions.
; This expands the form until it reaches a name, a form whose car is an
; operator, a form whose car is unknown, or a literal.
(define (expand-head form env)
(cond ((node? form)
(if (and (name-node? form)
(not (node-ref form 'binding)))
(expand-name (node-form form) env)
form))
((name? form)
(expand-name form env))
((pair? form)
(let ((op (expand-head (car form) env)))
(if (and (node? op)
(name-node? op))
(let ((probe (node-ref op 'binding)))
(if (binding? probe)
(let ((s (binding-static probe)))
(cond ((and (transform? s)
(eq? (binding-type probe) syntax-type))
(expand-macro-application
s (cons op (cdr form)) env expand-head))
((and (operator? s)
(eq? s operator/structure-ref))
(expand-structure-ref form env expand-head))
(else
(cons op (cdr form)))))
(cons op (cdr form))))
(cons op (cdr form)))))
(else
form)))
; Returns a DEFINE of the form (define <id> <value>). This handles the following
; kinds of defines:
; (define <id> <value>)
; (define <id>) ; value is unassigned
; (define (<id> . <formals>) <value>) ; value is a lambda
; The return value is #f if any syntax error is found.
(define (destructure-define form)
(if (at-least-this-long? form 2)
(let ((pat (cadr form))
(operator (car form)))
(cond ((pair? pat)
(if (and (names? (cdr pat))
(not (null? (cddr form))))
`(,operator ,(car pat)
(,operator/lambda ,(cdr pat)
. ,(cddr form)))
#f))
((null? (cddr form))
`(,operator ,pat (,operator/unassigned)))
((null? (cdddr form))
`(,operator ,pat ,(caddr form)))
(else
#f)))
#f))
(define (make-operator-predicate operator-id)
(let ((operator (get-operator operator-id syntax-type)))
(lambda (form)
(and (pair? form)
(eq? operator
(static-value (car form)))))))
(define define? (make-operator-predicate 'define))
(define begin? (make-operator-predicate 'begin))
(define define-syntax? (make-operator-predicate 'define-syntax))
(define (static-value form)
(if (and (node? form)
(name-node? form))
(let ((probe (node-ref form 'binding)))
(if (binding? probe)
(binding-static probe)
#f))
#f))
; --------------------
; The horror of internal defines
; This returns a single node, either a LETREC, if there are internal definitions,
; or a BEGIN if there aren't any.
(define (expand-body body env)
(if (null? (cdr body)) ;++
(expand (car body) env)
(call-with-values
(lambda ()
(scan-body-forms body env '()))
(lambda (defs exps env)
(if (null? defs)
(make-node operator/begin (cons 'begin (expand-list exps env)))
(expand-letrec (map car (reverse defs))
(map cdr (reverse defs))
exps
env))))))
; Walk through FORMS looking for definitions. ENV is the current environment,
; DEFS a list of definitions found so far.
;
; Returns three values: a list of (define <name> <value>) lists, a list of
; remaining forms, and the environment to use for expanding all of the above.
(define (scan-body-forms forms env defs)
(if (null? forms)
(values defs '() env)
(let ((form (expand-head (car forms) env))
(more-forms (cdr forms)))
(cond ((define? form)
(let ((new-form (destructure-define form)))
(if new-form
(let* ((name (cadr new-form))
(node (make-node operator/name name)))
(scan-body-forms more-forms
(bind1 name node env)
(cons (cons node
(caddr new-form))
defs)))
(values defs
(cons (syntax-error "ill-formed definition" form)
more-forms)
env))))
((begin? form)
(call-with-values
(lambda ()
(scan-body-forms (cdr form)
env
defs))
(lambda (new-defs exps env)
(cond ((null? exps)
(scan-body-forms more-forms env new-defs))
((eq? new-defs defs)
(values defs (append exps more-forms) env))
(else
(body-lossage forms env))))))
(else
(values defs (cons form more-forms) env))))))
(define (body-lossage node env)
(syntax-error "definitions and expressions intermixed"
(schemify node env)))
;--------------------
; Expands all macros in FORM and returns a node.
(define (expand form env)
(cond ((node? form)
(if (and (name-node? form)
(not (node-ref form 'binding)))
(expand-name (node-form form) env)
form))
((name? form)
(expand-name form env))
((pair? form)
(if (operator? (car form))
(expand-operator-form (car form) (car form) form env)
(let ((op-node (expand (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)
(expand-operator-form s op-node form env))
((and (transform? s)
(eq? (binding-type probe) syntax-type))
;; Non-syntax transforms get done later
(expand-macro-application
s (cons op-node (cdr form)) env expand))
(else
(expand-call op-node form env))))
(expand-call op-node form env)))
(expand-call op-node form env)))))
((literal? form)
(expand-literal form))
;; ((qualified? form) ...)
(else
(expand (syntax-error "invalid expression" form) env))))
(define (expand-list exps env)
(map (lambda (exp)
(expand exp env))
exps))
(define (expand-literal exp)
(make-node operator/literal (make-immutable! exp)))
(define (expand-call proc-node exp env)
(if (list? exp)
(make-node operator/call
(cons proc-node (expand-list (cdr exp) env)))
(expand (syntax-error "invalid expression" exp) env)))
; An environment is a procedure that takes a name and returns one of
; the following:
;
; 1. A binding record.
; 2. A pair (<binding-record> . <path>)
; 3. A node, which is taken to be a substitution for the name.
; Or, for lexically bound variables, this is just a name node.
; 4. #f, for unbound variables
;
; In case 1, EXPAND caches the binding as the node's BINDING property.
; In case 2, it simply returns the node.
(define (expand-name name env)
(let ((binding (lookup env name)))
(if (node? binding)
binding
(let ((node (make-node operator/name name)))
(node-set! node 'binding (or binding 'unbound))
node))))
; Expand a macro. EXPAND may either be expand or expand-head.
(define (expand-macro-application transform form env-of-use expand)
(call-with-values
(lambda ()
(maybe-apply-macro-transform transform
form
(node-form (car form))
env-of-use))
(lambda (new-form new-env)
(if (eq? new-form form)
(expand (syntax-error "use of macro doesn't match definition"
(cons (schemify (car form) env-of-use)
(desyntaxify (cdr form))))
env-of-use)
(expand new-form new-env)))))
;--------------------
; Specialist classifiers for particular operators
(define (expand-operator-form op op-node form env)
((operator-table-ref expanders (operator-uid op))
op op-node form env))
(define expanders
(make-operator-table (lambda (op op-node form env)
(if (let ((nargs (operator-nargs op)))
(or (not nargs)
(and (list? (cdr form))
(= nargs (length (cdr form))))))
(make-node op
(cons op-node
(expand-list (cdr form) env)))
(expand-call op-node form env)))))
(define (define-expander name proc)
(operator-define! expanders name syntax-type proc))
; Definitions are not expressions.
(define-expander 'define
(lambda (op op-node exp env)
(expand (syntax-error "definition in expression context" exp) env)))
; Remove generated names from quotations.
(define-expander 'quote
(lambda (op op-node exp env)
(if (this-long? exp 2)
(make-node op (list op (desyntaxify (cadr exp))))
(expand (syntax-error "invalid expression" exp) env))))
; Don't evaluate, but don't remove generated names either. This is
; used when writing macro-defining macros. Once we have avoided the
; use of DESYNTAXIFY it is safe to replace this with regular QUOTE.
(define-expander 'code-quote
(lambda (op op-node exp env)
(if (this-long? exp 2)
(make-node operator/quote (list op (cadr exp)))
(expand (syntax-error "invalid expression" exp) env))))
; Convert one-armed IF to two-armed IF.
(define-expander 'if
(lambda (op op-node exp env)
(cond ((this-long? exp 3)
(make-node op
(cons op
(expand-list (append (cdr exp)
(list (unspecific-node)))
env))))
((this-long? exp 4)
(make-node op
(cons op (expand-list (cdr exp) env))))
(else
(expand (syntax-error "invalid expression" exp) env)))))
(define (unspecific-node)
(make-node operator/unspecific '(unspecific)))
; For the module system:
(define-expander 'structure-ref
(lambda (op op-node form env)
(expand-structure-ref form env expand)))
; This is also called by EXPAND-HEAD, which passes in a different expander.
(define (expand-structure-ref form env expander)
(let ((struct-node (expand (cadr form) env))
(lose (lambda ()
(expand (syntax-error "invalid structure reference" form)
env))))
(if (and (this-long? form 3)
(name? (caddr form))
(name-node? struct-node))
(let ((b (node-ref struct-node 'binding)))
(if (and (binding? b)
(binding-static b)) ; (structure? ...)
(expand (generate-name (desyntaxify (caddr form))
(binding-static b)
(node-form struct-node))
env)
(lose)))
(lose))))
; Scheme 48 internal special form principally for use by the
; DEFINE-STRUCTURES macro.
(define-expander '%file-name%
(lambda (op op-node form env)
(make-node operator/quote `',(source-file-name env))))
; Checking the syntax of others special forms
(define-expander 'lambda
(lambda (op op-node exp env)
(if (and (at-least-this-long? exp 3)
(names? (cadr exp)))
(expand-lambda (cadr exp) (cddr exp) env)
(expand (syntax-error "invalid expression" exp) env))))
(define (expand-lambda names body env)
(call-with-values
(lambda ()
(bind-names names env))
(lambda (names env)
(make-node operator/lambda
(list 'lambda names (expand-body body env))))))
(define (bind-names names env)
(let loop ((names names) (nodes '()) (out-names '()))
(cond ((null? names)
(values (reverse nodes)
(bind out-names nodes env)))
((name? names)
(let ((last (make-node operator/name names)))
(values (append (reverse nodes) last)
(bind (cons names out-names) (cons last nodes) env))))
(else
(let ((node (make-node operator/name (car names))))
(loop (cdr names) (cons node nodes) (cons (car names) out-names)))))))
(define (names? l)
(or (null? l)
(name? l)
(and (pair? l)
(name? (car l))
(names? (cdr l)))))
(define-expander 'set!
(lambda (op op-node exp env)
(if (and (this-long? exp 3)
(name? (cadr exp)))
(make-node op (cons op (expand-list (cdr exp) env)))
(expand (syntax-error "invalid expression" exp) env))))
(define-expander 'letrec
(lambda (op op-node exp env)
(if (and (at-least-this-long? exp 3)
(specs? (cadr exp)))
(let ((specs (cadr exp))
(body (cddr exp)))
(let* ((names (map (lambda (spec)
(make-node operator/name (car spec)))
specs))
(env (bind (map car specs) names env)))
(expand-letrec names (map cadr specs) body env)))
(expand (syntax-error "invalid expression" exp) env))))
(define (expand-letrec names values body env)
(let* ((new-specs (map (lambda (name value)
(list name
(expand value env)))
names
values)))
(make-node operator/letrec
(list 'letrec new-specs (expand-body body env)))))
(define-expander 'loophole
(lambda (op op-node exp env)
(if (this-long? exp 3)
(make-node op (list op
(sexp->type (desyntaxify (cadr exp)) #t)
(expand (caddr exp) env)))
(expand (syntax-error "invalid expression" exp) env))))
(define-expander 'let-syntax
(lambda (op op-node exp env)
(if (and (at-least-this-long? exp 3)
(specs? (cadr exp)))
(let ((specs (cadr exp)))
(expand-body (cddr exp)
(bind (map car specs)
(map (lambda (spec)
(make-binding syntax-type
(list 'let-syntax)
(process-syntax (cadr spec)
env
(car spec)
env)))
specs)
env)))
(expand (syntax-error "invalid expression" exp) env))))
(define-expander 'letrec-syntax
(lambda (op op-node exp env)
(if (and (at-least-this-long? exp 3)
(specs? (cadr exp)))
(let ((specs (cadr exp)))
(expand-body
(cddr exp)
(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)))
(expand (syntax-error "invalid expression" exp) env))))
(define (process-syntax form env name env-or-package)
(let ((eval+env (force (environment-macro-eval env))))
(make-transform ((car eval+env) form (cdr eval+env))
env-or-package
syntax-type
form
name)))
; This just looks up the names that the LAP code will want and replaces them
; with the appropriate node.
;
; (lap <id> (<free name> ...) <instruction> ...)
(define-expander 'lap
(lambda (op op-node exp env)
(if (and (at-least-this-long? exp 4)
(name? (cdr exp))
(every name? (caddr exp)))
(make-node op `(,op
,(desyntaxify (cadr exp))
,(map (lambda (name)
(expand-name (cadr exp) env))
(caddr exp))
. ,(cdddr exp)))
(expand (syntax-error "invalid expression" exp) env))))
; --------------------
; Syntax checking utilities
(define (this-long? l n)
(cond ((null? l)
(= n 0))
((pair? l)
(this-long? (cdr l) (- n 1)))
(else
#f)))
(define (at-least-this-long? l n)
(cond ((null? l)
(<= n 0))
((pair? l)
(at-least-this-long? (cdr l) (- n 1)))
(else
#f)))
(define (specs? x)
(or (null? x)
(and (pair? x)
(let ((s (car x)))
(and (pair? s)
(name? (car s))
(pair? (cdr s))
(null? (cddr s))))
(specs? (cdr x)))))
; --------------------
; Utilities
(define (literal? exp)
(or (number? exp) (char? exp) (string? exp) (boolean? exp)))
(define (syntax? d)
(cond ((operator? d)
(eq? (operator-type d) syntax-type))
((transform? d)
(eq? (transform-type d) syntax-type))
(else #f)))
;----------------
; Node predicates and operators.
(define begin-node? (node-predicate 'begin syntax-type))
(define call-node? (node-predicate 'call 'internal))
(define name-node? (node-predicate 'name 'leaf))
(define operator/literal (get-operator 'literal 'leaf))
(define operator/quote (get-operator 'quote syntax-type))
(define operator/call (get-operator 'call 'internal))
(define operator/name (get-operator 'name 'leaf))
(define operator/unspecific (get-operator 'unspecific (proc () unspecific-type)))
(define operator/unassigned (get-operator 'unassigned (proc () value-type)))
(define operator/lambda (get-operator 'lambda syntax-type))
(define operator/begin (get-operator 'begin syntax-type))
(define operator/letrec (get-operator 'letrec syntax-type))
(define operator/define (get-operator 'define syntax-type))
(define operator/define-syntax (get-operator 'define-syntax syntax-type))
(define operator/primitive-procedure
(get-operator 'primitive-procedure syntax-type))
(define operator/structure-ref (get-operator 'structure-ref syntax-type))