Import Upstream version 5d6upstream/5d6

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: