Chez Scheme: Add more maybe-* and eof/* types

The logic was added in the previous commits, but it's necesary to add
the mapping from the names in primdata to cptypes.

Also add a few subsets of fixnum.

racket/src/ChezScheme/mats/cptypes.ms

@@ -1203,6 +1203,9 @@
   (cptypes-equivalent-expansion?
     '(lambda (p) (define x (get-char p)) (box? x))
     '(lambda (p) (define x (get-char p)) #f))
+(cptypes-equivalent-expansion?
+    '(lambda (p) (define x (get-u8 p)) (when (number? p) (fixnum? p)))
+    '(lambda (p) (define x (get-u8 p)) (when (number? p) #t)))
 )
 
 (mat cptypes-unreachable

racket/src/ChezScheme/s/cptypes-lattice.ss

@@ -77,9 +77,20 @@
   (define ptr-pred (make-pred-or 'immediate 'normalptr '$record))
   (define null-or-pair-pred (make-pred-or null-rec 'pair 'bottom))
   (define $fixmediate-pred (make-pred-or 'immediate 'fixnum 'bottom))
-  (define maybe-number-pred (make-pred-or false-rec 'number 'bottom))
   (define maybe-fixnum-pred (make-pred-or false-rec 'fixnum 'bottom))
+  (define eof/fixnum-pred (make-pred-or eof-rec 'fixnum 'bottom))
+  (define maybe-exact-integer-pred (make-pred-or false-rec 'fixnum 'bottom))
+  (define maybe-flonum-pred (make-pred-or false-rec 'flonum 'bottom))
+  (define maybe-number-pred (make-pred-or false-rec 'number 'bottom))
   (define maybe-symbol-pred (make-pred-or false-rec 'symbol 'bottom))
+  (define maybe-procedure-pred (make-pred-or false-rec 'procedure 'bottom))
+  (define maybe-string-pred (make-pred-or false-rec 'string 'bottom))
+  (define eof/string-pred (make-pred-or eof-rec 'string 'bottom))
+  (define maybe-bytevector-pred (make-pred-or false-rec 'bytevector 'bottom))
+  (define eof/bytevector-pred (make-pred-or eof-rec 'bytevector 'bottom))
+  (define maybe-pair-pred (make-pred-or false-rec 'pair 'bottom))
+  (define maybe-normalptr-pred (make-pred-or false-rec 'normalptr 'bottom))
+  (define maybe-$record-pred (make-pred-or false-rec 'bottom '$record))
   ; These are just symbols, but we assign a name for uniformity.
   (define maybe-char-pred 'maybe-char)
   (define eof/char-pred 'eof/char)
@@ -155,15 +166,6 @@
                           [else
                            (loop lo i)]))]))]))]))
 
-  (define (maybe-predicate? name)
-    (let ([name (symbol->string name)])
-      (and (>= (string-length name) 6)
-           (let loop ([n 0])
-             (or (fx= n 6)
-                 (and (eq? (string-ref name n) 
-                           (string-ref "maybe-" n))
-                      (loop (fx+ n 1))))))))
-
   ; nqm: no question mark
   ; Transform the types used in primdata.ss
   ; to the internal representation used here
@@ -175,69 +177,98 @@
   ; (pred? x) ==> #f and (something x) ==> <error>
   ; In case the non extended version is not #f, the extended version must be not #f
   (define (primref-name/nqm->predicate name extend?)
+    (cond
+      [(not name)
+       #f]
+      [(pair? name)
+       (cond
+         [(equal? name '(ptr . ptr))
+          'pair]
+         [else
+          (if (not extend?) 'bottom 'pair)])]
+      [else
+       (let ([r (do-primref-name/nqm->predicate name extend?)])
+         (cond
+           [(pair? r)
+            (if extend? (cdr r) (car r))]
+           [else
+            r]))]))
+
+  (define (do-primref-name/nqm->predicate name extend?)
     (case name
-      [pair 'pair]
-      [box 'box]
-      [$record '$record]
-      [fixnum 'fixnum]
-      [bignum 'bignum]
-      [flonum 'flonum]
-      [real 'real]
-      [number 'number]
-      [vector 'vector]
-      [string 'string]
-      [bytevector 'bytevector]
-      [fxvector 'fxvector]
-      [flvector 'flvector]
-      [gensym 'gensym]
-      [uninterned-symbol 'uninterned-symbol]
-      [interned-symbol 'interned-symbol]
-      [symbol 'symbol]
-      [char 'char]
       [bottom 'bottom]
       [ptr ptr-pred]
+      [sub-ptr (cons 'bottom ptr-pred)]
+
+      [char 'char]
+      [maybe-char maybe-char-pred]
+      [eof/char eof/char-pred]
       [boolean 'boolean]
       [true true-pred]
       [false false-rec]
-      [procedure 'procedure]
-      [exact-integer 'exact-integer]
       [void void-rec]
       [null null-rec]
       [eof-object eof-rec]
       [bwp-object bwp-rec]
       [$immediate 'immediate]
-      [(list list-assume-immutable) (if (not extend?) null-rec null-or-pair-pred)]
+
-      [sub-ptr (if (not extend?) 'bottom ptr-pred)]
+      [pair 'pair]
-      [maybe-number maybe-number-pred]
+      [maybe-pair maybe-pair-pred]
-      [maybe-fixnum maybe-fixnum-pred]
+      [(list list-assume-immutable) (cons null-rec null-or-pair-pred)]
-      [maybe-ufixnum (if (not extend?) false-rec maybe-fixnum-pred)]
+      [box 'box]
+      [vector 'vector]
+      [string 'string]
+      [sub-string '(bottom . string)]
+      [maybe-string maybe-string-pred]
+      [eof/string eof/string-pred]
+      [bytevector 'bytevector]
+      [maybe-bytevector maybe-bytevector-pred]
+      [eof/bytevector eof/bytevector-pred]
+      [fxvector 'fxvector]
+      [flvector 'flvector]
+      [pathname 'string]
+      [maybe-pathname maybe-string-pred]
+      [procedure 'procedure]
+      [maybe-procedure maybe-procedure-pred]
+      [maybe-who maybe-normalptr-pred] ;should be maybe-string/symbol
+
+      [gensym 'gensym]
+      [uninterned-symbol 'uninterned-symbol]
+      [interned-symbol 'interned-symbol]
+      [symbol 'symbol]
       [maybe-symbol maybe-symbol-pred]
-      [maybe-char 'maybe-char]
+      [sub-symbol '(bottom . symbol)]
-      [eof/char 'eof/char]
+      [maybe-sub-symbol (cons false-rec maybe-symbol-pred)]
-      [else ((if extend? cdr car)
+
-             (case name
+      [fixnum 'fixnum]
-               [(record rtd) '(bottom . $record)]
+      [(sub-fixnum bit length sub-length ufixnum sub-ufixnum pfixnum index sub-index u8 s8 u8/s8) '(bottom . fixnum)]
-               [(bit length ufixnum pfixnum) '(bottom . fixnum)]
+      [maybe-fixnum maybe-fixnum-pred]
-               [(uint sub-uint) '(bottom . exact-integer)]
+      [maybe-ufixnum (cons false-rec maybe-fixnum-pred)]
-               [(index sub-index u8 s8) '(bottom . fixnum)]
+      [(eof/length eof/u8) (cons eof-rec eof/fixnum-pred)]
-               [(sint) '(fixnum . exact-integer)]
+      [bignum 'bignum]
-               [(uinteger) '(bottom . real)]
+      [(exact-integer sint) 'exact-integer]
-               [(integer rational) '(exact-integer . real)]
+      [(uint sub-uint nzuint exact-uinteger sub-sint) '(bottom . exact-integer)]
-               [(cflonum) '(flonum . number)]
+      [maybe-uint (cons false-rec maybe-exact-integer-pred)]
-               [else
+      [flonum 'flonum]
-                (cond
+      [sub-flonum '(bottom . flonum)]
-                  [(not name) ; TODO: Move this case to the top?
+      [maybe-flonum maybe-flonum-pred]
-                   '(#f . #f)]
+      [real 'real]
-                  [(pair? name) ; TODO: Move this case to the top?
+      [(integer rational) '(exact-integer . real)]
-                   (cond
+      [(uinteger sub-integer) '(bottom . real)]
-                     [(equal? name '(ptr . ptr))
+      [cflonum '(flonum . number)]
-                      '(pair . pair)]
+      [number 'number]
-                     [else
+      [sub-number '(bottom . number)]
-                      '(bottom . pair)])]
+      [maybe-number maybe-number-pred]
-                  [(maybe-predicate? name)
+
-                   (cons false-rec ptr-pred)]         ; for types like maybe-*
+      [$record '$record]
-                  [else
+      [(record rtd) '(bottom . $record)] ; not sealed
-                   (cons 'bottom true-pred)])]))])) ; for all other types that exclude #f
+      [(maybe-rtd) (cons false-rec maybe-$record-pred)]
+      [(transcoder textual-input-port textual-output-port binary-input-port binary-output-port) '(bottom . $record)]  ; opaque
+      [(maybe-transcoder maybe-textual-input-port maybe-textual-output-port maybe-binary-input-port maybe-binary-output-port input-port output-port) (cons false-rec maybe-$record-pred)]
+      [(rcd sfd timeout) '(bottom . $record)] ; not opaque, sealed
+      [(maybe-rcd maybe-sub-rcd maybe-sfd maybe-timeout) (cons false-rec maybe-$record-pred)]
+
+      [else (cons 'bottom true-pred)])); for all other types that exclude #f
 
   (define (check-constant-is? x pred?)
     (and (Lsrc? x)

racket/src/ChezScheme/s/primdata.ss

@@ -854,7 +854,7 @@
   (add-duration (sig [(time time) -> (time)]) [flags alloc])
   (add-duration! (sig [(time time) -> (time)]) [flags alloc])
   (current-date [sig [() (sub-fixnum) -> (date)]] [flags alloc])
-  (current-time [sig [() (sub-fixnum) -> (time)]] [flags alloc])
+  (current-time [sig [() (sub-symbol) -> (time)]] [flags alloc])
   (date-day [sig [(date) -> (fixnum)]] [flags pure mifoldable discard true])
   (date? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
   (date-hour [sig [(date) -> (fixnum)]] [flags pure mifoldable discard true])
@@ -1239,13 +1239,13 @@
   (compile-script [sig [(pathname) (pathname pathname) (pathname pathname sub-symbol) -> (void)]] [flags true])
   (compile-time-value? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
   (compile-time-value-value [sig [(compile-time-value) -> (ptr)]] [flags pure mifoldable discard])
-  (compile-to-file [sig [(list pathname) (list pathname maybe-sfd) (list pathname maybe-sfd maybe-force-host-out?) -> (void/list)]] [flags true])
+  (compile-to-file [sig [(list pathname) (list pathname maybe-sfd) (list pathname maybe-sfd boolean) -> (void/list)]] [flags true])
   (compile-to-port [sig [(list binary-output-port) (list binary-output-port maybe-sfd) (list binary-output-port maybe-sfd maybe-binary-output-port) (list binary-output-port maybe-sfd maybe-binary-output-port maybe-textual-output-port) (list binary-output-port maybe-sfd maybe-binary-output-port maybe-textual-output-port sub-symbol) (list binary-output-port maybe-sfd maybe-binary-output-port maybe-textual-output-port sub-symbol maybe-binary-output-port) (list binary-output-port maybe-sfd maybe-binary-output-port maybe-textual-output-port sub-symbol maybe-binary-output-port ptr) (list binary-output-port maybe-sfd maybe-binary-output-port maybe-textual-output-port sub-symbol maybe-binary-output-port ptr ptr) -> (void/list)]] [flags true])
   (compile-whole-program [sig [(string string) (string string ptr) -> (void)]] [flags])
   (compile-whole-library [sig [(string string) -> (void)]] [flags])
   (compute-composition [sig [(ptr) -> (list)] [(ptr sub-ufixnum) -> (list)]] [flags alloc])
   (compute-size [sig [(ptr) -> (uint)] [(ptr sub-ufixnum) -> (uint)]] [flags alloc])
-  (compute-size-increments [sig [(list) -> (list)] [(list sub-ufixnum) -> (list)]] [flags alloc])
+  (compute-size-increments [sig [(list) -> (list)] [(list ptr) -> (list)]] [flags alloc]) ; the second argument is ufixnum or 'static
   (concatenate-object-files [sig [(pathname pathname pathname ...) -> (void)]] [flags true])
   (condition-broadcast [feature pthreads] [sig [(condition-object) -> (void)]] [flags true])
   (condition-continuation [sig [(continuation-condition) -> (ptr)]] [flags pure mifoldable discard])