From ddad4012e94f6a82df8a590d71cf7d2afedf85da Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 14 Feb 2008 02:12:52 +0000
Subject: [PATCH] Don't insert top-level bindings of procedures into code,
 assuming that they are primitives.  Use explicit references to primitives.

---
 v7/src/compiler/back/syerly.scm  | 12 +++++++-----
 v7/src/compiler/base/scode.scm   |  5 +++--
 v7/src/compiler/fggen/fggen.scm  |  6 ++++--
 v7/src/edwin/xform.scm           |  7 ++++---
 v7/src/runtime/lambda.scm        |  9 +++++----
 v7/src/runtime/syntax-output.scm |  5 +++--
 v7/src/runtime/urtrap.scm        |  4 ++--
 7 files changed, 28 insertions(+), 20 deletions(-)

diff --git a/v7/src/compiler/back/syerly.scm b/v7/src/compiler/back/syerly.scm
index ea10059ae..f42e751ce 100644
--- a/v7/src/compiler/back/syerly.scm
+++ b/v7/src/compiler/back/syerly.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: syerly.scm,v 1.17 2008/01/30 20:01:42 cph Exp $
+$Id: syerly.scm,v 1.18 2008/02/14 02:12:52 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -53,7 +53,7 @@ USA.
 			       ENTRY-POINT LABEL BLOCK-OFFSET))
 		(if-expanded
 		 (scode/make-combination
-		  (scode/make-variable  'DIRECTIVE->INSTRUCTION-SEQUENCE)
+		  (scode/make-variable 'DIRECTIVE->INSTRUCTION-SEQUENCE)
 		  operands)))
 	       (else
 		(let ((place (assq (car instruction) early-instructions)))
@@ -167,7 +167,9 @@ USA.
 		     (if (not (null? (scode/constant-value (cadr operands))))
 			 (error "CONS-SYNTAX-EXPANDER: bad tail"
 				(cadr operands)))
-		     (if-expanded (scode/make-combination cons operands)))))))
+		     (if-expanded
+		      (scode/make-combination (ucode-primitive cons)
+					      operands)))))))
        (if (and (scode/constant? (car operands))
 		(bit-string? (scode/constant-value (car operands)))
 		(scode/combination? (cadr operands)))
@@ -181,7 +183,7 @@ USA.
 		   (if-expanded
 		    (scode/make-combination
 		     (if (scode/constant? (cadr inner-operands))
-			 cons
+			 (ucode-primitive cons)
 			 operator)
 		     (cons (instruction-append
 			    (scode/constant-value (car operands))
@@ -233,6 +235,6 @@ USA.
 		     (list (car binding))
 		     (list (cdr binding))
 		     (scode/make-combination
-		      cons
+		      (ucode-primitive cons)
 		      (list rest
 			    (scode/make-variable (car binding))))))))))))))
