Merged in macro expander changes from Scheme 48 0.56.

scheme/alt/low-packages.scm

@@ -26,3 +26,10 @@
   (files primitives
 	 weak
 	 contin))
+
+(define-structure code-quote (export (code-quote :syntax))
+  (open scheme-level-2)
+  (begin
+    (define-syntax code-quote
+      (lambda (e r c)
+	`(,(r 'quote) ,(cadr e))))))

scheme/bcomp/name.scm

@@ -19,19 +19,19 @@
 ; environment in which M is *used*.
 
 (define-record-type generated :generated
-  (make-generated symbol token env parent-name)
+  (make-generated name token env parent-name)
   generated?
-  (symbol      generated-symbol)
+  (name        generated-name)
   (token       generated-token)
   (env	       generated-env)
   (parent-name generated-parent-name))
 
 (define-record-discloser :generated
   (lambda (name)
-    (list 'generated (generated-symbol name) (generated-uid name))))
+    (list 'generated (generated-name name) (generated-uid name))))
 
-(define (generate-name symbol env parent-name)    ;for opt/inline.scm
+(define (generate-name name env parent-name)    ;for opt/inline.scm
-  (make-generated symbol (cons #f #f) env parent-name)) ;foo
+  (make-generated name (cons #f #f) env parent-name))
 
 (define (generated-uid generated-name)
   (let ((token (generated-token generated-name)))
@@ -46,7 +46,8 @@
 (define (name->symbol name)
   (if (symbol? name)
       name
-      (string->symbol (string-append (symbol->string (generated-symbol name))
+      (string->symbol (string-append (symbol->string
+				       (name->symbol (generated-name name)))
 				     "##"
 				     (number->string (generated-uid name))))))
 
@@ -54,11 +55,12 @@
   (cond ((symbol? name)
 	 (string-hash (symbol->string name)))
 	((generated? name)
-	 (name-hash (generated-symbol name)))
+	 (name-hash (generated-name name)))
 	(else
 	 (error "invalid name" name))))
 
-(define make-name-table (make-table-maker eq? name-hash))
+(define make-name-table
+  (make-table-maker eq? name-hash))
 
 ; Used by QUOTE to turn generated names back into symbols
 
@@ -69,7 +71,7 @@
 	((string? thing)
 	 (make-immutable! thing))
 	((generated? thing)
-	 (desyntaxify (generated-symbol thing)))
+	 (desyntaxify (generated-name thing)))
 	((pair? thing)
 	 (make-immutable!
 	  (let ((x (desyntaxify (car thing)))
@@ -97,7 +99,7 @@
 ; 
 ; A qualified name is a generated name that has been translated into a path.
 ; For example, if syntax A introduces a reference to procedure B, then the
-; reference to B, as a qualified name, will be #(>> A B).  If B has refers
+; reference to B, as a qualified name, will be #(>> A B).  If B refers to
 ; C and is substituted in-line, then the reference to C is #(>> #(>> A B) C).
 ; The binding for C can be located by going to the structure which supplies A,
 ; finding where it gets B from, and then looking up C there.
@@ -114,6 +116,7 @@
 
 (define (qualified-parent-name q) (vector-ref q 1))
 (define (qualified-symbol q) (vector-ref q 2))
+(define (qualified-uid q) (vector-ref q 3))
 
 ; Convert an alias (generated name) to S-expression form ("qualified name").
 
@@ -121,13 +124,13 @@
   (cond ((not (generated? name))
 	 name)
 	((let ((d0 (lookup env name))
-	       (d1 (lookup env (generated-symbol name))))
+	       (d1 (lookup env (generated-name name))))
 	   (and d0 d1 (same-denotation? d0 d1)))
-	 (generated-symbol name))   ;+++
+	 (generated-name name))   ;+++
 	(else
 	 (make-qualified (qualify-parent (generated-parent-name name)
 					 env)
-			 (generated-symbol name)
+			 (generated-name name)
 			 (generated-uid name)))))
 	 
 ; As an optimization, we elide intermediate steps in the lookup path
@@ -137,6 +140,9 @@
 ;	   record-ref)
 ; is replaced with
 ;     #(>> define-record-type record-ref)
+;
+; I think that this is buggy.  The RECUR calls are using the wrong environment.
+; ENV is not the environment in which the names will be looked up.
 
 (define (qualify-parent name env)
   (let recur ((name name))
@@ -157,7 +163,7 @@
 					  (transform-env s2))))))))
 	      (recur parent) ;+++
 	      (make-qualified (recur parent)
-			      (generated-symbol name)
+			      (generated-name name)
 			      (generated-uid name))))
 	name)))
   

scheme/bcomp/package-undef.scm

@@ -92,7 +92,7 @@
 (define (note-caching! cenv name place)
   (if (generated? name)
       (note-caching! (generated-env name)
-		     (generated-symbol name)
+		     (generated-name name)
 		     place)
       (let ((package (cenv->package cenv)))
         (if (package? package)
@@ -103,7 +103,7 @@
 (define (get-location-for-unassignable cenv name)
   (if (generated? name)
       (get-location-for-unassignable (generated-env name)
-				     (generated-symbol name))
+				     (generated-name name))
       (let ((package (cenv->package cenv)))
 	(warn "invalid assignment" name)
 	(if (package? package)
@@ -115,7 +115,7 @@
 (define (get-location-for-undefined cenv name)
   (if (generated? name)
       (get-location-for-undefined (generated-env name)
-				  (generated-symbol name))
+				  (generated-name name))
       (let ((package (cenv->package cenv)))
 	((or (fluid $note-undefined)
 	     (lambda (cenv name) (values)))
@@ -171,7 +171,7 @@
         (lambda (env name)
 	  (if (generated? name)
 	      (add-name (generated-env name)
-			(generated-symbol name))
+			(generated-name name))
 	      (add-name env name)))
       (lambda ()
 	(dynamic-wind
@@ -200,7 +200,7 @@
 	  (display ": " out)
 	  (write (map (lambda (name)
 			(if (generated? name)
-			    (generated-symbol name)
+			    (generated-name name)
 			    name))
 		      (reverse names))
 		 out)

scheme/bcomp/package.scm

@@ -314,7 +314,7 @@
 	  ((generated? name)
 	   ; Access path is (generated-parent-name name)
 	   (generic-lookup (generated-env name)
-			   (generated-symbol name)))
+			   (generated-name name)))
 	  (else
 	   (search-opens (package-opens-really package) name integrate?)))))
 

scheme/bcomp/rules.scm

@@ -17,16 +17,16 @@
         (let ((subkeywords (cadr exp))
               (rules (cddr exp)))
        (if (and (list? subkeywords)
-                   (every name? subkeywords))
+		(every name? subkeywords))
        ;; Pair of the procedure and list of auxiliary names
-          `(,(r 'cons)              ;should be 'transformer
+	   `(,(r 'cons)              ;should be 'transformer
-               ,(process-rules rules subkeywords r c)
+	       ,(process-rules rules subkeywords r c)
-                (,(r 'quote)
+	       (,(r 'quote)
-           ,(find-free-names-in-syntax-rules subkeywords rules)))
+	        ,(find-free-names-in-syntax-rules subkeywords rules)))
-             exp))
+	   exp))
    exp))
   '(append and car cdr cond cons else eq? equal? lambda let let* map
-	   pair? quote values))
+	   pair? quote code-quote values))
 
 
 (define (process-rules rules subkeywords r c)
@@ -49,6 +49,7 @@
   (define %map (r 'map))
   (define %pair? (r 'pair?))
   (define %quote (r 'quote))
+  (define %code-quote (r 'code-quote))
   (define %rename (r 'rename))
   (define %tail (r 'tail))
   (define %temp (r 'temp))
@@ -79,7 +80,7 @@
   (define (process-match input pattern)
     (cond ((name? pattern)
 	   (if (member pattern subkeywords)
-	       `((,%compare ,input (,%rename ',pattern)))
+	       `((,%compare ,input (,%rename (,%code-quote ,pattern))))
 	       `()))
 	  ((segment-pattern? pattern)
 	   (process-segment-match input (car pattern)))
@@ -134,7 +135,7 @@
 		     template
 		     (syntax-error "template dimension error (too few ...'s?)"
 				   template))
-		 `(,%rename ',template))))
+		 `(,%rename (,%code-quote ,template)))))
 	  ((segment-template? template)
 	   (let* ((depth (segment-depth template))
 		  (seg-dim (+ dim depth))
@@ -160,7 +161,8 @@
 	  ((pair? template)
 	   `(,%cons ,(process-template (car template) dim env)
 		    ,(process-template (cdr template) dim env)))
-	  (else `(,%quote ,template))))
+	  (else
+	   `(,%quote ,template))))
 
   ; Return an association list of (var . dim)
 

scheme/bcomp/syntax.scm

@@ -178,7 +178,9 @@
 ; The horror of internal defines
 
 ; This returns a single node, either a LETREC, if there are internal definitions,
-; or a BEGIN if there aren't any.
+; or a BEGIN if there aren't any.  If there are no expressions we turn the last
+; definition back into an expression, thus causing the correct warning to be
+; printed by the compiler.
 
 (define (expand-body body env)
   (if (null? (cdr body))  ;++
@@ -189,10 +191,18 @@
        (lambda (defs exps env)
 	 (if (null? defs)
 	     (make-node operator/begin (cons 'begin (expand-list exps env)))
-	     (expand-letrec (map car (reverse defs))
+	     (call-with-values
-			    (map cdr (reverse defs))
+	      (lambda ()
-			    exps
+		(if (null? exps)
-			    env))))))
+		    (values (reverse (cdr defs))
+			    `((,operator/define ,(caar defs) ,(cdar defs))))
+		    (values (reverse defs)
+			    exps)))
+	      (lambda (defs exps)
+		(expand-letrec (map car defs)
+			       (map cdr defs)
+			       exps
+			       env))))))))
 
 ; Walk through FORMS looking for definitions.  ENV is the current environment,
 ; DEFS a list of definitions found so far.

