653 lines
24 KiB
Scheme
653 lines
24 KiB
Scheme
;;; Ported from Scheme 48 1.9. See file COPYING for notices and license.
|
|
;;;
|
|
;;; Port Author: Andrew Whatson
|
|
;;;
|
|
;;; Original Authors: Richard Kelsey, Jonathan Rees, Mike Sperber, Robert Ransom
|
|
;;;
|
|
;;; scheme48-1.9.2/scheme/bcomp/syntax.scm
|
|
;;;
|
|
;;; 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-module (prescheme bcomp syntax)
|
|
#:use-module (prescheme scheme48)
|
|
#:use-module (prescheme bcomp binding)
|
|
#:use-module (prescheme bcomp cenv)
|
|
#:use-module (prescheme bcomp mtype)
|
|
#:use-module (prescheme bcomp name)
|
|
#:use-module (prescheme bcomp node)
|
|
#:use-module (prescheme bcomp schemify)
|
|
#:use-module (prescheme bcomp transform)
|
|
#:export (expand
|
|
expand-form
|
|
scan-forms
|
|
expand-scanned-form
|
|
syntax?
|
|
static-value))
|
|
|
|
(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
|
|
(comp-env-define! env (cadr new-form) usual-variable-type)
|
|
new-form)
|
|
(syntax-violation 'syntax-rules "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-comp-env env)))
|
|
(comp-env-define! env
|
|
name
|
|
syntax-type
|
|
(process-syntax (if (null? (cdddr form))
|
|
source
|
|
`(cons ,source ',(cadddr form)))
|
|
env
|
|
name
|
|
package))
|
|
'())
|
|
(syntax-violation 'define-syntax "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)
|
|
(let* ((new-form (destructure-define form))
|
|
(temp (if new-form
|
|
(expand-define new-form env)
|
|
(syntax-violation 'expand "ill-formed definition"
|
|
form))))
|
|
(loop more-forms (cons temp 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 (name? (car pat))
|
|
(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. If there are no expressions we turn the last
|
|
;; definition back into an expression, thus causing the correct warning to be
|
|
;; printed by the compiler.
|
|
|
|
(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)))
|
|
(call-with-values
|
|
(lambda ()
|
|
(if (null? exps)
|
|
(values (reverse (cdr defs))
|
|
`((,operator/define ,(caar defs) ,(cdar defs))))
|
|
(values (reverse defs)
|
|
exps)))
|
|
(lambda (defs exps)
|
|
(expand-letrec operator/letrec
|
|
(map car defs)
|
|
(map cdr 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)))
|
|
(syntax-violation 'scan-body-forms
|
|
"ill-formed definition" form))))
|
|
((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-violation 'body
|
|
"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
|
|
(syntax-violation 'expand "invalid expression" form))))
|
|
|
|
(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)))
|
|
(syntax-violation 'expand-call "invalid expression" exp)))
|
|
|
|
;; 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)
|
|
(syntax-violation (schemify (car form) env-of-use)
|
|
"use of macro doesn't match definition"
|
|
(cons (schemify (car form) env-of-use)
|
|
(desyntaxify (cdr form))))
|
|
(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)
|
|
(syntax-violation 'define
|
|
(if (destructure-define exp)
|
|
"definition in expression context"
|
|
"ill-formed definition")
|
|
exp)))
|
|
|
|
;; 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))))
|
|
(syntax-violation 'quote "invalid expression" exp))))
|
|
|
|
;; 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)))
|
|
(syntax-violation 'code-quote "invalid expression" exp))))
|
|
|
|
;; 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
|
|
(syntax-violation 'if "invalid expression" exp)))))
|
|
|
|
(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 ()
|
|
(syntax-violation 'structure-ref "invalid structure reference" form))))
|
|
(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? ...)
|
|
(expander (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)
|
|
(syntax-violation 'lambda "invalid expression" exp))))
|
|
|
|
(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)))
|
|
(syntax-violation 'set! "invalid expression" exp))))
|
|
|
|
(define (letrec-expander op/letrec)
|
|
(lambda (op op-node exp env)
|
|
(if (and (at-least-this-long? exp 3)
|
|
(let-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 op/letrec names (map cadr specs) body env)))
|
|
(syntax-violation 'letrec "invalid expression" exp))))
|
|
|
|
(define-expander 'letrec
|
|
(letrec-expander operator/letrec))
|
|
|
|
(define-expander 'letrec*
|
|
(letrec-expander operator/letrec*))
|
|
|
|
(define (expand-letrec op/letrec names values body env)
|
|
(let* ((new-specs (map (lambda (name value)
|
|
(list name
|
|
(expand value env)))
|
|
names
|
|
values)))
|
|
(make-node op/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)))
|
|
(syntax-violation 'loophole "invalid expression" exp))))
|
|
|
|
(define-expander 'let-syntax
|
|
(lambda (op op-node exp env)
|
|
(if (and (at-least-this-long? exp 3)
|
|
(let-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)))
|
|
(syntax-violation 'let-syntax "invalid expression" exp))))
|
|
|
|
(define-expander 'letrec-syntax
|
|
(lambda (op op-node exp env)
|
|
(if (and (at-least-this-long? exp 3)
|
|
(let-specs? (cadr exp)))
|
|
(let* ((specs (cadr exp))
|
|
(bindings (map (lambda (spec)
|
|
(make-binding syntax-type
|
|
(list 'letrec-syntax)
|
|
'unassigned))
|
|
specs))
|
|
(new-env (bind (map car specs) bindings env)))
|
|
(for-each (lambda (spec binding)
|
|
(set-binding-static! binding
|
|
(process-syntax (cadr spec)
|
|
new-env
|
|
(car spec)
|
|
new-env)))
|
|
specs bindings)
|
|
(expand-body (cddr exp) new-env))
|
|
(syntax-violation 'letrec-syntax "invalid expression" exp))))
|
|
|
|
(define (process-syntax form env name env-or-package)
|
|
(let ((eval+env (force (comp-env-macro-eval env))))
|
|
(make-transform/macro ((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)))
|
|
(syntax-violation 'lap "invalid expression" exp))))
|
|
|
|
;; --------------------
|
|
;; 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 (let-specs? x)
|
|
(or (null? x)
|
|
(and (pair? x)
|
|
(let ((s (car x)))
|
|
(and (pair? s)
|
|
(name? (car s))
|
|
(pair? (cdr s))
|
|
(null? (cddr s))))
|
|
(let-specs? (cdr x)))))
|
|
|
|
;; --------------------
|
|
;; Utilities
|
|
|
|
(define (literal? exp)
|
|
(or (number? exp) (char? exp) (string? exp) (boolean? exp)
|
|
(code-vector? exp)))
|
|
|
|
(define (syntax? d)
|
|
(cond ((operator? d)
|
|
(eq? (operator-type d) syntax-type))
|
|
((transform? d)
|
|
(eq? (transform-type d) syntax-type))
|
|
(else #f)))
|