From 6ffab54eb03b947ae8f303f88c71f3dfe6edc9cd Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 10 Feb 2008 04:42:43 +0000
Subject: [PATCH] Change handling of global primitives; they are now integrated
 only when they appear in operator position.

---
 v7/src/sf/gconst.scm | 317 ++++++++++++++++---------------------------
 v7/src/sf/pardec.scm |  36 ++---
 v7/src/sf/subst.scm  |   5 +-
 v7/src/sf/usicon.scm |  36 ++---
 4 files changed, 154 insertions(+), 240 deletions(-)

diff --git a/v7/src/sf/gconst.scm b/v7/src/sf/gconst.scm
index 0a8519a0a..bd07b1ef4 100644
--- a/v7/src/sf/gconst.scm
+++ b/v7/src/sf/gconst.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: gconst.scm,v 4.37 2008/01/30 20:02:38 cph Exp $
+$Id: gconst.scm,v 4.38 2008/02/10 04:42:40 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -30,213 +30,124 @@ USA.
 
 (declare (usual-integrations))
 
-;;; This is a list of names that are bound in the global environment.
-;;; Normally the compiler will replace references to one of these
-;;; names with the value of that name, which is a constant.
-
 (define global-constant-objects
-  '(
-    %RECORD
-    %RECORD-LENGTH
-    %RECORD-REF
-    %RECORD-SET!
-    %RECORD?
-    *THE-NON-PRINTING-OBJECT*
-    BIT-STRING->UNSIGNED-INTEGER
-    BIT-STRING-ALLOCATE
-    BIT-STRING-AND!
-    BIT-STRING-ANDC!
-    BIT-STRING-CLEAR!
-    BIT-STRING-FILL!
-    BIT-STRING-LENGTH
-    BIT-STRING-MOVE!
-    BIT-STRING-MOVEC!
-    BIT-STRING-OR!
-    BIT-STRING-REF
-    BIT-STRING-SET!
-    BIT-STRING-XOR!
-    BIT-STRING-ZERO?
-    BIT-STRING=?
-    BIT-STRING?
-    BIT-SUBSTRING-FIND-NEXT-SET-BIT
-    BIT-SUBSTRING-MOVE-RIGHT!
-    CAR
-    CDR
-    CHAR->INTEGER
-    CHAR-BITS-LIMIT
+  '(CHAR-BITS-LIMIT
     CHAR-CODE-LIMIT
     CHAR-INTEGER-LIMIT
     CHAR:NEWLINE
-    CHAR?
-    COMPILED-CODE-ADDRESS->BLOCK
-    COMPILED-CODE-ADDRESS->OFFSET
-    CONS
-    EQ?
-    ERROR-PROCEDURE
     FALSE
-    FALSE?
-    FIX:*
-    FIX:+
-    FIX:-
-    FIX:-1+
-    FIX:1+
-    FIX:<
-    FIX:=
-    FIX:>
-    FIX:AND
-    FIX:ANDC
-    FIX:DIVIDE
-    FIX:FIXNUM?
-    FIX:GCD
-    FIX:LSH
-    FIX:NEGATIVE?
-    FIX:NOT
-    FIX:OR
-    FIX:POSITIVE?
-    FIX:QUOTIENT
-    FIX:REMAINDER
-    FIX:XOR
-    FIX:ZERO?
-    FLO:*
-    FLO:+
-    FLO:-
-    FLO:/
-    FLO:<
-    FLO:=
-    FLO:>
-    FLO:ABS
-    FLO:ACOS
-    FLO:ASIN
-    FLO:ATAN
-    FLO:ATAN2
-    FLO:CEILING
-    FLO:CEILING->EXACT
-    FLO:COS
-    FLO:EXP
-    FLO:EXPT
-    FLO:FLONUM?
-    FLO:FLOOR
-    FLO:FLOOR->EXACT
-    FLO:LOG
-    FLO:NEGATE
-    FLO:NEGATIVE?
-    FLO:POSITIVE?
-    FLO:ROUND
-    FLO:ROUND->EXACT
-    FLO:SIN
-    FLO:SQRT
-    FLO:TAN
-    FLO:TRUNCATE
-    FLO:TRUNCATE->EXACT
-    FLO:VECTOR-CONS
-    FLO:VECTOR-LENGTH
-    FLO:VECTOR-REF
-    FLO:VECTOR-SET!
-    FLO:ZERO?
-    GENERAL-CAR-CDR
-    GET-FIXED-OBJECTS-VECTOR
-    GET-INTERRUPT-ENABLES
-    HUNK3-CONS
-    INDEX-FIXNUM?
-    INT:*
-    INT:+
-    INT:-
-    INT:-1+
-    INT:1+
-    INT:<
-    INT:=
-    INT:>
-    INT:DIVIDE
-    INT:NEGATE
-    INT:NEGATIVE?
-    INT:POSITIVE?
-    INT:QUOTIENT
-    INT:REMAINDER
-    INT:ZERO?
-    INTEGER->CHAR
-    INTEGER-DIVIDE-QUOTIENT
-    INTEGER-DIVIDE-REMAINDER
-    INTERRUPT-BIT/AFTER-GC
-    INTERRUPT-BIT/GC
-    INTERRUPT-BIT/GLOBAL-1
-    INTERRUPT-BIT/GLOBAL-3
-    INTERRUPT-BIT/GLOBAL-GC
-    INTERRUPT-BIT/KBD
-    INTERRUPT-BIT/STACK
-    INTERRUPT-BIT/SUSPEND
-    INTERRUPT-BIT/TIMER
-    INTERRUPT-MASK/ALL
-    INTERRUPT-MASK/GC-OK
-    INTERRUPT-MASK/NONE
-    INTERRUPT-MASK/TIMER-OK
-    LAMBDA-TAG:FLUID-LET
-    LAMBDA-TAG:LET
-    LAMBDA-TAG:UNNAMED
-    LEXICAL-ASSIGNMENT
-    LEXICAL-REFERENCE
-    LEXICAL-UNASSIGNED?
-    LEXICAL-UNBOUND?
-    LEXICAL-UNREFERENCEABLE?
-    LIST->VECTOR
-    LOCAL-ASSIGNMENT
-    MAKE-NON-POINTER-OBJECT
-    NOT
-    NULL?
-    OBJECT-CONSTANT?
-    OBJECT-DATUM
-    OBJECT-NEW-TYPE
-    OBJECT-TYPE
-    OBJECT-TYPE?
-    PAIR?
-    PRIMITIVE-PROCEDURE-ARITY
-    SET-CAR!
-    SET-CDR!
-    SET-INTERRUPT-ENABLES!
-    SET-STRING-LENGTH!
-    STRING-ALLOCATE
-    STRING-HASH-MOD
-    STRING-LENGTH
-    STRING-MAXIMUM-LENGTH
-    STRING-REF
-    STRING-SET!
-    STRING?
-    SUBSTRING-MOVE-LEFT!
-    SUBSTRING-MOVE-RIGHT!
-    SUBVECTOR->LIST
-    SUBVECTOR-FILL!
-    SUBVECTOR-MOVE-LEFT!
-    SUBVECTOR-MOVE-RIGHT!
-    SYSTEM-GLOBAL-ENVIRONMENT
-    SYSTEM-HUNK3-CXR0
-    SYSTEM-HUNK3-CXR1
-    SYSTEM-HUNK3-CXR2
-    SYSTEM-HUNK3-SET-CXR0!
-    SYSTEM-HUNK3-SET-CXR1!
-    SYSTEM-HUNK3-SET-CXR2!
-    SYSTEM-LIST->VECTOR
-    SYSTEM-PAIR-CAR
-    SYSTEM-PAIR-CDR
-    SYSTEM-PAIR-CONS
-    SYSTEM-PAIR-SET-CAR!
-    SYSTEM-PAIR-SET-CDR!
-    SYSTEM-PAIR?
-    SYSTEM-SUBVECTOR->LIST
-    SYSTEM-VECTOR-LENGTH
-    SYSTEM-VECTOR-REF
-    SYSTEM-VECTOR-SET!
-    SYSTEM-VECTOR?
     THE-EMPTY-STREAM
     TRUE
     UNDEFINED-CONDITIONAL-BRANCH
-    UNSIGNED-INTEGER->BIT-STRING
-    UNSPECIFIC
-    VECTOR
-    VECTOR-8B-REF
-    VECTOR-8B-SET!
-    VECTOR-LENGTH
-    VECTOR-REF
-    VECTOR-SET!
-    VECTOR?
-    WITH-HISTORY-DISABLED
-    WITH-INTERRUPT-MASK
-    ))
\ No newline at end of file
+    UNSPECIFIC))
+
+(define global-primitives
+  '((%RECORD %RECORD)
+    (%RECORD-LENGTH %RECORD-LENGTH)
+    (%RECORD-REF %RECORD-REF)
+    (%RECORD-SET! %RECORD-SET!)
+    (%RECORD? %RECORD?)
+    (BIT-STRING-LENGTH BIT-STRING-LENGTH)
+    (BIT-STRING? BIT-STRING?)
+    (CAR CAR)
+    (CDR CDR)
+    (CHAR->INTEGER CHAR->INTEGER)
+    (CHAR? CHAR?)
+    (CONS CONS)
+    (EQ? EQ?)
+    (FALSE? NOT)
+    (FIX:* MULTIPLY-FIXNUM)
+    (FIX:+ PLUS-FIXNUM)
+    (FIX:- MINUS-FIXNUM)
+    (FIX:-1+ MINUS-ONE-PLUS-FIXNUM)
+    (FIX:1+ ONE-PLUS-FIXNUM)
+    (FIX:< LESS-THAN-FIXNUM?)
+    (FIX:= EQUAL-FIXNUM?)
+    (FIX:> GREATER-THAN-FIXNUM?)
+    (FIX:AND FIXNUM-AND)
+    (FIX:ANDC FIXNUM-ANDC)
+    (FIX:FIXNUM? FIXNUM?)
+    (FIX:GCD GCD-FIXNUM)
+    (FIX:LSH FIXNUM-LSH)
+    (FIX:NEGATIVE? NEGATIVE-FIXNUM?)
+    (FIX:NOT FIXNUM-NOT)
+    (FIX:OR FIXNUM-OR)
+    (FIX:POSITIVE? POSITIVE-FIXNUM?)
+    (FIX:QUOTIENT FIXNUM-QUOTIENT)
+    (FIX:REMAINDER FIXNUM-REMAINDER)
+    (FIX:XOR FIXNUM-XOR)
+    (FIX:ZERO? ZERO-FIXNUM?)
+    (FLO:* FLONUM-MULTIPLY)
+    (FLO:+ FLONUM-ADD)
+    (FLO:- FLONUM-SUBTRACT)
+    (FLO:/ FLONUM-DIVIDE)
+    (FLO:< FLONUM-LESS?)
+    (FLO:= FLONUM-EQUAL?)
+    (FLO:> FLONUM-GREATER?)
+    (FLO:ABS FLONUM-ABS)
+    (FLO:ACOS FLONUM-ACOS)
+    (FLO:ASIN FLONUM-ASIN)
+    (FLO:ATAN FLONUM-ATAN)
+    (FLO:ATAN2 FLONUM-ATAN2)
+    (FLO:CEILING FLONUM-CEILING)
+    (FLO:COS FLONUM-COS)
+    (FLO:EXP FLONUM-EXP)
+    (FLO:FLONUM? FLONUM?)
+    (FLO:FLOOR FLONUM-FLOOR)
+    (FLO:LOG FLONUM-LOG)
+    (FLO:NEGATE FLONUM-NEGATE)
+    (FLO:NEGATIVE? FLONUM-NEGATIVE?)
+    (FLO:POSITIVE? FLONUM-POSITIVE?)
+    (FLO:ROUND FLONUM-ROUND)
+    (FLO:SIN FLONUM-SIN)
+    (FLO:SQRT FLONUM-SQRT)
+    (FLO:TAN FLONUM-TAN)
+    (FLO:TRUNCATE FLONUM-TRUNCATE)
+    (FLO:VECTOR-CONS FLOATING-VECTOR-CONS)
+    (FLO:VECTOR-LENGTH FLOATING-VECTOR-LENGTH)
+    (FLO:VECTOR-REF FLOATING-VECTOR-REF)
+    (FLO:VECTOR-SET! FLOATING-VECTOR-SET!)
+    (FLO:ZERO? FLONUM-ZERO?)
+    (GET-INTERRUPT-ENABLES GET-INTERRUPT-ENABLES)
+    (INDEX-FIXNUM? INDEX-FIXNUM?)
+    (INT:* INTEGER-MULTIPLY)
+    (INT:+ INTEGER-ADD)
+    (INT:- INTEGER-SUBTRACT)
+    (INT:-1+ INTEGER-SUBTRACT-1)
+    (INT:1+ INTEGER-ADD-1)
+    (INT:< INTEGER-LESS?)
+    (INT:= INTEGER-EQUAL?)
+    (INT:> INTEGER-GREATER?)
+    (INT:NEGATIVE? INTEGER-NEGATIVE?)
+    (INT:POSITIVE? INTEGER-POSITIVE?)
+    (INT:QUOTIENT INTEGER-QUOTIENT)
+    (INT:REMAINDER INTEGER-REMAINDER)
+    (INT:ZERO? INTEGER-ZERO?)
+    (INTEGER->CHAR INTEGER->CHAR)
+    (NOT NOT)
+    (NULL? NULL?)
+    (OBJECT-TYPE OBJECT-TYPE)
+    (OBJECT-TYPE? OBJECT-TYPE?)
+    (PAIR? PAIR?)
+    (SET-CAR! SET-CAR!)
+    (SET-CDR! SET-CDR!)
+    (SET-STRING-LENGTH! SET-STRING-LENGTH!)
+    (STRING-ALLOCATE STRING-ALLOCATE)
+    (STRING-LENGTH STRING-LENGTH)
+    (STRING-REF STRING-REF)
+    (STRING-SET! STRING-SET!)
+    (STRING? STRING?)
+    (SYSTEM-HUNK3-CXR0 SYSTEM-HUNK3-CXR0)
+    (SYSTEM-HUNK3-CXR1 SYSTEM-HUNK3-CXR1)
+    (SYSTEM-HUNK3-CXR2 SYSTEM-HUNK3-CXR2)
+    (SYSTEM-PAIR-CAR SYSTEM-PAIR-CAR)
+    (SYSTEM-PAIR-CDR SYSTEM-PAIR-CDR)
+    (SYSTEM-PAIR-CONS SYSTEM-PAIR-CONS)
+    (SYSTEM-VECTOR-REF SYSTEM-VECTOR-REF)
+    (VECTOR VECTOR)
+    (VECTOR-8B-REF VECTOR-8B-REF)
+    (VECTOR-8B-SET! VECTOR-8B-SET!)
+    (VECTOR-LENGTH VECTOR-LENGTH)
+    (VECTOR-REF VECTOR-REF)
+    (VECTOR-SET! VECTOR-SET!)
+    (VECTOR? VECTOR?)))
\ No newline at end of file
diff --git a/v7/src/sf/pardec.scm b/v7/src/sf/pardec.scm
index f3b715650..bfb360963 100644
--- a/v7/src/sf/pardec.scm
+++ b/v7/src/sf/pardec.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: pardec.scm,v 4.19 2008/01/30 20:02:38 cph Exp $
+$Id: pardec.scm,v 4.20 2008/02/10 04:42:41 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -205,22 +205,24 @@ USA.
 			     (cons (vector operation name value)
 				   remaining))))
 		 unspecific))))