scheme/bcomp/transform.scm

@@ -65,7 +65,7 @@
 
 (define (name->source-name name)
   (if (generated? name)
-      (generated-symbol name)
+      (name->source-name (generated-name name))
       name))
 				       
 ; The env-of-definition for macros defined at top-level is a package,
@@ -79,7 +79,7 @@
 	  (if (and (generated? name)
 		   (eq? (generated-token name)
 			token))
-	      (lookup env-of-definition (generated-symbol name))
+	      (lookup env-of-definition (generated-name name))
 	      (lookup env-of-use name)))
 	env-of-use)))
 
@@ -89,20 +89,20 @@
 
 (define (make-name-generator env token parent-name)
   (let ((alist '()))			;list of (symbol . generated)
-    (lambda (symbol)
+    (lambda (name)
-      (if (symbol? symbol)
+      (if (name? name)
-	  (let ((probe (assq symbol alist)))
+	  (let ((probe (assq name alist)))
 	    (if probe
 		(cdr probe)
-		(let ((new-name (make-generated symbol token env parent-name)))
+		(let ((new-name (make-generated name token env parent-name)))
-		  (set! alist (cons (cons symbol new-name)
+		  (set! alist (cons (cons name new-name)
 				    alist))
 		  new-name)))
-	  (error "non-symbol argument to rename procedure"
+	  (error "non-name argument to rename procedure"
-		 symbol parent-name)))))
+		 name parent-name)))))
 
 ;----------------
 ; We break an abstraction here to avoid a circular module dependency.
 
 (define (lookup cenv name)
-  (cenv name))
+  (cenv name))

scheme/bcomp/usual.scm

@@ -263,7 +263,8 @@
 	(lambda (car-mode car-arg)
 	  (descend-quasiquote (cdr x) level
 	    (lambda (cdr-mode cdr-arg)
-	      (cond ((and (eq? car-mode 'quote) (eq? cdr-mode 'quote))
+	      (cond ((and (eq? car-mode 'quote)
+			  (eq? cdr-mode 'quote))
 		     (return 'quote x))
 		    ((eq? car-mode 'unquote-splicing)
 		     ;; (,@mumble ...)
@@ -288,7 +289,8 @@
 			  (list (finalize-quasiquote mode arg))))))))
 
     (define (interesting-to-quasiquote? x marker)
-      (and (pair? x) (c (car x) marker)))
+      (and (pair? x)
+	   (c (car x) marker)))
 
     (if (and (pair? (cdr exp))
 	     (null? (cddr exp)))

scheme/comp-packages.scm

@@ -86,6 +86,7 @@
   (open scheme-level-2
 	names		;name?
 	fluids		;used in definition of %file-name%
+	code-quote
 	util
 	tables signals)
   (files (bcomp usual)

scheme/interfaces.scm

@@ -825,7 +825,7 @@
 	  generate-name		;qualified->name in opt/inline.scm
 	  generated?
 
-	  generated-symbol
+	  generated-name
 	  generated-token
 	  generated-env
 	  generated-parent-name

scheme/opt/inline.scm

@@ -88,7 +88,7 @@
 
 (define (unused-name env name)
   (let ((sym (if (generated? name)
-		 (generated-symbol name)
+		 (generated-name name)
 		 name)))
     (do ((i 0 (+ i 1))
 	 (name sym
@@ -211,7 +211,7 @@
 	(let ((parent (recur (qualified-parent-name name))))
 	  (generate-name (qualified-symbol name)
 			 (get-qualified-env (generated-env parent)
-					    (generated-symbol parent))
+					    (generated-name parent))
 			 parent))
 	(rename name))))
 

scheme/rts-packages.scm

@@ -3,7 +3,8 @@
 
 (define-structures ((scheme-level-1 scheme-level-1-interface)
 		    (util util-interface))
-  (open scheme-level-0 ascii signals)
+  (open scheme-level-0 ascii signals
+	code-quote)			; needed by SYNTAX-RULES
   (usual-transforms case quasiquote syntax-rules)
   (files (rts base)
 	 (rts util)