From bfddab3b09e01c3a29643381420876cd979df1b4 Mon Sep 17 00:00:00 2001 From: Stephen Adams Date: Thu, 31 Jul 1997 10:40:38 +0000 Subject: [PATCH] 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.) --- v7/src/sf/usiexp.scm | 8 +++++--- v8/src/compiler/midend/cleanup.scm | 8 +++++++- v8/src/compiler/midend/typedb.scm | 6 +++++- v8/src/sf/usiexp.scm | 6 ++++-- 4 files changed, 21 insertions(+), 7 deletions(-) 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 -- 2.25.1