From 1116c78f619af7cc3f8eb3cc05e6a9feac56c544 Mon Sep 17 00:00:00 2001
From: Stephen Adams <edu/mit/csail/zurich/adams>
Date: Mon, 22 Jul 1996 17:49:20 +0000
Subject: [PATCH] Added LENGTH, and vector and string constructors.

---
 v8/src/compiler/midend/typedb.scm | 62 +++++++++++++++++++++++++++++--
 1 file changed, 58 insertions(+), 4 deletions(-)

diff --git a/v8/src/compiler/midend/typedb.scm b/v8/src/compiler/midend/typedb.scm
index 005e7dd32..1fb5b2ec3 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.7 1996/07/20 18:30:14 adams Exp $
+$Id: typedb.scm,v 1.8 1996/07/22 17:49:20 adams Exp $
 
 Copyright (c) 1996 Massachusetts Institute of Technology
 
@@ -68,13 +68,27 @@ MIT in each case. |#
 	(procedure-type (list type:string type:string) type:boolean
 			'effect-sensitive effect:string-set!)))
   '(STRING<?    STRING=?    STRING>?    STRING<=?    STRING>=?
-    STRING-CI<? STRING-CI=? STRING-CI>? STRING-CI<=? STRING-CI>=?))
+    STRING-CI<? STRING-CI=? STRING-CI>? STRING-CI<=? STRING-CI>=?
+    STRING-PREFIX?     STRING-SUFFIX?
+    STRING-PREFIX-CI?  STRING-SUFFIX-CI?))
 
 (define-operator-type 'SUBSTRING?
   (procedure-type (list type:string type:string)
 		  (type:or type:false type:fixnum>=0)
 		  'effect-sensitive effect:string-set!))
 
+(define-operator-type 'STRING-APPEND
+  (procedure-type type:string
+		  type:string
+		  'effect-sensitive effect:string-set!
+		  'effect effect:allocation))
+
+(define-operator-type 'STRING-COPY
+  (procedure-type type:string
+		  type:string
+		  'effect-sensitive effect:string-set!
+		  'effect effect:allocation))
+
 
 ;; The following error:* procedures have return type empty, which means
 ;; the procedure never returns.  This is only true if there are no
@@ -135,17 +149,36 @@ MIT in each case. |#
 			    'effect-insensitive
 			    'effect effect:set-cdr!))
 
+(define-operator-type (make-primitive-procedure 'LENGTH)
+  (primitive-procedure-type (list type:list) type:fixnum>=0
+			    'effect-free
+			    'effect-sensitive (effect:union effect:set-car!
+							    effect:set-cdr!)))
+
 (define-operator-type (make-primitive-procedure 'SYSTEM-VECTOR-SIZE)
   (primitive-procedure-type (list type:any) type:vector-length
 			    'function))
 
-;; Note: before the VECTOR definition is useful, we need to change typerew to
-;; handle rest lists:
 (define-operator-type (make-primitive-procedure 'VECTOR)
   (primitive-procedure-type type:any type:vector
 			    'effect-insensitive
 			    'effect effect:allocation))
 
+(define-operator-type (make-primitive-procedure 'VECTOR-CONS)
+  (primitive-procedure-type (list type:vector-length type:any)  type:vector
+			    'effect-insensitive
+			    'effect  effect:allocation))
+
+(define-operator-type %vector-cons
+  (primitive-procedure-type (list type:vector-length type:any)  type:vector
+			    'effect-insensitive
+			    'effect  effect:allocation))
+
+(define-operator-type 'MAKE-VECTOR
+  (procedure-type (cons* type:vector-length   type:any)  type:vector
+		  'effect-insensitive
+		  'effect  effect:allocation))
+
 (define-operator-type (make-primitive-procedure 'VECTOR-LENGTH)
   (primitive-procedure-type (list type:vector) type:vector-length
 			    'function))
@@ -154,6 +187,27 @@ MIT in each case. |#
   (primitive-procedure-type (list type:%record) type:vector-length
 			    'function))
 
+(define-operator-type 'STRING
+  (procedure-type type:any	; should be charatcer but it doesn't check.
+		  type:string
+		  'effect-insensitive
+		  'effect effect:allocation))
+
+(define-operator-type (make-primitive-procedure 'STRING-ALLOCATE)
+  (primitive-procedure-type (list type:string-length)  type:string
+			    'effect-insensitive
+			    'effect  effect:allocation))
+
+(define-operator-type %string-allocate
+  (primitive-procedure-type (list type:string-length)  type:string
+			    'effect-insensitive
+			    'effect  effect:allocation))
+
+(define-operator-type 'MAKE-STRING
+  (procedure-type (cons* type:string-length  type:character)  type:string
+		  'effect-insensitive
+		  'effect  effect:allocation))
+
 (define-operator-type (make-primitive-procedure 'STRING-LENGTH)
   (primitive-procedure-type (list type:string) type:string-length
 			    'effect-free
-- 
2.25.1