summaryrefslogtreecommitdiffstats
path: root/mwexpand.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:25 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:25 -0800
commit8ffbc2df0fde83082610149d24e594c1cd879f4a (patch)
treea2be9aad5101c5e450ad141d15c514bc9c2a2963 /mwexpand.scm
downloadslib-8ffbc2df0fde83082610149d24e594c1cd879f4a.tar.gz
slib-8ffbc2df0fde83082610149d24e594c1cd879f4a.zip
Import Upstream version 2a6upstream/2a6
Diffstat (limited to 'mwexpand.scm')
-rw-r--r--mwexpand.scm548
1 files changed, 548 insertions, 0 deletions
diff --git a/mwexpand.scm b/mwexpand.scm
new file mode 100644
index 0000000..10083a3
--- /dev/null
+++ b/mwexpand.scm
@@ -0,0 +1,548 @@
+;"mwexpand.scm" macro expander
+; Copyright 1992 William Clinger
+;
+; Permission to copy this software, in whole or in part, to use this
+; software for any lawful purpose, and to redistribute this software
+; is granted subject to the restriction that all copies made of this
+; software must include this copyright notice in full.
+;
+; I also request that you send me a copy of any improvements that you
+; make to this software so that they may be incorporated within it to
+; the benefit of the Scheme community.
+
+; The external entry points and kernel of the macro expander.
+;
+; Part of this code is snarfed from the Twobit macro expander.
+
+(define mw:define-syntax-scope
+ (let ((flag 'letrec))
+ (lambda args
+ (cond ((null? args) flag)
+ ((not (null? (cdr args)))
+ (apply mw:warn
+ "Too many arguments passed to define-syntax-scope"
+ args))
+ ((memq (car args) '(letrec letrec* let*))
+ (set! flag (car args)))
+ (else (mw:warn "Unrecognized argument to define-syntax-scope"
+ (car args)))))))
+
+(define mw:quit ; assigned by macwork:expand
+ (lambda (v) v))
+
+(define (macwork:expand def-or-exp)
+ (call-with-current-continuation
+ (lambda (k)
+ (set! mw:quit k)
+ (set! mw:renaming-counter 0)
+ (mw:desugar-definitions def-or-exp mw:global-syntax-environment))))
+
+(define (mw:desugar-definitions exp env)
+ (letrec
+ ((define-loop
+ (lambda (exp rest first)
+ (cond ((and (pair? exp)
+ (eq? (mw:syntax-lookup env (car exp))
+ mw:denote-of-begin)
+ (pair? (cdr exp)))
+ (define-loop (cadr exp) (append (cddr exp) rest) first))
+ ((and (pair? exp)
+ (eq? (mw:syntax-lookup env (car exp))
+ mw:denote-of-define))
+ (let ((exp (desugar-define exp env)))
+ (cond ((and (null? first) (null? rest))
+ exp)
+ ((null? rest)
+ (cons mw:begin1 (reverse (cons exp first))))
+ (else (define-loop (car rest)
+ (cdr rest)
+ (cons exp first))))))
+ ((and (pair? exp)
+ (eq? (mw:syntax-lookup env (car exp))
+ mw:denote-of-define-syntax)
+ (null? first))
+ (define-syntax-loop exp rest))
+ ((and (null? first) (null? rest))
+ (mw:expand exp env))
+ ((null? rest)
+ (cons mw:begin1 (reverse (cons (mw:expand exp env) first))))
+ (else (cons mw:begin1
+ (append (reverse first)
+ (map (lambda (exp) (mw:expand exp env))
+ (cons exp rest))))))))
+
+ (desugar-define
+ (lambda (exp env)
+ (cond
+ ((null? (cdr exp)) (mw:error "Malformed definition" exp))
+ ; (define foo) syntax is transformed into (define foo (undefined)).
+ ((null? (cddr exp))
+ (let ((id (cadr exp)))
+ (redefinition id)
+ (mw:syntax-bind-globally! id (mw:make-identifier-denotation id))
+ (list mw:define1 id mw:undefined)))
+ ((pair? (cadr exp))
+ ; mw:lambda0 is an unforgeable lambda, needed here because the
+ ; lambda expression will undergo further expansion.
+ (desugar-define `(,mw:define1 ,(car (cadr exp))
+ (,mw:lambda0 ,(cdr (cadr exp))
+ ,@(cddr exp)))
+ env))
+ ((> (length exp) 3) (mw:error "Malformed definition" exp))
+ (else (let ((id (cadr exp)))
+ (redefinition id)
+ (mw:syntax-bind-globally! id (mw:make-identifier-denotation id))
+ `(,mw:define1 ,id ,(mw:expand (caddr exp) env)))))))
+
+ (define-syntax-loop
+ (lambda (exp rest)
+ (cond ((and (pair? exp)
+ (eq? (mw:syntax-lookup env (car exp))
+ mw:denote-of-begin)
+ (pair? (cdr exp)))
+ (define-syntax-loop (cadr exp) (append (cddr exp) rest)))
+ ((and (pair? exp)
+ (eq? (mw:syntax-lookup env (car exp))
+ mw:denote-of-define-syntax))
+ (if (pair? (cdr exp))
+ (redefinition (cadr exp)))
+ (if (null? rest)
+ (mw:define-syntax exp env)
+ (begin (mw:define-syntax exp env)
+ (define-syntax-loop (car rest) (cdr rest)))))
+ ((null? rest)
+ (mw:expand exp env))
+ (else (cons mw:begin1
+ (map (lambda (exp) (mw:expand exp env))
+ (cons exp rest)))))))
+
+ (redefinition
+ (lambda (id)
+ (if (symbol? id)
+ (if (not (mw:identifier?
+ (mw:syntax-lookup mw:global-syntax-environment id)))
+ (mw:warn "Redefining keyword" id))
+ (mw:error "Malformed variable or keyword" id)))))
+
+ ; body of letrec
+
+ (define-loop exp '() '())))
+
+; Given an expression and a syntactic environment,
+; returns an expression in core Scheme.
+
+(define (mw:expand exp env)
+ (if (not (pair? exp))
+ (mw:atom exp env)
+ (let ((keyword (mw:syntax-lookup env (car exp))))
+ (case (mw:denote-class keyword)
+ ((special)
+ (cond
+ ((eq? keyword mw:denote-of-quote) (mw:quote exp))
+ ((eq? keyword mw:denote-of-lambda) (mw:lambda exp env))
+ ((eq? keyword mw:denote-of-if) (mw:if exp env))
+ ((eq? keyword mw:denote-of-set!) (mw:set exp env))
+ ((eq? keyword mw:denote-of-begin) (mw:begin exp env))
+ ((eq? keyword mw:denote-of-let-syntax) (mw:let-syntax exp env))
+ ((eq? keyword mw:denote-of-letrec-syntax)
+ (mw:letrec-syntax exp env))
+ ; @@ let, let*, letrec, paint within quasiquotation -- kend
+ ((eq? keyword mw:denote-of-let) (mw:let exp env))
+ ((eq? keyword mw:denote-of-let*) (mw:let* exp env))
+ ((eq? keyword mw:denote-of-letrec) (mw:letrec exp env))
+ ((eq? keyword mw:denote-of-quasiquote) (mw:quasiquote exp env))
+ ((eq? keyword mw:denote-of-do) (mw:do exp env))
+ ((or (eq? keyword mw:denote-of-define)
+ (eq? keyword mw:denote-of-define-syntax))
+ ;; slight hack to allow expansion into defines -KenD
+ (if mw:in-define?
+ (mw:error "Definition out of context" exp)
+ (begin
+ (set! mw:in-define? #t)
+ (let ( (result (mw:desugar-definitions exp env)) )
+ (set! mw:in-define? #f)
+ result))
+ ))
+ (else (mw:bug "Bug detected in mw:expand" exp env))))
+ ((macro) (mw:macro exp env))
+ ((identifier) (mw:application exp env))
+ (else (mw:bug "Bug detected in mw:expand" exp env))
+ ) )
+) )
+
+(define mw:in-define? #f) ; should be fluid
+
+(define (mw:atom exp env)
+ (cond ((not (symbol? exp))
+ ; Here exp ought to be a boolean, number, character, or string,
+ ; but I'll allow for non-standard extensions by passing exp
+ ; to the underlying Scheme system without further checking.
+ exp)
+ (else (let ((denotation (mw:syntax-lookup env exp)))
+ (case (mw:denote-class denotation)
+ ((special macro)
+ (mw:error "Syntactic keyword used as a variable" exp env))
+ ((identifier) (mw:identifier-name denotation))
+ (else (mw:bug "Bug detected by mw:atom" exp env)))))))
+
+(define (mw:quote exp)
+ (if (= (mw:safe-length exp) 2)
+ (list mw:quote1 (mw:strip (cadr exp)))
+ (mw:error "Malformed quoted constant" exp)))
+
+(define (mw:lambda exp env)
+ (if (> (mw:safe-length exp) 2)
+ (let* ((formals (cadr exp))
+ (alist (mw:rename-vars (mw:make-null-terminated formals)))
+ (env (mw:syntax-rename env alist))
+ (body (cddr exp)))
+ (list mw:lambda1
+ (mw:rename-formals formals alist)
+ (mw:body body env)))
+ (mw:error "Malformed lambda expression" exp)))
+
+(define (mw:body body env)
+ (define (loop body env defs)
+ (if (null? body)
+ (mw:error "Empty body"))
+ (let ((exp (car body)))
+ (if (and (pair? exp)
+ (symbol? (car exp)))
+ (let ((denotation (mw:syntax-lookup env (car exp))))
+ (case (mw:denote-class denotation)
+ ((special)
+ (cond ((eq? denotation mw:denote-of-begin)
+ (loop (append (cdr exp) (cdr body)) env defs))
+ ((eq? denotation mw:denote-of-define)
+ (loop (cdr body) env (cons exp defs)))
+ (else (mw:finalize-body body env defs))))
+ ((macro)
+ (mw:transcribe exp
+ env
+ (lambda (exp env)
+ (loop (cons exp (cdr body))
+ env
+ defs))))
+ ((identifier)
+ (mw:finalize-body body env defs))
+ (else (mw:bug "Bug detected in mw:body" body env))))
+ (mw:finalize-body body env defs))))
+ (loop body env '()))
+
+(define (mw:finalize-body body env defs)
+ (if (null? defs)
+ (let ((body (map (lambda (exp) (mw:expand exp env))
+ body)))
+ (if (null? (cdr body))
+ (car body)
+ (cons mw:begin1 body)))
+ (let* ((alist (mw:rename-vars '(quote lambda set!)))
+ (env (mw:syntax-alias env alist mw:standard-syntax-environment))
+ (new-quote (cdr (assq 'quote alist)))
+ (new-lambda (cdr (assq 'lambda alist)))
+ (new-set! (cdr (assq 'set! alist))))
+ (define (desugar-definition def)
+ (if (> (mw:safe-length def) 2)
+ (cond ((pair? (cadr def))
+ (desugar-definition
+ `(,(car def)
+ ,(car (cadr def))
+ (,new-lambda
+ ,(cdr (cadr def))
+ ,@(cddr def)))))
+ ((= (length def) 3)
+ (cdr def))
+ (else (mw:error "Malformed definition" def env)))
+ (mw:error "Malformed definition" def env)))
+ (mw:letrec
+ `(letrec ,(map desugar-definition (reverse defs)) ,@body)
+ env)))
+ )
+
+(define (mw:if exp env)
+ (let ((n (mw:safe-length exp)))
+ (if (or (= n 3) (= n 4))
+ (cons mw:if1 (map (lambda (exp) (mw:expand exp env)) (cdr exp)))
+ (mw:error "Malformed if expression" exp env))))
+
+(define (mw:set exp env)
+ (if (= (mw:safe-length exp) 3)
+ `(,mw:set!1 ,(mw:expand (cadr exp) env) ,(mw:expand (caddr exp) env))
+ (mw:error "Malformed assignment" exp env)))
+
+(define (mw:begin exp env)
+ (if (positive? (mw:safe-length exp))
+ `(,mw:begin1 ,@(map (lambda (exp) (mw:expand exp env)) (cdr exp)))
+ (mw:error "Malformed begin expression" exp env)))
+
+(define (mw:application exp env)
+ (if (> (mw:safe-length exp) 0)
+ (map (lambda (exp) (mw:expand exp env))
+ exp)
+ (mw:error "Malformed application")))
+
+; I think the environment argument should always be global here.
+
+(define (mw:define-syntax exp env)
+ (cond ((and (= (mw:safe-length exp) 3)
+ (symbol? (cadr exp)))
+ (mw:define-syntax1 (cadr exp)
+ (caddr exp)
+ env
+ (mw:define-syntax-scope)))
+ ((and (= (mw:safe-length exp) 4)
+ (symbol? (cadr exp))
+ (memq (caddr exp) '(letrec letrec* let*)))
+ (mw:define-syntax1 (cadr exp)
+ (cadddr exp)
+ env
+ (caddr exp)))
+ (else (mw:error "Malformed define-syntax" exp env))))
+
+(define (mw:define-syntax1 keyword spec env scope)
+ (case scope
+ ((letrec) (mw:define-syntax-letrec keyword spec env))
+ ((letrec*) (mw:define-syntax-letrec* keyword spec env))
+ ((let*) (mw:define-syntax-let* keyword spec env))
+ (else (mw:bug "Weird scope" scope)))
+ (list mw:quote1 keyword))
+
+(define (mw:define-syntax-letrec keyword spec env)
+ (mw:syntax-bind-globally!
+ keyword
+ (mw:compile-transformer-spec spec env)))
+
+(define (mw:define-syntax-letrec* keyword spec env)
+ (let* ((env (mw:syntax-extend (mw:syntax-copy env)
+ (list keyword)
+ '((fake denotation))))
+ (transformer (mw:compile-transformer-spec spec env)))
+ (mw:syntax-assign! env keyword transformer)
+ (mw:syntax-bind-globally! keyword transformer)))
+
+(define (mw:define-syntax-let* keyword spec env)
+ (mw:syntax-bind-globally!
+ keyword
+ (mw:compile-transformer-spec spec (mw:syntax-copy env))))
+
+(define (mw:let-syntax exp env)
+ (if (and (> (mw:safe-length exp) 2)
+ (comlist:every (lambda (binding)
+ (and (pair? binding)
+ (symbol? (car binding))
+ (pair? (cdr binding))
+ (null? (cddr binding))))
+ (cadr exp)))
+ (mw:body (cddr exp)
+ (mw:syntax-extend env
+ (map car (cadr exp))
+ (map (lambda (spec)
+ (mw:compile-transformer-spec
+ spec
+ env))
+ (map cadr (cadr exp)))))
+ (mw:error "Malformed let-syntax" exp env)))
+
+(define (mw:letrec-syntax exp env)
+ (if (and (> (mw:safe-length exp) 2)
+ (comlist:every (lambda (binding)
+ (and (pair? binding)
+ (symbol? (car binding))
+ (pair? (cdr binding))
+ (null? (cddr binding))))
+ (cadr exp)))
+ (let ((env (mw:syntax-extend env
+ (map car (cadr exp))
+ (map (lambda (id)
+ '(fake denotation))
+ (cadr exp)))))
+ (for-each (lambda (id spec)
+ (mw:syntax-assign!
+ env
+ id
+ (mw:compile-transformer-spec spec env)))
+ (map car (cadr exp))
+ (map cadr (cadr exp)))
+ (mw:body (cddr exp) env))
+ (mw:error "Malformed let-syntax" exp env)))
+
+(define (mw:macro exp env)
+ (mw:transcribe exp
+ env
+ (lambda (exp env)
+ (mw:expand exp env))))
+
+; To do:
+; Clean up alist hacking et cetera.
+
+;;-----------------------------------------------------------------
+;; The following was added to allow expansion without flattening
+;; LETs to LAMBDAs so that the origianl structure of the program
+;; is preserved by macro expansion. I.e. so that usual.scm is not
+;; required. -- added KenD
+
+(define (mw:process-let-bindings alist binding-list env) ;; helper proc
+ (map (lambda (bind)
+ (list (cdr (assq (car bind) alist)) ; renamed name
+ (mw:body (cdr bind) env))) ; alpha renamed value expression
+ binding-list)
+)
+
+(define (mw:strip-begin exp) ;; helper proc: mw:body sometimes puts one in
+ (if (and (pair? exp) (eq? (car exp) 'begin))
+ (cdr exp)
+ exp)
+)
+
+; LET
+(define (mw:let exp env)
+ (let* ( (name (if (or (pair? (cadr exp)) (null? (cadr exp)))
+ #f
+ (cadr exp))) ; named let?
+ (binds (if name (caddr exp) (cadr exp)))
+ (body (if name (cdddr exp) (cddr exp)))
+ (vars (if (null? binds) #f (map car binds)))
+ (alist (if vars (mw:rename-vars vars) #f))
+ (newenv (if alist (mw:syntax-rename env alist) env))
+ )
+ (if name ;; extend env with new name
+ (let ( (rename (mw:rename-vars (list name))) )
+ (set! alist (append rename alist))
+ (set! newenv (mw:syntax-rename newenv rename))
+ ) )
+ `(let
+ ,@(if name (list (cdr (assq name alist))) '())
+ ,(mw:process-let-bindings alist binds env)
+ ,(mw:body body newenv))
+) )
+
+
+; LETREC differs from LET in that the binding values are processed in the
+; new rather than the original environment.
+
+(define (mw:letrec exp env)
+ (let* ( (binds (cadr exp))
+ (body (cddr exp))
+ (vars (if (null? binds) #f (map car binds)))
+ (alist (if vars (mw:rename-vars vars) #f))
+ (newenv (if alist (mw:syntax-rename env alist) env))
+ )
+ `(letrec
+ ,(mw:process-let-bindings alist binds newenv)
+ ,(mw:body body newenv))
+) )
+
+
+; LET* adds to ENV for each new binding.
+
+(define (mw:let* exp env)
+ (let ( (binds (cadr exp))
+ (body (cddr exp))
+ )
+ (let bind-loop ( (bindings binds) (newbinds '()) (newenv env) )
+ (if (null? bindings)
+ `(let* ,(reverse newbinds) ,(mw:body body newenv))
+ (let* ( (bind (car bindings))
+ (var (car bind))
+ (valexp (cdr bind))
+ (rename (mw:rename-vars (list var)))
+ (next-newenv (mw:syntax-rename newenv rename))
+ )
+ (bind-loop (cdr bindings)
+ (cons (list (cdr (assq var rename))
+ (mw:body valexp newenv))
+ newbinds)
+ next-newenv))
+) ) ) )
+
+
+; DO
+
+(define (mw:process-do-bindings var-init-steps alist oldenv newenv) ;; helper proc
+ (map (lambda (vis)
+ (let ( (v (car vis))
+ (i (cadr vis))
+ (s (if (null? (cddr vis)) (car vis) (caddr vis))))
+ `( ,(cdr (assq v alist)) ; renamed name
+ ,(mw:body (list i) oldenv) ; init in outer/old env
+ ,(mw:body (list s) newenv) ))) ; step in letrec/inner/new env
+ var-init-steps)
+)
+
+(define (mw:do exp env)
+ (let* ( (vis (cadr exp)) ; (Var Init Step ...)
+ (ts (caddr exp)) ; (Test Sequence ...)
+ (com (cdddr exp)) ; (COMmand ...)
+ (vars (if (null? vis) #f (map car vis)))
+ (rename (if vars (mw:rename-vars vars) #f))
+ (newenv (if vars (mw:syntax-rename env rename) env))
+ )
+ `(do ,(if vars (mw:process-do-bindings vis rename env newenv) '())
+ ,(if (null? ts) '() (mw:strip-begin (mw:body (list ts) newenv)))
+ ,@(if (null? com) '() (list (mw:body com newenv))))
+) )
+
+;
+; Quasiquotation (backquote)
+;
+; At level 0, unquoted forms are left painted (not mw:strip'ed).
+; At higher levels, forms which are unquoted to level 0 are painted.
+; This includes forms within quotes. E.g.:
+; (lambda (a)
+; (quasiquote
+; (a (unquote a) b (quasiquote (a (unquote (unquote a)) b)))))
+;or equivalently:
+; (lambda (a) `(a ,a b `(a ,,a b)))
+;=>
+; (lambda (a|1) `(a ,a|1 b `(a ,,a|1 b)))
+
+(define (mw:quasiquote exp env)
+
+ (define (mw:atom exp env)
+ (if (not (symbol? exp))
+ exp
+ (let ((denotation (mw:syntax-lookup env exp)))
+ (case (mw:denote-class denotation)
+ ((special macro identifier) (mw:identifier-name denotation))
+ (else (mw:bug "Bug detected by mw:atom" exp env))))
+ ) )
+
+ (define (quasi subexp level)
+ (cond
+ ((null? subexp) subexp)
+ ((not (or (pair? subexp) (vector? subexp)))
+ (if (zero? level) (mw:atom subexp env) subexp) ; the work is here
+ )
+ ((vector? subexp)
+ (let* ((l (vector-length subexp))
+ (v (make-vector l)))
+ (do ((i 0 (+ i 1)))
+ ((= i l) v)
+ (vector-set! v i (quasi (vector-ref subexp i) level))
+ )
+ )
+ )
+ (else
+ (let ( (keyword (mw:syntax-lookup env (car subexp))) )
+ (cond
+ ((eq? keyword mw:denote-of-unquote)
+ (cons 'unquote (quasi (cdr subexp) (- level 1)))
+ )
+ ((eq? keyword mw:denote-of-unquote-splicing)
+ (cons 'unquote-splicing (quasi (cdr subexp) (- level 1)))
+ )
+ ((eq? keyword mw:denote-of-quasiquote)
+ (cons 'quasiquote (quasi (cdr subexp) (+ level 1)))
+ )
+ (else
+ (cons (quasi (car subexp) level) (quasi (cdr subexp) level))
+ )
+ )
+ ) ) ; end else, let
+ ) ; end cond
+ )
+
+ (quasi exp 0) ; need to unquote to level 0 to paint
+)
+
+;; --- E O F ---