7.4: Fixed STRING->SYMBOL expansion to test that it's argument is a

constant whose value is a string rather than applying STRING?
directly (which has been broken since it was added in 1992.)  Fixed
INTERN likewise.

8.0: treat INTERN similarly to STRING->SYMBOL: Add INTERN as a
integrated to a global reference.  Added type rule and constant
folding rule for intern. (This is better than constant folding at
integration time since it deals with constant propagation.)

diff --git a/v7/src/sf/usiexp.scm b/v7/src/sf/usiexp.scm
index 78cda41768ae692ac14ab67c4a34a251e5c6bbab..986be3a6dfe4f771f493605e4af8791468a90451 100644 (file)
--- a/v7/src/sf/usiexp.scm
+++ b/v7/src/sf/usiexp.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: usiexp.scm,v 4.35 1995/08/02 21:42:07 cph Exp $
+$Id: usiexp.scm,v 4.36 1997/07/31 10:40:38 adams Exp $
 
 Copyright (c) 1988-95 Massachusetts Institute of Technology
 
@@ -550,7 +550,8 @@ MIT in each case. |#
                                  block)
   block
   (if (and (pair? operands)
-          (string? (car operands))
+          (constant? (car operands))
+          (string? (constant/value (car operands)))
           (null? (cdr operands)))
       (if-expanded
        (constant/make (and expr (object/scode expr))
@@ -560,7 +561,8 @@ MIT in each case. |#
 (define (intern-expansion expr operands if-expanded if-not-expanded block)
   block
   (if (and (pair? operands)
-          (string? (car operands))
+          (constant? (car operands))
+          (string? (constant/value (car operands)))
           (null? (cdr operands)))
       (if-expanded
        (constant/make (and expr (object/scode expr))

diff --git a/v8/src/compiler/midend/cleanup.scm b/v8/src/compiler/midend/cleanup.scm
index ac6db2e88c9dd70f09bee3b743bed487fa9190ba..6c3a42d2e2d60f9f89d47792791fa036015a06cd 100644 (file)
--- a/v8/src/compiler/midend/cleanup.scm
+++ b/v8/src/compiler/midend/cleanup.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: cleanup.scm,v 1.30 1996/07/20 23:03:03 adams Exp $
+$Id: cleanup.scm,v 1.31 1997/07/31 10:40:16 adams Exp $
 
 Copyright (c) 1994-1996 Massachusetts Institute of Technology
 
@@ -401,6 +401,12 @@ MIT in each case. |#
         (string? (quote/text expr))
         `(QUOTE ,(string->symbol (quote/text expr))))))
 
+(define-cleanup-rewrite 'INTERN 1
+  (lambda (expr)
+    (and (QUOTE/? expr)
+        (string? (quote/text expr))
+        `(QUOTE ,(intern (quote/text expr))))))
+
 (define-cleanup-rewrite (make-primitive-procedure 'EQ?) 2
   (lambda (e1 e2)
     (and (QUOTE/? e1)

diff --git a/v8/src/compiler/midend/typedb.scm b/v8/src/compiler/midend/typedb.scm
index 837a5483620d7d35a5d9fffe4ffb89437f10fb92..414ea50dbf4db08e3f9e7b5e4880a849a40b3ec4 100644 (file)
--- a/v8/src/compiler/midend/typedb.scm
+++ b/v8/src/compiler/midend/typedb.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: typedb.scm,v 1.14 1997/07/11 02:35:04 adams Exp $
+$Id: typedb.scm,v 1.15 1997/07/31 10:39:52 adams Exp $
 
 Copyright (c) 1996 Massachusetts Institute of Technology
 
@@ -56,6 +56,10 @@ MIT in each case. |#
   (procedure-type (list type:string) type:interned-symbol
                  'effect-sensitive effect:string-set!))
 
+(define-operator-type 'INTERN
+  (procedure-type (list type:string) type:interned-symbol
+                 'effect-sensitive effect:string-set!))
+
 (define-operator-type 'SYMBOL->STRING
   (procedure-type (list type:symbol) type:string
                  'effect effect:allocation))

diff --git a/v8/src/sf/usiexp.scm b/v8/src/sf/usiexp.scm
index 9612e9c88f888c3c31a2146efe32b6114f76d3d2..8a7eaca16b987636130555a6febe0b0ea67544b4 100644 (file)
--- a/v8/src/sf/usiexp.scm
+++ b/v8/src/sf/usiexp.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: usiexp.scm,v 1.13 1996/07/22 19:04:06 adams Exp $
+$Id: usiexp.scm,v 1.14 1997/07/31 10:39:37 adams Exp $
 
 Copyright (c) 1988-1995 Massachusetts Institute of Technology
 
@@ -489,7 +489,8 @@ MIT in each case. |#
                                    block)
     block
     (if (and (pair? operands)
-            (string? (car operands))
+            (constant? (car operands))
+            (string? (constant/value (car operands)))
             (null? (cdr operands)))
        (if-expanded
         (constant/make (and expr (object/scode expr))
@@ -646,6 +647,7 @@ MIT in each case. |#
     FLOOR->EXACT
     FOR-EACH
     INEXACT->EXACT
+    INTERN
     LIST-REF
     LOG
     MAKE-STRING