suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch '17-5-Types-Pass' of github.com:gus-massa/ChezScheme

Browse Source 
original commit: caf857a33e13c116afa6e2d960eccbada3604190
This commit is contained in:
Matthew Flatt 2019-01-11 13:52:40 -07:00
commit 54282dedc4
20 changed files with 2544 additions and 274 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
mats/4.ms
View File

@ -1304,9 +1304,9 @@
(list 'b 'u 'y) (list 'b 'u 'y)
(list 'c 'v 'z)))) (list 'c 'v 'z))))
'(#2%list '(#2%list
(#2%string->symbol (#2%string-append "a" "b" "c")) (#3%string->symbol (#3%string-append "a" "b" "c"))
(#2%string->symbol (#2%string-append "t" "u" "v")) (#3%string->symbol (#3%string-append "t" "u" "v"))
(#2%string->symbol (#2%string-append "x" "y" "z")))) (#3%string->symbol (#3%string-append "x" "y" "z"))))
(equivalent-expansion? (equivalent-expansion?
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(expand/optimize (expand/optimize

2
mats/Mf-base
View File

@ -125,7 +125,7 @@ ecpf = $(defaultecpf)
# set of mats to run # set of mats to run
mats = primvars 3 4 5_1 5_2 5_3 5_4 5_5 bytevector thread\ mats = primvars 3 4 5_1 5_2 5_3 5_4 5_5 bytevector thread\
misc cp0 5_6 5_7 5_8 6 io format 7 record hash enum 8 fx fl cfl foreign\ misc cp0 cptypes 5_6 5_7 5_8 6 io format 7 record hash enum 8 fx fl cfl foreign\
ftype unix windows examples ieee date exceptions oop ftype unix windows examples ieee date exceptions oop
Examples = ../examples Examples = ../examples

8
mats/cp0.ms
View File

@ -849,13 +849,13 @@
(lambda (r) (lambda (r)
(emit-word! 2953052161) (emit-word! 2953052161)
(emit-word! 3766812992) (emit-word! 3766812992)
(emit-word! (#2%+ 3766747136 (#2%ash r 0)))))) (emit-word! (#3%+ 3766747136 (#2%ash r 0))))))
(syntax-case x ($primitive) (syntax-case x ($primitive)
[(set! test [(set! test
(lambda (r1) (lambda (r1)
(ew1! 2953052161) (ew1! 2953052161)
(ew2! 3766812992) (ew2! 3766812992)
(ew3! (#2%+ 3766747136 (#2%ash r2 0))))) (ew3! (#3%+ 3766747136 (#2%ash r2 0)))))
(eq? #'r1 #'r2)]))) (eq? #'r1 #'r2)])))
; verify optimization of (if e s s) => (begin e s) ; verify optimization of (if e s s) => (begin e s)
(equivalent-expansion? (equivalent-expansion?
@ -893,14 +893,14 @@
(expand/optimize (expand/optimize
'(lambda (x y) (if (not (or (fx< x y) (fx> y x))) x y)))) '(lambda (x y) (if (not (or (fx< x y) (fx> y x))) x y))))
'(lambda (x.0 y.1) '(lambda (x.0 y.1)
(if (if (#2%fx< x.0 y.1) #t (#2%fx> y.1 x.0)) (if (if (#2%fx< x.0 y.1) #t (#3%fx> y.1 x.0))
y.1 y.1
x.0))) x.0)))
(equivalent-expansion? (equivalent-expansion?
(parameterize ([#%$suppress-primitive-inlining #f] [run-cp0 (lambda (cp0 x) (cp0 x))] [optimize-level 2]) (parameterize ([#%$suppress-primitive-inlining #f] [run-cp0 (lambda (cp0 x) (cp0 x))] [optimize-level 2])
(expand/optimize (expand/optimize
'(lambda (x y) (if (or (fx< x y) (fx> y x)) x y)))) '(lambda (x y) (if (or (fx< x y) (fx> y x)) x y))))
'(lambda (x y) (if (if (#2%fx< x y) #t (#2%fx> y x)) x y))) '(lambda (x y) (if (if (#2%fx< x y) #t (#3%fx> y x)) x y)))
(equivalent-expansion? (equivalent-expansion?
(parameterize ([#%$suppress-primitive-inlining #f] [run-cp0 (lambda (cp0 x) (cp0 x))] [optimize-level 2]) (parameterize ([#%$suppress-primitive-inlining #f] [run-cp0 (lambda (cp0 x) (cp0 x))] [optimize-level 2])
(expand/optimize (expand/optimize

697
mats/cptypes.ms Normal file
View File

@ -0,0 +1,697 @@
;;; cptypes.ms
;;; Copyright 1984-2017 Cisco Systems, Inc.
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;; http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.
(define-syntax cptypes-equivalent-expansion?
(syntax-rules ()
[(_ x y)
(equivalent-expansion?
(parameterize ([enable-cp0 #t]
[#%$suppress-primitive-inlining #f]
#;[optimize-level (max (optimize-level) 2)])
(expand/optimize x))
(parameterize ([enable-cp0 #t]
[#%$suppress-primitive-inlining #f]
#;[optimize-level (max (optimize-level) 2)])
(expand/optimize y)))]))
(define-syntax cptypes/nocp0-equivalent-expansion?
(syntax-rules ()
[(_ x y)
(equivalent-expansion?
(parameterize ([enable-cp0 #f]
[#%$suppress-primitive-inlining #f]
#;[optimize-level (max (optimize-level) 2)])
(expand/optimize x))
(parameterize ([enable-cp0 #f]
[#%$suppress-primitive-inlining #f]
#;[optimize-level (max (optimize-level) 2)])
(expand/optimize y)))]))
(define-syntax cptypes/nocp0/alternative-equivalent-expansion?
(syntax-rules ()
[(_ x y)
(equivalent-expansion?
(parameterize ([enable-cp0 #f]
[enable-type-recovery #f]
[run-cp0 (lambda (cp0 c) (#3%$cptypes c))]
[#%$suppress-primitive-inlining #f]
#;[optimize-level (max (optimize-level) 2)])
(expand/optimize x))
(parameterize ([enable-cp0 #f]
[enable-type-recovery #f]
[run-cp0 (lambda (cp0 c) (#3%$cptypes c))]
[#%$suppress-primitive-inlining #f]
#;[optimize-level (max (optimize-level) 2)])
(expand/optimize y)))]))
(mat cptypes-handcoded
(cptypes-equivalent-expansion?
'(vector? (vector)) ;actually reduced by folding, not cptypes
#t)
(cptypes-equivalent-expansion?
'(vector? (vector 1 2 3))
#t)
(cptypes-equivalent-expansion?
'(vector? (box 1))
#f)
(cptypes-equivalent-expansion?
'(box? (vector 1 2 3))
#f)
(cptypes-equivalent-expansion?
'(box? (box 1))
#t)
(cptypes-equivalent-expansion?
'(pair? (cons 1 2))
#t)
(cptypes-equivalent-expansion?
'(pair? (list 1 2))
#t)
(cptypes-equivalent-expansion?
'(pair? (list))
#f)
(cptypes-equivalent-expansion?
'(lambda (x) (vector-set! x 0 0) (vector? x))
'(lambda (x) (vector-set! x 0 0) #t))
(cptypes-equivalent-expansion?
'(lambda (x) (vector-set! x 0 0) (box? x))
'(lambda (x) (vector-set! x 0 0) #f))
(cptypes-equivalent-expansion?
'(lambda (x y) (vector-set! x 0 0) (set! y (vector? x)))
'(lambda (x y) (vector-set! x 0 0) (set! y #t)))
(cptypes-equivalent-expansion?
'(lambda (x y) (set! y (vector-ref x 0)) (list (vector? x) y))
'(lambda (x y) (set! y (vector-ref x 0)) (list #t y)))
(cptypes-equivalent-expansion?
'(lambda (x) (vector-set! x 0 0) (let ([y (random 7)]) (list (vector? x) y y)))
'(lambda (x) (vector-set! x 0 0) (let ([y (random 7)]) (list #t y y))))
(cptypes-equivalent-expansion?
'(lambda (x) (vector-set! x 0 0) (let ([y (vector? x)]) (list (random 7) y y)))
'(lambda (x) (vector-set! x 0 0) (let ([y #t]) (list (random 7) y y))))
(cptypes-equivalent-expansion?
'(lambda (x) (let ([y (vector-ref x 0)]) (list (vector? x) y y)))
'(lambda (x) (let ([y (vector-ref x 0)]) (list #t y y))))
(cptypes-equivalent-expansion?
'(lambda (x) (let ([y (vector-ref x 0)])
(let ([z (vector? x)])
(list y y z z))))
'(lambda (x) (let ([y (vector-ref x 0)])
(let ([z #t])
(list y y z z)))))
(cptypes-equivalent-expansion?
'(lambda (x) (let ([y (vector-ref x 0)]) (display (list y y))) (vector? x))
'(lambda (x) (let ([y (vector-ref x 0)]) (display (list y y))) #t))
(cptypes-equivalent-expansion?
'(lambda (x) (let ([y (random 7)]) (display (list (vector-ref x 0) y y))) (vector? x))
'(lambda (x) (let ([y (random 7)]) (display (list (vector-ref x 0) y y))) #t))
(cptypes-equivalent-expansion?
'(let ([y (vector 1 2 3)]) (display (list (vector? y) y y)))
'(let ([y (vector 1 2 3)]) (display (list #t y y))))
(cptypes-equivalent-expansion?
'(let ([y (vector 1 2 3)]) (display (list y y)) (vector? y))
'(let ([y (vector 1 2 3)]) (display (list y y)) #t))
(cptypes-equivalent-expansion?
'(vector? (let ([y (vector 1 2 3)]) (display (list y y)) y))
'(begin (let ([y (vector 1 2 3)]) (display (list y y)) y) #t))
(cptypes-equivalent-expansion?
'(vector? (let ([y (vector 1 2 3)]) (display (list y y)) (vector 4 5 6)))
'(begin (let ([y (vector 1 2 3)]) (display (list y y)) (vector 4 5 6)) #t))
(cptypes-equivalent-expansion?
'(lambda (x) (when (null? x) (display x)))
'(lambda (x) (when (null? x) (display '()))))
(cptypes-equivalent-expansion?
'(lambda (x) (when (vector? x) (eq? x 'vector?)))
'(lambda (x) (when (vector? x) #f)))
(cptypes-equivalent-expansion?
'(lambda (x) (when (vector? x) (pair? x)))
'(lambda (x) (when (vector? x) #f)))
(cptypes-equivalent-expansion?
'(lambda (x) (when (vector? x) (vector? x)))
'(lambda (x) (when (vector? x) #t)))
(cptypes-equivalent-expansion?
'(lambda (x) (when (procedure? x) (procedure? x)))
'(lambda (x) (when (procedure? x) #t)))
(cptypes-equivalent-expansion?
'(lambda (f) (f) (procedure? f))
'(lambda (f) (f) #t))
(cptypes-equivalent-expansion?
'(lambda (x)
(vector-set! x 0 0)
(let loop ([n 1000])
(unless (zero? n)
(display (vector? x))
(loop (- n 1)))))
'(lambda (x)
(vector-set! x 0 0)
(let loop ([n 1000])
(unless (zero? n)
(display #t)
(loop (- n 1))))))
(cptypes-equivalent-expansion?
'(lambda (x)
(let loop ([n 1000])
(unless (zero? n)
(vector-set! x 0 n)
(loop (- n 1))))
(vector? x))
'(lambda (x)
(let loop ([n 1000])
(unless (zero? n)
(vector-set! x 0 n)
(loop (- n 1))))
(vector? x)))
(cptypes-equivalent-expansion?
'(begin (error 'who "msg") 1) ;could be reduced in cp0
'(begin (error 'who "msg") 2))
(cptypes-equivalent-expansion?
'(lambda (x) (vector-set! x) 1)
'(lambda (x) (vector-set! x) 2))
(cptypes-equivalent-expansion?
'(lambda (x) (#2%-) 1)
'(lambda (x) (#2%-) 2))
(cptypes-equivalent-expansion?
'(lambda (x) (#2%make-vector x 0 7) 1)
'(lambda (x) (#2%make-vector x 0 7) 2))
(cptypes-equivalent-expansion?
'(lambda (x) (vector-set! x 0 0) (set-box! x 0) 1)
'(lambda (x) (vector-set! x 0 0) (set-box! x 0) 2))
(cptypes-equivalent-expansion?
'(lambda (x) (vector-set! (box 5) 0 0) 1)
'(lambda (x) (vector-set! (box 5) 0 0) 2))
(cptypes-equivalent-expansion?
'(lambda (x) (#2%odd? x) (real? x))
'(lambda (x) (#2%odd? x) #t))
(cptypes-equivalent-expansion?
'(lambda (x) (vector-set! x 0 0) (#2%odd? x) 1)
'(lambda (x) (vector-set! x 0 0) (#2%odd? x) 2))
)
(mat cptypes-type-if
(cptypes-equivalent-expansion?
'(lambda (x) (if (vector-ref x 0) (newline) (void)) (vector? x))
'(lambda (x) (if (vector-ref x 0) (newline) (void)) #t))
(cptypes-equivalent-expansion?
'(lambda (x) (if (vector-ref x 0) (vector? x) (void)))
'(lambda (x) (if (vector-ref x 0) #t (void))))
(cptypes-equivalent-expansion?
'(lambda (x) (if (vector-ref x 0) (void) (vector? x)))
'(lambda (x) (if (vector-ref x 0) (void) #t)))
(cptypes-equivalent-expansion?
'(lambda (x) (if (zero? (vector-ref x 0)) (newline) (void)) (vector? x))
'(lambda (x) (if (zero? (vector-ref x 0)) (newline) (void)) #t))
(not (cptypes-equivalent-expansion?
'(lambda (x) (if (zero? (random 2)) (vector-set! x 0 0) (void)) (vector? x))
'(lambda (x) (if (zero? (random 2)) (vector-set! x 0 0) (void)) #t)))
(not (cptypes-equivalent-expansion?
'(lambda (x) (if (zero? (random 2)) (void) (vector-set! x 0 0)) (vector? x))
'(lambda (x) (if (zero? (random 2)) (void) (vector-set! x 0 0)) #t)))
(cptypes-equivalent-expansion?
'(lambda (x) (vector-set! x 0 0) (if x (newline) (void)))
'(lambda (x) (vector-set! x 0 0) (if #t (newline) (void))))
(cptypes-equivalent-expansion?
'(lambda (x) (vector-set! x 0 0) (if (vector? x) (newline) (void)))
'(lambda (x) (vector-set! x 0 0) (if #t (newline) (void))))
(cptypes-equivalent-expansion?
'(lambda (x) (when (vector? x) (if x (newline) (void))))
'(lambda (x) (when (vector? x) (if #t (newline) (void)))))
(not (cptypes-equivalent-expansion?
'(lambda (x) (when (boolean? x) (if x (newline) (void))))
'(lambda (x) (when (boolean? x) (if #t (newline) (void))))))
(cptypes-equivalent-expansion?
'(lambda (x) (vector-set! x 0 0) (if (zero? (random 2)) (vector? x) (void)))
'(lambda (x) (vector-set! x 0 0) (if (zero? (random 2)) #t (void))))
(cptypes-equivalent-expansion?
'(lambda (x) (vector-set! x 0 0) (if (zero? (random 2)) (void) (vector? x)))
'(lambda (x) (vector-set! x 0 0) (if (zero? (random 2)) (void) #t)))
(cptypes-equivalent-expansion?
'(lambda (x) (if (vector? x) (vector? x) (void)))
'(lambda (x) (if (vector? x) #t (void))))
(not (cptypes-equivalent-expansion?
'(lambda (x) (if (vector? x) (void) (vector? x)))
'(lambda (x) (if (vector? x) (void) #t))))
(cptypes-equivalent-expansion?
'(lambda (x y) (if (vector? x) (if (vector? y) (list (vector? x) (vector? y)) (void)) (void)))
'(lambda (x y) (if (vector? x) (if (vector? y) (list #t #t) (void)) (void))))
(cptypes-equivalent-expansion?
'(lambda (x y) (if (and (vector? x) (vector? y)) (list (vector? x) (vector? y)) (void)))
'(lambda (x y) (if (and (vector? x) (vector? y)) (list #t #t) (void))))
(not (cptypes-equivalent-expansion?
'(lambda (x y) (if (or (vector? x) (vector? y)) (vector? x) (void)))
'(lambda (x y) (if (or (vector? x) (vector? y)) #t (void)))))
(not (cptypes-equivalent-expansion?
'(lambda (x y) (if (or (vector? x) (vector? y)) (vector? y) (void)))
'(lambda (x y) (if (or (vector? x) (vector? y)) #t (void)))))
(cptypes-equivalent-expansion?
'(lambda (x y) (if (if (vector? x) (vector? y) #f) (list (vector? x) (vector? y)) (void)))
'(lambda (x y) (if (if (vector? x) (vector? y) #f) (list #t #t) (void))))
(cptypes-equivalent-expansion?
'(lambda (x y) (if (if (vector? x) (vector? y) #t) (void) (vector? x)))
'(lambda (x y) (if (if (vector? x) (vector? y) #t) (void) #t)))
(cptypes-equivalent-expansion?
'(lambda (t) (let ([x (if t (begin (newline) #f) #f)]) (number? x)))
'(lambda (t) (let ([x (if t (begin (newline) #f) #f)]) #f)))
(cptypes-equivalent-expansion?
'(lambda (t) (let ([x (if t 1 2)]) (fixnum? x)))
'(lambda (t) (let ([x (if t 1 2)]) #t)))
(cptypes-equivalent-expansion?
'(lambda (t) (let ([x (if t 1 2.0)]) (number? x)))
'(lambda (t) (let ([x (if t 1 2.0)]) #t)))
(cptypes-equivalent-expansion?
'(if (error 'who "msg") (display 1) (display 2))
'(if (error 'who "msg") (display -1) (display -2)))
(cptypes-equivalent-expansion?
'(begin (if (error 'who "msg") (display 1) (display 2)) (display 3))
'(begin (if (error 'who "msg") (display 1) (display 2)) (display -3)))
(cptypes-equivalent-expansion?
'(begin (if (box? (box 0)) (error 'who "msg") (void)) (display 1))
'(begin (if (box? (box 0)) (error 'who "msg") (void)) (display -1)))
(not (cptypes-equivalent-expansion?
'(begin (if (box? (box 0)) (void) (error 'who "msg")) (display 1))
'(begin (if (box? (box 0)) (void) (error 'who "msg")) (display -1))))
(cptypes-equivalent-expansion?
'(lambda (x) (if (zero? (random 2)) (vector-set! x 0 0) (error 'who "msg")) (vector? x))
'(lambda (x) (if (zero? (random 2)) (vector-set! x 0 0) (error 'who "msg")) #t))
(cptypes-equivalent-expansion?
'(lambda (x) (if (zero? (random 2)) (error 'who "msg") (vector-set! x 0 0)) (vector? x))
'(lambda (x) (if (zero? (random 2)) (error 'who "msg") (vector-set! x 0 0)) #t))
(cptypes-equivalent-expansion?
'(begin (if (zero? (random 2)) (error 'who "msg") (error 'who "other")) (display 1))
'(begin (if (zero? (random 2)) (error 'who "msg") (error 'who "other")) (display -1)))
(cptypes-equivalent-expansion?
'(lambda (x y) (if y (vector-set! x 0 0) (vector-set! x 0 1)) (vector? x))
'(lambda (x y) (if y (vector-set! x 0 0) (vector-set! x 0 1)) #t))
(not (cptypes-equivalent-expansion?
'(lambda (x y) (if y (void) (vector-set! x 0 0)) (vector? x))
'(lambda (x y) (if y (void) (vector-set! x 0 0)) #t)))
(not (cptypes-equivalent-expansion?
'(lambda (x y) (if y (vector-set! x 0 0) (void)) (vector? x))
'(lambda (x y) (if y (vector-set! x 0 0) (void)) #t)))
(cptypes-equivalent-expansion?
'(lambda (x y) (if (if y (vector? x) (error 'who "msg")) (vector? x) (void)))
'(lambda (x y) (if (if y (vector? x) (error 'who "msg")) #t (void))))
(cptypes-equivalent-expansion?
'(lambda (x y) (if (if y (error 'who "msg") (vector? x)) (vector? x) (void)))
'(lambda (x y) (if (if y (error 'who "msg") (vector? x)) #t (void))))
(not (cptypes-equivalent-expansion?
'(lambda (x y) (if (if y (vector? x) (error 'who "msg")) (void) (vector? x)))
'(lambda (x y) (if (if y (vector? x) (error 'who "msg")) (void) #t))))
(not (cptypes-equivalent-expansion?
'(lambda (x y) (if (if y (error 'who "msg") (vector? x)) (void) (vector? x)))
'(lambda (x y) (if (if y (error 'who "msg") (vector? x)) (void) #t))))
(cptypes-equivalent-expansion?
'(lambda (t) (vector? (if t (vector 1) (vector 2))))
'(lambda (t) (if t (vector 1) (vector 2)) #t))
(cptypes-equivalent-expansion?
'(number? (if t 1 2.0))
'(begin (if t 1 2.0) #t))
(cptypes-equivalent-expansion?
'(lambda (t) (fixnum? (if t 1 2)))
'(lambda (t) (if t 1 2.0) #t))
(cptypes-equivalent-expansion?
'(lambda (t) (boolean? (if t #t #f)))
'(lambda (t) (if t #t #f) #t))
(cptypes-equivalent-expansion?
'(lambda (t) ((lambda (x) (if x #t #f)) (if t (vector 1) (box 1))))
'(lambda (t) (if t (vector 1) (box 1)) #t))
(cptypes-equivalent-expansion?
'(lambda (t)(not (if t (vector 1) (box 1))))
'(lambda (t) (if t (vector 1) (box 1)) #f))
(cptypes-equivalent-expansion?
'(lambda (x y z f)
(let ([t (if x (vector 1) (box 1))])
(if (if y t z) (f t 1) (f t 2))))
'(lambda (x y z f)
(let ([t (if x (vector 1) (box 1))])
(if (if y #t z) (f t 1) (f t 2)))))
(not (cptypes-equivalent-expansion?
'(lambda (x y z f)
(let ([t (vector? x)])
(if (if y t z) (f t 1) (f t 2))))
'(lambda (x y z f)
(let ([t (vector? x)])
(if (if y #t z) (f t 1) (f t 2))))))
(not (cptypes-equivalent-expansion?
'(lambda (x y z f)
(let ([t (vector? x)])
(if (if y t z) (f t 1) (f t 2))))
'(lambda (x y z f)
(let ([t (vector? x)])
(if (if y #f z) (f t 1) (f t 2))))))
)
(mat cptype-directly-applied-case-lambda
(equal?
(parameterize ([enable-type-recovery #t]
[run-cp0 (lambda (cp0 x) x)])
(eval
'(let ([t ((lambda (x y) (cons y x)) 'a 'b)])
(list t t))))
'((b . a) (b . a)))
(equal?
(parameterize ([enable-type-recovery #t]
[run-cp0 (lambda (cp0 x) x)])
(eval
'(let ([t ((lambda (x . y) (cons y x)) 'a 'b 'c 'd)])
(list t t))))
'(((b c d) . a) ((b c d) . a)))
(equal?
(parameterize ([enable-type-recovery #t]
[run-cp0 (lambda (cp0 x) x)])
(eval
'(let ([t ((case-lambda
[(x) (cons 'first x)]
[(x y) (cons* 'second y x)]
[(x . y) (cons* 'third y x)]) 'a 'b)])
(list t t))))
'((second b . a) (second b . a)))
(equal?
(parameterize ([enable-type-recovery #t]
[run-cp0 (lambda (cp0 x) x)])
(eval
'(let ([t ((case-lambda
[(x) (cons 'first x)]
[(x y) (cons* 'second y x)]
[(x . y) (cons* 'third y x)]) 'a 'b 'c)])
(list t t))))
'((third (b c) . a) (third (b c) . a)))
(equal?
(parameterize ([enable-type-recovery #t]
[run-cp0 (lambda (cp0 x) x)])
(eval
'(let ([t 'z])
((lambda args (set! t (cons args t))) 'a 'b 'c)
t)))
'((a b c) . z))
(equal?
(parameterize ([enable-type-recovery #t]
[run-cp0 (lambda (cp0 x) x)])
(eval
'(let ([t 'z])
((lambda args (set! t (cons args t))) 'a 'b 'c)
t)))
'((a b c) . z))
(equal?
(parameterize ([enable-type-recovery #t]
[run-cp0 (lambda (cp0 x) x)])
(eval
'(let ([t 'z])
((lambda (x . y) (set! t (cons* y x t))) 'a 'b 'c)
t)))
'((b c) a . z))
(equal?
(parameterize ([enable-type-recovery #t]
[run-cp0 (lambda (cp0 x) x)])
(eval
'(let ([t 'z])
((case-lambda
[(x) (set! t (cons* 'first x t))]
[(x y) (set! t (cons* 'second y x t))]
[(x . y) (set! t (cons* 'third y x t))]) 'a 'b)
t)))
'(second b a . z))
(equal?
(parameterize ([enable-type-recovery #t]
[run-cp0 (lambda (cp0 x) x)])
(eval
'(let ([t 'z])
((case-lambda
[(x) (set! t (cons* 'first x t))]
[(x y) (set! t (cons* 'second y x t))]
[(x . y) (set! t (cons* 'third y x t))]) 'a 'b 'c 'd)
t)))
'(third (b c d) a . z))
)
(define (test-chain/preamble/self preamble check-self? l)
(let loop ([l l])
(if (null? l)
#t
(and (or (not check-self?)
(cptypes-equivalent-expansion?
`(let ()
,preamble
(lambda (x) (when (,(car l) x) (,(car l) x))))
`(let ()
,preamble
(lambda (x) (when (,(car l) x) #t)))))
(let loop ([t (cdr l)])
(if (null? t)
#t
(and (cptypes-equivalent-expansion?
`(let ()
,preamble
(lambda (x) (when (,(car l) x) (,(car t) x))))
`(let ()
,preamble
(lambda (x) (when (,(car l) x) #t))))
(not (cptypes-equivalent-expansion?
`(let ()
,preamble
(lambda (x) (when (,(car t) x) (,(car l) x))))
`(let ()
,preamble
(lambda (x) (when (,(car t) x) #t)))))
(loop (cdr t)))))
(loop (cdr l))))))
(define (test-chain l)
(test-chain/preamble/self '(void) #t l))
(define (test-chain* l)
(test-chain/preamble/self '(void) #f l))
(define (test-chain/preamble preamble l)
(test-chain/preamble/self preamble #t l))
(define (test-chain*/preamble l)
(test-chain/preamble/self preamble #f l))
(define (test-disjoint/preamble/self preamble check-self? l)
(let loop ([l l])
(if (null? l)
#t
(and (or (not check-self?)
(cptypes-equivalent-expansion?
`(let ()
,preamble
(lambda (x) (when (,(car l) x) (,(car l) x))))
`(let ()
,preamble
(lambda (x) (when (,(car l) x) #t)))))
(let loop ([t (cdr l)])
(if (null? t)
#t
(and (cptypes-equivalent-expansion?
`(let ()
,preamble
(lambda (x) (when (,(car l) x) (,(car t) x))))
`(let ()
,preamble
(lambda (x) (when (,(car l) x) #f))))
(cptypes-equivalent-expansion?
`(let ()
,preamble
(lambda (x) (when (,(car t) x) (,(car l) x))))
`(let ()
,preamble
(lambda (x) (when (,(car t) x) #f))))
(loop (cdr t)))))
(loop (cdr l))))))
(define (test-disjoint l)
(test-disjoint/preamble/self '(void) #t l))
(define (test-disjoint* l)
(test-disjoint/preamble/self '(void) #f l))
(define (test-disjoint/preamble preamble l)
(test-disjoint/preamble/self preamble #t l))
(define (test-disjoint*/preamble preamble l)
(test-disjoint/preamble/self preamble #f l))
(mat cptypes-type-implies?
(test-chain '((lambda (x) (eq? x 0)) fixnum? #;exact-integer? real? number?))
(test-chain* '(fixnum? integer? real?))
(test-chain* '(fixnum? exact? number?)) ; exact? may raise an error
(test-chain* '((lambda (x) (eq? x (expt 256 100))) real? number?)) ; bignum?
(test-chain '((lambda (x) (eqv? 0.0 x)) flonum? real? number?))
(test-chain '(gensym? symbol?))
(test-chain '(not boolean?))
(test-chain '((lambda (x) (eq? x #t)) boolean?))
(test-chain* '(record? #3%$record?))
(test-chain* '((lambda (x) (eq? x car)) procedure?))
(test-chain* '(record-type-descriptor? #3%$record?))
(test-disjoint '(pair? box? #3%$record? number?
vector? string? bytevector? fxvector? symbol?
char? boolean? null? (lambda (x) (eq? x (void)))
eof-object? bwp-object? procedure?))
(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* '(list? record? vector?))
(not (test-disjoint* '(list? null?)))
(not (test-disjoint* '(list? pair?)))
)
; use a gensym to make expansions equivalent
(define my-rec (gensym "my-rec"))
(mat cptypes-type-record?
; define-record
(parameterize ([optimize-level 2])
(cptypes-equivalent-expansion?
`(let () (define-record ,my-rec (a)) (lambda (x) (display (my-rec-a x)) (my-rec? x)))
`(let () (define-record ,my-rec (a)) (lambda (x) (display (my-rec-a x)) #t))))
(parameterize ([optimize-level 2])
(cptypes-equivalent-expansion?
`(let () (define-record ,my-rec (a)) (lambda (x) (set-my-rec-a! x 0) (my-rec? x)))
`(let () (define-record ,my-rec (a)) (lambda (x) (set-my-rec-a! x 0) #t))))
(cptypes-equivalent-expansion?
`(let () (define-record ,my-rec (a)) (let ([x (make-my-rec 0)]) (display (list x x)) (my-rec? x)))
`(let () (define-record ,my-rec (a)) (let ([x (make-my-rec 0)]) (display (list x x)) #t)))
(cptypes-equivalent-expansion?
`(let () (define-record ,my-rec (a)) (let ([x (make-my-rec 0)]) (display (list x x)) (if x 1 2)))
`(let () (define-record ,my-rec (a)) (let ([x (make-my-rec 0)]) (display (list x x)) (if #t 1 2))))
(test-chain/preamble `(define-record ,my-rec (a)) '(my-rec? #3%$record?))
(test-chain/preamble `(begin
(define-record ,my-rec (a))
(define-record ,(gensym "sub-rec") ,my-rec (b)))
'(sub-rec? my-rec? #3%$record?))
(test-disjoint/preamble `(define-record ,my-rec (a)) '(my-rec? pair? null? not number?))
(test-disjoint/preamble `(begin
(define-record ,my-rec (a))
(define-record ,(gensym "other-rec") (a)))
'(my-rec? other-rec?))
; define-record-type
(parameterize ([optimize-level 2])
(cptypes-equivalent-expansion?
`(let () (define-record-type ,my-rec (fields a)) (lambda (x) (display (my-rec-a x)) (my-rec? x)))
`(let () (define-record-type ,my-rec (fields a)) (lambda (x) (display (my-rec-a x)) #t))))
(parameterize ([optimize-level 2])
(cptypes-equivalent-expansion?
`(let () (define-record-type ,my-rec (fields (mutable a))) (lambda (x) (my-rec-a-set! x 0) (my-rec? x)))
`(let () (define-record-type ,my-rec (fields (mutable a))) (lambda (x) (my-rec-a-set! x 0) #t))))
(cptypes-equivalent-expansion?
`(let () (define-record-type ,my-rec (fields a)) (let ([x (make-my-rec 0)]) (display (list x x)) (my-rec? x)))
`(let () (define-record-type ,my-rec (fields a)) (let ([x (make-my-rec 0)]) (display (list x x)) #t)))
(cptypes-equivalent-expansion?
`(let () (define-record-type ,my-rec (fields a)) (let ([x (make-my-rec 0)]) (display (list x x)) (if x 1 2)))
`(let () (define-record-type ,my-rec (fields a)) (let ([x (make-my-rec 0)]) (display (list x x)) (if #t 1 2))))
(test-chain/preamble `(define-record-type ,my-rec (fields a)) '(my-rec? #3%$record?))
#;(test-chain/preamble `(begin
(define-record-type ,my-rec (fields a))
(define-record-type ,(gensym "sub-rec") (parent ,my-rec) (fields b)))
'(sub-rec? my-rec? #3%$record?))
(test-disjoint/preamble `(define-record-type ,my-rec (fields a)) '(my-rec? pair? null? not number?))
#;(test-disjoint/preamble `(begin
(define-record-type ,my-rec (fields a))
(define-record-type ,(gensym "other-rec") (fields a)))
'(my-rec? other-rec?))
; define-record-type (sealed #t)
(parameterize ([optimize-level 2])
(cptypes-equivalent-expansion?
`(let () (define-record-type ,my-rec (fields a) (sealed #t)) (lambda (x) (display (my-rec-a x)) (my-rec? x)))
`(let () (define-record-type ,my-rec (fields a) (sealed #t)) (lambda (x) (display (my-rec-a x)) #t))))
(parameterize ([optimize-level 2])
(cptypes-equivalent-expansion?
`(let () (define-record-type ,my-rec (fields (mutable a)) (sealed #t)) (lambda (x) (my-rec-a-set! x 0) (my-rec? x)))
`(let () (define-record-type ,my-rec (fields (mutable a)) (sealed #t)) (lambda (x) (my-rec-a-set! x 0) #t))))
(cptypes-equivalent-expansion?
`(let () (define-record-type ,my-rec (fields a) (sealed #t)) (let ([x (make-my-rec 0)]) (display (list x x)) (my-rec? x)))
`(let () (define-record-type ,my-rec (fields a) (sealed #t)) (let ([x (make-my-rec 0)]) (display (list x x)) #t)))
(cptypes-equivalent-expansion?
`(let () (define-record-type ,my-rec (fields a) (sealed #t)) (let ([x (make-my-rec 0)]) (display (list x x)) (if x 1 2)))
`(let () (define-record-type ,my-rec (fields a) (sealed #t)) (let ([x (make-my-rec 0)]) (display (list x x)) (if #t 1 2))))
(test-chain/preamble `(define-record-type ,my-rec (fields a) (sealed #t)) '(my-rec? #3%$record?))
#;(test-chain/preamble `(begin
(define-record-type ,my-rec (fields a))
(define-record-type ,(gensym "sub-rec") (parent ,my-rec) (fields b) (sealed #t)))
'(sub-rec? my-rec? #3%$record?))
(test-disjoint/preamble `(define-record-type ,my-rec (fields a) (sealed #t)) '(my-rec? pair? null? not number?))
#;(test-disjoint/preamble `(begin
(define-record-type ,my-rec (fields a) (sealed #t))
(define-record-type ,(gensym "other-rec") (fields a) (sealed #t)))
'(my-rec? other-rec?))
#;(test-disjoint/preamble `(begin
(define-record-type ,my-rec (fields a) (sealed #t))
(define-record-type ,(gensym "other-rec") (fields a)))
'(my-rec? other-rec?))
)
(mat cptypes-unsafe
(cptypes-equivalent-expansion?
'(lambda (x) (when (pair? x) (car x)))
'(lambda (x) (when (pair? x) (#3%car x))))
(cptypes-equivalent-expansion?
'(lambda (x) (when (pair? x) (cdr x)))
'(lambda (x) (when (pair? x) (#3%cdr x))))
(not (cptypes-equivalent-expansion?
'(lambda (x) (when (pair? x) (#2%cadr x)))
'(lambda (x) (when (pair? x) (#3%cadr x)))))
(cptypes-equivalent-expansion?
'(lambda (x y) (when (and (fixnum? x) (fixnum? y)) (fxmax x y)))
'(lambda (x y) (when (and (fixnum? x) (fixnum? y)) (#3%fxmax x y))))
(cptypes-equivalent-expansion?
'(lambda (x y) (when (and (fixnum? x) (eq? y 5)) (fxmax x y)))
'(lambda (x y) (when (and (fixnum? x) (eq? y 5)) (#3%fxmax x y))))
(cptypes-equivalent-expansion?
'(lambda (x) (when (fixnum? x) (fxmax x 5)))
'(lambda (x) (when (fixnum? x) (#3%fxmax x 5))))
(cptypes-equivalent-expansion?
'(lambda (x y z) (when (and (fixnum? x) (fixnum? y) (fixnum? z)) (fxmax x y z)))
'(lambda (x y z) (when (and (fixnum? x) (fixnum? y) (fixnum? z)) (#3%fxmax x y z))))
(cptypes-equivalent-expansion?
'(lambda (x) (when (fixnum? x) (fxzero? x)))
'(lambda (x) (when (fixnum? x) (#3%fxzero? x))))
(not (cptypes-equivalent-expansion?
'(lambda (x) (when (number? x) (#2%odd? x)))
'(lambda (x) (when (number? x) (#3%odd? x)))))
)
(mat cptypes-rest-argument
(cptypes/nocp0-equivalent-expansion?
'((lambda (x . r) (pair? r)) 1)
'((lambda (x . r) #f) 1))
(cptypes/nocp0-equivalent-expansion?
'((lambda (x . r) (null? r)) 1)
'((lambda (x . r) #t) 1))
(cptypes/nocp0-equivalent-expansion?
'((lambda (x . r) (pair? r)) 1 2)
'((lambda (x . r) #t) 1 2))
(cptypes/nocp0-equivalent-expansion?
'((lambda (x . r) (null? r)) 1 2)
'((lambda (x . r) #f) 1 2))
)
(mat cptypes-rest-argument/alternative
(cptypes/nocp0/alternative-equivalent-expansion?
'((lambda (x . r) (pair? r)) 1)
'((lambda (x . r) #f) 1))
(cptypes/nocp0/alternative-equivalent-expansion?
'((lambda (x . r) (null? r)) 1)
'((lambda (x . r) #t) 1))
(cptypes/nocp0/alternative-equivalent-expansion?
'((lambda (x . r) (pair? r)) 1 2)
'((lambda (x . r) #t) 1 2))
(cptypes/nocp0/alternative-equivalent-expansion?
'((lambda (x . r) (null? r)) 1 2)
'((lambda (x . r) #f) 1 2))
)

2
mats/misc.ms
View File

@ -5058,7 +5058,7 @@
'(if (#3%zero? (#3%random 1000)) '(if (#3%zero? (#3%random 1000))
(begin (pariah (void)) (#3%display 0)) (begin (pariah (void)) (#3%display 0))
(#3%display 1)) (#3%display 1))
'(if (#2%zero? (#2%random 1000)) '(if (#3%zero? (#2%random 1000))
(begin (pariah (void)) (#2%display 0)) (begin (pariah (void)) (#2%display 0))
(#2%display 1)))) (#2%display 1))))
) )

22
mats/record.ms
View File

@ -6375,9 +6375,7 @@
(#3%$object-set! 'scheme-object b ,fixnum? g7)) (#3%$object-set! 'scheme-object b ,fixnum? g7))
(#2%list (#2%list
(#3%record? b g5) (#3%record? b g5)
(begin (#3%$object-ref 'scheme-object b ,fixnum?))))))
(if (#3%record? b g6) (#2%void) (#3%$record-oops 'unbox b g6))
(#3%$object-ref 'scheme-object b ,fixnum?)))))))
(equal? (equal?
(let () (let ()
(define build-box (define build-box
@ -6407,13 +6405,9 @@
(record-mutator (make-record-type-descriptor (record-mutator (make-record-type-descriptor
name #f #f #f #f '#((mutable x))) 0))) name #f #f #f #f '#((mutable x))) 0)))
(procedure? (useless 'useless-box-setter))))) (procedure? (useless 'useless-box-setter)))))
`(#2%procedure? `(begin
(let ([g0 (#2%make-record-type-descriptor 'useless-box-setter #f #f #f #f '#((mutable x)))]) (#2%make-record-type-descriptor 'useless-box-setter #f #f #f #f '#((mutable x)))
(lambda (g1 g2) #t))
(if (#3%record? g1 g0)
(#2%void)
(#3%$record-oops 'moi g1 g0))
(#3%$object-set! 'scheme-object g1 ,fixnum? g2)))))
(let () (let ()
(define useless (define useless
(lambda (name) (lambda (name)
@ -8592,9 +8586,7 @@
(if b (frob-x x) 72))))) (if b (frob-x x) 72)))))
`(lambda (b) `(lambda (b)
(if b (if b
(begin (#3%$record-oops 'frob-x 'x ',record-type-descriptor?)
(#3%$record-oops 'frob-x 'x ',record-type-descriptor?)
(#3%$object-ref 'scheme-object 'x ,fixnum?))
72))) 72)))
(equivalent-expansion? (equivalent-expansion?
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
@ -8793,7 +8785,7 @@
[r (inc r)] [r (inc r)]
[r (inc r)]) [r (inc r)])
r))))) r)))))
`(lambda (x) (#3%$record ',record-type-descriptor? 37 (#2%+ 1 (#2%+ 1 x))))) `(lambda (x) (#3%$record ',record-type-descriptor? 37 (#3%+ 1 (#2%+ 1 x)))))
(equivalent-expansion? (equivalent-expansion?
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(expand/optimize (expand/optimize
@ -8820,7 +8812,7 @@
[r (inc r)]) [r (inc r)])
r))))) r)))))
'(let ([rtd (#2%$make-record-type-descriptor #!base-rtd 'foo #f #f #f #f '#((immutable a) (immutable b)) 'define-record-type)]) '(let ([rtd (#2%$make-record-type-descriptor #!base-rtd 'foo #f #f #f #f '#((immutable a) (immutable b)) 'define-record-type)])
(lambda (x) (#3%$record rtd 37 (#2%+ 1 (#2%+ 1 x)))))) (lambda (x) (#3%$record rtd 37 (#3%+ 1 (#2%+ 1 x))))))
(equivalent-expansion? (equivalent-expansion?
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(expand/optimize (expand/optimize

8
s/Mf-base
View File

@ -105,7 +105,7 @@ patch = patch
# putting cpnanopass.patch early for maximum make --jobs=2 benefit # putting cpnanopass.patch early for maximum make --jobs=2 benefit
patchobj = patch.patch cpnanopass.patch cprep.patch cpcheck.patch\ patchobj = patch.patch cpnanopass.patch cprep.patch cpcheck.patch\
cp0.patch cpvalid.patch cpcommonize.patch cpletrec.patch\ cp0.patch cpvalid.patch cptypes.patch cpcommonize.patch cpletrec.patch\
reloc.patch\ reloc.patch\
compile.patch fasl.patch syntax.patch env.patch\ compile.patch fasl.patch syntax.patch env.patch\
read.patch interpret.patch ftype.patch strip.patch\ read.patch interpret.patch ftype.patch strip.patch\
@ -127,7 +127,7 @@ basesrc =\
strnum.ss bytevector.ss 5_4.ss 5_6.ss 5_7.ss\ strnum.ss bytevector.ss 5_4.ss 5_6.ss 5_7.ss\
event.ss 4.ss front.ss foreign.ss 6.ss print.ss newhash.ss\ event.ss 4.ss front.ss foreign.ss 6.ss print.ss newhash.ss\
format.ss date.ss 7.ss cafe.ss trace.ss engine.ss\ format.ss date.ss 7.ss cafe.ss trace.ss engine.ss\
interpret.ss cprep.ss cpcheck.ss cp0.ss cpvalid.ss cpcommonize.ss cpletrec.ss inspect.ss\ interpret.ss cprep.ss cpcheck.ss cp0.ss cpvalid.ss cptypes.ss cpcommonize.ss cpletrec.ss inspect.ss\
enum.ss io.ss read.ss primvars.ss syntax.ss costctr.ss expeditor.ss\ enum.ss io.ss read.ss primvars.ss syntax.ss costctr.ss expeditor.ss\
exceptions.ss pretty.ss env.ss\ exceptions.ss pretty.ss env.ss\
fasl.ss reloc.ss pdhtml.ss strip.ss ftype.ss back.ss fasl.ss reloc.ss pdhtml.ss strip.ss ftype.ss back.ss
@ -149,7 +149,7 @@ macroobj =\
allsrc =\ allsrc =\
${basesrc} ${compilersrc} cmacros.ss ${archincludes} setup.ss debug.ss priminfo.ss primdata.ss layout.ss\ ${basesrc} ${compilersrc} cmacros.ss ${archincludes} setup.ss debug.ss priminfo.ss primdata.ss layout.ss\
base-lang.ss expand-lang.ss primref.ss types.ss io-types.ss fasl-helpers.ss hashtable-types.ss\ base-lang.ss expand-lang.ss primref.ss types.ss io-types.ss fasl-helpers.ss hashtable-types.ss\
np-languages.ss bitset.ss np-languages.ss bitset.ss fxmap.ss
# doit uses a different Scheme process to compile each target # doit uses a different Scheme process to compile each target
doit: ${PetiteBoot} ${SchemeBoot} ${Cheader} ${Cequates} doit: ${PetiteBoot} ${SchemeBoot} ${Cheader} ${Cequates}
@ -495,7 +495,7 @@ primvars.so setup.so mkheader.so env.so: cmacros.so priminfo.so primref.ss
setup.so: debug.ss setup.so: debug.ss
${patchobj}: ${macroobj} nanopass.so base-lang.ss expand-lang.ss primref.ss types.ss io-types.ss fasl-helpers.ss hashtable-types.ss env.ss ${patchobj}: ${macroobj} nanopass.so base-lang.ss expand-lang.ss primref.ss types.ss io-types.ss fasl-helpers.ss hashtable-types.ss env.ss
cpnanopass.$m cpnanopass.patch: nanopass.so np-languages.ss ${archincludes} cpnanopass.$m cpnanopass.patch: nanopass.so np-languages.ss fxmap.ss ${archincludes}
5_4.$m: ../unicode/unicode-char-cases.ss ../unicode/unicode-charinfo.ss 5_4.$m: ../unicode/unicode-char-cases.ss ../unicode/unicode-charinfo.ss
inspect.$m: bitset.ss inspect.$m: bitset.ss

4
s/base-lang.ss
View File

@ -14,14 +14,14 @@
;;; limitations under the License. ;;; limitations under the License.
(module (Lsrc Lsrc? Ltype Ltype? unparse-Ltype unparse-Lsrc count-Lsrc (module (Lsrc Lsrc? Ltype Ltype? unparse-Ltype unparse-Lsrc count-Lsrc
lookup-primref primref? primref-name primref-level primref-flags primref-arity lookup-primref primref? primref-name primref-level primref-flags primref-arity primref-signatures
sorry! make-preinfo preinfo? preinfo-lambda? preinfo-sexpr preinfo-sexpr-set! preinfo-src sorry! make-preinfo preinfo? preinfo-lambda? preinfo-sexpr preinfo-sexpr-set! preinfo-src
make-preinfo-lambda preinfo-lambda-name preinfo-lambda-name-set! preinfo-lambda-flags preinfo-lambda-libspec make-preinfo-lambda preinfo-lambda-name preinfo-lambda-name-set! preinfo-lambda-flags preinfo-lambda-libspec
prelex? make-prelex prelex-name prelex-name-set! prelex-flags prelex-flags-set! prelex? make-prelex prelex-name prelex-name-set! prelex-flags prelex-flags-set!
prelex-source prelex-operand prelex-operand-set! prelex-uname make-prelex* prelex-source prelex-operand prelex-operand-set! prelex-uname make-prelex*
target-fixnum? target-bignum?) target-fixnum? target-bignum?)
(module (lookup-primref primref? primref-name primref-flags primref-arity primref-level) (module (lookup-primref primref? primref-name primref-flags primref-arity primref-signatures primref-level)
(include "primref.ss") (include "primref.ss")
(define $lookup-primref (define $lookup-primref

1
s/cmacros.ss
View File

@ -1599,6 +1599,7 @@
(abort-op #b00000100000000000000000) (abort-op #b00000100000000000000000)
(unsafe #b00001000000000000000000) (unsafe #b00001000000000000000000)
(unrestricted #b00010000000000000000000) (unrestricted #b00010000000000000000000)
(safeongoodargs #b00100000000000000000000)
(arith-op (or proc pure true)) (arith-op (or proc pure true))
(alloc (or proc discard true)) (alloc (or proc discard true))
; would be nice to check that these and only these actually have cp0 partial folders ; would be nice to check that these and only these actually have cp0 partial folders

24
s/compile.ss
View File

@ -551,6 +551,12 @@
(when ($enable-check-prelex-flags) (when ($enable-check-prelex-flags)
($pass-time 'cpcheck-prelex-flags (lambda () (do-trace $cpcheck-prelex-flags x 'uncprep)))))) ($pass-time 'cpcheck-prelex-flags (lambda () (do-trace $cpcheck-prelex-flags x 'uncprep))))))
(define cptypes
(lambda (x)
(if (enable-type-recovery)
($pass-time 'cptypes (lambda () ($cptypes x)))
x)))
(define compile-file-help (define compile-file-help
(lambda (op hostop wpoop machine sfd do-read outfn) (lambda (op hostop wpoop machine sfd do-read outfn)
(include "types.ss") (include "types.ss")
@ -569,7 +575,8 @@
[$compile-profile ($compile-profile)] [$compile-profile ($compile-profile)]
[generate-interrupt-trap (generate-interrupt-trap)] [generate-interrupt-trap (generate-interrupt-trap)]
[$optimize-closures ($optimize-closures)] [$optimize-closures ($optimize-closures)]
[enable-cross-library-optimization (enable-cross-library-optimization)]) [enable-cross-library-optimization (enable-cross-library-optimization)]
[enable-type-recovery (enable-type-recovery)])
(emit-header op (constant machine-type)) (emit-header op (constant machine-type))
(when hostop (emit-header hostop (host-machine-type))) (when hostop (emit-header hostop (host-machine-type)))
(when wpoop (emit-header wpoop (host-machine-type))) (when wpoop (emit-header wpoop (host-machine-type)))
@ -650,14 +657,18 @@
(set! cpletrec-ran? #t) (set! cpletrec-ran? #t)
(let* ([x ($pass-time 'cp0 (lambda () (do-trace $cp0 x)))] (let* ([x ($pass-time 'cp0 (lambda () (do-trace $cp0 x)))]
[waste (check-prelex-flags x 'cp0)] [waste (check-prelex-flags x 'cp0)]
[x (cptypes x)]
[waste (check-prelex-flags x 'cptypes)]
[x ($pass-time 'cpletrec (lambda () (do-trace $cpletrec x)))] [x ($pass-time 'cpletrec (lambda () (do-trace $cpletrec x)))]
[waste (check-prelex-flags x 'cpletrec)]) [waste (check-prelex-flags x 'cpletrec)])
x)) x))
x2)]) x2)])
(if cpletrec-ran? (if cpletrec-ran?
x x
(let ([x ($pass-time 'cpletrec (lambda () (do-trace $cpletrec x)))]) (let* ([x (cptypes x)]
(check-prelex-flags x 'cpletrec) [waste (check-prelex-flags x 'cptypes)]
[x ($pass-time 'cpletrec (lambda () (do-trace $cpletrec x)))]
[waste (check-prelex-flags x 'cpletrec)])
x))))] x))))]
[x2b ($pass-time 'cpcheck (lambda () (do-trace $cpcheck x2a)))] [x2b ($pass-time 'cpcheck (lambda () (do-trace $cpcheck x2a)))]
[waste (check-prelex-flags x2b 'cpcheck)] [waste (check-prelex-flags x2b 'cpcheck)]
@ -1489,10 +1500,13 @@
(let ([x ((run-cp0) (let ([x ((run-cp0)
(lambda (x) (lambda (x)
(set! cpletrec-ran? #t) (set! cpletrec-ran? #t)
(let ([x ($pass-time 'cp0 (lambda () ($cp0 x)))]) (let* ([x ($pass-time 'cp0 (lambda () ($cp0 x)))]
[x (cptypes x)])
($pass-time 'cpletrec (lambda () ($cpletrec x))))) ($pass-time 'cpletrec (lambda () ($cpletrec x)))))
x2)]) x2)])
(if cpletrec-ran? x ($pass-time 'cpletrec (lambda () ($cpletrec x))))))] (if cpletrec-ran? x
(let ([x (cptypes x)])
($pass-time 'cpletrec (lambda () ($cpletrec x)))))))]
[x2b ($pass-time 'cpcheck (lambda () ($cpcheck x2a)))] [x2b ($pass-time 'cpcheck (lambda () ($cpcheck x2a)))]
[x2b ($pass-time 'cpcommonize (lambda () ($cpcommonize x2b)))]) [x2b ($pass-time 'cpcommonize (lambda () ($cpcommonize x2b)))])
(when (and (expand/optimize-output) (not ($noexpand? x0))) (when (and (expand/optimize-output) (not ($noexpand? x0)))

1
s/cpnanopass.ss
View File

@ -4556,6 +4556,7 @@
[(e1 e2) (dofxlogbit1 e2 e1)]) [(e1 e2) (dofxlogbit1 e2 e1)])
(define-inline 3 fxcopy-bit (define-inline 3 fxcopy-bit
[(e1 e2 e3) [(e1 e2 e3)
;; NB: even in the case where e3 is not known to be 0 or 1, seems like we could do better here.
(and (fixnum-constant? e3) (and (fixnum-constant? e3)
(case (constant-value e3) (case (constant-value e3)
[(0) (dofxlogbit0 e1 e2)] [(0) (dofxlogbit0 e1 e2)]

8
s/cprep.ss
View File

@ -215,6 +215,10 @@
(if (eq? (subset-mode) 'system) (if (eq? (subset-mode) 'system)
($system-environment) ($system-environment)
(interaction-environment))) (interaction-environment)))
(define (cptypes x)
(if (enable-type-recovery)
($cptypes x)
x))
(define e/o (define e/o
(lambda (who cte? x env) (lambda (who cte? x env)
(define (go x) (define (go x)
@ -225,9 +229,9 @@
(let ([x ((run-cp0) (let ([x ((run-cp0)
(lambda (x) (lambda (x)
(set! cpletrec-ran? #t) (set! cpletrec-ran? #t)
($cpletrec ($cp0 x $compiler-is-loaded?))) ($cpletrec (cptypes ($cp0 x $compiler-is-loaded?))))
($cpvalid x))]) ($cpvalid x))])
(if cpletrec-ran? x ($cpletrec x)))))))) (if cpletrec-ran? x ($cpletrec (cptypes x)))))))))
(unless (environment? env) (unless (environment? env)
($oops who "~s is not an environment" env)) ($oops who "~s is not an environment" env))
; claim compiling-a-file to get cte as well as run-time code ; claim compiling-a-file to get cte as well as run-time code

1058
s/cptypes.ss Normal file
View File

File diff suppressed because it is too large Load Diff

5
s/front.ss
View File

@ -104,6 +104,7 @@
(define enable-cross-library-optimization ($make-thread-parameter #t (lambda (x) (and x #t)))) (define enable-cross-library-optimization ($make-thread-parameter #t (lambda (x) (and x #t))))
(define-who current-generate-id (define-who current-generate-id
($make-thread-parameter ($make-thread-parameter
(lambda (sym) (lambda (sym)
@ -113,6 +114,9 @@
(unless (procedure? p) ($oops who "~s is not a procedure" p)) (unless (procedure? p) ($oops who "~s is not a procedure" p))
p))) p)))
(define enable-type-recovery ($make-thread-parameter #t (lambda (x) (and x #t))))
(define machine-type (define machine-type
(lambda () (lambda ()
(constant machine-type-name))) (constant machine-type-name)))
@ -223,6 +227,7 @@
(package-stubs compiler-support (package-stubs compiler-support
$cp0 $cp0
$cpvalid $cpvalid
$cptypes
$cpletrec $cpletrec
$cpcheck) $cpcheck)
(package-stubs syntax-support (package-stubs syntax-support

490
s/fxmap.ss Normal file
View File

@ -0,0 +1,490 @@
;;; fxmap.ss
;;; Copyright 1984-2017 Cisco Systems, Inc.
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;; http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.
;; Based on Okasaki and Gill's "Fast Mergeable Integer Maps" (1998).
(module fxmap
(fxmap?
empty-fxmap
fxmap-empty?
fxmap-count
fxmap-ref
fxmap-set
fxmap-remove
fxmap-remove/base
fxmap-reset/base
fxmap-advance/base
fxmap-for-each
fxmap-for-each/diff
fxmap-changes
;; internals
; $branch? make-$branch $branch-prefix $branch-mask $branch-left $branch-right
; $leaf? make-$leaf $leaf-key $leaf-val
;; We treat $empty as a singleton, so don't use these functions.
; $empty? make-$empty
)
;; record types
(define-record-type $branch
(fields prefix mask left right count changes)
(nongenerative #{$branch pfv8jpsat5jrk6vq7vclc3ntg-1})
(sealed #t))
(define-record-type $leaf
(fields key val changes)
(nongenerative #{$leaf pfv8jq2dzw50ox4f6vqm1ff5v-1})
(sealed #t))
(define-record-type $empty
(nongenerative #{$empty pfwk1nal7cs5dornqtzvda91m-0})
(sealed #t))
(define-syntax let-branch
(syntax-rules ()
[(_ ([(p m l r) d] ...) exp ...)
(let ([p ($branch-prefix d)] ...
[m ($branch-mask d)] ...
[l ($branch-left d)] ...
[r ($branch-right d)] ...)
exp ...)]))
;; constants & empty
(define empty-fxmap (make-$empty))
(define (fxmap-empty? x) (eq? empty-fxmap x))
;; predicate
(define (fxmap? x)
(or ($branch? x)
($leaf? x)
(eq? empty-fxmap x)))
;; count & changes
(define (fxmap-count d)
(cond
[($branch? d)
($branch-count d)]
[($leaf? d) 1]
[else 0]))
(define (fxmap-changes d)
(cond
[($branch? d)
($branch-changes d)]
[($leaf? d)
($leaf-changes d)]
[else 0]))
;; ref
(define (fxmap-ref/leaf d key)
(cond
[($branch? d)
(let-branch ([(p m l r) d])
(cond
[(fx<= key p)
(fxmap-ref/leaf l key)]
[else
(fxmap-ref/leaf r key)]))]
[($leaf? d)
(if (fx= key ($leaf-key d))
d
#f)]
[else
#f]))
(define (fxmap-ref d key default)
(let ([d (fxmap-ref/leaf d key)])
(if d
($leaf-val d)
default)))
(define (fxmap-ref/changes d key)
(let ([d (fxmap-ref/leaf d key)])
(if d
($leaf-changes d)
0)))
;; set
(define (fxmap-set/changes d key val changes)
(cond
[($branch? d)
(let-branch ([(p m l r) d])
(cond
[(nomatch? key p m)
(join key (make-$leaf key val (or changes 1)) p d)]
[(fx<= key p)
(br p m (fxmap-set/changes l key val changes) r)]
[else
(br p m l (fxmap-set/changes r key val changes))]))]
[($leaf? d)
(let ([k ($leaf-key d)])
(if (fx= key k)
(make-$leaf key val (or changes (fx+ ($leaf-changes d) 1)))
(join key (make-$leaf key val (or changes 1)) k d)))]
[else
(make-$leaf key val (or changes 1))]))
(define (fxmap-set d key val)
(fxmap-set/changes d key val #f))
;; remove
(define (fxmap-remove d key)
(cond
[($branch? d)
(let-branch ([(p m l r) d])
(cond
[(nomatch? key p m) d]
[(fx<= key p) (br* p m (fxmap-remove l key) r)]
[else (br* p m l (fxmap-remove r key))]))]
[($leaf? d)
(if (fx= key ($leaf-key d))
empty-fxmap
d)]
[else
empty-fxmap]))
(define (fxmap-remove/base d key base)
; Remove key from d, but try to reuse the branches from base when possible
; instead of creating new ones.
; TODO: This assumes that all the keys in base are in d too.
; Perhaps this restriction can be removed.
(cond
[($branch? base)
(cond
[($branch? d)
(let-branch ([(p0 m0 l0 r0) base]
[(p m l r) d])
(let ([sub-base (cond
[(fx< m0 m) base]
[(fx<= key p0) l0]
[else r0])])
(cond
[(nomatch? key p m)
d]
[(fx<= key p)
(br*/base p m (fxmap-remove/base l key sub-base) r base)]
[else
(br*/base p m l (fxmap-remove/base r key sub-base) base)])))]
[($leaf? d)
(if (fx= key ($leaf-key d))
empty-fxmap
d)]
[else
empty-fxmap])]
[else
(fxmap-remove d key)]))
;; reset and advance
(define (fxmap-reset/base d key base)
; Reset key in d to the value it has in base, but try to reuse the branches
; from base when possible instead of creating new ones.
; TODO: This assumes that all the keys in base are in d too.
; Perhaps this restriction can be removed.
(cond
[($branch? d)
(let-branch ([(p m l r) d])
(let ([sub-base (cond
[($branch? base)
(let-branch ([(p0 m0 l0 r0) base])
(cond
[(fx< m0 m) base]
[(fx<= key p0) l0]
[else r0]))]
[else base])])
(cond
[(nomatch? key p m)
d]
[(fx<= key p)
(br*/base p m (fxmap-reset/base l key sub-base) r base)]
[else
(br*/base p m l (fxmap-reset/base r key sub-base) base)])))]
[(and ($leaf? d)
(fx= key ($leaf-key d))
($leaf? base)
(fx= key ($leaf-key base)))
base]
[else
(error 'fxmap-reset/base "")]))
(define (fxmap-advance/base d key base)
(let ([changes (fx+ (fxmap-ref/changes base key) 1)]
[l (fxmap-ref/leaf d key)])
(if l
(if (fx= changes ($leaf-changes l))
d
(fxmap-set/changes d key ($leaf-val l) changes))
(error 'fxmap-advance/base ""))))
;; set and remove utilities
(define-syntax define-syntax-rule
(syntax-rules ()
[(_ (name arg ...) e ...)
(define-syntax name
(syntax-rules ()
[(_ arg ...) e ...]))]))
(define (br p m l r)
(make-$branch p m l r
(fx+ (fxmap-count l) (fxmap-count r))
(fx+ (fxmap-changes l) (fxmap-changes r))))
(define (br* p m l r)
(cond [(eq? empty-fxmap r) l]
[(eq? empty-fxmap l) r]
[else (br p m l r)]))
(define (br*/base p m l r base)
(cond [(eq? empty-fxmap r) l]
[(eq? empty-fxmap l) r]
[(and ($branch? base)
(eq? l ($branch-left base))
(eq? r ($branch-right base)))
base]
[else (br p m l r)]))
(define (join p0 d0 p1 d1)
(let ([m (branching-bit p0 p1)])
(if (fx<= p0 p1)
(br (mask p0 m) m d0 d1)
(br (mask p0 m) m d1 d0))))
(define (join* p1 d1 p2 d2)
(cond
[(eq? empty-fxmap d1) d2]
[(eq? empty-fxmap d2) d1]
[else (join p1 d1 p2 d2)]))
(define (branching-bit p m)
(highest-set-bit (fxxor p m)))
(define-syntax-rule (mask h m)
(fxand (fxior h (fx1- m)) (fxnot m)))
(define highest-set-bit
(if (fx= (fixnum-width) 61)
(lambda (x1)
(let* ([x2 (fxior x1 (fxsrl x1 1))]
[x3 (fxior x2 (fxsrl x2 2))]
[x4 (fxior x3 (fxsrl x3 4))]
[x5 (fxior x4 (fxsrl x4 8))]
[x6 (fxior x5 (fxsrl x5 16))]
[x7 (fxior x6 (fxsrl x6 32))])
(fxxor x7 (fxsrl x7 1))))
(lambda (x1)
(let* ([x2 (fxior x1 (fxsrl x1 1))]
[x3 (fxior x2 (fxsrl x2 2))]
[x4 (fxior x3 (fxsrl x3 4))]
[x5 (fxior x4 (fxsrl x4 8))]
[x6 (fxior x5 (fxsrl x5 16))])
(fxxor x6 (fxsrl x6 1))))))
(define-syntax-rule (nomatch? h p m)
(not (fx= (mask h m) p)))
;; merge
(define (fxmap-merge bin f id g1 g2 d1 d2)
(define-syntax go
(syntax-rules ()
[(_ d1 d2) (fxmap-merge bin f id g1 g2 d1 d2)]))
(cond
[(eq? d1 d2) (id d1)]
[($branch? d1)
(cond
[($branch? d2)
(let-branch ([(p1 m1 l1 r1) d1]
[(p2 m2 l2 r2) d2])
(cond
[(fx> m1 m2) (cond
[(nomatch? p2 p1 m1) (join* p1 (g1 d1) p2 (g2 d2))]
[(fx<= p2 p1) (bin p1 m1 (go l1 d2) (g1 r1))]
[else (bin p1 m1 (g1 l1) (go r1 d2))])]
[(fx> m2 m1) (cond
[(nomatch? p1 p2 m2) (join* p1 (g1 d1) p2 (g2 d2))]
[(fx<= p1 p2) (bin p2 m2 (go d1 l2) (g2 r2))]
[else (bin p2 m2 (g2 l2) (go d1 r2))])]
[(fx= p1 p2) (bin p1 m1 (go l1 l2) (go r1 r2))]
[else (join* p1 (g1 d1) p2 (g2 d2))]))]
[($leaf? d2)
(let ([k2 ($leaf-key d2)])
(let merge0 ([d1 d1])
(cond
[(eq? d1 d2)
(id d1)]
[($branch? d1)
(let-branch ([(p1 m1 l1 r1) d1])
(cond [(nomatch? k2 p1 m1) (join* p1 (g1 d1) k2 (g2 d2))]
[(fx<= k2 p1) (bin p1 m1 (merge0 l1) (g1 r1))]
[else (bin p1 m1 (g1 l1) (merge0 r1))]))]
[($leaf? d1)
(let ([k1 ($leaf-key d1)])
(cond [(fx= k1 k2) (f d1 d2)]
[else (join* k1 (g1 d1) k2 (g2 d2))]))]
[else ; (eq? empty-fxmap d1)
(g2 d2)])))]
[else ; (eq? empty-fxmap d2)
(g1 d1)])]
[($leaf? d1)
(let ([k1 ($leaf-key d1)])
(let merge0 ([d2 d2])
(cond
[(eq? d1 d2)
(id d1)]
[($branch? d2)
(let-branch ([(p2 m2 l2 r2) d2])
(cond [(nomatch? k1 p2 m2) (join* k1 (g1 d1) p2 (g2 d2))]
[(fx<= k1 p2) (bin p2 m2 (merge0 l2) (g2 r2))]
[else (bin p2 m2 (g2 l2) (merge0 r2))]))]
[($leaf? d2)
(let ([k2 ($leaf-key d2)])
(cond [(fx= k1 k2) (f d1 d2)]
[else (join* k1 (g1 d1) k2 (g2 d2))]))]
[else ; (eq? empty-fxmap d2)
(g1 d1)])))]
[else ; (eq? empty-fxmap d1)
(g2 d2)]))
;; merge*
; like merge, but the result is (void)
(define (fxmap-merge* f id g1 g2 d1 d2)
(define (merge* f id g1 g2 d1 d2)
(define-syntax go
(syntax-rules ()
[(_ d1 d2) (merge* f id g1 g2 d1 d2)]))
(cond
[(eq? d1 d2) (id d1)]
[($branch? d1)
(cond
[($branch? d2)
(let-branch ([(p1 m1 l1 r1) d1]
[(p2 m2 l2 r2) d2])
(cond
[(fx> m1 m2) (cond
[(nomatch? p2 p1 m1) (g1 d1) (g2 d2)]
[(fx<= p2 p1) (go l1 d2) (g1 r1)]
[else (g1 l1) (go r1 d2)])]
[(fx> m2 m1) (cond
[(nomatch? p1 p2 m2) (g1 d1) (g2 d2)]
[(fx<= p1 p2) (go d1 l2) (g2 r2)]
[else (g2 l2) (go d1 r2)])]
[(fx= p1 p2) (go l1 l2) (go r1 r2)]
[else (g1 d1) (g2 d2)]))]
[else ; ($leaf? d2)
(let ([k2 ($leaf-key d2)])
(let merge*0 ([d1 d1])
(cond
[(eq? d1 d2)
(id d1)]
[($branch? d1)
(let-branch ([(p1 m1 l1 r1) d1])
(cond [(nomatch? k2 p1 m1) (g1 d1) (g2 d2)]
[(fx<= k2 p1) (merge*0 l1) (g1 r1)]
[else (g1 l1) (merge*0 r1)]))]
[else ; ($leaf? d1)
(let ([k1 ($leaf-key d1)])
(cond [(fx= k1 k2) (f d1 d2)]
[else (g1 d1) (g2 d2)]))])))])]
[($leaf? d1)
(let ([k1 ($leaf-key d1)])
(let merge*0 ([d2 d2])
(cond
[(eq? d1 d2)
(id d1)]
[($branch? d2)
(let-branch ([(p2 m2 l2 r2) d2])
(cond [(nomatch? k1 p2 m2) (g1 d1) (g2 d2)]
[(fx<= k1 p2) (merge*0 l2) (g2 r2)]
[else (g2 l2) (merge*0 r2)]))]
[else ; ($leaf? d2)
(let ([k2 ($leaf-key d2)])
(cond [(fx= k1 k2) (f d1 d2)]
[else (g1 d1) (g2 d2)]))])))]))
(cond
[(eq? d1 d2)
(id d1)]
[(eq? empty-fxmap d1)
(g2 d2)]
[(eq? empty-fxmap d2)
(g1 d1)]
[else
(merge* f id g1 g2 d1 d2)])
(void))
;; for-each
(define (fxmap-for-each g1 d1)
(cond
[($branch? d1)
(fxmap-for-each g1 ($branch-left d1))
(fxmap-for-each g1 ($branch-right d1))]
[($leaf? d1)
(g1 ($leaf-key d1) ($leaf-val d1))]
[else ; (eq? empty-fxmap d1)
(void)])
(void))
(define (fxmap-for-each/diff f g1 g2 d1 d2)
(fxmap-merge* (lambda (x y) (f ($leaf-key x) ($leaf-val x) ($leaf-val y)))
(lambda (x) (void))
(lambda (x) (fxmap-for-each g1 x))
(lambda (x) (fxmap-for-each g2 x))
d1
d2)
(void))
)

9
s/interpret.ss
View File

@ -661,6 +661,11 @@
(c-var-index-set! (car vars) i) (c-var-index-set! (car vars) i)
(loop (cdr vars) regs (fx+ i 1))]))))) (loop (cdr vars) regs (fx+ i 1))])))))
(define (cptypes x)
(if (enable-type-recovery)
($cptypes x))
x)
(define-pass interpret-Lexpand : Lexpand (ir situation for-import? ofn eoo) -> * (val) (define-pass interpret-Lexpand : Lexpand (ir situation for-import? ofn eoo) -> * (val)
(definitions (definitions
(define (ibeval x1) (define (ibeval x1)
@ -670,9 +675,9 @@
(let ([x ((run-cp0) (let ([x ((run-cp0)
(lambda (x) (lambda (x)
(set! cpletrec-ran? #t) (set! cpletrec-ran? #t)
($cpletrec ($cp0 x #f))) ($cpletrec (cptypes ($cp0 x #f))))
x2)]) x2)])
(if cpletrec-ran? x ($cpletrec x))))] (if cpletrec-ran? x ($cpletrec (cptypes x)))))]
[x2b ($cpcheck x2a)] [x2b ($cpcheck x2a)]
[x2b ($cpcommonize x2b)]) [x2b ($cpcommonize x2b)])
(when eoo (pretty-print ($uncprep x2b) eoo)) (when eoo (pretty-print ($uncprep x2b) eoo))

2
s/patch.ss
View File

@ -13,7 +13,7 @@
;;; See the License for the specific language governing permissions and ;;; See the License for the specific language governing permissions and
;;; limitations under the License. ;;; limitations under the License.
(define ($value x) x) (define enable-type-recovery ($make-thread-parameter #t (lambda (x) (and x #t))))
(printf "loading ~s cross compiler~%" (constant machine-type-name)) (printf "loading ~s cross compiler~%" (constant machine-type-name))

454
s/primdata.ss
View File

@ -16,23 +16,23 @@
;;; r6rs features ;;; r6rs features
(define-symbol-flags* ([libraries (rnrs) (rnrs arithmetic bitwise)] [flags primitive proc]) (define-symbol-flags* ([libraries (rnrs) (rnrs arithmetic bitwise)] [flags primitive proc])
(bitwise-not [sig [(sint) -> (sint)]] [flags arith-op mifoldable discard]) (bitwise-not [sig [(sint) -> (sint)]] [flags arith-op mifoldable discard safeongoodargs])
(bitwise-and [sig [(sint ...) -> (sint)]] [flags arith-op partial-folder]) (bitwise-and [sig [(sint ...) -> (sint)]] [flags arith-op partial-folder safeongoodargs])
(bitwise-ior [sig [(sint ...) -> (sint)]] [flags arith-op partial-folder]) (bitwise-ior [sig [(sint ...) -> (sint)]] [flags arith-op partial-folder safeongoodargs])
(bitwise-xor [sig [(sint ...) -> (sint)]] [flags arith-op partial-folder]) (bitwise-xor [sig [(sint ...) -> (sint)]] [flags arith-op partial-folder safeongoodargs])
(bitwise-if [sig [(sint sint sint) -> (sint)]] [flags arith-op mifoldable discard]) (bitwise-if [sig [(sint sint sint) -> (sint)]] [flags arith-op mifoldable discard safeongoodargs])
(bitwise-bit-count [sig [(sint) -> (sint)]] [flags arith-op mifoldable discard]) (bitwise-bit-count [sig [(sint) -> (sint)]] [flags arith-op mifoldable discard safeongoodargs])
(bitwise-length [sig [(sint) -> (uint)]] [flags arith-op mifoldable discard]) (bitwise-length [sig [(sint) -> (uint)]] [flags arith-op mifoldable discard safeongoodargs])
(bitwise-first-bit-set [sig [(sint) -> (sint)]] [flags arith-op mifoldable discard]) (bitwise-first-bit-set [sig [(sint) -> (sint)]] [flags arith-op mifoldable discard safeongoodargs])
(bitwise-bit-set? [sig [(sint uint) -> (boolean)]] [flags pure mifoldable discard]) (bitwise-bit-set? [sig [(sint uint) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
(bitwise-copy-bit [sig [(sint uint bit) -> (sint)]] [flags arith-op mifoldable discard]) (bitwise-copy-bit [sig [(sint uint bit) -> (sint)]] [flags arith-op mifoldable discard safeongoodargs])
(bitwise-bit-field [sig [(sint sub-uint sub-uint) -> (uint)]] [flags arith-op mifoldable discard]) (bitwise-bit-field [sig [(sint sub-uint sub-uint) -> (uint)]] [flags arith-op mifoldable discard safeongoodargs])
(bitwise-copy-bit-field [sig [(sint sub-uint sub-uint sint) -> (sint)]] [flags arith-op mifoldable discard]) (bitwise-copy-bit-field [sig [(sint sub-uint sub-uint sint) -> (sint)]] [flags arith-op mifoldable discard safeongoodargs])
(bitwise-arithmetic-shift [sig [(sint sint) -> (sint)]] [flags arith-op mifoldable discard cp03]) (bitwise-arithmetic-shift [sig [(sint sint) -> (sint)]] [flags arith-op mifoldable discard cp03 safeongoodargs])
(bitwise-arithmetic-shift-left [sig [(sint uint) -> (sint)]] [flags arith-op mifoldable discard cp03]) (bitwise-arithmetic-shift-left [sig [(sint uint) -> (sint)]] [flags arith-op mifoldable discard cp03 safeongoodargs])
(bitwise-arithmetic-shift-right [sig [(sint uint) -> (sint)]] [flags arith-op mifoldable discard cp03]) (bitwise-arithmetic-shift-right [sig [(sint uint) -> (sint)]] [flags arith-op mifoldable discard cp03 safeongoodargs])
(bitwise-rotate-bit-field [sig [(sint sub-uint sub-uint sub-uint) -> (sint)]] [flags arith-op mifoldable discard]) (bitwise-rotate-bit-field [sig [(sint sub-uint sub-uint sub-uint) -> (sint)]] [flags arith-op mifoldable discard safeongoodargs])
(bitwise-reverse-bit-field [sig [(sint sub-uint sub-uint) -> (sint)]] [flags arith-op mifoldable discard]) (bitwise-reverse-bit-field [sig [(sint sub-uint sub-uint) -> (sint)]] [flags arith-op mifoldable discard safeongoodargs])
) )
(define-symbol-flags* ([libraries (rnrs) (rnrs arithmetic fixnums)] [flags primitive proc]) (define-symbol-flags* ([libraries (rnrs) (rnrs arithmetic fixnums)] [flags primitive proc])
@ -40,18 +40,18 @@
(fixnum-width [sig [() -> (fixnum)]] [flags pure unrestricted true cp02]) (fixnum-width [sig [() -> (fixnum)]] [flags pure unrestricted true cp02])
(least-fixnum [sig [() -> (fixnum)]] [flags pure unrestricted true cp02]) (least-fixnum [sig [() -> (fixnum)]] [flags pure unrestricted true cp02])
(greatest-fixnum [sig [() -> (fixnum)]] [flags pure unrestricted true cp02]) (greatest-fixnum [sig [() -> (fixnum)]] [flags pure unrestricted true cp02])
(fx<? [sig [(fixnum fixnum fixnum ...) -> (boolean)]] [flags pure cp02]) ; restricted to 2+ arguments (fx<? [sig [(fixnum fixnum fixnum ...) -> (boolean)]] [flags pure cp02 safeongoodargs]) ; restricted to 2+ arguments
(fx<=? [sig [(fixnum fixnum fixnum ...) -> (boolean)]] [flags pure cp02]) ; restricted to 2+ arguments (fx<=? [sig [(fixnum fixnum fixnum ...) -> (boolean)]] [flags pure cp02 safeongoodargs]) ; restricted to 2+ arguments
(fx=? [sig [(fixnum fixnum fixnum ...) -> (boolean)]] [flags pure cp02]) ; restricted to 2+ arguments (fx=? [sig [(fixnum fixnum fixnum ...) -> (boolean)]] [flags pure cp02 safeongoodargs]) ; restricted to 2+ arguments
(fx>? [sig [(fixnum fixnum fixnum ...) -> (boolean)]] [flags pure cp02]) ; restricted to 2+ arguments (fx>? [sig [(fixnum fixnum fixnum ...) -> (boolean)]] [flags pure cp02 safeongoodargs]) ; restricted to 2+ arguments
(fx>=? [sig [(fixnum fixnum fixnum ...) -> (boolean)]] [flags pure cp02]) ; restricted to 2+ arguments (fx>=? [sig [(fixnum fixnum fixnum ...) -> (boolean)]] [flags pure cp02 safeongoodargs]) ; restricted to 2+ arguments
(fxzero? [sig [(fixnum) -> (boolean)]] [flags pure cp02]) (fxzero? [sig [(fixnum) -> (boolean)]] [flags pure cp02 safeongoodargs])
(fxnegative? [sig [(fixnum) -> (boolean)]] [flags pure cp02]) (fxnegative? [sig [(fixnum) -> (boolean)]] [flags pure cp02 safeongoodargs])
(fxpositive? [sig [(fixnum) -> (boolean)]] [flags pure cp02]) (fxpositive? [sig [(fixnum) -> (boolean)]] [flags pure cp02 safeongoodargs])
(fxeven? [sig [(fixnum) -> (boolean)]] [flags pure cp02]) (fxeven? [sig [(fixnum) -> (boolean)]] [flags pure cp02 safeongoodargs])
(fxodd? [sig [(fixnum) -> (boolean)]] [flags pure cp02]) (fxodd? [sig [(fixnum) -> (boolean)]] [flags pure cp02 safeongoodargs])
(fxmax [sig [(fixnum fixnum ...) -> (fixnum)]] [flags arith-op cp02]) (fxmax [sig [(fixnum fixnum ...) -> (fixnum)]] [flags arith-op cp02 safeongoodargs])
(fxmin [sig [(fixnum fixnum ...) -> (fixnum)]] [flags arith-op cp02]) (fxmin [sig [(fixnum fixnum ...) -> (fixnum)]] [flags arith-op cp02 safeongoodargs])
((r6rs: fx*) [sig [(fixnum fixnum) -> (fixnum)]] [flags arith-op partial-folder]) ; restricted to 2 arguments ((r6rs: fx*) [sig [(fixnum fixnum) -> (fixnum)]] [flags arith-op partial-folder]) ; restricted to 2 arguments
((r6rs: fx+) [sig [(fixnum fixnum) -> (fixnum)]] [flags arith-op partial-folder]) ; restricted to 2 arguments ((r6rs: fx+) [sig [(fixnum fixnum) -> (fixnum)]] [flags arith-op partial-folder]) ; restricted to 2 arguments
((r6rs: fx-) [sig [(fixnum) (fixnum fixnum) -> (fixnum)]] [flags arith-op partial-folder]) ; restricted to 1 or 2 arguments ((r6rs: fx-) [sig [(fixnum) (fixnum fixnum) -> (fixnum)]] [flags arith-op partial-folder]) ; restricted to 1 or 2 arguments
@ -61,17 +61,17 @@
(fxdiv0-and-mod0 [sig [(fixnum fixnum) -> (fixnum fixnum)]] [flags discard]) (fxdiv0-and-mod0 [sig [(fixnum fixnum) -> (fixnum fixnum)]] [flags discard])
(fxdiv0 [sig [(fixnum fixnum) -> (fixnum)]] [flags arith-op cp02]) (fxdiv0 [sig [(fixnum fixnum) -> (fixnum)]] [flags arith-op cp02])
(fxmod0 [sig [(fixnum fixnum) -> (fixnum)]] [flags arith-op cp02]) (fxmod0 [sig [(fixnum fixnum) -> (fixnum)]] [flags arith-op cp02])
(fx+/carry [sig [(fixnum fixnum fixnum) -> (fixnum fixnum)]] [flags cp02]) (fx+/carry [sig [(fixnum fixnum fixnum) -> (fixnum fixnum)]] [flags cp02 safeongoodargs])
(fx-/carry [sig [(fixnum fixnum fixnum) -> (fixnum fixnum)]] [flags cp02]) (fx-/carry [sig [(fixnum fixnum fixnum) -> (fixnum fixnum)]] [flags cp02 safeongoodargs])
(fx*/carry [sig [(fixnum fixnum fixnum) -> (fixnum fixnum)]] [flags cp02]) (fx*/carry [sig [(fixnum fixnum fixnum) -> (fixnum fixnum)]] [flags cp02 safeongoodargs])
(fxnot [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02]) (fxnot [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02 safeongoodargs])
(fxand [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder]) (fxand [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder safeongoodargs])
(fxior [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder]) (fxior [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder safeongoodargs])
(fxxor [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder]) (fxxor [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder safeongoodargs])
(fxif [sig [(fixnum fixnum fixnum) -> (fixnum)]] [flags arith-op cp02]) (fxif [sig [(fixnum fixnum fixnum) -> (fixnum)]] [flags arith-op cp02 safeongoodargs])
(fxbit-count [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02]) (fxbit-count [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02 safeongoodargs])
(fxlength [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02]) (fxlength [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02 safeongoodargs])
(fxfirst-bit-set [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02]) (fxfirst-bit-set [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02 safeongoodargs])
(fxbit-set? [sig [(fixnum sub-ufixnum) -> (boolean)]] [flags pure cp02]) (fxbit-set? [sig [(fixnum sub-ufixnum) -> (boolean)]] [flags pure cp02])
(fxcopy-bit [sig [(fixnum sub-ufixnum bit) -> (fixnum)]] [flags arith-op cp02]) (fxcopy-bit [sig [(fixnum sub-ufixnum bit) -> (fixnum)]] [flags arith-op cp02])
(fxbit-field [sig [(fixnum sub-ufixnum sub-ufixnum) -> (fixnum)]] [flags arith-op cp02 cp03]) (fxbit-field [sig [(fixnum sub-ufixnum sub-ufixnum) -> (fixnum)]] [flags arith-op cp02 cp03])
@ -90,28 +90,28 @@
(define-symbol-flags* ([libraries (rnrs) (rnrs arithmetic flonums)] [flags primitive proc]) (define-symbol-flags* ([libraries (rnrs) (rnrs arithmetic flonums)] [flags primitive proc])
(flonum? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) (flonum? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
(real->flonum [sig [(real) -> (flonum)]] [flags arith-op mifoldable discard]) (real->flonum [sig [(real) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
(fl=? [sig [(flonum flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard]) ; restricted to 2+ arguments (fl=? [sig [(flonum flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; restricted to 2+ arguments
(fl<? [sig [(flonum flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard]) ; restricted to 2+ arguments (fl<? [sig [(flonum flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; restricted to 2+ arguments
(fl<=? [sig [(flonum flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard]) ; restricted to 2+ arguments (fl<=? [sig [(flonum flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; restricted to 2+ arguments
(fl>? [sig [(flonum flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard]) ; restricted to 2+ arguments (fl>? [sig [(flonum flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; restricted to 2+ arguments
(fl>=? [sig [(flonum flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard]) ; restricted to 2+ arguments (fl>=? [sig [(flonum flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; restricted to 2+ arguments
(flinteger? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard]) (flinteger? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
(flzero? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard]) (flzero? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
(flpositive? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard]) (flpositive? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
(flnegative? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard]) (flnegative? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
(flodd? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard]) (flodd? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard])
(fleven? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard]) (fleven? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard])
(flfinite? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard]) (flfinite? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
(flinfinite? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard]) (flinfinite? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
(flnan? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard]) (flnan? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
(flmax [sig [(flonum flonum ...) -> (flonum)]] [flags arith-op mifoldable discard]) (flmax [sig [(flonum flonum ...) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
(flmin [sig [(flonum flonum ...) -> (flonum)]] [flags arith-op mifoldable discard]) (flmin [sig [(flonum flonum ...) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
(fl* [sig [(flonum ...) -> (flonum)]] [flags arith-op partial-folder]) (fl* [sig [(flonum ...) -> (flonum)]] [flags arith-op partial-folder safeongoodargs])
(fl+ [sig [(flonum ...) -> (flonum)]] [flags arith-op partial-folder]) (fl+ [sig [(flonum ...) -> (flonum)]] [flags arith-op partial-folder safeongoodargs])
(fl- [sig [(flonum flonum ...) -> (flonum)]] [flags arith-op partial-folder]) (fl- [sig [(flonum flonum ...) -> (flonum)]] [flags arith-op partial-folder safeongoodargs])
(fl/ [sig [(flonum flonum ...) -> (flonum)]] [flags arith-op partial-folder]) (fl/ [sig [(flonum flonum ...) -> (flonum)]] [flags arith-op partial-folder safeongoodargs])
(flabs [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard]) (flabs [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
(fldiv-and-mod [sig [(flonum flonum) -> (flonum flonum)]] [flags discard]) (fldiv-and-mod [sig [(flonum flonum) -> (flonum flonum)]] [flags discard])
(fldiv [sig [(flonum flonum) -> (flonum)]] [flags arith-op mifoldable discard]) (fldiv [sig [(flonum flonum) -> (flonum)]] [flags arith-op mifoldable discard])
(flmod [sig [(flonum flonum) -> (flonum)]] [flags arith-op mifoldable discard]) (flmod [sig [(flonum flonum) -> (flonum)]] [flags arith-op mifoldable discard])
@ -120,25 +120,25 @@
(flmod0 [sig [(flonum flonum) -> (flonum)]] [flags arith-op mifoldable discard]) (flmod0 [sig [(flonum flonum) -> (flonum)]] [flags arith-op mifoldable discard])
(flnumerator [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard]) (flnumerator [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard])
(fldenominator [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard]) (fldenominator [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard])
(flfloor [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard]) (flfloor [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
(flceiling [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard]) (flceiling [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
(fltruncate [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard]) (fltruncate [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
(flround [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard]) (flround [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
(flexp [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard]) (flexp [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
(fllog [sig [(flonum) (flonum flonum) -> (flonum)]] [flags arith-op mifoldable discard]) (fllog [sig [(flonum) (flonum flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
(flsin [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard]) (flsin [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
(flcos [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard]) (flcos [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
(fltan [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard]) (fltan [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
(flasin [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard]) (flasin [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
(flacos [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard]) (flacos [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
(flatan [sig [(flonum) (flonum flonum) -> (flonum)]] [flags arith-op mifoldable discard]) (flatan [sig [(flonum) (flonum flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
(flsqrt [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard]) (flsqrt [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
(flexpt [sig [(flonum flonum) -> (flonum)]] [flags arith-op mifoldable discard]) (flexpt [sig [(flonum flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
(make-no-infinities-violation [sig [() -> (ptr)]] [flags pure unrestricted alloc]) (make-no-infinities-violation [sig [() -> (ptr)]] [flags pure unrestricted alloc])
(no-infinities-violation? [sig [(ptr) -> (ptr)]] [flags pure unrestricted mifoldable discard]) (no-infinities-violation? [sig [(ptr) -> (ptr)]] [flags pure unrestricted mifoldable discard])
(make-no-nans-violation [sig [() -> (ptr)]] [flags pure unrestricted alloc]) (make-no-nans-violation [sig [() -> (ptr)]] [flags pure unrestricted alloc])
(no-nans-violation? [sig [(ptr) -> (ptr)]] [flags pure unrestricted mifoldable discard]) (no-nans-violation? [sig [(ptr) -> (ptr)]] [flags pure unrestricted mifoldable discard])
(fixnum->flonum [sig [(fixnum) -> (flonum)]] [flags arith-op cp02]) (fixnum->flonum [sig [(fixnum) -> (flonum)]] [flags arith-op cp02 safeongoodargs])
) )
(define-symbol-flags* ([libraries (rnrs) (rnrs base) (rnrs exceptions)] [flags keyword]) (define-symbol-flags* ([libraries (rnrs) (rnrs base) (rnrs exceptions)] [flags keyword])
@ -192,30 +192,30 @@
(real-valued? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) (real-valued? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
(rational-valued? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) (rational-valued? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
(integer-valued? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) (integer-valued? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
(exact? [sig [(number) -> (boolean)]] [flags pure mifoldable discard ieee r5rs]) (exact? [sig [(number) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs])
(inexact? [sig [(number) -> (boolean)]] [flags pure mifoldable discard ieee r5rs]) (inexact? [sig [(number) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs])
(inexact [sig [(number) -> (inexact-number)]] [flags arith-op mifoldable discard]) (inexact [sig [(number) -> (inexact-number)]] [flags arith-op mifoldable discard safeongoodargs])
(exact [sig [(number) -> (exact-number)]] [flags arith-op mifoldable discard]) (exact [sig [(number) -> (exact-number)]] [flags arith-op mifoldable discard safeongoodargs])
((r6rs: <) [sig [(real real real ...) -> (boolean)]] [flags pure mifoldable discard ieee r5rs]) ; restricted to 2+ arguments ((r6rs: <) [sig [(real real real ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs]) ; restricted to 2+ arguments
((r6rs: <=) [sig [(real real real ...) -> (boolean)]] [flags pure mifoldable discard ieee r5rs]) ; restricted to 2+ arguments ((r6rs: <=) [sig [(real real real ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs]) ; restricted to 2+ arguments
((r6rs: =) [sig [(number number number ...) -> (boolean)]] [flags pure mifoldable discard ieee r5rs]) ; restricted to 2+ arguments ((r6rs: =) [sig [(number number number ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs]) ; restricted to 2+ arguments
((r6rs: >) [sig [(real real real ...) -> (boolean)]] [flags pure mifoldable discard ieee r5rs]) ; restricted to 2+ arguments ((r6rs: >) [sig [(real real real ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs]) ; restricted to 2+ arguments
((r6rs: >=) [sig [(real real real ...) -> (boolean)]] [flags pure mifoldable discard ieee r5rs]) ; restricted to 2+ arguments ((r6rs: >=) [sig [(real real real ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs]) ; restricted to 2+ arguments
(zero? [sig [(number) -> (boolean)]] [flags pure mifoldable discard ieee r5rs]) (zero? [sig [(number) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs])
(positive? [sig [(real) -> (boolean)]] [flags pure mifoldable discard ieee r5rs]) (positive? [sig [(real) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs])
(negative? [sig [(real) -> (boolean)]] [flags pure mifoldable discard ieee r5rs]) (negative? [sig [(real) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs])
(odd? [sig [(integer) -> (boolean)]] [flags pure mifoldable discard ieee r5rs]) (odd? [sig [(integer) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs])
(even? [sig [(integer) -> (boolean)]] [flags pure mifoldable discard ieee r5rs]) (even? [sig [(integer) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs])
(finite? [sig [(real) -> (boolean)]] [flags pure mifoldable discard]) (finite? [sig [(real) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
(infinite? [sig [(real) -> (boolean)]] [flags pure mifoldable discard]) (infinite? [sig [(real) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
(nan? [sig [(real) -> (boolean)]] [flags pure mifoldable discard]) (nan? [sig [(real) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
(max [sig [(real real ...) -> (real)]] [flags arith-op mifoldable discard ieee r5rs]) (max [sig [(real real ...) -> (real)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs])
(min [sig [(real real ...) -> (real)]] [flags arith-op mifoldable discard ieee r5rs]) (min [sig [(real real ...) -> (real)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs])
(+ [sig [(number ...) -> (number)]] [flags arith-op partial-folder ieee r5rs]) (+ [sig [(number ...) -> (number)]] [flags arith-op partial-folder safeongoodargs ieee r5rs])
(* [sig [(number ...) -> (number)]] [flags arith-op partial-folder ieee r5rs]) (* [sig [(number ...) -> (number)]] [flags arith-op partial-folder safeongoodargs ieee r5rs])
(- [sig [(number number ...) -> (number)]] [flags arith-op partial-folder ieee r5rs]) (- [sig [(number number ...) -> (number)]] [flags arith-op partial-folder safeongoodargs ieee r5rs])
(/ [sig [(number number ...) -> (number)]] [flags arith-op partial-folder ieee r5rs]) (/ [sig [(number number ...) -> (number)]] [flags arith-op partial-folder ieee r5rs])
(abs [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs]) (abs [sig [(number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs])
(div-and-mod [sig [(number number) -> (number number)]] [flags discard]) (div-and-mod [sig [(number number) -> (number number)]] [flags discard])
(div [sig [(number number) -> (number)]] [flags arith-op mifoldable discard]) (div [sig [(number number) -> (number)]] [flags arith-op mifoldable discard])
(mod [sig [(number number) -> (number)]] [flags arith-op mifoldable discard]) (mod [sig [(number number) -> (number)]] [flags arith-op mifoldable discard])
@ -226,11 +226,11 @@
(lcm [sig [(number ...) -> (number)]] [flags arith-op mifoldable discard ieee r5rs]) (lcm [sig [(number ...) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
(numerator [sig [(rational) -> (integer)]] [flags arith-op mifoldable discard ieee r5rs]) (numerator [sig [(rational) -> (integer)]] [flags arith-op mifoldable discard ieee r5rs])
(denominator [sig [(rational) -> (integer)]] [flags arith-op mifoldable discard ieee r5rs]) (denominator [sig [(rational) -> (integer)]] [flags arith-op mifoldable discard ieee r5rs])
(floor [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs]) (floor [sig [(number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs])
(ceiling [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs]) (ceiling [sig [(number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs])
(truncate [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs]) (truncate [sig [(number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs])
(round [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs]) (round [sig [(number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs])
(rationalize [sig [(number number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs]) (rationalize [sig [(number number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs])
(exp [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs]) (exp [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
(log [sig [(number) (number number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs]) (log [sig [(number) (number number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
(sin [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs]) (sin [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
@ -242,22 +242,22 @@
(sqrt [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs]) (sqrt [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
(exact-integer-sqrt [sig [(integer) -> (integer integer)]] [flags discard discard]) ; could be mifoldable if multiple values were handled (exact-integer-sqrt [sig [(integer) -> (integer integer)]] [flags discard discard]) ; could be mifoldable if multiple values were handled
(expt [sig [(number number) -> (number)]] [flags pure discard true cp02 ieee r5rs]) ; can take too long to fold (expt [sig [(number number) -> (number)]] [flags pure discard true cp02 ieee r5rs]) ; can take too long to fold
(make-rectangular [sig [(number number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs]) (make-rectangular [sig [(number number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs])
(make-polar [sig [(number number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs]) (make-polar [sig [(number number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs])
(real-part [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs]) (real-part [sig [(number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs])
(imag-part [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs]) (imag-part [sig [(number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs])
(magnitude [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs]) (magnitude [sig [(number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs])
(angle [sig [(number) -> (real)]] [flags arith-op mifoldable discard ieee r5rs]) (angle [sig [(number) -> (real)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs])
((r6rs: number->string) [sig [(number) (number sub-ufixnum) (number sub-ufixnum sub-ufixnum) -> (string)]] [flags alloc ieee r5rs]) ; radix restricted to 2, 4, 8, 16 ((r6rs: number->string) [sig [(number) (number sub-ufixnum) (number sub-ufixnum sub-ufixnum) -> (string)]] [flags alloc ieee r5rs]) ; radix restricted to 2, 4, 8, 16
((r6rs: string->number) [sig [(string) (string sub-ufixnum) -> (maybe-number)]] [flags discard ieee r5rs]) ; radix restricted to 2, 4, 8, 16 ((r6rs: string->number) [sig [(string) (string sub-ufixnum) -> (maybe-number)]] [flags discard ieee r5rs]) ; radix restricted to 2, 4, 8, 16
(not [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard ieee r5rs cp02]) (not [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard ieee r5rs cp02])
(boolean? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard ieee r5rs]) (boolean? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard ieee r5rs])
(boolean=? [sig [(boolean boolean boolean ...) -> (boolean)]] [flags pure mifoldable discard cp03]) (boolean=? [sig [(boolean boolean boolean ...) -> (boolean)]] [flags pure mifoldable discard cp03 safeongoodargs])
(pair? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard ieee r5rs]) (pair? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard ieee r5rs])
(cons [sig [(ptr ptr) -> (#1=(ptr . ptr))]] [flags unrestricted alloc ieee r5rs]) (cons [sig [(ptr ptr) -> (#1=(ptr . ptr))]] [flags unrestricted alloc ieee r5rs])
; c..r non-alphabetic so marks come before references ; c..r non-alphabetic so marks come before references
(car [sig [(#1#) -> (ptr)]] [flags mifoldable discard cp02 ieee r5rs]) (car [sig [(#1#) -> (ptr)]] [flags mifoldable discard cp02 safeongoodargs ieee r5rs])
(cdr [sig [(#1#) -> (ptr)]] [flags mifoldable discard cp02 ieee r5rs]) (cdr [sig [(#1#) -> (ptr)]] [flags mifoldable discard cp02 safeongoodargs ieee r5rs])
(caar [sig [(#2=(#1# . ptr)) -> (ptr)]] [flags mifoldable discard ieee r5rs]) (caar [sig [(#2=(#1# . ptr)) -> (ptr)]] [flags mifoldable discard ieee r5rs])
(cdar [sig [(#2#) -> (ptr)]] [flags mifoldable discard ieee r5rs]) (cdar [sig [(#2#) -> (ptr)]] [flags mifoldable discard ieee r5rs])
(cadr [sig [(#3=(ptr . #1#)) -> (ptr)]] [flags mifoldable discard ieee r5rs]) (cadr [sig [(#3=(ptr . #1#)) -> (ptr)]] [flags mifoldable discard ieee r5rs])
@ -297,40 +297,40 @@
(map [sig [(procedure list list ...) -> (list)]] [flags cp02 cp03 ieee r5rs true]) (map [sig [(procedure list list ...) -> (list)]] [flags cp02 cp03 ieee r5rs true])
(for-each [sig [(procedure list list ...) -> (ptr ...)]] [flags cp02 cp03 ieee r5rs]) (for-each [sig [(procedure list list ...) -> (ptr ...)]] [flags cp02 cp03 ieee r5rs])
(symbol? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard ieee r5rs]) (symbol? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard ieee r5rs])
(symbol->string [sig [(symbol) -> (string)]] [flags true mifoldable discard ieee r5rs]) (symbol->string [sig [(symbol) -> (string)]] [flags true mifoldable discard safeongoodargs ieee r5rs])
(symbol=? [sig [(symbol symbol symbol ...) -> (boolean)]] [flags pure mifoldable discard cp03]) (symbol=? [sig [(symbol symbol symbol ...) -> (boolean)]] [flags pure mifoldable discard cp03 safeongoodargs])
(string->symbol [sig [(string) -> (symbol)]] [flags true mifoldable discard ieee r5rs]) (string->symbol [sig [(string) -> (symbol)]] [flags true mifoldable discard safeongoodargs ieee r5rs])
(char? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard ieee r5rs]) (char? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard ieee r5rs])
(char->integer [sig [(char) -> (fixnum)]] [flags pure mifoldable discard true ieee r5rs]) (char->integer [sig [(char) -> (fixnum)]] [flags pure mifoldable discard safeongoodargs true ieee r5rs])
(integer->char [sig [(sub-ufixnum) -> (char)]] [flags pure mifoldable discard true ieee r5rs]) (integer->char [sig [(sub-ufixnum) -> (char)]] [flags pure mifoldable discard true ieee r5rs])
((r6rs: char<=?) [sig [(char char char ...) -> (boolean)]] [flags pure mifoldable discard ieee r5rs]) ; restricted to 2+ arguments ((r6rs: char<=?) [sig [(char char char ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs]) ; restricted to 2+ arguments
((r6rs: char<?) [sig [(char char char ...) -> (boolean)]] [flags pure mifoldable discard ieee r5rs]) ; restricted to 2+ arguments ((r6rs: char<?) [sig [(char char char ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs]) ; restricted to 2+ arguments
((r6rs: char=?) [sig [(char char char ...) -> (boolean)]] [flags pure mifoldable discard ieee r5rs cp03]) ; restricted to 2+ arguments ((r6rs: char=?) [sig [(char char char ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs cp03]) ; restricted to 2+ arguments
((r6rs: char>=?) [sig [(char char char ...) -> (boolean)]] [flags pure mifoldable discard ieee r5rs]) ; restricted to 2+ arguments ((r6rs: char>=?) [sig [(char char char ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs]) ; restricted to 2+ arguments
((r6rs: char>?) [sig [(char char char ...) -> (boolean)]] [flags pure mifoldable discard ieee r5rs]) ; restricted to 2+ arguments ((r6rs: char>?) [sig [(char char char ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs]) ; restricted to 2+ arguments
(string? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard ieee r5rs]) (string? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard ieee r5rs])
(make-string [sig [(length) (length char) -> (string)]] [flags alloc ieee r5rs]) (make-string [sig [(length) (length char) -> (string)]] [flags alloc ieee r5rs])
(string [sig [(char ...) -> (string)]] [flags alloc ieee r5rs cp02]) (string [sig [(char ...) -> (string)]] [flags alloc ieee r5rs cp02 safeongoodargs])
(string-length [sig [(string) -> (length)]] [flags pure true ieee r5rs mifoldable discard]) (string-length [sig [(string) -> (length)]] [flags pure true ieee r5rs mifoldable discard safeongoodargs])
(string-ref [sig [(string sub-index) -> (ptr)]] [flags true ieee r5rs mifoldable discard cp02]) (string-ref [sig [(string sub-index) -> (ptr)]] [flags true ieee r5rs mifoldable discard cp02])
((r6rs: string<=?) [sig [(string string string ...) -> (boolean)]] [flags mifoldable discard ieee r5rs]) ; restricted to 2+ arguments ((r6rs: string<=?) [sig [(string string string ...) -> (boolean)]] [flags mifoldable discard safeongoodargs ieee r5rs]) ; restricted to 2+ arguments
((r6rs: string<?) [sig [(string string string ...) -> (boolean)]] [flags mifoldable discard ieee r5rs]) ; restricted to 2+ arguments ((r6rs: string<?) [sig [(string string string ...) -> (boolean)]] [flags mifoldable discard safeongoodargs ieee r5rs]) ; restricted to 2+ arguments
((r6rs: string=?) [sig [(string string string ...) -> (boolean)]] [flags mifoldable discard ieee r5rs cp03]) ; restricted to 2+ arguments ((r6rs: string=?) [sig [(string string string ...) -> (boolean)]] [flags mifoldable discard safeongoodargs ieee r5rs cp03]) ; restricted to 2+ arguments
((r6rs: string>=?) [sig [(string string string ...) -> (boolean)]] [flags mifoldable discard ieee r5rs]) ; restricted to 2+ arguments ((r6rs: string>=?) [sig [(string string string ...) -> (boolean)]] [flags mifoldable discard safeongoodargs ieee r5rs]) ; restricted to 2+ arguments
((r6rs: string>?) [sig [(string string string ...) -> (boolean)]] [flags mifoldable discard ieee r5rs]) ; restricted to 2+ arguments ((r6rs: string>?) [sig [(string string string ...) -> (boolean)]] [flags mifoldable discard safeongoodargs ieee r5rs]) ; restricted to 2+ arguments
(substring [sig [(string sub-length sub-length) -> (string)]] [flags alloc ieee r5rs]) (substring [sig [(string sub-length sub-length) -> (string)]] [flags alloc ieee r5rs])
(string-append [sig [(string ...) -> (string)]] [flags alloc ieee r5rs]) (string-append [sig [(string ...) -> (string)]] [flags alloc safeongoodargs ieee r5rs])
(string->list [sig [(string) -> (list)]] [flags alloc ieee r5rs]) (string->list [sig [(string) -> (list)]] [flags alloc safeongoodargs ieee r5rs])
(list->string [sig [(sub-list) -> (string)]] [flags alloc ieee r5rs]) (list->string [sig [(sub-list) -> (string)]] [flags alloc ieee r5rs])
(string-for-each [sig [(procedure string string ...) -> (void)]] [flags cp03]) (string-for-each [sig [(procedure string string ...) -> (void)]] [flags cp03])
(string-copy [sig [(string) -> (string)]] [flags alloc ieee r5rs]) (string-copy [sig [(string) -> (string)]] [flags alloc safeongoodargs ieee r5rs])
(vector? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard ieee r5rs]) (vector? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard ieee r5rs])
(make-vector [sig [(length) (length ptr) -> (vector)]] [flags alloc ieee r5rs]) (make-vector [sig [(length) (length ptr) -> (vector)]] [flags alloc ieee r5rs])
(vector [sig [(ptr ...) -> (vector)]] [flags unrestricted alloc ieee r5rs cp02]) (vector [sig [(ptr ...) -> (vector)]] [flags unrestricted alloc ieee r5rs cp02])
(vector-length [sig [(vector) -> (length)]] [flags pure true ieee r5rs mifoldable discard]) (vector-length [sig [(vector) -> (length)]] [flags pure true ieee r5rs mifoldable discard safeongoodargs])
(vector-ref [sig [(vector sub-index) -> (ptr)]] [flags ieee r5rs mifoldable discard cp02]) (vector-ref [sig [(vector sub-index) -> (ptr)]] [flags ieee r5rs mifoldable discard cp02])
(vector-set! [sig [(vector sub-index ptr) -> (void)]] [flags true ieee r5rs]) (vector-set! [sig [(vector sub-index ptr) -> (void)]] [flags true ieee r5rs])
(vector->list [sig [(vector) -> (list)]] [flags alloc ieee r5rs]) (vector->list [sig [(vector) -> (list)]] [flags alloc safeongoodargs ieee r5rs])
(list->vector [sig [(list) -> (vector)]] [flags alloc ieee r5rs]) (list->vector [sig [(list) -> (vector)]] [flags alloc ieee r5rs])
(vector-fill! [sig [(vector ptr) -> (void)]] [flags true ieee r5rs]) (vector-fill! [sig [(vector ptr) -> (void)]] [flags true ieee r5rs])
(vector-map [sig [(procedure vector vector ...) -> (vector)]] [flags cp03]) (vector-map [sig [(procedure vector vector ...) -> (vector)]] [flags cp03])
@ -353,16 +353,16 @@
(native-endianness [sig [() -> (symbol)]] [flags pure unrestricted alloc cp02]) (native-endianness [sig [() -> (symbol)]] [flags pure unrestricted alloc cp02])
(bytevector? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) (bytevector? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
(make-bytevector [sig [(length) (length u8/s8) -> (bytevector)]] [flags alloc]) (make-bytevector [sig [(length) (length u8/s8) -> (bytevector)]] [flags alloc])
(bytevector-length [sig [(bytevector) -> (length)]] [flags true mifoldable discard]) (bytevector-length [sig [(bytevector) -> (length)]] [flags true mifoldable discard safeongoodargs])
(bytevector=? [sig [(bytevector bytevector) -> (boolean)]] [flags mifoldable discard cp03]) (bytevector=? [sig [(bytevector bytevector) -> (boolean)]] [flags mifoldable discard cp03 safeongoodargs])
(bytevector-fill! [sig [(bytevector u8/s8) -> (void)]] [flags true]) (bytevector-fill! [sig [(bytevector u8/s8) -> (void)]] [flags true])
(bytevector-copy! [sig [(bytevector sub-length bytevector sub-length sub-length) -> (void)]] [flags true]) (bytevector-copy! [sig [(bytevector sub-length bytevector sub-length sub-length) -> (void)]] [flags true])
(bytevector-copy [sig [(bytevector) -> (bytevector)]] [flags alloc]) (bytevector-copy [sig [(bytevector) -> (bytevector)]] [flags alloc safeongoodargs])
(bytevector-u8-ref [sig [(bytevector sub-index) -> (u8)]] [flags true mifoldable discard]) (bytevector-u8-ref [sig [(bytevector sub-index) -> (u8)]] [flags true mifoldable discard])
(bytevector-s8-ref [sig [(bytevector sub-index) -> (s8)]] [flags true mifoldable discard]) (bytevector-s8-ref [sig [(bytevector sub-index) -> (s8)]] [flags true mifoldable discard])
(bytevector-u8-set! [sig [(bytevector sub-index u8) -> (void)]] [flags true]) (bytevector-u8-set! [sig [(bytevector sub-index u8) -> (void)]] [flags true])
(bytevector-s8-set! [sig [(bytevector sub-index s8) -> (void)]] [flags true]) (bytevector-s8-set! [sig [(bytevector sub-index s8) -> (void)]] [flags true])
(bytevector->u8-list [sig [(bytevector) -> (list)]] [flags alloc]) (bytevector->u8-list [sig [(bytevector) -> (list)]] [flags alloc safeongoodargs])
(u8-list->bytevector [sig [(sub-list) -> (bytevector)]] [flags alloc]) (u8-list->bytevector [sig [(sub-list) -> (bytevector)]] [flags alloc])
(bytevector-uint-ref [sig [(bytevector sub-index symbol sub-length) -> (uint)]] [flags true mifoldable discard]) (bytevector-uint-ref [sig [(bytevector sub-index symbol sub-length) -> (uint)]] [flags true mifoldable discard])
(bytevector-sint-ref [sig [(bytevector sub-index symbol sub-length) -> (sint)]] [flags true mifoldable discard]) (bytevector-sint-ref [sig [(bytevector sub-index symbol sub-length) -> (sint)]] [flags true mifoldable discard])
@ -535,9 +535,9 @@
(hashtable-hash-function [sig [(hashtable) -> (ptr)]] [flags]) (hashtable-hash-function [sig [(hashtable) -> (ptr)]] [flags])
(hashtable-mutable? [sig [(hashtable) -> (boolean)]] [flags mifoldable discard]) (hashtable-mutable? [sig [(hashtable) -> (boolean)]] [flags mifoldable discard])
(equal-hash [sig [(ptr) -> (length)]] [flags unrestricted true]) (equal-hash [sig [(ptr) -> (length)]] [flags unrestricted true])
(string-hash [sig [(string) -> (length)]] [flags true]) (string-hash [sig [(string) -> (length)]] [flags true safeongoodargs])
(string-ci-hash [sig [(string) -> (length)]] [flags true]) (string-ci-hash [sig [(string) -> (length)]] [flags true safeongoodargs])
(symbol-hash [sig [(symbol) -> (length)]] [flags true]) (symbol-hash [sig [(symbol) -> (length)]] [flags true safeongoodargs])
) )
(define-symbol-flags* ([libraries (rnrs) (rnrs io ports)] [flags keyword]) (define-symbol-flags* ([libraries (rnrs) (rnrs io ports)] [flags keyword])
@ -729,8 +729,8 @@
) )
(define-symbol-flags* ([libraries (rnrs r5rs)] [flags primitive proc]) (define-symbol-flags* ([libraries (rnrs r5rs)] [flags primitive proc])
(exact->inexact [sig [(number) -> (inexact-number)]] [flags arith-op mifoldable discard ieee r5rs]) (exact->inexact [sig [(number) -> (inexact-number)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs])
(inexact->exact [sig [(number) -> (exact-number)]] [flags arith-op mifoldable discard ieee r5rs]) (inexact->exact [sig [(number) -> (exact-number)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs])
(quotient [sig [(number number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs]) (quotient [sig [(number number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
(remainder [sig [(number number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs]) (remainder [sig [(number number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
(modulo [sig [(number number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs]) (modulo [sig [(number number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
@ -871,9 +871,9 @@
(make-date [sig [(sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-fixnum) -> (date)] (make-date [sig [(sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-fixnum) -> (date)]
[(sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum) -> (date)]] [(sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum) -> (date)]]
[flags alloc]) [flags alloc])
(make-time [sig [(sub-symbol sub-ufixnum sub-fixnum) -> (time)]] [flags alloc]) (make-time [sig [(sub-symbol sub-ufixnum exact-integer) -> (time)]] [flags alloc])
(set-time-nanosecond! [sig [(time sub-uint) -> (void)]] [flags true]) (set-time-nanosecond! [sig [(time sub-uint) -> (void)]] [flags true])
(set-time-second! [sig [(time sub-fixnum) -> (void)]] [flags true]) (set-time-second! [sig [(time exact-integer) -> (void)]] [flags true])
(set-time-type! [sig [(time sub-symbol) -> (void)]] [flags true]) (set-time-type! [sig [(time sub-symbol) -> (void)]] [flags true])
(subtract-duration (sig [(time time) -> (time)]) [flags alloc]) (subtract-duration (sig [(time time) -> (time)]) [flags alloc])
(subtract-duration! (sig [(time time) -> (time)]) [flags alloc]) (subtract-duration! (sig [(time time) -> (time)]) [flags alloc])
@ -886,7 +886,7 @@
(time-difference (sig [(time time) -> (time)]) [flags alloc]) (time-difference (sig [(time time) -> (time)]) [flags alloc])
(time-difference! (sig [(time time) -> (time)]) [flags alloc]) (time-difference! (sig [(time time) -> (time)]) [flags alloc])
(time-nanosecond [sig [(time) -> (uint)]] [flags mifoldable discard true]) (time-nanosecond [sig [(time) -> (uint)]] [flags mifoldable discard true])
(time-second [sig [(time) -> (fixnum)]] [flags mifoldable discard true]) (time-second [sig [(time) -> (exact-integer)]] [flags mifoldable discard true])
(time-type [sig [(time) -> (symbol)]] [flags mifoldable discard true]) (time-type [sig [(time) -> (symbol)]] [flags mifoldable discard true])
(time-utc->date [sig [(time) (time sub-fixnum) -> (date)]] [flags alloc]) (time-utc->date [sig [(time) (time sub-fixnum) -> (date)]] [flags alloc])
) )
@ -951,6 +951,7 @@
(enable-cross-library-optimization [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted]) (enable-cross-library-optimization [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted])
(enable-object-backreferences [sig [() -> (boolean)] [(ptr) -> (void)]] [flags]) (enable-object-backreferences [sig [() -> (boolean)] [(ptr) -> (void)]] [flags])
(enable-object-counts [sig [() -> (boolean)] [(ptr) -> (void)]] [flags]) (enable-object-counts [sig [() -> (boolean)] [(ptr) -> (void)]] [flags])
(enable-type-recovery [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted])
(eval-syntax-expanders-when [sig [() -> (list)] [(sub-list) -> (void)]] [flags]) (eval-syntax-expanders-when [sig [() -> (list)] [(sub-list) -> (void)]] [flags])
(expand-omit-library-invocations [sig [() -> (boolean)] [(ptr) -> (void)]] [flags]) (expand-omit-library-invocations [sig [() -> (boolean)] [(ptr) -> (void)]] [flags])
(expand-output [sig [() -> (maybe-textual-output-port)] [(maybe-textual-output-port) -> (void)]] [flags]) (expand-output [sig [() -> (maybe-textual-output-port)] [(maybe-textual-output-port) -> (void)]] [flags])
@ -1108,17 +1109,17 @@
) )
(define-symbol-flags* ([libraries] [flags primitive proc]) (define-symbol-flags* ([libraries] [flags primitive proc])
(< [sig [(real real ...) -> (boolean)]] [flags pure mifoldable discard]) ; not restricted to 2+ arguments (< [sig [(real real ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; not restricted to 2+ arguments
(<= [sig [(real real ...) -> (boolean)]] [flags pure mifoldable discard]) ; not restricted to 2+ arguments (<= [sig [(real real ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; not restricted to 2+ arguments
(= [sig [(number number ...) -> (boolean)]] [flags pure mifoldable discard]) ; not restricted to 2+ arguments (= [sig [(number number ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; not restricted to 2+ arguments
(> [sig [(real real ...) -> (boolean)]] [flags pure mifoldable discard]) ; not restricted to 2+ arguments (> [sig [(real real ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; not restricted to 2+ arguments
(>= [sig [(real real ...) -> (boolean)]] [flags pure mifoldable discard]) ; not restricted to 2+ arguments (>= [sig [(real real ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; not restricted to 2+ arguments
(-1+ [sig [(number) -> (number)]] [flags arith-op mifoldable discard]) (-1+ [sig [(number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs])
(1+ [sig [(number) -> (number)]] [flags arith-op mifoldable discard]) (1+ [sig [(number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs])
(1- [sig [(number) -> (number)]] [flags arith-op mifoldable discard]) (1- [sig [(number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs])
(abort [sig [() (ptr) -> (bottom)]] [flags abort-op]) (abort [sig [() (ptr) -> (bottom)]] [flags abort-op])
(acosh [sig [(number) -> (number)]] [flags arith-op mifoldable discard]) (acosh [sig [(number) -> (number)]] [flags arith-op mifoldable discard])
(add1 [sig [(number) -> (number)]] [flags arith-op mifoldable discard]) (add1 [sig [(number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs])
(andmap [sig [(procedure list list ...) -> (ptr ...)]] [flags cp03]) (andmap [sig [(procedure list list ...) -> (ptr ...)]] [flags cp03])
(annotation? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) (annotation? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
(annotation-expression [sig [(annotation) -> (ptr)]] [flags pure mifoldable discard true]) (annotation-expression [sig [(annotation) -> (ptr)]] [flags pure mifoldable discard true])
@ -1181,27 +1182,27 @@
(call-with-input-file [sig [(pathname procedure) (pathname procedure sub-ptr) -> (ptr ...)]] [flags ieee r5rs]) ; has options argument (call-with-input-file [sig [(pathname procedure) (pathname procedure sub-ptr) -> (ptr ...)]] [flags ieee r5rs]) ; has options argument
(call-with-output-file [sig [(pathname procedure) (pathname procedure sub-ptr) -> (ptr ...)]] [flags ieee r5rs]) ; has options argument (call-with-output-file [sig [(pathname procedure) (pathname procedure sub-ptr) -> (ptr ...)]] [flags ieee r5rs]) ; has options argument
(call-setting-continuation-attachment [sig [(ptr procedure) -> (ptr ...)]] [flags]) (call-setting-continuation-attachment [sig [(ptr procedure) -> (ptr ...)]] [flags])
(cfl* [sig [(cflonum ...) -> (cflonum)]] [flags arith-op partial-folder]) (cfl* [sig [(cflonum ...) -> (cflonum)]] [flags arith-op partial-folder safeongoodargs])
(cfl+ [sig [(cflonum ...) -> (cflonum)]] [flags arith-op partial-folder]) (cfl+ [sig [(cflonum ...) -> (cflonum)]] [flags arith-op partial-folder safeongoodargs])
(cfl- [sig [(cflonum cflonum ...) -> (cflonum)]] [flags arith-op partial-folder]) (cfl- [sig [(cflonum cflonum ...) -> (cflonum)]] [flags arith-op partial-folder safeongoodargs])
(cfl/ [sig [(cflonum cflonum ...) -> (cflonum)]] [flags arith-op partial-folder]) (cfl/ [sig [(cflonum cflonum ...) -> (cflonum)]] [flags arith-op partial-folder])
(cfl= [sig [(cflonum cflonum ...) -> (boolean)]] [flags pure mifoldable discard]) (cfl= [sig [(cflonum cflonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
(cfl-conjugate [sig [(cflonum) -> (cflonum)]] [flags arith-op mifoldable discard]) (cfl-conjugate [sig [(cflonum) -> (cflonum)]] [flags arith-op mifoldable discard safeongoodargs])
(cfl-imag-part [sig [(cflonum) -> (flonum)]] [flags arith-op mifoldable discard]) (cfl-imag-part [sig [(cflonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
(cfl-magnitude-squared [sig [(cflonum) -> (flonum)]] [flags arith-op mifoldable discard]) (cfl-magnitude-squared [sig [(cflonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
(cfl-real-part [sig [(cflonum) -> (flonum)]] [flags arith-op mifoldable discard]) (cfl-real-part [sig [(cflonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
(cflonum? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) (cflonum? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
(char<=? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard]) ; not restricted to 2+ arguments (char<=? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; not restricted to 2+ arguments
(char<? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard]) ; not restricted to 2+ arguments (char<? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; not restricted to 2+ arguments
(char=? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard cp03]) ; not restricted to 2+ arguments (char=? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard cp03 safeongoodargs]) ; not restricted to 2+ arguments
(char>=? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard]) ; not restricted to 2+ arguments (char>=? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; not restricted to 2+ arguments
(char>? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard]) ; not restricted to 2+ arguments (char>? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; not restricted to 2+ arguments
(char- [sig [(char char) -> (fixnum)]] [flags pure mifoldable discard true]) (char- [sig [(char char) -> (fixnum)]] [flags pure mifoldable discard true safeongoodargs])
(char-ci<=? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard]) ; not restricted to 2+ arguments (char-ci<=? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; not restricted to 2+ arguments
(char-ci<? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard]) ; not restricted to 2+ arguments (char-ci<? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; not restricted to 2+ arguments
(char-ci=? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard cp03]) ; not restricted to 2+ arguments (char-ci=? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard cp03 safeongoodargs]) ; not restricted to 2+ arguments
(char-ci>=? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard]) ; not restricted to 2+ arguments (char-ci>=? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; not restricted to 2+ arguments
(char-ci>? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard]) ; not restricted to 2+ arguments (char-ci>? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; not restricted to 2+ arguments
(char-name [sig [(sub-ptr) (sub-symbol maybe-char) -> (ptr)]] [flags]) (char-name [sig [(sub-ptr) (sub-symbol maybe-char) -> (ptr)]] [flags])
(char-ready? [sig [() (textual-input-port) -> (boolean)]] [flags ieee r5rs]) (char-ready? [sig [() (textual-input-port) -> (boolean)]] [flags ieee r5rs])
(chmod [sig [(pathname sub-ufixnum) -> (void)]] [flags]) (chmod [sig [(pathname sub-ufixnum) -> (void)]] [flags])
@ -1299,16 +1300,16 @@
(port-file-compressed! [sig [(port) -> (void)]] [flags]) (port-file-compressed! [sig [(port) -> (void)]] [flags])
(file-regular? [sig [(pathname) (pathname ptr) -> (boolean)]] [flags discard]) (file-regular? [sig [(pathname) (pathname ptr) -> (boolean)]] [flags discard])
(file-symbolic-link? [sig [(pathname) -> (boolean)]] [flags discard]) (file-symbolic-link? [sig [(pathname) -> (boolean)]] [flags discard])
(fllp [sig [(flonum) -> (ufixnum)]] [flags arith-op mifoldable discard]) (fllp [sig [(flonum) -> (ufixnum)]] [flags arith-op mifoldable discard safeongoodargs])
(fl-make-rectangular [sig [(flonum flonum) -> (inexactnum)]] [flags arith-op mifoldable discard]) (fl-make-rectangular [sig [(flonum flonum) -> (inexactnum)]] [flags arith-op mifoldable discard safeongoodargs])
(flonum->fixnum [sig [(flonum) -> (fixnum)]] [flags arith-op cp02]) (flonum->fixnum [sig [(flonum) -> (fixnum)]] [flags arith-op cp02])
(flnonpositive? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard]) (flnonpositive? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
(flnonnegative? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard]) (flnonnegative? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
(fl= [sig [(flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard]) ; not restricted to 2+ arguments (fl= [sig [(flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; not restricted to 2+ arguments
(fl< [sig [(flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard]) ; not restricted to 2+ arguments (fl< [sig [(flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; not restricted to 2+ arguments
(fl<= [sig [(flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard]) ; not restricted to 2+ arguments (fl<= [sig [(flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; not restricted to 2+ arguments
(fl> [sig [(flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard]) ; not restricted to 2+ arguments (fl> [sig [(flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; not restricted to 2+ arguments
(fl>= [sig [(flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard]) ; not restricted to 2+ arguments (fl>= [sig [(flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; not restricted to 2+ arguments
(flush-output-port [sig [() (output-port) -> (void)]] [flags true]) ; not restricted to 1 argument (flush-output-port [sig [() (output-port) -> (void)]] [flags true]) ; not restricted to 1 argument
(foreign-entry? [sig [(string) -> (boolean)]] [flags discard]) (foreign-entry? [sig [(string) -> (boolean)]] [flags discard])
(foreign-entry [sig [(string) -> (uptr)]] [flags discard true]) (foreign-entry [sig [(string) -> (uptr)]] [flags discard true])
@ -1336,39 +1337,39 @@
(fx/ [sig [(fixnum fixnum ...) -> (fixnum)]] [flags arith-op partial-folder]) ; not restricted to 1 or 2 arguments (fx/ [sig [(fixnum fixnum ...) -> (fixnum)]] [flags arith-op partial-folder]) ; not restricted to 1 or 2 arguments
(fx1+ [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02]) (fx1+ [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02])
(fx1- [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02]) (fx1- [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02])
(fx< [sig [(fixnum fixnum ...) -> (boolean)]] [flags pure cp02]) ; not restricted to 2+ arguments (fx< [sig [(fixnum fixnum ...) -> (boolean)]] [flags pure cp02 safeongoodargs]) ; not restricted to 2+ arguments
(fx<= [sig [(fixnum fixnum ...) -> (boolean)]] [flags pure cp02]) ; not restricted to 2+ arguments (fx<= [sig [(fixnum fixnum ...) -> (boolean)]] [flags pure cp02 safeongoodargs]) ; not restricted to 2+ arguments
(fx= [sig [(fixnum fixnum ...) -> (boolean)]] [flags pure cp02]) ; not restricted to 2+ arguments (fx= [sig [(fixnum fixnum ...) -> (boolean)]] [flags pure cp02 safeongoodargs]) ; not restricted to 2+ arguments
(fx> [sig [(fixnum fixnum ...) -> (boolean)]] [flags pure cp02]) ; not restricted to 2+ arguments (fx> [sig [(fixnum fixnum ...) -> (boolean)]] [flags pure cp02 safeongoodargs]) ; not restricted to 2+ arguments
(fx>= [sig [(fixnum fixnum ...) -> (boolean)]] [flags pure cp02]) ; not restricted to 2+ arguments (fx>= [sig [(fixnum fixnum ...) -> (boolean)]] [flags pure cp02 safeongoodargs]) ; not restricted to 2+ arguments
(fxabs [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02]) (fxabs [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02])
(fxlogand [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder]) (fxlogand [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder])
(fxlogbit? [sig [(ufixnum fixnum) -> (boolean)]] [flags pure cp02]) (fxlogbit? [sig [(ufixnum fixnum) -> (boolean)]] [flags pure cp02])
(fxlogbit0 [sig [(sub-ufixnum fixnum) -> (fixnum)]] [flags arith-op cp02]) (fxlogbit0 [sig [(sub-ufixnum fixnum) -> (fixnum)]] [flags arith-op cp02])
(fxlogbit1 [sig [(sub-ufixnum fixnum) -> (fixnum)]] [flags arith-op cp02]) (fxlogbit1 [sig [(sub-ufixnum fixnum) -> (fixnum)]] [flags arith-op cp02])
(fxlogior [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder]) (fxlogior [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder safeongoodargs])
(fxlognot [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02]) (fxlognot [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02 safeongoodargs])
(fxlogor [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder]) (fxlogor [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder safeongoodargs])
(fxlogtest [sig [(fixnum fixnum) -> (boolean)]] [flags pure cp02]) (fxlogtest [sig [(fixnum fixnum) -> (boolean)]] [flags pure cp02 safeongoodargs])
(fxlogxor [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder]) (fxlogxor [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder safeongoodargs])
(fxmodulo [sig [(fixnum fixnum) -> (fixnum)]] [flags arith-op cp02]) (fxmodulo [sig [(fixnum fixnum) -> (fixnum)]] [flags arith-op cp02])
(fxnonnegative? [sig [(fixnum) -> (boolean)]] [flags pure cp02]) (fxnonnegative? [sig [(fixnum) -> (boolean)]] [flags pure cp02 safeongoodargs])
(fxnonpositive? [sig [(fixnum) -> (boolean)]] [flags pure cp02]) (fxnonpositive? [sig [(fixnum) -> (boolean)]] [flags pure cp02 safeongoodargs])
(fxquotient [sig [(fixnum fixnum ...) -> (fixnum)]] [flags arith-op partial-folder]) (fxquotient [sig [(fixnum fixnum ...) -> (fixnum)]] [flags arith-op partial-folder])
(fxremainder [sig [(fixnum fixnum) -> (fixnum)]] [flags arith-op cp02]) (fxremainder [sig [(fixnum fixnum) -> (fixnum)]] [flags arith-op cp02])
(fxsll [sig [(fixnum sub-ufixnum) -> (fixnum)]] [flags arith-op cp02]) (fxsll [sig [(fixnum sub-ufixnum) -> (fixnum)]] [flags arith-op cp02])
(fxsra [sig [(fixnum sub-ufixnum) -> (fixnum)]] [flags arith-op cp02]) (fxsra [sig [(fixnum sub-ufixnum) -> (fixnum)]] [flags arith-op cp02])
(fxsrl [sig [(fixnum sub-ufixnum) -> (fixnum)]] [flags arith-op cp02]) (fxsrl [sig [(fixnum sub-ufixnum) -> (fixnum)]] [flags arith-op cp02])
(fxvector [sig [(fixnum ...) -> (fxvector)]] [flags alloc cp02]) (fxvector [sig [(fixnum ...) -> (fxvector)]] [flags alloc cp02 safeongoodargs])
(fxvector->list [sig [(fxvector) -> (list)]] [flags alloc]) (fxvector->list [sig [(fxvector) -> (list)]] [flags alloc safeongoodargs])
(fxvector-copy [sig [(fxvector) -> (fxvector)]] [flags alloc]) (fxvector-copy [sig [(fxvector) -> (fxvector)]] [flags alloc safeongoodargs])
(fxvector-fill! [sig [(fxvector fixnum) -> (void)]] [flags true]) (fxvector-fill! [sig [(fxvector fixnum) -> (void)]] [flags true])
(fxvector->immutable-fxvector [sig [(fxvector) -> (fxvector)]] [flags alloc]) (fxvector->immutable-fxvector [sig [(fxvector) -> (fxvector)]] [flags alloc safeongoodargs])
(fxvector-length [sig [(fxvector) -> (length)]] [flags pure mifoldable discard true]) (fxvector-length [sig [(fxvector) -> (length)]] [flags pure mifoldable discard true safeongoodargs])
(fxvector-ref [sig [(fxvector sub-index) -> (fixnum)]] [flags mifoldable discard cp02]) (fxvector-ref [sig [(fxvector sub-index) -> (fixnum)]] [flags mifoldable discard cp02])
(fxvector-set! [sig [(fxvector sub-index fixnum) -> (void)]] [flags true]) (fxvector-set! [sig [(fxvector sub-index fixnum) -> (void)]] [flags true])
(fxvector? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) (fxvector? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
(gensym [sig [() (string) (string string) -> (gensym)]] [flags alloc]) (gensym [sig [() (string) (string string) -> (gensym)]] [flags alloc safeongoodargs])
(gensym? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) (gensym? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
(gensym->unique-string [sig [(gensym) -> (string)]] [flags true mifoldable]) ; can't discard ... if we have our hands on it, it must be in the oblist after this (gensym->unique-string [sig [(gensym) -> (string)]] [flags true mifoldable]) ; can't discard ... if we have our hands on it, it must be in the oblist after this
(get-bytevector-some! [sig [(binary-input-port bytevector length length) -> (ptr)]] [flags true]) (get-bytevector-some! [sig [(binary-input-port bytevector length length) -> (ptr)]] [flags true])
@ -1422,15 +1423,15 @@
(lock-object [sig [(ptr) -> (void)]] [flags unrestricted true]) (lock-object [sig [(ptr) -> (void)]] [flags unrestricted true])
(locked-object? [sig [(ptr) -> (boolean)]] [flags unrestricted discard]) (locked-object? [sig [(ptr) -> (boolean)]] [flags unrestricted discard])
(logand [sig [(sint ...) -> (sint)]] [flags arith-op partial-folder]) (logand [sig [(sint ...) -> (sint)]] [flags arith-op partial-folder])
(logbit? [sig [(uint sint) -> (boolean)]] [flags pure mifoldable discard]) (logbit? [sig [(uint sint) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
(logbit0 [sig [(uint sint) -> (sint)]] [flags arith-op mifoldable discard]) (logbit0 [sig [(uint sint) -> (sint)]] [flags arith-op mifoldable discard])
(logbit1 [sig [(uint sint) -> (sint)]] [flags arith-op mifoldable discard]) (logbit1 [sig [(uint sint) -> (sint)]] [flags arith-op mifoldable discard])
(logior [sig [(sint ...) -> (sint)]] [flags arith-op partial-folder]) (logior [sig [(sint ...) -> (sint)]] [flags arith-op partial-folder safeongoodargs])
(lognot [sig [(sint) -> (sint)]] [flags arith-op mifoldable discard]) (lognot [sig [(sint) -> (sint)]] [flags arith-op mifoldable discard safeongoodargs])
(logor [sig [(sint ...) -> (sint)]] [flags arith-op partial-folder]) (logor [sig [(sint ...) -> (sint)]] [flags arith-op partial-folder safeongoodargs])
(logtest [sig [(sint sint) -> (boolean)]] [flags pure mifoldable discard]) (logtest [sig [(sint sint) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
(logxor [sig [(sint ...) -> (sint)]] [flags arith-op partial-folder]) (logxor [sig [(sint ...) -> (sint)]] [flags arith-op partial-folder safeongoodargs])
(magnitude-squared [sig [(number) -> (number)]] [flags arith-op mifoldable discard]) (magnitude-squared [sig [(number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs])
(make-annotation [sig [(ptr source-object ptr) (ptr source-object ptr annotation-options) -> (annotation)]] [flags pure true mifoldable discard]) (make-annotation [sig [(ptr source-object ptr) (ptr source-object ptr annotation-options) -> (annotation)]] [flags pure true mifoldable discard])
(make-arity-wrapper-procedure [sig [(procedure sint ptr) -> (procedure)]] [flags pure true mifoldable discard]) (make-arity-wrapper-procedure [sig [(procedure sint ptr) -> (procedure)]] [flags pure true mifoldable discard])
(make-boot-file [sig [(pathname sub-list pathname ...) -> (void)]] [flags true]) (make-boot-file [sig [(pathname sub-list pathname ...) -> (void)]] [flags true])
@ -1528,7 +1529,7 @@
(pretty-format [sig [(symbol) -> (ptr)] [(symbol sub-ptr) -> (void)]] [flags]) (pretty-format [sig [(symbol) -> (ptr)] [(symbol sub-ptr) -> (void)]] [flags])
(pretty-print [sig [(ptr) (ptr textual-output-port) -> (void)]] [flags true]) (pretty-print [sig [(ptr) (ptr textual-output-port) -> (void)]] [flags true])
(printf [sig [(string sub-ptr ...) -> (void)]] [flags true]) (printf [sig [(string sub-ptr ...) -> (void)]] [flags true])
(procedure-arity-mask [sig [(procedure) -> (sint)]] [flags mifoldable discard true]) (procedure-arity-mask [sig [(procedure) -> (sint)]] [flags mifoldable discard safeongoodargs true])
(process [sig [(string) -> (list)]] [flags]) (process [sig [(string) -> (list)]] [flags])
(profile-clear-database [sig [() -> (void)]] [flags true]) (profile-clear-database [sig [() -> (void)]] [flags true])
(profile-clear [sig [() -> (void)]] [flags true]) (profile-clear [sig [() -> (void)]] [flags true])
@ -1536,12 +1537,12 @@
(profile-dump-data [sig [(pathname) (pathname sub-list) -> (void)]] [flags true]) (profile-dump-data [sig [(pathname) (pathname sub-list) -> (void)]] [flags true])
(profile-dump-list [sig [() (ptr) (ptr sub-list) -> (list)]] [flags discard true]) (profile-dump-list [sig [() (ptr) (ptr sub-list) -> (list)]] [flags discard true])
(profile-dump-html [sig [() (pathname) (pathname sub-list) -> (void)]] [flags true]) (profile-dump-html [sig [() (pathname) (pathname sub-list) -> (void)]] [flags true])
(property-list [sig [(symbol) -> (list)]] [flags discard true]) (property-list [sig [(symbol) -> (list)]] [flags discard true safeongoodargs])
(put-bytevector-some [sig [(binary-output-port bytevector) (binary-output-port bytevector length) (binary-output-port bytevector length length) -> (uint)]] [flags true]) (put-bytevector-some [sig [(binary-output-port bytevector) (binary-output-port bytevector length) (binary-output-port bytevector length length) -> (uint)]] [flags true])
(put-hash-table! [sig [(old-hash-table ptr ptr) -> (void)]] [flags true]) (put-hash-table! [sig [(old-hash-table ptr ptr) -> (void)]] [flags true])
(put-registry! [feature windows] [sig [(string string) -> (void)]] [flags true]) (put-registry! [feature windows] [sig [(string string) -> (void)]] [flags true])
(put-string-some [sig [(textual-output-port string) (textual-output-port string length) (textual-output-port string length length) -> (uint)]] [flags true]) (put-string-some [sig [(textual-output-port string) (textual-output-port string length) (textual-output-port string length length) -> (uint)]] [flags true])
(putprop [sig [(symbol ptr ptr) -> (void)]] [flags true]) (putprop [sig [(symbol ptr ptr) -> (void)]] [flags true safeongoodargs])
(putenv [sig [(string string) -> (void)]] [flags true]) (putenv [sig [(string string) -> (void)]] [flags true])
(profile-query-weight [sig [(ptr) -> (maybe-flonum)]] [flags unrestricted discard]) (profile-query-weight [sig [(ptr) -> (maybe-flonum)]] [flags unrestricted discard])
(random [sig [(sub-number) -> (number)]] [flags alloc]) (random [sig [(sub-number) -> (number)]] [flags alloc])
@ -1562,7 +1563,7 @@
(remove-hash-table! [sig [(old-hash-table ptr) -> (void)]] [flags true]) (remove-hash-table! [sig [(old-hash-table ptr) -> (void)]] [flags true])
(remove-registry! [feature windows] [sig [(string) -> (void)]] [flags true]) (remove-registry! [feature windows] [sig [(string) -> (void)]] [flags true])
(remove! [sig [(ptr list) -> (list)]] [flags true]) (remove! [sig [(ptr list) -> (list)]] [flags true])
(remprop [sig [(symbol ptr) -> (void)]] [flags]) (remprop [sig [(symbol ptr) -> (void)]] [flags safeongoodargs])
(remq! [sig [(ptr list) -> (list)]] [flags true]) (remq! [sig [(ptr list) -> (list)]] [flags true])
(remv! [sig [(ptr list) -> (list)]] [flags true]) (remv! [sig [(ptr list) -> (list)]] [flags true])
(rename-file [sig [(pathname ptr) -> (void)]] [flags]) (rename-file [sig [(pathname ptr) -> (void)]] [flags])
@ -1642,21 +1643,21 @@
(statistics [sig [() -> (sstats)]] [flags unrestricted alloc]) (statistics [sig [() -> (sstats)]] [flags unrestricted alloc])
(string->multibyte [feature windows] [sig [(sub-uint string) -> (bytevector)]] [flags true discard]) (string->multibyte [feature windows] [sig [(sub-uint string) -> (bytevector)]] [flags true discard])
(string->number [sig [(string) (string sub-ufixnum) -> (maybe-number)]] [flags discard]) ; radix not restricted to 2, 4, 8, 16 (string->number [sig [(string) (string sub-ufixnum) -> (maybe-number)]] [flags discard]) ; radix not restricted to 2, 4, 8, 16
(string<=? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard]) ; not restricted to 2+ arguments (string<=? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard safeongoodargs]) ; not restricted to 2+ arguments
(string<? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard]) ; not restricted to 2+ arguments (string<? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard safeongoodargs]) ; not restricted to 2+ arguments
(string=? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard cp03]) ; not restricted to 2+ arguments (string=? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard cp03 safeongoodargs]) ; not restricted to 2+ arguments
(string>=? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard]) ; not restricted to 2+ arguments (string>=? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard safeongoodargs]) ; not restricted to 2+ arguments
(string>? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard]) ; not restricted to 2+ arguments (string>? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard safeongoodargs]) ; not restricted to 2+ arguments
(string-ci<=? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard ieee r5rs]) ; not restricted to 2+ arguments (string-ci<=? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard safeongoodargs ieee r5rs]) ; not restricted to 2+ arguments
(string-ci<? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard ieee r5rs]) ; not restricted to 2+ arguments (string-ci<? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard safeongoodargs ieee r5rs]) ; not restricted to 2+ arguments
(string-ci=? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard ieee r5rs cp03]) ; not restricted to 2+ arguments (string-ci=? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard safeongoodargs ieee r5rs cp03]) ; not restricted to 2+ arguments
(string-ci>=? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard ieee r5rs]) ; not restricted to 2+ arguments (string-ci>=? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard safeongoodargs ieee r5rs]) ; not restricted to 2+ arguments
(string-ci>? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard ieee r5rs]) ; not restricted to 2+ arguments (string-ci>? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard safeongoodargs ieee r5rs]) ; not restricted to 2+ arguments
(string-copy! [sig [(string sub-length string sub-length sub-length) -> (void)]] [flags true]) (string-copy! [sig [(string sub-length string sub-length sub-length) -> (void)]] [flags true])
(string->immutable-string [sig [(string) -> (string)]] [flags alloc]) (string->immutable-string [sig [(string) -> (string)]] [flags alloc safeongoodargs])
(string-truncate! [sig [(string length) -> (string)]] [flags true]) (string-truncate! [sig [(string length) -> (string)]] [flags true])
(strip-fasl-file [sig [(pathname pathname fasl-strip-options) -> (void)]] [flags true]) (strip-fasl-file [sig [(pathname pathname fasl-strip-options) -> (void)]] [flags true])
(sub1 [sig [(number) -> (number)]] [flags arith-op mifoldable discard]) (sub1 [sig [(number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs])
(subst [sig [(ptr ptr ptr) -> (ptr)]] [flags alloc]) (subst [sig [(ptr ptr ptr) -> (ptr)]] [flags alloc])
(subst! [sig [(ptr ptr ptr) -> (ptr)]] [flags]) (subst! [sig [(ptr ptr ptr) -> (ptr)]] [flags])
(substq [sig [(ptr ptr ptr) -> (ptr)]] [flags alloc]) (substq [sig [(ptr ptr ptr) -> (ptr)]] [flags alloc])
@ -1699,7 +1700,7 @@
(transcript-on [sig [(pathname) -> (void)]] [flags true ieee r5rs]) (transcript-on [sig [(pathname) -> (void)]] [flags true ieee r5rs])
(truncate-file [sig [(output-port) (output-port sub-ptr) -> (void)]] [flags]) (truncate-file [sig [(output-port) (output-port sub-ptr) -> (void)]] [flags])
(truncate-port [sig [(output-port) (output-port sub-ptr) -> (void)]] [flags]) (truncate-port [sig [(output-port) (output-port sub-ptr) -> (void)]] [flags])
(unbox [sig [(box) -> (ptr)]] [flags mifoldable discard]) (unbox [sig [(box) -> (ptr)]] [flags mifoldable discard safeongoodargs])
(unget-u8 [sig [(binary-input-port ptr) -> (void)]] [flags true]) (unget-u8 [sig [(binary-input-port ptr) -> (void)]] [flags true])
(unget-char [sig [(textual-input-port ptr) -> (void)]] [flags true]) (unget-char [sig [(textual-input-port ptr) -> (void)]] [flags true])
(unlock-object [sig [(ptr) -> (void)]] [flags unrestricted true]) (unlock-object [sig [(ptr) -> (void)]] [flags unrestricted true])
@ -1708,8 +1709,8 @@
(utf-16le-codec [sig [() -> (codec)]] [flags pure unrestricted true]) (utf-16le-codec [sig [() -> (codec)]] [flags pure unrestricted true])
(utf-16be-codec [sig [() -> (codec)]] [flags pure unrestricted true]) (utf-16be-codec [sig [() -> (codec)]] [flags pure unrestricted true])
(vector-cas! [sig [(vector sub-index ptr ptr) -> (boolean)]] [flags]) (vector-cas! [sig [(vector sub-index ptr ptr) -> (boolean)]] [flags])
(vector-copy [sig [(vector) -> (vector)]] [flags alloc]) (vector-copy [sig [(vector) -> (vector)]] [flags alloc safeongoodargs])
(vector->immutable-vector [sig [(vector) -> (vector)]] [flags alloc]) (vector->immutable-vector [sig [(vector) -> (vector)]] [flags alloc safeongoodargs])
(vector-set-fixnum! [sig [(vector sub-index fixnum) -> (void)]] [flags true]) (vector-set-fixnum! [sig [(vector sub-index fixnum) -> (void)]] [flags true])
(virtual-register [sig [(sub-index) -> (ptr)]] [flags discard]) (virtual-register [sig [(sub-index) -> (ptr)]] [flags discard])
(virtual-register-count [sig [() -> (length)]] [flags pure unrestricted true cp02]) (virtual-register-count [sig [() -> (length)]] [flags pure unrestricted true cp02])
@ -1792,6 +1793,7 @@
($continuation-attachments [flags]) ($continuation-attachments [flags])
($cp0 [flags]) ($cp0 [flags])
($cpcheck [flags]) ($cpcheck [flags])
($cptypes [flags])
($cpcheck-prelex-flags [flags]) ($cpcheck-prelex-flags [flags])
($cpcommonize [flags]) ($cpcommonize [flags])
($cpletrec [flags]) ($cpletrec [flags])

4
s/primref.ss
View File

@ -14,9 +14,9 @@
;;; limitations under the License. ;;; limitations under the License.
(define-record-type primref (define-record-type primref
(nongenerative #{primref a0xltlrcpeygsahopkplcn-2}) (nongenerative #{primref a0xltlrcpeygsahopkplcn-3})
(sealed #t) (sealed #t)
(fields name flags arity)) (fields name flags arity signatures))
(define primref-level (define primref-level
(lambda (pr) (lambda (pr)

11
s/primvars.ss
View File

@ -18,7 +18,7 @@
(include "primref.ss") (include "primref.ss")
(define record-prim! (define record-prim!
(lambda (prim unprefixed flags arity boolean-valued? result-arity) (lambda (prim unprefixed flags arity boolean-valued? result-arity signatures)
(unless (eq? unprefixed prim) ($sputprop prim '*unprefixed* unprefixed)) (unless (eq? unprefixed prim) ($sputprop prim '*unprefixed* unprefixed))
(let* ([flags (if boolean-valued? (fxlogor flags (prim-mask boolean-valued)) flags)] (let* ([flags (if boolean-valued? (fxlogor flags (prim-mask boolean-valued)) flags)]
[flags (if (eq? 'single result-arity) (fxlogor flags (prim-mask single-valued)) flags)] [flags (if (eq? 'single result-arity) (fxlogor flags (prim-mask single-valued)) flags)]
@ -27,13 +27,13 @@
($oops 'prims "inconsistent single-value information for ~s" prim)) ($oops 'prims "inconsistent single-value information for ~s" prim))
($sputprop prim '*flags* flags) ($sputprop prim '*flags* flags)
(when (any-set? (prim-mask (or primitive system)) flags) (when (any-set? (prim-mask (or primitive system)) flags)
($sputprop prim '*prim2* (make-primref prim flags arity)) ($sputprop prim '*prim2* (make-primref prim flags arity signatures))
($sputprop prim '*prim3* (make-primref prim (fxlogor flags (prim-mask unsafe)) arity)))))) ($sputprop prim '*prim3* (make-primref prim (fxlogor flags (prim-mask unsafe)) arity signatures))))))
(define-syntax setup (define-syntax setup
(lambda (x) (lambda (x)
(import priminfo) (import priminfo)
; sort vector of primitive names so boot files compare equal ; sort vector of primitive names so boot files compare equal
(let ([v-prim (vector-sort (lambda (x y) (string<=? (symbol->string x) (symbol->string y))) (primvec))]) (let ([v-prim (vector-sort (lambda (x y) (string<=? (symbol->string x) (symbol->string y))) (primvec))])
(let ([v-info (vector-map get-priminfo v-prim)]) (let ([v-info (vector-map get-priminfo v-prim)])
#`(vector-for-each record-prim! #`(vector-for-each record-prim!
@ -42,7 +42,8 @@
'#,(datum->syntax #'* (vector-map priminfo-mask v-info)) '#,(datum->syntax #'* (vector-map priminfo-mask v-info))
'#,(datum->syntax #'* (vector-map priminfo-arity v-info)) '#,(datum->syntax #'* (vector-map priminfo-arity v-info))
'#,(datum->syntax #'* (vector-map priminfo-boolean? v-info)) '#,(datum->syntax #'* (vector-map priminfo-boolean? v-info))
'#,(datum->syntax #'* (vector-map priminfo-result-arity v-info))))))) '#,(datum->syntax #'* (vector-map priminfo-result-arity v-info))
'#,(datum->syntax #'* (vector-map priminfo-signatures v-info)))))))
(for-each (lambda (x) (for-each (lambda (key) ($sremprop x key)) '(*prim2* *prim3* *flags* *unprefixed*))) (oblist)) (for-each (lambda (x) (for-each (lambda (key) ($sremprop x key)) '(*prim2* *prim3* *flags* *unprefixed*))) (oblist))
setup) setup)