diff options
author | Bryan Newbold <bnewbold@robocracy.org> | 2017-02-20 00:05:25 -0800 |
---|---|---|
committer | Bryan Newbold <bnewbold@robocracy.org> | 2017-02-20 00:05:25 -0800 |
commit | 8ffbc2df0fde83082610149d24e594c1cd879f4a (patch) | |
tree | a2be9aad5101c5e450ad141d15c514bc9c2a2963 /mwexpand.scm | |
download | slib-8ffbc2df0fde83082610149d24e594c1cd879f4a.tar.gz slib-8ffbc2df0fde83082610149d24e594c1cd879f4a.zip |
Import Upstream version 2a6upstream/2a6
Diffstat (limited to 'mwexpand.scm')
-rw-r--r-- | mwexpand.scm | 548 |
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 --- |