From 00970f12d24dc82b256576d4e4700d9c549fe68f Mon Sep 17 00:00:00 2001
From: Abdulaziz Ghuloum <aghuloum@cs.indiana.edu>
Date: Tue, 8 Jul 2008 08:15:14 -0700
Subject: [PATCH] - compound conditions are made non-opaque. - more tag
 analysis for bytevectors and friends.

---
 ...ikarus.compiler.tag-annotation-analysis.ss | 35 ++++++++++---------
 scheme/ikarus.conditions.ss                   |  3 +-
 scheme/ikarus.ontology.ss                     |  5 +--
 scheme/last-revision                          |  2 +-
 4 files changed, 25 insertions(+), 20 deletions(-)

diff --git a/scheme/ikarus.compiler.tag-annotation-analysis.ss b/scheme/ikarus.compiler.tag-annotation-analysis.ss
index b1154f4..5a2aa7e 100644
--- a/scheme/ikarus.compiler.tag-annotation-analysis.ss
+++ b/scheme/ikarus.compiler.tag-annotation-analysis.ss
@@ -25,18 +25,7 @@
   #;
   (define primitive-return-types 
     '(
-      [length                fixnum]
-      [bytevector-length     fixnum]
-      [bytevector-u8-ref     fixnum]
-      [bytevector-s8-ref     fixnum]
-      [bytevector-u16-ref    fixnum]
-      [bytevector-s16-ref    fixnum]
-      [bytevector-u16-native-ref    fixnum]
-      [bytevector-s16-native-ref    fixnum]
-      [fixnum-width          fixnum]
-      [greatest-fixnum       fixnum]
-      [least-fixnum          fixnum]
-      [=                     boolean]
+     [=                     boolean]
       [<                     boolean]
       [<=                    boolean]
       [>                     boolean]
@@ -305,17 +294,30 @@
        (inject T:object T:vector T:fixnum)]
       [(vector-set!)
        (inject T:void T:vector T:fixnum T:object)]
+      [(length)
+       (inject T:fixnum (T:or T:null T:pair))]
+      [(bytevector-length)
+       (inject T:fixnum T:bytevector)]
       [(integer->char)
        (inject T:char T:fixnum)]
       [(char->integer)
        (inject T:fixnum T:char)]
+      [(bytevector-u8-ref bytevector-s8-ref 
+        bytevector-u16-native-ref bytevector-s16-native-ref)
+       (inject T:fixnum T:bytevector T:fixnum)]
+      [(bytevector-u16-ref bytevector-s16-ref)
+       (inject T:fixnum T:bytevector T:fixnum T:symbol)]
+      [(bytevector-u8-set! bytevector-s8-set! 
+        bytevector-u16-native-set! bytevector-s16-native-set!)
+       (inject T:void T:bytevector T:fixnum T:fixnum)]
+      [(bytevector-u16-set! bytevector-s16-set!)
+       (inject T:void T:bytevector T:fixnum T:fixnum T:symbol)]
       [(fx+         fx-         fx*         fxadd1      fxsub1
         fxquotient  fxremainder fxmodulo    fxsll       fxsra
         fxand       fxdiv       fxdiv0      fxif        fxior
         fxlength    fxmax       fxmin       fxmod       fxmod0
         fxnot       fxxor       fxlogand    fxlogor     fxlognot
-        fxlogxor    fxlogand    fxlogand    fxlogand    fxlogand
-        fxlogand    fxlogand)
+        fxlogxor)
        (inject* T:fixnum T:fixnum)]
       [(fx= fx< fx<= fx> fx>= fx=? fx<? fx<=? fx>? fx>=?
         fxeven? fxodd? fxnegative? fxpositive? fxzero?
@@ -343,9 +345,10 @@
         enum-set-indexer    
         make-guardian)
        (return T:procedure)]
+      [(fixnum-width greatest-fixnum least-fixnum)
+       (return T:fixnum)]
       [else
        (return T:object)]))
-      
  
 
   ;;;
@@ -429,6 +432,6 @@
            [else T:object]))]))
   (let-values ([(x env t) (V x empty-env)])
     (when (tag-analysis-output)
-      (pretty-print (unparse x)))
+      (pretty-print (unparse-pretty x)))
     x))
 
diff --git a/scheme/ikarus.conditions.ss b/scheme/ikarus.conditions.ss
index 674cffa..bf14c33 100644
--- a/scheme/ikarus.conditions.ss
+++ b/scheme/ikarus.conditions.ss
@@ -128,6 +128,7 @@
   
   (define-record-type &condition 
     (nongenerative))
+
   (define &condition-rtd (record-type-descriptor &condition))
   (define &condition-rcd (record-constructor-descriptor &condition))
   
@@ -135,7 +136,7 @@
     (nongenerative)
     (fields (immutable components))
     (sealed #t)
-    (opaque #t))
+    (opaque #f))
 
   (define (condition? x)
     (or (&condition? x)
diff --git a/scheme/ikarus.ontology.ss b/scheme/ikarus.ontology.ss
index 513604f..6b51987 100755
--- a/scheme/ikarus.ontology.ss
+++ b/scheme/ikarus.ontology.ss
@@ -217,7 +217,7 @@
                (let* ([ls '()]
                       [ls
                        (case (predname* x)
-                         [(yes) (cons '(name* yes) ls)]
+                         [(yes) (cons 'name* ls)]
                          [else  ls])]
                       ...)
                  ls))
@@ -231,7 +231,8 @@
   [immediate     (exclusive fixnum boolean null char void)]
   [obj-truth     (exclusive false non-false)]
   [obj-tag       (exclusive procedure string vector pair null
-                            boolean char number void other-object)]
+                            boolean char number void bytevector 
+                            symbol other-object)]
   [boolean       (exclusive true false)]
   [number        (inclusive number-tag number-size number-exactness)]
   [number-size   (exclusive negative zero positive)]
diff --git a/scheme/last-revision b/scheme/last-revision
index f44a8bb..04cad1a 100644
--- a/scheme/last-revision
+++ b/scheme/last-revision
@@ -1 +1 @@
-1532
+1533