From bfd9d3ce59f0e899b0490d0b544dfc15e39791b4 Mon Sep 17 00:00:00 2001
From: Stephen Adams <edu/mit/csail/zurich/adams>
Date: Tue, 23 Jul 1996 14:49:42 +0000
Subject: [PATCH] Added SORT[!], FOR-EACH and MAP, and some generic arithmetic
 operators.

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

diff --git a/v8/src/compiler/midend/typedb.scm b/v8/src/compiler/midend/typedb.scm
index 1fb5b2ec3..2f82ac78c 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.8 1996/07/22 17:49:20 adams Exp $
+$Id: typedb.scm,v 1.9 1996/07/23 14:49:42 adams Exp $
 
 Copyright (c) 1996 Massachusetts Institute of Technology
 
@@ -89,6 +89,25 @@ MIT in each case. |#
 		  'effect-sensitive effect:string-set!
 		  'effect effect:allocation))
 
+(let ((list-or-vector (type:or type:list type:vector)))
+  (define-operator-type 'SORT
+    (procedure-type (list list-or-vector type:procedure)
+		    list-or-vector
+		    'effect-sensitive effect:unknown))
+  (define-operator-type 'SORT!
+    (procedure-type (list list-or-vector type:procedure)
+		    list-or-vector
+		    'effect-sensitive effect:unknown)))
+
+(define-operator-type 'FOR-EACH
+  (procedure-type (cons* type:procedure type:list)
+		  type:unspecified
+		  'effect-sensitive effect:unknown))
+
+(define-operator-type 'MAP
+  (procedure-type (cons* type:procedure type:list)
+		  type:list
+		  'effect-sensitive effect:unknown))
 
 ;; The following error:* procedures have return type empty, which means
 ;; the procedure never returns.  This is only true if there are no
@@ -299,8 +318,7 @@ MIT in each case. |#
     type:flonum-vector type:vector-length type:flonum  effect:flo:vector-set!)
   (define-indexed 'BIT-STRING-REF  'BIT-STRING-SET!
     type:bit-string type:string-length type:boolean effect:bit-string-set!))
-
-
+
 (let ()
   (define ((unchecked-function domain* range) . ops)
     (for-each
@@ -311,6 +329,18 @@ MIT in each case. |#
 	     'function 'unchecked)))
       ops))
 
+  (define ((checked-function domain* range) . ops)
+    (let ((arity #F))
+      (pp domain*)
+      (for-each
+	  (lambda (op)
+	    (if (exact-integer? op)
+		(set! arity op)
+		(define-operator-type op
+		  (primitive-procedure-type (make-list arity domain*) range
+					    'function))))
+	ops)))
+
   ((unchecked-function type:flonum type:flonum)
    flo:+ flo:- flo:* flo:/ flo:negate flo:abs flo:sqrt
    flo:floor flo:ceiling flo:truncate flo:round
@@ -325,7 +355,22 @@ MIT in each case. |#
    fix:andc fix:and fix:or fix:xor fix:not fix:lsh)
 
   ((unchecked-function type:fixnum type:boolean)
-   fix:= fix:< fix:> fix:zero? fix:negative? fix:positive?))
+   fix:= fix:< fix:> fix:zero? fix:negative? fix:positive?)
+
+  ((checked-function type:exact-integer type:exact-integer)
+   2 int:+ int:- int:* int:quotient int:remainder)
+
+  ((checked-function type:exact-integer  type:boolean)
+   2 int:= int:< int:>
+   1 int:zero? int:negative? int:positive?)
+
+  (let-syntax ((p (macro spec (apply make-primitive-procedure spec))))
+    ((checked-function type:number type:number)
+     2 %+ %- %* %/ (p &+) (p &-) (p &*) (p &/))
+    ((checked-function type:number type:boolean)
+     2 %< %= %> (p &=) (p &<) (p &>)))
+  )
+   
 
 (for-each
     (lambda (name)
-- 
2.25.1