\ No newline at end of file
diff --git a/v7/src/compiler/base/scode.scm b/v7/src/compiler/base/scode.scm
index 1353ea8a0..f6682449e 100644
--- a/v7/src/compiler/base/scode.scm
+++ b/v7/src/compiler/base/scode.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: scode.scm,v 4.19 2008/01/30 20:01:43 cph Exp $
+$Id: scode.scm,v 4.20 2008/02/14 02:12:27 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -123,5 +123,6 @@ USA.
   (scode/make-absolute-combination
    'ERROR-PROCEDURE
    (list message
-	 (scode/make-combination cons (list operand '()))
+	 (scode/make-combination (ucode-primitive cons)
+				 (list operand '()))
 	 (scode/make-the-environment))))
\ No newline at end of file
diff --git a/v7/src/compiler/fggen/fggen.scm b/v7/src/compiler/fggen/fggen.scm
index e4a992ecb..0584b86cb 100644
--- a/v7/src/compiler/fggen/fggen.scm
+++ b/v7/src/compiler/fggen/fggen.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: fggen.scm,v 4.44 2008/01/30 20:01:44 cph Exp $
+$Id: fggen.scm,v 4.45 2008/02/14 02:12:14 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -589,7 +589,9 @@ USA.
 		(if (= n 1)
 		    expression
 		    (loop (scode/make-combination
-			   (if (= (remainder n 2) 1) car cdr)
+			   (if (= (remainder n 2) 1)
+			       (ucode-primitive car)
+			       (ucode-primitive cdr))
 			   (list expression))
 			  (quotient n 2))))))
 	    (else
diff --git a/v7/src/edwin/xform.scm b/v7/src/edwin/xform.scm
index 86d0e9a9f..58dbbfcaf 100644
--- a/v7/src/edwin/xform.scm
+++ b/v7/src/edwin/xform.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: xform.scm,v 1.18 2008/01/30 20:02:07 cph Exp $
+$Id: xform.scm,v 1.19 2008/02/14 02:11:51 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -64,7 +64,8 @@ USA.
   (let ((entry (assq (scode-variable-name variable) transforms)))
     (if (not entry)
 	variable
-	(make-combination vector-ref (list name-of-self (cdr entry))))))
+	(make-combination (ucode-primitive vector-ref)
+			  (list name-of-self (cdr entry))))))
 
 (define (transform-assignment transforms assignment)
   (assignment-components assignment
@@ -73,7 +74,7 @@ USA.
 	    (value (transform-expression transforms value)))
 	(if (not entry)
 	    (make-assignment name value)
-	    (make-combination vector-set!
+	    (make-combination (ucode-primitive vector-set!)
 			      (list name-of-self
 				    (cdr entry)
 				    value)))))))
diff --git a/v7/src/runtime/lambda.scm b/v7/src/runtime/lambda.scm
index 4b7cb28be..dedeb0342 100644
--- a/v7/src/runtime/lambda.scm
+++ b/v7/src/runtime/lambda.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: lambda.scm,v 14.22 2008/01/30 20:02:32 cph Exp $
+$Id: lambda.scm,v 14.23 2008/02/14 02:11:34 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -250,11 +250,12 @@ USA.
 				       (make-unassigned auxiliary))))
 		(list (let ((environment (make-the-environment)))
 			(make-combination
-			 system-subvector->list
+			 (ucode-primitive system-subvector-to-list)
 			 (list environment
 			       (+ (length required) 3)
-			       (make-combination system-vector-length
-						 (list environment)))))))))
+			       (make-combination
+				(ucode-primitive system-vector-size)
+				(list environment)))))))))
 
 (define (clexpr-components clexpr receiver)
   (slexpr-components clexpr
diff --git a/v7/src/runtime/syntax-output.scm b/v7/src/runtime/syntax-output.scm
index db1a620cc..b222afbba 100644
--- a/v7/src/runtime/syntax-output.scm
+++ b/v7/src/runtime/syntax-output.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: syntax-output.scm,v 14.15 2008/01/30 20:02:36 cph Exp $
+$Id: syntax-output.scm,v 14.16 2008/02/14 02:11:38 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -139,7 +139,8 @@ USA.
   (make-access environment name))
 
 (define (output/access-assignment name environment value)
-  (make-combination lexical-assignment (list environment name value)))
+  (make-combination (ucode-primitive lexical-assignment)
+		    (list environment name value)))
 
 (define (output/local-declare declarations body)
   (make-declaration declarations body))
diff --git a/v7/src/runtime/urtrap.scm b/v7/src/runtime/urtrap.scm
index 2e27aff02..5b6c5009f 100644
--- a/v7/src/runtime/urtrap.scm
+++ b/v7/src/runtime/urtrap.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: urtrap.scm,v 14.21 2008/02/13 14:25:33 cph Exp $
+$Id: urtrap.scm,v 14.22 2008/02/14 02:11:39 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -160,7 +160,7 @@ USA.
 	      (fix:= 15 (primitive-object-ref (getter) 0))))))
 
 (define (make-macro-reference-trap-expression transformer)
-  (make-combination primitive-object-set-type
+  (make-combination (ucode-primitive primitive-object-set-type)
 		    (list (ucode-type reference-trap)
 			  (make-combination (ucode-primitive cons)
 					    (list 15 transformer)))))
-- 
2.25.1