From 00970f12d24dc82b256576d4e4700d9c549fe68f Mon Sep 17 00:00:00 2001 From: Abdulaziz Ghuloum 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>=? 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