;"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 ---