aboutsummaryrefslogtreecommitdiffstats
path: root/Macexp.scm
diff options
context:
space:
mode:
Diffstat (limited to 'Macexp.scm')
-rw-r--r--Macexp.scm586
1 files changed, 586 insertions, 0 deletions
diff --git a/Macexp.scm b/Macexp.scm
new file mode 100644
index 0000000..6802699
--- /dev/null
+++ b/Macexp.scm
@@ -0,0 +1,586 @@
+;; Copyright (C) 1999 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this software; see the file COPYING. If not, write to
+;; the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
+;;
+;; As a special exception, the Free Software Foundation gives permission
+;; for additional uses of the text contained in its release of SCM.
+;;
+;; The exception is that, if you link the SCM library with other files
+;; to produce an executable, this does not by itself cause the
+;; resulting executable to be covered by the GNU General Public License.
+;; Your use of that executable is in no way restricted on account of
+;; linking the SCM library code into it.
+;;
+;; This exception does not however invalidate any other reasons why
+;; the executable file might be covered by the GNU General Public License.
+;;
+;; This exception applies only to the code released by the
+;; Free Software Foundation under the name SCM. If you copy
+;; code from other Free Software Foundation releases into a copy of
+;; SCM, as the General Public License permits, the exception does
+;; not apply to the code that you add in this way. To avoid misleading
+;; anyone as to the status of such modified files, you must delete
+;; this exception notice from them.
+;;
+;; If you write modifications of your own for SCM, it is your choice
+;; whether to permit this exception to apply to your modifications.
+;; If you do not wish that, delete this exception notice.
+
+;;;; "Macexp.scm", macro expansion, respecting hygiene.
+;;; Author: Radey Shouman
+
+;; LLIST is a lambda list, BINDINGS an alist using the same identifiers.
+(define extended-environment
+ (let ((env:annotation-marker 4))
+ (lambda (llist bindings env)
+ (cons llist (cons env:annotation-marker (cons bindings env))))))
+
+(define syntax-extended-environment
+ (let ((env:syntax-marker 6))
+ ;;BINDINGS is an alist
+ (lambda (bindings env)
+ (cons (cons env:syntax-marker bindings) env))))
+
+(define (environment-ref env id)
+ (environment-annotation id env))
+
+;;(debind:if_ ?llist ?val ?body ?alt)
+;;?alt should evaluate to a procedure taking two arguments, a pattern
+;;and an object. This macro requires the (... ...) ellipsis quote
+;;extension.
+(define-syntax debind:if
+ (syntax-rules ()
+ ((_ "PARSE LLIST" () ?val ?body ?alt)
+ (if (null? ?val) ?body (?alt '() ?val)))
+
+ ((_ "PARSE LLIST" (?pattern (... ...)) ?val ?body ?alt)
+ (let loop ((v ?val))
+ (cond ((null? v)
+ (debind:if "PARSE ..." ?pattern ?val ?body))
+ ((pair? v)
+ (let ((carv (car v)))
+ (debind:if "PARSE LLIST" ?pattern carv
+ (loop (cdr v)) ?alt)))
+ (else
+ (?alt '(?pattern (... ...)) ?val)))))
+
+ ((_ "PARSE LLIST" (?first . ?rest) ?val ?body ?alt)
+ (if (pair? ?val)
+ (let ((carv (car ?val))
+ (cdrv (cdr ?val)))
+ (debind:if "PARSE LLIST" ?first carv
+ (debind:if "PARSE LLIST" ?rest cdrv ?body ?alt)
+ ?alt))
+ (?alt '(?first . ?rest) ?val)))
+
+ ((_ "PARSE LLIST" ?name ?val ?body ?alt)
+ (let ((?name ?val)) ?body))
+
+ ((_ "PARSE ..." () ?val ?body)
+ ?body)
+
+ ((_ "PARSE ..." (?pattern (... ...)) ?val ?body)
+ (debind:if "PARSE ..." ?pattern ?val ?body))
+
+ ((_ "PARSE ..." (?first . ?rest) ?val ?body)
+ (debind:if "PARSE ..." ?first (map car ?val)
+ (debind:if "PARSE ..." ?rest (map cdr ?val)
+ ?body)))
+
+ ((_ "PARSE ..." ?name ?val ?body)
+ (let ((?name ?val)) ?body))
+
+ ((_ ?llist ?val ?body)
+ (debind:if ?llist ?val ?body
+ (lambda (pat val "debind:if" '?llist val
+ "does not match" pat))))
+
+ ((_ ?llist ?val ?body ?alt)
+ (let ((val ?val)
+ (alt ?alt))
+ (debind:if "PARSE LLIST" ?llist val ?body alt)))))
+
+;; Uncomment for DESTRUCTURING-BIND enhanced with ellipsis (...) patterns.
+;(define-syntax destructuring-bind
+; (syntax-rules ()
+; ((_ ?llist ?val ?body1 ?body ...)
+; (debind:if ?llist ?val
+; (let () ?body1 ?body ...)
+; (lambda (pat val)
+; (slib:error 'destructuring-bind '?llist
+; val "does not match" pat))))))
+
+;; This should really dispatch on the keyword only, then
+;; use destructuring-case for each keyword, that way errors
+;; may be more accurately reported for primitives.
+;;
+;;(keyword-case expr env (pattern body ...) ...)
+(define-syntax keyword-case
+ (syntax-rules (else)
+ ((_ "RECURSE" ?expr ?env)
+ (error 'keyword-case ?expr "not matched"))
+ ((_ "RECURSE" ?expr ?env
+ (else ?body1 ?body ...))
+ (let () ?body1 ?body ...))
+ ((_ "RECURSE" ?expr ?env
+ ((?keyword . ?pattern) ?body1 ?body ...)
+ ?clause ...)
+ (let ((alt (lambda (ignore1 ignore2)
+ (keyword-case "RECURSE" ?expr ?env ?clause ...))))
+ ;;Keywords are renamed in the top-level environment for each
+ ;;comparison, this is wasteful and somewhat ugly.
+ (if (identifier-equal? (renamed-identifier '?keyword '())
+ (car ?expr) ?env)
+ (debind:if ?pattern (cdr ?expr)
+ (let () ?body1 ?body ...)
+ alt)
+ (alt #f #f))))
+ ((_ ?expr ?env ?clause1 ?clause ...)
+ (let ((expr ?expr))
+ (if (or (not (pair? expr))
+ (not (identifier? (car expr))))
+ (error 'keyword-case expr "bad form")
+ (keyword-case "RECURSE" expr ?env ?clause1 ?clause ...))))))
+
+;; This is still not safe when ENV has non-macro bindings in it.
+;; It could be made safe by rebuilding an equivalent environment,
+;; retaining values only for syntactic bindings.
+(define (macro:expand-syntax form env pretty? verbose?)
+ (define globals '())
+ (define shadowed-globals '())
+ (define top-lambda (renamed-identifier 'LAMBDA #f))
+ (define top-let (renamed-identifier 'LET #f))
+ (define top-let* (renamed-identifier 'LET* #f))
+ (define top-letrec (renamed-identifier 'LETREC #f))
+ (define top-arrow (renamed-identifier '=> #f))
+ (define top-else (renamed-identifier 'ELSE #f))
+ (define top-define (renamed-identifier 'DEFINE #f))
+ (define top-begin (renamed-identifier 'BEGIN #f))
+ (define (arrow? id env)
+ (and (identifier? id)
+ (identifier-equal? id top-arrow env)))
+ (define (else? id env)
+ (and (identifier? id)
+ (identifier-equal? id top-else env)))
+ (define (define? form env)
+ (and (list? form) ;FORM will have been expanded.
+ (identifier? (car form))
+ (identifier-equal? top-define (car form) env)))
+ (define (begin? form env)
+ (and (list? form)
+ (identifier? (car form))
+ (identifier-equal? (car form) top-begin env)))
+
+ (define locally-bound? environment-annotation)
+
+ (define pretty-name
+ (if pretty?
+ (letrec ((counter 0)
+ (genname
+ (lambda (sym)
+ (set! counter (+ counter 1))
+ (string->symbol
+ (string-append (symbol->string sym)
+ "|" (number->string counter))))))
+ (lambda (name env)
+ (if (symbol? name)
+ (if (or (memq name
+ '(LAMBDA LET LET* LETREC DO DEFINE SET!
+ BEGIN IF COND CASE AND OR QUOTE
+ QUASIQUOTE UNQUOTE UNQUOTE-SPLICING
+ DEFINE-SYNTAX LET-SYNTAX LETREC-SYNTAX
+ SYNTAX-QUOTE ELSE =>))
+ (locally-bound? name env))
+ (genname name)
+ name)
+ (genname (identifier->symbol name)))))
+ identity))
+
+ ;; Local bindings -> (identifier pretty-name (usage-context ...))
+ ;; This will change.
+ (define (initial-binding name env)
+ (or (identifier? name)
+ (slib:error 'macro:expand name "not identifier"))
+ (list name (pretty-name name env) '()))
+ (define binding->name cadr)
+ (define binding->contexts caddr)
+ (define (binding-add-context! b context)
+ (let ((ctx (caddr b)))
+ (if (not (list? ctx))
+ (error 'not-a-list ctx))
+ (or (memq context ctx)
+ (set-car! (cddr b) (cons context ctx)))))
+
+ ;; Produces an alist
+ (define (llist->bindings llist env)
+ (let recurse ((ll llist))
+ (cond ((pair? ll)
+ (cons (initial-binding (car ll) env)
+ (recurse (cdr ll))))
+ ((identifier? ll)
+ (list (initial-binding ll env)))
+ ((null? ll) ll)
+ (else (error 'strange-lambda-list llist)))))
+
+ (define (expand-begin forms env context)
+ (if (null? forms)
+ '()
+ (let recurse ((forms forms))
+ (if (null? (cdr forms))
+ (list (expand (car forms) env context))
+ (cons (expand (car forms) env 'SIDE-EFFECT)
+ (recurse (cdr forms)))))))
+
+ (define (expand-body forms env context)
+ (define (rewrite forms defs)
+ (if (null? defs)
+ (expand-begin forms env context)
+ (list
+ (expand-primitive
+ `(,top-letrec ,(reverse defs) ;reverse just to make it pretty
+ ,@forms) env context))))
+ (let loop ((forms forms)
+ (defs '()))
+ (if (null? (cdr forms))
+ (rewrite forms defs)
+ (let ((form1 (expand (car forms) env 'SIDE-EFFECT)))
+ (cond ((define? form1 env)
+ (loop (cdr forms)
+ (cons (cdr form1) defs)))
+ ((begin? form1 env)
+ (loop (append (cdr form1) (cdr forms))
+ defs))
+ (else (rewrite forms defs)))))))
+
+ (define (lookup id env)
+ (or (environment-ref env id)
+ (let* ((sym (identifier->symbol id))
+ (binding (cond ((assq sym globals))
+ (else
+ (let ((b (initial-binding sym env)))
+ (set! globals (cons b globals))
+ b)))))
+ (cond ((not pretty?) id)
+ ((not (locally-bound? sym env)))
+ ((assq sym shadowed-globals))
+ (else
+ (set! shadowed-globals
+ (cons (cons sym (binding->name binding))
+ shadowed-globals))))
+ binding)))
+
+ (define pretty-varref
+ (if pretty?
+ (lambda (id env)
+ (if (symbol? id)
+ id
+ (let ((sym (identifier->symbol id)))
+ (if (identifier-equal? id sym env) sym id))))
+ (lambda (id env) id)))
+
+ (define unpaint
+ (if pretty?
+ (lambda (x)
+ (cond ((symbol? x) x)
+ ((identifier? x) (identifier->symbol x))
+ ((pair? x) (cons (unpaint (car x)) (unpaint (cdr x))))
+ ((vector? x) (let* ((n (vector-length x))
+ (v (make-vector n)))
+ (do ((i 0 (+ i 1)))
+ ((>= i n) v)
+ (vector-set! v i (unpaint (vector-ref x i))))))
+ (else x)))
+ identity))
+
+ (define (expand* forms env context)
+ (map (lambda (form) (expand form env context)) forms))
+
+ (define (expand-primitive form env context)
+ (define keyword (and (pair? form)
+ (if pretty?
+ (identifier->symbol (car form))
+ (car form))))
+ (keyword-case
+ form env
+ ;;Binding forms
+ ((LAMBDA llist body1 body ...)
+ (let* ((bindings (llist->bindings llist env))
+ (env (extended-environment llist bindings env))
+ (body (expand-body (cons body1 body) env context))
+ (llist (let recurse ((ll llist)
+ (bl bindings))
+ (cond ((null? ll) '())
+ ((pair? ll) (cons (binding->name (car bl))
+ (recurse (cdr ll) (cdr bl))))
+ (else (binding->name bl))))))
+ `(,keyword ,llist ,@body)))
+ ((LET ((names values) ...) body1 body ...)
+ (let* ((values (expand* values env 'VALUE))
+ (bindings (llist->bindings names env))
+ (env (extended-environment names bindings env))
+ (body (expand-body (cons body1 body) env context)))
+ `(,keyword ,(map (lambda (b val) (list (binding->name b) val))
+ bindings values)
+ ,@body)))
+ ((LET name1 ((names values) ...) body1 body ...)
+ (expand `((,top-letrec
+ ((,name1 (,(pretty-varref top-lambda env) ,names
+ ,@(cons body1 body))))
+ ,name1) ,@values)
+ env context))
+ ((LETREC ((names values) ...) body1 body ...)
+ (let* ((bindings (llist->bindings names env))
+ (env (extended-environment names bindings env))
+ (values (expand* values env 'VALUE))
+ (body (expand-body (cons body1 body) env context)))
+ `(,keyword ,(map (lambda (b val) (list (binding->name b) val))
+ bindings values)
+ ,@body)))
+ ((LET* ((names values) ...) body1 body ...)
+ (let recurse ((ns names)
+ (vs values)
+ (env env)
+ (bs '()))
+ (if (null? ns)
+ (let ((body (expand-body (cons body1 body) env context)))
+ `(,keyword ,(reverse bs) ,@body))
+ (let ((binding (initial-binding (car ns) env)))
+ (recurse (cdr ns) (cdr vs)
+ (extended-environment (car ns)
+ (list binding)
+ env)
+ (cons (list (binding->name binding)
+ (expand (car vs) env 'VALUE))
+ bs))))))
+ ((DO ((names inits . steps) ...)
+ (test exit ...)
+ body ...)
+ (let* ((steps (map (lambda (name step)
+ (if (null? step) name (car step)))
+ names steps))
+ (inits (expand* inits env 'VALUE))
+ (bindings (llist->bindings names env))
+ (env (extended-environment names bindings env))
+ (steps (expand* steps env 'VALUE))
+ (test (expand test env 'BOOLEAN))
+ (exit (expand-begin exit env context))
+ (body (expand-begin body env 'SIDE-EFFECT)))
+ `(,keyword
+ ,(map (lambda (binding init step)
+ (list (binding->name binding) init step))
+ bindings inits steps)
+ ,(cons test exit)
+ ,@body)))
+ ((DEFINE (name . llist) body ...)
+ (expand-primitive
+ `(,keyword ,name (,top-lambda ,llist ,@body)) env context))
+ ((DEFINE name value)
+ (cond ((null? env) ;Top level
+ (binding-add-context! (lookup name env) 'DEFINE)
+ `(,keyword ,(pretty-varref name env)
+ ,(expand value env 'VALUE)))
+ (else
+ `(,keyword ,name ,value)))) ;Expansion will be done by expand-body.
+
+ ((SET! var value)
+ (let ((b (lookup var env)))
+ (binding-add-context! b 'SET!)
+ `(,keyword ,(binding->name b) ,(expand value env 'VALUE))))
+
+ ;;Non-binding forms
+ ((BEGIN body ...)
+ (let ((body (expand-begin body env context)))
+ (if (null? (cdr body))
+ (car body)
+ `(,keyword ,@body))))
+ ((IF test conseq . alt)
+ `(,keyword ,(expand test env 'BOOLEAN)
+ ,(expand conseq env context)
+ ,@(if (pair? alt)
+ (list (expand (car alt) env context))
+ '())))
+ ((COND (test exprs ...) ...)
+ `(,keyword
+ ,@(map (lambda (test exprs)
+ (cond ((null? exprs) (list (expand test env context)))
+ ((arrow? (car exprs) env)
+ (list (expand test env 'VALUE)
+ (pretty-varref top-arrow env)
+ (expand (cadr exprs) env 'PROCEDURE)))
+ ((else? test env)
+ (cons (pretty-varref top-else env)
+ (expand-begin exprs env context)))
+ (else
+ (cons (expand test env 'BOOLEAN)
+ (expand-begin exprs env context)))))
+ test exprs)))
+ ((CASE obj (datums exprs ...) ...)
+ `(,keyword ,(expand obj env 'VALUE)
+ ,@(map (lambda (datums exprs)
+ (cons (if (else? datums env)
+ (pretty-varref datums env)
+ (unpaint datums))
+ (expand-begin exprs env context)))
+ datums exprs)))
+ ((AND forms ...)
+ `(,keyword ,@(expand* forms env context)))
+ ((OR forms ...)
+ `(,keyword ,@(expand* forms env context)))
+
+ ;; Should unpaint synthetic identifiers
+ ((QUOTE obj)
+ `(,keyword ,(unpaint obj)))
+ ((QUASIQUOTE obj)
+ `(,keyword
+ ,(let qexp ((obj obj)
+ (depth 0))
+ (cond ((not (pair? obj))
+ (unpaint obj))
+ ((identifier? (car obj))
+ (let ((keyword (car obj)))
+ (keyword-case
+ obj env
+ ((QUASIQUOTE arg)
+ (list keyword (qexp arg (+ depth 1))))
+ ((UNQUOTE arg)
+ (list keyword
+ (if (zero? depth)
+ (expand arg env context)
+ (qexp arg (- depth 1)))))
+ ((UNQUOTE-SPLICING arg)
+ (list keyword
+ (if (zero? depth)
+ (expand arg env context)
+ (qexp arg (- depth 1)))))
+ (else
+ (cons (unpaint keyword) (qexp (cdr obj) depth))))))
+ (else
+ (cons (qexp (car obj) depth)
+ (qexp (cdr obj) depth)))))))
+ ((DEFINE-SYNTAX name def)
+ form)
+ ((LET-SYNTAX ((names defs) ...) body1 body ...)
+ (let* ((env (syntax-extended-environment '() env))
+ (defs (map (lambda (name def)
+ (cons name (eval-syntax def env)))
+ names defs))
+ (env (syntax-extended-environment defs env))
+ (body (expand-body (cons body1 body) env context)))
+ (if pretty?
+ `(,(pretty-varref top-let env) () ,@body)
+ `(,top-let* (,(list marker #f)) ,@body))))
+ ((LETREC-SYNTAX ((names defs) ...) body1 body ...)
+ (let* ((eframe (map (lambda (name) (cons name #f)) names))
+ (env (syntax-extended-environment eframe env)))
+ (do ((ds defs (cdr ds))
+ (ef eframe (cdr ef)))
+ ((null? ds))
+ (set-cdr! (car ef) (eval-syntax (car ds) env)))
+ (let ((body (expand-body (cons body1 body) env context)))
+ (if pretty?
+ `(,(pretty-varref top-let env) () ,@body)
+ `(,top-let* (,(list marker #f)) ,@body)))))
+ ;;SCM extension
+ ((SYNTAX-QUOTE obj)
+ `(,keyword ,obj))
+ (else
+ (warn 'expand-syntax "Unexpected primitive syntax" form)
+ form)))
+
+ (define (handle-shadowed form env)
+ (if (define? form env)
+ (list (car form) (cadr form)
+ (handle-shadowed (caddr form)))
+ `(,(pretty-varref top-let env)
+ ,(map (lambda (s)
+ (list (cdr s)
+ (if (environment-ref env (car s))
+ (renamed-identifier (car s) #f)
+ (car s))))
+ shadowed-globals)
+ ,form)))
+
+ (define (expand form env context)
+ (cond
+ ((identifier? form)
+ (let ((expanded (@macroexpand1 form env)))
+ (cond ((eq? form expanded) form)
+ ((not expanded)
+ (let* ((b (lookup form env))
+ (name (binding->name b)))
+ (binding-add-context! b context)
+ name))
+ (else expanded))))
+ ((number? form) form)
+ ((char? form) form)
+ ((boolean? form) form)
+ ((null? form) form)
+ ((string? form) form)
+ ((list? form)
+ (if (identifier? (car form))
+ (let ((expanded (@macroexpand1 form env)))
+ (cond ((eq? expanded form)
+ (expand-primitive form env context))
+ ((not expanded)
+ (cons (expand (car form) env 'PROCEDURE)
+ (map (lambda (arg)
+ (expand arg env 'VALUE))
+ (cdr form))))
+ (else
+ (expand expanded env context))))
+ (cons (expand (car form) env 'PROCEDURE)
+ (expand* (cdr form) env 'VALUE))))
+ (else
+ (warn 'expand-syntax "Unexpected type of form" form)
+ form)))
+
+ (let ((res (expand form env 'TOP)))
+ (cond (verbose?
+ (display "Globals: ")
+ (pretty-print globals)
+ (display "Shadowed Globals: ")
+ (pretty-print shadowed-globals)))
+ (cond ((null? shadowed-globals) res)
+ ((not (begin? res env)) (handle-shadowed res env))
+ (else (cons (car res)
+ (map (lambda (form)
+ (handle-shadowed form env))
+ (cdr res)))))))
+
+(define (macro:expand form . opt)
+ (macro:expand-syntax form '()
+ (not (memq 'not-pretty opt))
+ (memq 'verbose opt)))
+
+;; Debugging fodder.
+(begin
+ (define (read* filename)
+ (call-with-input-file filename
+ (lambda (p)
+ (let loop ((forms '()))
+ (let ((form (read p)))
+ (if (eof-object? form)
+ (cons 'BEGIN (reverse forms))
+ (loop (cons form forms))))))))
+ (define (expand-file filename . opt)
+ (apply macro:expand (read* filename) '() opt))
+ (define s (read* (or *load-pathname* "Macexp.scm"))))
+
+
+;;; Local Variables:
+;;; mode:scheme
+;;; eval:(put 'destructuring-bind 'scheme-indent-function 1)
+;;; eval:(put 'destructuring-case 'scheme-indent-function 1)
+;;; End: