From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 10 Feb 2008 04:42:43 +0000 (+0000)
Subject: Change handling of global primitives; they are now integrated only
X-Git-Tag: 20090517-FFI~344
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=6ffab54eb03b947ae8f303f88c71f3dfe6edc9cd;p=mit-scheme.git
Change handling of global primitives; they are now integrated only
when they appear in operator position.
---
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