-	(call-with-values
-	    (lambda ()
-	      (do-deletions usual-integrations/expansion-names
-			    usual-integrations/expansion-values))
-	  (lambda (expansion-names expansion-values)
-	    (for-each (constructor 'EXPAND)
-		      expansion-names
-		      expansion-values)))
-	(call-with-values
-	    (lambda ()
-	      (do-deletions usual-integrations/constant-names
-			    usual-integrations/constant-values))
-	  (lambda (constant-names constant-values)
-	    (for-each (constructor 'INTEGRATE)
-		      constant-names
-		      constant-values))))
+	(receive (expansion-names expansion-values)
+	    (do-deletions usual-integrations/expansion-names
+			  usual-integrations/expansion-values)
+	  (for-each (constructor 'EXPAND)
+		    expansion-names
+		    expansion-values))
+	(receive (constant-names constant-values)
+	    (do-deletions usual-integrations/constant-names
+			  usual-integrations/constant-values)
+	  (for-each (constructor 'INTEGRATE)
+		    constant-names
+		    constant-values))
+	(receive (primitive-names primitive-values)
+	    (do-deletions usual-integrations/primitive-names
+			  usual-integrations/primitive-values)
+	  (for-each (constructor 'INTEGRATE-OPERATOR)
+		    primitive-names
+		    primitive-values)))
       (map* declarations
 	    (let ((top-level-block
 		   (let loop ((block block))
diff --git a/v7/src/sf/subst.scm b/v7/src/sf/subst.scm
index de686efab..f802c0602 100644
--- a/v7/src/sf/subst.scm
+++ b/v7/src/sf/subst.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: subst.scm,v 4.23 2008/01/30 20:02:38 cph Exp $
+$Id: subst.scm,v 4.24 2008/02/10 04:42:42 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -663,7 +663,8 @@ you ask for.
 	   => (lambda (operands*)
 		(integrate/combination expression operations environment
 				       block (car operands*) (cdr operands*))))
-	  ((assq name usual-integrations/constant-alist)
+	  ((or (assq name usual-integrations/constant-alist)
+	       (assq name usual-integrations/primitive-alist))
 	   => (lambda (entry)
 		(integrate/combination expression operations environment
 				       block (cdr entry) operands)))
diff --git a/v7/src/sf/usicon.scm b/v7/src/sf/usicon.scm
index 1df064712..a2dad1850 100644
--- a/v7/src/sf/usicon.scm
+++ b/v7/src/sf/usicon.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: usicon.scm,v 4.11 2008/01/30 20:02:38 cph Exp $
+$Id: usicon.scm,v 4.12 2008/02/10 04:42:43 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -30,14 +30,13 @@ USA.
 
 (declare (usual-integrations)
 	 (integrate-external "object"))
-
+
 (define usual-integrations/constant-names)
 (define usual-integrations/constant-values)
 (define usual-integrations/constant-alist)
-
-(define (usual-integrations/delete-constant! name)
-  (set! global-constant-objects (delq! name global-constant-objects))
-  (usual-integrations/cache!))
+(define usual-integrations/primitive-names)
+(define usual-integrations/primitive-values)
+(define usual-integrations/primitive-alist)
 
 (define (usual-integrations/cache!)
   (set! usual-integrations/constant-names
@@ -53,20 +52,9 @@ USA.
 				  FALSE
 				  FIXNUM
 				  FLONUM
-				  INTERNED-SYMBOL
-				  PAIR
-				  PRIMITIVE
-				  QUAD
 				  RATNUM
 				  RECNUM
-				  RETURN-CODE
-				  STRING
-				  TRIPLE
-				  TRUE
-				  UNINTERNED-SYMBOL
-				  VECTOR
-				  VECTOR-16B
-				  VECTOR-1B)))
+				  TRUE)))
 		     (error "USUAL-INTEGRATIONS: not a constant" name))
 		 (constant->integration-info object)))
 	     usual-integrations/constant-names))
@@ -77,4 +65,16 @@ USA.
 		      #f
 		      (environment-lookup system-global-environment name))))
 	     usual-integrations/constant-names))
+  (set! usual-integrations/primitive-names
+	(map car global-primitives))
+  (set! usual-integrations/primitive-values
+	(map (lambda (p)
+	       (constant->integration-info
+		(make-primitive-procedure (cadr p))))
+	     global-primitives))
+  (set! usual-integrations/primitive-alist
+	(map (lambda (p)
+	       (cons (car p)
+		     (constant/make #f (make-primitive-procedure (cadr p)))))
+	     global-primitives))
   unspecific)
\ No newline at end of file
-- 
2.25.1