Skip to content

Add more numeric predictates to cptypes #1007

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
gus-massa wants to merge 2 commits into
base: main
Choose a base branch
from
Open

Add more numeric predictates to cptypes #1007

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
8e41c04
boot?
gus-massa Jan 7, 2026
5095b27
Add more numeric predicates to cptypes
gus-massa Jan 14, 2026
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
Binary file modified boot/pb/petite.boot
View file
Open in desktop
Binary file not shown.
Binary file modified boot/pb/scheme.boot
View file
Open in desktop
Binary file not shown.
60 changes: 48 additions & 12 deletions mats/cptypes.ms
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -466,6 +466,15 @@
(cptypes/once-equivalent-expansion?
'(lambda (x y) (when (and (flonum? x) (flonum? y)) (flonum? (max x y))))
'(lambda (x y) (when (and (flonum? x) (flonum? y)) (#3%flmax x y) #t)))
(cptypes-equivalent-expansion?
'(lambda (x) (when (fixnum? x) (even? x)))
'(lambda (x) (when (fixnum? x) (#3%fxeven? x))))
(cptypes-equivalent-expansion?
'(lambda (x) (when (flonum? x) (even? x)))
'(lambda (x) (when (flonum? x) (#3%fleven? x))))
(cptypes-equivalent-expansion?
'(lambda (x) (when (real? x) (rational-valued? x)))
'(lambda (x) (when (real? x) (#3%rational? x))))
)

(mat cptype-directly-applied-case-lambda
Expand Down Expand Up @@ -675,20 +684,53 @@
(define (test-disjoint*/preamble preamble l)
(test-disjoint/preamble/self preamble #f l))

(mat cptypes-type-implies?
(mat cptypes-type-implies/numbers?
(test-chain '((lambda (x) (eq? x 0)) fixnum? (lambda (x) (and (integer? x) (exact? x))) real? number?))
(test-chain* '((lambda (x) (or (eq? x 0) (eq? x 10))) fixnum? (lambda (x) (and (integer? x) (exact? x))) real? number?))
(test-chain '(fixnum? integer? real?))
(test-chain '(fixnum? exact? number?))
(test-chain '(bignum? exact? number?))
(test-all-imply '(fixnum? bignum?) 'integer?)
(test-all-imply '(fixnum? bignum? ratnum?) 'exact?)
(test-chain '(integer? #;rational? real? number?))
(test-chain* '(integer? rational? real? number?))
(test-chain '(exact? number?))
(test-all-imply* '(rational? finite?) 'real?)
(test-chain '(fixnum? (lambda (x) (and (integer? x) (exact? x))) (lambda (x) (and (number? x) (exact? x))) number?))
(test-chain '((lambda (x) (eqv? x (expt 256 100))) bignum? integer? real? number?))
(test-chain '((lambda (x) (eqv? 0.0 x)) flonum? real? number?))
(test-chain '((lambda (x) (eqv? 0.0 x)) flonum? cflonum? number?))
(test-chain* '((lambda (x) (or (eqv? x 0.0) (eqv? x 3.14))) flonum? real? number?))
(test-chain* '((lambda (x) (or (eq? x 0) (eqv? x 3.14))) real? number?))
(test-chain* '(fixnum? rational? real?))
(test-chain* '(flzero? rational? real?))
(test-disjoint '((lambda (x) (eq? x 0)) (lambda (x) (eq? x 1)) flonum?))
(test-disjoint '((lambda (x) (eqv? x 0.0)) (lambda (x) (eqv? x 1.0)) fixnum?))
(test-disjoint '(exact? inexact?))
(test-disjoint '(integer? ratnum?))
(test-all-imply* '(infinite? nan? flfinite? flinfinite? flnan?) 'flonum?)
(test-chain* '((lambda (x) (eqv? x 0)) fxeven? #;even? integer?))
(test-chain* '((lambda (x) (and (flonum? x) (zero? x))) fleven? #;even? integer?))
(test-chain* '((lambda (x) (eqv? x 1)) fxodd? #;odd? integer?))
(test-chain* '(#;(lambda (x) (eqv? x 1.0)) flodd? #;odd? integer?))
(test-all-imply* '(fxzero? fxeven? fxodd?
fxpositive? fxnegative? fxnonpositive? fxnonnegative?)
'fixnum?)
(test-all-imply* '(flzero? fleven? flodd?)
'flinteger?)
(test-all-imply* '(flpositive? flnegative? flnonpositive? flnonnegative?)
'flonum?)
(test-all-imply* '((lambda(x) (and (real? x) (zero? x))) even? odd?)
'integer?)
(test-all-imply* '(positive? negative? nonpositive? nonnegative?)
'real?)
(not (test-chain* '(positive? rational?)))
(not (test-chain* '(negative? rational?)))
(not (test-chain* '(nonpositive? rational?)))
(not (test-chain* '(nonnegative? rational?)))
; #3%flinteger? assumes the argument is a flonum, so integer? implies #3%flinteger?
(test-chain* '(#2%flinteger? integer?))
(test-chain* '(real? real-valued? number?))
(test-chain* '(#;rational? rational-valued? number?))
(test-chain* '(integer? integer-valued? number?))
)

(mat cptypes-type-implies?
(test-chain '(gensym? symbol?))
(test-chain '((lambda (x) (eq? x 'banana)) symbol?))
(test-chain '(not boolean?))
Expand All @@ -703,14 +745,8 @@
(test-disjoint '(pair? box? real? gensym? not))
(test-disjoint '(pair? box? fixnum? flonum? (lambda (x) (eq? x #t))))
(test-disjoint '(pair? box? fixnum? flonum? (lambda (x) (eq? #t x))))
(test-disjoint '((lambda (x) (eq? x 0)) (lambda (x) (eq? x 1)) flonum?))
(test-disjoint '((lambda (x) (eqv? x 0.0)) (lambda (x) (eqv? x 1.0)) fixnum?))
(test-disjoint '(exact? inexact?))
(test-disjoint '(integer? ratnum?))
(test-disjoint '((lambda (x) (eq? x 'banana)) (lambda (x) (eq? x 'apple))))
(test-disjoint* '(list? record? vector?))
(test-all-imply* '(rational? finite?) 'real?)
(test-all-imply* '(infinite? nan? flfinite? flinfinite? flnan?) 'flonum?)
)

; use a gensym to make expansions equivalent
Expand Down
23 changes: 20 additions & 3 deletions mats/primvars.ms
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -405,10 +405,12 @@
[(cost-center) *cost-center '(a) #f]
[(source-table) (make-source-table) *time #f]
[(date) *date *time #f]
[(dreal) 0 1/2 1 1+2i +nan.0 #f]
[(endianness) 'big 'giant #f]
[(enum-set) (file-options compressed) 0 #f]
[(environment) *env '((a . b)) #f]
[(eq-hashtable) *eq-hashtable *symbol-hashtable #f]
[(even) 2 1 .5 1/2 2+2i #f]
[(exact-integer) (- (most-negative-fixnum) 1) 2.0 1/2 #f]
[(exact-real) 1/2 1+1i 2.0 #f]
[(exact-uinteger) (+ (most-positive-fixnum) 1) -10 2.0 1/2 #f]
Expand All @@ -418,13 +420,17 @@
[(fasl-strip-options) (fasl-strip-options inspector-source) (file-options compressed) #f]
[(file-options) (file-options compressed) 1/2 #f]
[(fixnum) -1 'q (+ (most-positive-fixnum) 1) (- (most-negative-fixnum) 1) #f]
[(fleven) 2.0 2 2.0+2.0i 'a #f]
[(flinteger) 0.0 0 0.5 0.0+1.0i 'a #f]
[(flodd) 1.0 1 1.0+1.0i 'a #f]
[(flonum) 0.0 0 0.0+1.0i 'a #f]
[(flrational) 0.5 1/2 1+2i +inf.0 #f]
[(flvector) '#vfl(0.0) "a" #f]
[(flzero) 0.0 0 "a" #f]
[(ftype-pointer) *ftype-pointer 0 *time #f]
[(sub-ftype-pointer) no-good]
[(fxeven) 2 2.0 2+2i 'a #f]
[(fxodd) 1 1.0 1+1i 'a #f]
[(fxvector) '#vfx(0) "a" #f]
[(fxzero) 0 0.0 "a" #f]
[(gensym) *genny 'sym #f]
Expand All @@ -439,6 +445,7 @@
[(infinite) +inf.0 +nan.0 +inf.0+inf.0i 0.0 0 "a" #f]
[(input-port) (current-input-port) 0 *binary-output-port *textual-output-port #f]
[(integer) 0.0 1/2 1.0+0.0i 'a #f]
[(integer-valued) 0.0+0.0i 1/2 1.0+1.0i 'a #f]
[(i/o-encoding-error) (make-i/o-encoding-error 17 23) (make-who-condition 'who) 1/2 #f]
[(i/o-filename-error) (make-i/o-filename-error 17) (make-who-condition 'who) 3 #f]
[(i/o-invalid-position-error) (make-i/o-invalid-position-error 17) (make-who-condition 'who) "" #f]
Expand Down Expand Up @@ -468,26 +475,35 @@
[(maybe-timeout) *time 371]
[(message-condition) (make-message-condition 17) (make-who-condition 'who) 'q #f]
[(nan) +nan.0 +inf.0 +nan.0+nan.0i 0.0 0 "a" #f]
[(nfixnum) -1 'q (+ (most-positive-fixnum) 1) (- (most-negative-fixnum) 1) #f]
[(nflonum) -1.0 0.0 0 0.0+1.0i 'a #f]
[(nonempty-bytevector) '#vu8(0) '#vu8() "a" #f]
[(nonempty-flvector) '#vfl(0.0) '#vfl() "a" #f]
[(nonempty-fxvector) '#vfx(0) '#vfx() "a" #f]
[(nonempty-string) "a" "" 'a #f]
[(nonempty-vector) '#(a) '#() "a" #f]
[(number) 1+2i 'oops #f]
[(nzuint) 1 0 'a #f]
[(nreal) -1/2 0 1 1+2i +nan.0 #f]
[(number) 1+2i 'oops #f]
[(odd) 1 2 .5 1/2 2+2i #f]
[(old-hash-table) *old-hash-table '((a . b)) #f]
[(output-port) (current-output-port) 0 *binary-input-port *textual-input-port #f]
[(pair) '(a . b) 'a #f]
[(pathname) "a" 'a #f]
[(pbignum) (+ (most-positive-fixnum) 1) -1 (most-positive-fixnum) 2.0 1/2 #f]
[(pfixnum) 1 0 #f]
[(pflonum) 1.0 0.0 0 0.0+1.0i 'a #f]
[(phantom-bytevector) *phantom-bytevector '#vu8(0) #f]
[(pseudo-random-generator) *pseudo-random-generator #f]
[(pint) 1 0 'a #f]
[(port) (current-input-port) 0 #f]
[(preal) 1/2 0 -1 1+2i +nan.0 #f]
[(procedure) values 0 #f]
[(pseudo-random-generator) *pseudo-random-generator #f]
[(ptr) 1.0+2.0i]
[(rational) 1/2 1+2i #f]
[(rational-valued) 0.5+0.0i 1+2i #f]
[(rcd) *rcd *rtd "" #f]
[(real) 1/2 1+2i #f]
[(real-valued) +inf.0+0.0i 1+2i #f]
[(record) *record '#(a) #f]
[(rtd) *rtd *record "" #f]
[(s16) -1 'q (expt 2 15) (- -1 (expt 2 15)) #f]
Expand Down Expand Up @@ -531,6 +547,7 @@
[(uinteger) 9.0 -1 -1.0 'a #f]
[(uptr) 0 -1 'a (+ *max-uptr 1) #f]
[(uptr/iptr) -1 'q (+ *max-uptr 1) (- *min-iptr 1) #f]
[(ureal) 0 -1/2 -1 1+2i +nan.0 #f]
[(vector) '#(a) "a" #f]
[(stencil-vector) (stencil-vector 7 1 2 3) "a" #f]
[(who-condition) (make-who-condition 'me) (make-message-condition "hello") 'the-who #f]
Expand Down
6 changes: 6 additions & 0 deletions release_notes/release_notes.stex
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -117,6 +117,12 @@ Online versions of both books can be found at
%-----------------------------------------------------------------------------
\section{Functionality Changes}\label{section:functionality}

\subsection{Type recovery improvements (10.5.0)}

The type recovery pass has partial support more predicates, like
\scheme{even?}, \scheme{odd?}, \scheme{positive?},
\scheme{negative?}, \scheme{real-valued?} and similar.

\subsection{Add machine type a6gnu (10.4.0)}

GNU/Hurd on x86\_64 is now supported as machine type a6gnu.
Expand Down
35 changes: 30 additions & 5 deletions s/cptypes-lattice.ss
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -566,28 +566,37 @@
[sub-symbol (cons 'bottom symbol-pred)]
[maybe-sub-symbol (cons false-rec maybe-symbol-pred)]

[fxzero fxzero-rec]
[fixnum fixnum-pred]
[(sub-fixnum bit length sub-length ufixnum sub-ufixnum pfixnum index sub-index u8 s8 u8/s8) (cons 'bottom fixnum-pred)]
[(sub-fixnum sub-length pfixnum nfixnum sub-ufixnum sub-index) (cons 'bottom fixnum-pred)]
[(bit length ufixnum dfixnum index u8 s8 u8/s8) (cons 'fxzero-rec fixnum-pred)]
[maybe-fixnum maybe-fixnum-pred]
[maybe-ufixnum (cons false-rec maybe-fixnum-pred)]
[(eof/length eof/u8) (cons eof-rec eof/fixnum-pred)]
[bignum bignum-pred]
[pbignum (cons 'bottom bignum-pred)]
[(exact-integer sint) exact-integer-pred]
[(uint sub-uint nzuint exact-uinteger sub-sint) (cons 'bottom exact-integer-pred)]
[(uint sub-uint pint exact-uinteger sub-sint) (cons 'bottom exact-integer-pred)]
[maybe-uint (cons false-rec maybe-exact-integer-pred)]
[ratnum ratnum-pred]
[flonum flonum-pred]
[sub-flonum (cons 'bottom flonum-pred)]
[(sub-flonum pflonum nflonum) (cons 'bottom flonum-pred)]
[(uflonum dflonum) (cons flzero-pred flonum-pred)]
[maybe-flonum maybe-flonum-pred]
[real real-pred]
[sub-real (cons 'bottom real-pred)]
[(sub-real preal nreal) (cons 'bottom real-pred)]
[(ureal dreal) (cons real-zero-pred real-pred)]
[real-valued (cons (predicate-union real-pred inexact-complex-zero-pred)
(predicate-union real-pred inexact-complex-pred))]
[rational (cons subset-of-rational-pred real-pred)]
[flrational (cons flinteger-pred flonum-pred)]
[rational-valued (cons (predicate-union subset-of-rational-pred inexact-complex-zero-pred)
(predicate-union real-pred inexact-complex-pred))]
[(infinite nan) (cons 'bottom flonum**-pred)]
[integer integer-pred]
[(uinteger sub-integer) (cons 'bottom integer-pred)]
[flinteger flinteger-pred]
[integer-valued (cons (predicate-union integer-pred inexact-complex-zero-pred)
(predicate-union integer-pred inexact-complex-pred))]
[(cflonum inexact-number) inexact-pred]
[exact-real exact-real-pred]
[exact-number exact-pred]
Expand All @@ -596,8 +605,17 @@
[number number-pred]
[sub-number (cons 'bottom number-pred)]
[maybe-number maybe-number-pred]

[zero zero-pred]
[fxzero fxzero-rec]
[flzero flzero-pred]
[even (cons real-zero-pred integer-pred)]
[fxeven (cons fxzero-rec exact-integer-pred)]
[fleven (cons flzero-pred flinteger-pred)]
[odd (cons 'bottom integer*-pred)]
[fxodd (cons 'bottom exact-integer*-pred)]
[flodd (cons 'bottom flinteger*-pred)]

[port 'port]
[(textual-input-port textual-output-port textual-port
binary-input-port binary-output-port binary-port
Expand Down Expand Up @@ -1470,20 +1488,24 @@
(define ptr-pred (make-pred-or singleton-pred multiplet-pred 'normalptr 'exact-integer* '$record))
(define true-pred (make-pred-or true-singleton-pred multiplet-pred 'normalptr 'exact-integer* '$record))
(define immediate-pred (predicate-union immediate*-pred char-pred))
(define fixnum*-pred 'fixnum*)
(define fixnum-pred (predicate-union fxzero-rec 'fixnum*))
(define exact-integer*-pred 'exact-integer*)
(define exact-integer-pred (predicate-union fxzero-rec 'exact-integer*))
(define bignum-pred 'bignum)
(define $fixmediate-pred (predicate-union immediate-pred fixnum-pred))
(define pair-pred (predicate-union list-pair-pred nonlist-pair-pred))
(define maybe-pair-pred (maybe pair-pred))
(define null-or-pair-pred (predicate-union null-rec pair-pred))
(define $list-pred (predicate-union null-rec list-pair-pred))

(define maybe-fixnum-pred (maybe fixnum-pred))
(define eof/fixnum-pred (eof/ fixnum-pred))
(define maybe-exact-integer-pred (maybe exact-integer-pred))
(define flonum-pred (predicate-union flonum*-pred flzero-pred))
(define maybe-flonum-pred (maybe flonum-pred))
(define flinteger-pred (predicate-union flinteger*-pred flzero-pred))
(define integer*-pred (predicate-union flinteger*-pred exact-integer*-pred))
(define integer-pred (predicate-union flinteger-pred exact-integer-pred))
(define exact-pred (predicate-union exact*-pred exact-integer-pred))
(define exact-real-pred (predicate-union ratnum-pred exact-integer-pred))
Expand All @@ -1497,6 +1519,9 @@
fxzero-rec))
(define subset-of-rational-pred (predicate-union exact-real-pred flinteger-pred))
(define subset-of-complex-rational-pred (predicate-union subset-of-rational-pred inexact-complex-zero-pred))

(define real-zero-pred (predicate-union fxzero-rec flzero-pred))

(define maybe-symbol-pred (maybe symbol-pred))
(define maybe-procedure-pred (maybe 'procedure))
(define vector-pred (predicate-union null-vector-pred vector*-pred))
Expand Down
25 changes: 22 additions & 3 deletions s/cptypes.ss
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -1068,8 +1068,6 @@ Notes:
(define-syntax define-specialize/fxfl
(syntax-rules ()
[(_ lev prim fxprim flprim)
(define-specialize/fxfl lev prim fxprim flprim #f)]
[(_ lev prim fxprim flprim ret)
(define-specialize lev prim
; Arity is checked before calling this handle.
[e* (let* ([r* (get-type e*)]
Expand All @@ -1080,7 +1078,7 @@ Notes:
(lookup-primref 3 'flprim)]
[else #f])])
(when pr
(fold-call/primref/shallow preinfo pr e* ret r* ctxt ntypes oldtypes plxc)))])]))
(fold-call/primref/shallow preinfo pr e* #f r* ctxt ntypes oldtypes plxc)))])]))

(define-specialize/fxfl 2 (< r6rs:<) fx< fl<)
(define-specialize/fxfl 2 (<= r6rs:<=) fx<= fl<=)
Expand All @@ -1089,6 +1087,27 @@ Notes:
(define-specialize/fxfl 2 (>= r6rs:>=) fx>= fl>=)
(define-specialize/fxfl 2 min fxmin flmin)
(define-specialize/fxfl 2 max fxmax flmax)
(define-specialize/fxfl 2 even? fxeven? fleven?)
(define-specialize/fxfl 2 odd? fxodd? flodd?)
(define-specialize/fxfl 2 positive? fxpositive? flpositive?)
(define-specialize/fxfl 2 negative? fxnegative? flnegative?)
(define-specialize/fxfl 2 nonpositive? fxnonpositive? flnonpositive?)
(define-specialize/fxfl 2 nonnegative? fxnonnegative? flnonnegative?)
)

(let ()
(define-syntax define-specialize/real
(syntax-rules ()
[(_ lev prim realprim)
(define-specialize lev prim
; Arity is checked before calling this handle.
[e* (let ([r* (get-type e*)])
(when (andmap (lambda (r) (predicate-implies? r real-pred)) r*)
(fold-call/primref/shallow preinfo (lookup-primref 3 'realprim) e* #f r* ctxt ntypes oldtypes plxc)))])]))

#;(define-specialize/real 2 real-valued? real?) ; it's not necesary
(define-specialize/real 2 rational-valued? rational?)
(define-specialize/real 2 integer-valued? integer?)
)

(let ()
Expand Down
Loading