From: Stephen Adams <edu/mit/csail/zurich/adams>
Date: Thu, 31 Jul 1997 10:40:38 +0000 (+0000)
Subject: 7.4: Fixed STRING->SYMBOL expansion to test that it's argument is a
X-Git-Tag: 20090517-FFI~5031
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=bfddab3b09e01c3a29643381420876cd979df1b4;p=mit-scheme.git

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 78cda4176..986be3a6d 100644
--- 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 ac6db2e88..6c3a42d2e 100644
--- 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 837a54836..414ea50db 100644
--- 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 9612e9c88..8a7eaca16 100644
--- 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