Merge branch '17-5-Types-Pass' of github.com:gus-massa/ChezScheme
original commit: caf857a33e13c116afa6e2d960eccbada3604190
This commit is contained in:
Matthew Flatt
commit
54282dedc4
|
|
@ -1304,9 +1304,9 @@
|
|||
(list 'b 'u 'y)
|
||||
(list 'c 'v 'z))))
|
||||
'(#2%list
|
||||
(#2%string->symbol (#2%string-append "a" "b" "c"))
|
||||
(#2%string->symbol (#2%string-append "t" "u" "v"))
|
||||
(#2%string->symbol (#2%string-append "x" "y" "z"))))
|
||||
(#3%string->symbol (#3%string-append "a" "b" "c"))
|
||||
(#3%string->symbol (#3%string-append "t" "u" "v"))
|
||||
(#3%string->symbol (#3%string-append "x" "y" "z"))))
|
||||
(equivalent-expansion?
|
||||
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||||
(expand/optimize
|
||||
|
|
|
|||
|
|
@ -125,7 +125,7 @@ ecpf = $(defaultecpf)
|
|||
|
||||
# set of mats to run
|
||||
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
|
||||
|
||||
Examples = ../examples
|
||||
|
|
|
|||
|
|
@ -849,13 +849,13 @@
|
|||
(lambda (r)
|
||||
(emit-word! 2953052161)
|
||||
(emit-word! 3766812992)
|
||||
(emit-word! (#2%+ 3766747136 (#2%ash r 0))))))
|
||||
(emit-word! (#3%+ 3766747136 (#2%ash r 0))))))
|
||||
(syntax-case x ($primitive)
|
||||
[(set! test
|
||||
(lambda (r1)
|
||||
(ew1! 2953052161)
|
||||
(ew2! 3766812992)
|
||||
(ew3! (#2%+ 3766747136 (#2%ash r2 0)))))
|
||||
(ew3! (#3%+ 3766747136 (#2%ash r2 0)))))
|
||||
(eq? #'r1 #'r2)])))
|
||||
; verify optimization of (if e s s) => (begin e s)
|
||||
(equivalent-expansion?
|
||||
|
|
@ -893,14 +893,14 @@
|
|||
(expand/optimize
|
||||
'(lambda (x y) (if (not (or (fx< x y) (fx> y x))) x y))))
|
||||
'(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
|
||||
x.0)))
|
||||
(equivalent-expansion?
|
||||
(parameterize ([#%$suppress-primitive-inlining #f] [run-cp0 (lambda (cp0 x) (cp0 x))] [optimize-level 2])
|
||||
(expand/optimize
|
||||
'(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?
|
||||
(parameterize ([#%$suppress-primitive-inlining #f] [run-cp0 (lambda (cp0 x) (cp0 x))] [optimize-level 2])
|
||||
(expand/optimize
|
||||
|
|
|
|||
697
mats/cptypes.ms
Normal file
697
mats/cptypes.ms
Normal 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))
|
||||
)
|
||||
|
|
@ -5058,7 +5058,7 @@
|
|||
'(if (#3%zero? (#3%random 1000))
|
||||
(begin (pariah (void)) (#3%display 0))
|
||||
(#3%display 1))
|
||||
'(if (#2%zero? (#2%random 1000))
|
||||
'(if (#3%zero? (#2%random 1000))
|
||||
(begin (pariah (void)) (#2%display 0))
|
||||
(#2%display 1))))
|
||||
)
|
||||
|
|
|
|||
|
|
@ -6375,9 +6375,7 @@
|
|||
(#3%$object-set! 'scheme-object b ,fixnum? g7))
|
||||
(#2%list
|
||||
(#3%record? b g5)
|
||||
(begin
|
||||
(if (#3%record? b g6) (#2%void) (#3%$record-oops 'unbox b g6))
|
||||
(#3%$object-ref 'scheme-object b ,fixnum?)))))))
|
||||
(#3%$object-ref 'scheme-object b ,fixnum?))))))
|
||||
(equal?
|
||||
(let ()
|
||||
(define build-box
|
||||
|
|
@ -6407,13 +6405,9 @@
|
|||
(record-mutator (make-record-type-descriptor
|
||||
name #f #f #f #f '#((mutable x))) 0)))
|
||||
(procedure? (useless 'useless-box-setter)))))
|
||||
`(#2%procedure?
|
||||
(let ([g0 (#2%make-record-type-descriptor 'useless-box-setter #f #f #f #f '#((mutable x)))])
|
||||
(lambda (g1 g2)
|
||||
(if (#3%record? g1 g0)
|
||||
(#2%void)
|
||||
(#3%$record-oops 'moi g1 g0))
|
||||
(#3%$object-set! 'scheme-object g1 ,fixnum? g2)))))
|
||||
`(begin
|
||||
(#2%make-record-type-descriptor 'useless-box-setter #f #f #f #f '#((mutable x)))
|
||||
#t))
|
||||
(let ()
|
||||
(define useless
|
||||
(lambda (name)
|
||||
|
|
@ -8592,9 +8586,7 @@
|
|||
(if b (frob-x x) 72)))))
|
||||
`(lambda (b)
|
||||
(if b
|
||||
(begin
|
||||
(#3%$record-oops 'frob-x 'x ',record-type-descriptor?)
|
||||
(#3%$object-ref 'scheme-object 'x ,fixnum?))
|
||||
(#3%$record-oops 'frob-x 'x ',record-type-descriptor?)
|
||||
72)))
|
||||
(equivalent-expansion?
|
||||
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||||
|
|
@ -8793,7 +8785,7 @@
|
|||
[r (inc r)]
|
||||
[r (inc 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?
|
||||
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||||
(expand/optimize
|
||||
|
|
@ -8820,7 +8812,7 @@
|
|||
[r (inc r)])
|
||||
r)))))
|
||||
'(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?
|
||||
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||||
(expand/optimize
|
||||
|
|
|
|||
|
|
@ -105,7 +105,7 @@ patch = patch
|
|||
|
||||
# putting cpnanopass.patch early for maximum make --jobs=2 benefit
|
||||
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\
|
||||
compile.patch fasl.patch syntax.patch env.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\
|
||||
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\
|
||||
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\
|
||||
exceptions.ss pretty.ss env.ss\
|
||||
fasl.ss reloc.ss pdhtml.ss strip.ss ftype.ss back.ss
|
||||
|
|
@ -149,7 +149,7 @@ macroobj =\
|
|||
allsrc =\
|
||||
${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\
|
||||
np-languages.ss bitset.ss
|
||||
np-languages.ss bitset.ss fxmap.ss
|
||||
|
||||
# doit uses a different Scheme process to compile each target
|
||||
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
|
||||
|
||||
${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
|
||||
inspect.$m: bitset.ss
|
||||
|
||||
|
|
|
|||
|
|
@ -14,14 +14,14 @@
|
|||
;;; limitations under the License.
|
||||
|
||||
(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
|
||||
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-source prelex-operand prelex-operand-set! prelex-uname make-prelex*
|
||||
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")
|
||||
|
||||
(define $lookup-primref
|
||||
|
|
|
|||
|
|
@ -1599,6 +1599,7 @@
|
|||
(abort-op #b00000100000000000000000)
|
||||
(unsafe #b00001000000000000000000)
|
||||
(unrestricted #b00010000000000000000000)
|
||||
(safeongoodargs #b00100000000000000000000)
|
||||
(arith-op (or proc pure true))
|
||||
(alloc (or proc discard true))
|
||||
; would be nice to check that these and only these actually have cp0 partial folders
|
||||
|
|
|
|||
24
s/compile.ss
24
s/compile.ss
|
|
@ -551,6 +551,12 @@
|
|||
(when ($enable-check-prelex-flags)
|
||||
($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
|
||||
(lambda (op hostop wpoop machine sfd do-read outfn)
|
||||
(include "types.ss")
|
||||
|
|
@ -569,7 +575,8 @@
|
|||
[$compile-profile ($compile-profile)]
|
||||
[generate-interrupt-trap (generate-interrupt-trap)]
|
||||
[$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))
|
||||
(when hostop (emit-header hostop (host-machine-type)))
|
||||
(when wpoop (emit-header wpoop (host-machine-type)))
|
||||
|
|
@ -650,14 +657,18 @@
|
|||
(set! cpletrec-ran? #t)
|
||||
(let* ([x ($pass-time 'cp0 (lambda () (do-trace $cp0 x)))]
|
||||
[waste (check-prelex-flags x 'cp0)]
|
||||
[x (cptypes x)]
|
||||
[waste (check-prelex-flags x 'cptypes)]
|
||||
[x ($pass-time 'cpletrec (lambda () (do-trace $cpletrec x)))]
|
||||
[waste (check-prelex-flags x 'cpletrec)])
|
||||
x))
|
||||
x2)])
|
||||
(if cpletrec-ran?
|
||||
x
|
||||
(let ([x ($pass-time 'cpletrec (lambda () (do-trace $cpletrec x)))])
|
||||
(check-prelex-flags x 'cpletrec)
|
||||
(let* ([x (cptypes x)]
|
||||
[waste (check-prelex-flags x 'cptypes)]
|
||||
[x ($pass-time 'cpletrec (lambda () (do-trace $cpletrec x)))]
|
||||
[waste (check-prelex-flags x 'cpletrec)])
|
||||
x))))]
|
||||
[x2b ($pass-time 'cpcheck (lambda () (do-trace $cpcheck x2a)))]
|
||||
[waste (check-prelex-flags x2b 'cpcheck)]
|
||||
|
|
@ -1489,10 +1500,13 @@
|
|||
(let ([x ((run-cp0)
|
||||
(lambda (x)
|
||||
(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)))))
|
||||
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 'cpcommonize (lambda () ($cpcommonize x2b)))])
|
||||
(when (and (expand/optimize-output) (not ($noexpand? x0)))
|
||||
|
|
|
|||
|
|
@ -4556,6 +4556,7 @@
|
|||
[(e1 e2) (dofxlogbit1 e2 e1)])
|
||||
(define-inline 3 fxcopy-bit
|
||||
[(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)
|
||||
(case (constant-value e3)
|
||||
[(0) (dofxlogbit0 e1 e2)]
|
||||
|
|
|
|||
|
|
@ -215,6 +215,10 @@
|
|||
(if (eq? (subset-mode) 'system)
|
||||
($system-environment)
|
||||
(interaction-environment)))
|
||||
(define (cptypes x)
|
||||
(if (enable-type-recovery)
|
||||
($cptypes x)
|
||||
x))
|
||||
(define e/o
|
||||
(lambda (who cte? x env)
|
||||
(define (go x)
|
||||
|
|
@ -225,9 +229,9 @@
|
|||
(let ([x ((run-cp0)
|
||||
(lambda (x)
|
||||
(set! cpletrec-ran? #t)
|
||||
($cpletrec ($cp0 x $compiler-is-loaded?)))
|
||||
($cpletrec (cptypes ($cp0 x $compiler-is-loaded?))))
|
||||
($cpvalid x))])
|
||||
(if cpletrec-ran? x ($cpletrec x))))))))
|
||||
(if cpletrec-ran? x ($cpletrec (cptypes x)))))))))
|
||||
(unless (environment? env)
|
||||
($oops who "~s is not an environment" env))
|
||||
; claim compiling-a-file to get cte as well as run-time code
|
||||
|
|
|
|||
1058
s/cptypes.ss
Normal file
1058
s/cptypes.ss
Normal file
File diff suppressed because it is too large
Load Diff
|
|
@ -104,6 +104,7 @@
|
|||
|
||||
(define enable-cross-library-optimization ($make-thread-parameter #t (lambda (x) (and x #t))))
|
||||
|
||||
|
||||
(define-who current-generate-id
|
||||
($make-thread-parameter
|
||||
(lambda (sym)
|
||||
|
|
@ -113,6 +114,9 @@
|
|||
(unless (procedure? p) ($oops who "~s is not a procedure" p))
|
||||
p)))
|
||||
|
||||
(define enable-type-recovery ($make-thread-parameter #t (lambda (x) (and x #t))))
|
||||
|
||||
|
||||
(define machine-type
|
||||
(lambda ()
|
||||
(constant machine-type-name)))
|
||||
|
|
@ -223,6 +227,7 @@
|
|||
(package-stubs compiler-support
|
||||
$cp0
|
||||
$cpvalid
|
||||
$cptypes
|
||||
$cpletrec
|
||||
$cpcheck)
|
||||
(package-stubs syntax-support
|
||||
|
|
|
|||
490
s/fxmap.ss
Normal file
490
s/fxmap.ss
Normal 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))
|
||||
)
|
||||
|
|
@ -661,6 +661,11 @@
|
|||
(c-var-index-set! (car vars) i)
|
||||
(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)
|
||||
(definitions
|
||||
(define (ibeval x1)
|
||||
|
|
@ -670,9 +675,9 @@
|
|||
(let ([x ((run-cp0)
|
||||
(lambda (x)
|
||||
(set! cpletrec-ran? #t)
|
||||
($cpletrec ($cp0 x #f)))
|
||||
($cpletrec (cptypes ($cp0 x #f))))
|
||||
x2)])
|
||||
(if cpletrec-ran? x ($cpletrec x))))]
|
||||
(if cpletrec-ran? x ($cpletrec (cptypes x)))))]
|
||||
[x2b ($cpcheck x2a)]
|
||||
[x2b ($cpcommonize x2b)])
|
||||
(when eoo (pretty-print ($uncprep x2b) eoo))
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@
|
|||
;;; See the License for the specific language governing permissions and
|
||||
;;; 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))
|
||||
|
||||
|
|
|
|||
454
s/primdata.ss
454
s/primdata.ss
|
|
@ -16,23 +16,23 @@
|
|||
;;; r6rs features
|
||||
|
||||
(define-symbol-flags* ([libraries (rnrs) (rnrs arithmetic bitwise)] [flags primitive proc])
|
||||
(bitwise-not [sig [(sint) -> (sint)]] [flags arith-op mifoldable discard])
|
||||
(bitwise-and [sig [(sint ...) -> (sint)]] [flags arith-op partial-folder])
|
||||
(bitwise-ior [sig [(sint ...) -> (sint)]] [flags arith-op partial-folder])
|
||||
(bitwise-xor [sig [(sint ...) -> (sint)]] [flags arith-op partial-folder])
|
||||
(bitwise-if [sig [(sint sint sint) -> (sint)]] [flags arith-op mifoldable discard])
|
||||
(bitwise-bit-count [sig [(sint) -> (sint)]] [flags arith-op mifoldable discard])
|
||||
(bitwise-length [sig [(sint) -> (uint)]] [flags arith-op mifoldable discard])
|
||||
(bitwise-first-bit-set [sig [(sint) -> (sint)]] [flags arith-op mifoldable discard])
|
||||
(bitwise-bit-set? [sig [(sint uint) -> (boolean)]] [flags pure mifoldable discard])
|
||||
(bitwise-copy-bit [sig [(sint uint bit) -> (sint)]] [flags arith-op mifoldable discard])
|
||||
(bitwise-bit-field [sig [(sint sub-uint sub-uint) -> (uint)]] [flags arith-op mifoldable discard])
|
||||
(bitwise-copy-bit-field [sig [(sint sub-uint sub-uint sint) -> (sint)]] [flags arith-op mifoldable discard])
|
||||
(bitwise-arithmetic-shift [sig [(sint sint) -> (sint)]] [flags arith-op mifoldable discard cp03])
|
||||
(bitwise-arithmetic-shift-left [sig [(sint uint) -> (sint)]] [flags arith-op mifoldable discard cp03])
|
||||
(bitwise-arithmetic-shift-right [sig [(sint uint) -> (sint)]] [flags arith-op mifoldable discard cp03])
|
||||
(bitwise-rotate-bit-field [sig [(sint sub-uint 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])
|
||||
(bitwise-not [sig [(sint) -> (sint)]] [flags arith-op mifoldable discard safeongoodargs])
|
||||
(bitwise-and [sig [(sint ...) -> (sint)]] [flags arith-op partial-folder safeongoodargs])
|
||||
(bitwise-ior [sig [(sint ...) -> (sint)]] [flags arith-op partial-folder safeongoodargs])
|
||||
(bitwise-xor [sig [(sint ...) -> (sint)]] [flags arith-op partial-folder safeongoodargs])
|
||||
(bitwise-if [sig [(sint sint sint) -> (sint)]] [flags arith-op mifoldable discard safeongoodargs])
|
||||
(bitwise-bit-count [sig [(sint) -> (sint)]] [flags arith-op mifoldable discard safeongoodargs])
|
||||
(bitwise-length [sig [(sint) -> (uint)]] [flags arith-op mifoldable discard safeongoodargs])
|
||||
(bitwise-first-bit-set [sig [(sint) -> (sint)]] [flags arith-op mifoldable discard safeongoodargs])
|
||||
(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 safeongoodargs])
|
||||
(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 safeongoodargs])
|
||||
(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 safeongoodargs])
|
||||
(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 safeongoodargs])
|
||||
(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])
|
||||
|
|
@ -40,18 +40,18 @@
|
|||
(fixnum-width [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])
|
||||
(fx<? [sig [(fixnum fixnum fixnum ...) -> (boolean)]] [flags pure cp02]) ; 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]) ; 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]) ; restricted to 2+ arguments
|
||||
(fxzero? [sig [(fixnum) -> (boolean)]] [flags pure cp02])
|
||||
(fxnegative? [sig [(fixnum) -> (boolean)]] [flags pure cp02])
|
||||
(fxpositive? [sig [(fixnum) -> (boolean)]] [flags pure cp02])
|
||||
(fxeven? [sig [(fixnum) -> (boolean)]] [flags pure cp02])
|
||||
(fxodd? [sig [(fixnum) -> (boolean)]] [flags pure cp02])
|
||||
(fxmax [sig [(fixnum fixnum ...) -> (fixnum)]] [flags arith-op cp02])
|
||||
(fxmin [sig [(fixnum fixnum ...) -> (fixnum)]] [flags arith-op cp02])
|
||||
(fx<? [sig [(fixnum fixnum fixnum ...) -> (boolean)]] [flags pure cp02 safeongoodargs]) ; 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 safeongoodargs]) ; 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 safeongoodargs]) ; restricted to 2+ arguments
|
||||
(fxzero? [sig [(fixnum) -> (boolean)]] [flags pure cp02 safeongoodargs])
|
||||
(fxnegative? [sig [(fixnum) -> (boolean)]] [flags pure cp02 safeongoodargs])
|
||||
(fxpositive? [sig [(fixnum) -> (boolean)]] [flags pure cp02 safeongoodargs])
|
||||
(fxeven? [sig [(fixnum) -> (boolean)]] [flags pure cp02 safeongoodargs])
|
||||
(fxodd? [sig [(fixnum) -> (boolean)]] [flags pure cp02 safeongoodargs])
|
||||
(fxmax [sig [(fixnum fixnum ...) -> (fixnum)]] [flags arith-op cp02 safeongoodargs])
|
||||
(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) -> (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 [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])
|
||||
(fx*/carry [sig [(fixnum fixnum fixnum) -> (fixnum fixnum)]] [flags cp02])
|
||||
(fxnot [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02])
|
||||
(fxand [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder])
|
||||
(fxior [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder])
|
||||
(fxxor [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder])
|
||||
(fxif [sig [(fixnum fixnum fixnum) -> (fixnum)]] [flags arith-op cp02])
|
||||
(fxbit-count [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02])
|
||||
(fxlength [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02])
|
||||
(fxfirst-bit-set [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02])
|
||||
(fx+/carry [sig [(fixnum fixnum fixnum) -> (fixnum fixnum)]] [flags cp02 safeongoodargs])
|
||||
(fx-/carry [sig [(fixnum fixnum fixnum) -> (fixnum fixnum)]] [flags cp02 safeongoodargs])
|
||||
(fx*/carry [sig [(fixnum fixnum fixnum) -> (fixnum fixnum)]] [flags cp02 safeongoodargs])
|
||||
(fxnot [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02 safeongoodargs])
|
||||
(fxand [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder safeongoodargs])
|
||||
(fxior [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder safeongoodargs])
|
||||
(fxxor [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder safeongoodargs])
|
||||
(fxif [sig [(fixnum fixnum fixnum) -> (fixnum)]] [flags arith-op cp02 safeongoodargs])
|
||||
(fxbit-count [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02 safeongoodargs])
|
||||
(fxlength [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02 safeongoodargs])
|
||||
(fxfirst-bit-set [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02 safeongoodargs])
|
||||
(fxbit-set? [sig [(fixnum sub-ufixnum) -> (boolean)]] [flags pure 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])
|
||||
|
|
@ -90,28 +90,28 @@
|
|||
|
||||
(define-symbol-flags* ([libraries (rnrs) (rnrs arithmetic flonums)] [flags primitive proc])
|
||||
(flonum? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
|
||||
(real->flonum [sig [(real) -> (flonum)]] [flags arith-op mifoldable discard])
|
||||
(fl=? [sig [(flonum flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard]) ; 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]) ; 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]) ; restricted to 2+ arguments
|
||||
(flinteger? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard])
|
||||
(flzero? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard])
|
||||
(flpositive? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard])
|
||||
(flnegative? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard])
|
||||
(real->flonum [sig [(real) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
|
||||
(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 safeongoodargs]) ; 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 safeongoodargs]) ; 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 safeongoodargs])
|
||||
(flzero? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
|
||||
(flpositive? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
|
||||
(flnegative? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
|
||||
(flodd? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard])
|
||||
(fleven? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard])
|
||||
(flfinite? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard])
|
||||
(flinfinite? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard])
|
||||
(flnan? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard])
|
||||
(flmax [sig [(flonum flonum ...) -> (flonum)]] [flags arith-op mifoldable discard])
|
||||
(flmin [sig [(flonum flonum ...) -> (flonum)]] [flags arith-op mifoldable discard])
|
||||
(fl* [sig [(flonum ...) -> (flonum)]] [flags arith-op partial-folder])
|
||||
(fl+ [sig [(flonum ...) -> (flonum)]] [flags arith-op partial-folder])
|
||||
(fl- [sig [(flonum flonum ...) -> (flonum)]] [flags arith-op partial-folder])
|
||||
(fl/ [sig [(flonum flonum ...) -> (flonum)]] [flags arith-op partial-folder])
|
||||
(flabs [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard])
|
||||
(flfinite? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
|
||||
(flinfinite? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
|
||||
(flnan? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
|
||||
(flmax [sig [(flonum flonum ...) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
|
||||
(flmin [sig [(flonum flonum ...) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
|
||||
(fl* [sig [(flonum ...) -> (flonum)]] [flags arith-op partial-folder safeongoodargs])
|
||||
(fl+ [sig [(flonum ...) -> (flonum)]] [flags arith-op partial-folder safeongoodargs])
|
||||
(fl- [sig [(flonum flonum ...) -> (flonum)]] [flags arith-op partial-folder safeongoodargs])
|
||||
(fl/ [sig [(flonum flonum ...) -> (flonum)]] [flags arith-op partial-folder safeongoodargs])
|
||||
(flabs [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
|
||||
(fldiv-and-mod [sig [(flonum flonum) -> (flonum flonum)]] [flags discard])
|
||||
(fldiv [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])
|
||||
(flnumerator [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])
|
||||
(flceiling [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard])
|
||||
(fltruncate [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard])
|
||||
(flround [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard])
|
||||
(flexp [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard])
|
||||
(fllog [sig [(flonum) (flonum flonum) -> (flonum)]] [flags arith-op mifoldable discard])
|
||||
(flsin [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard])
|
||||
(flcos [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard])
|
||||
(fltan [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard])
|
||||
(flasin [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard])
|
||||
(flacos [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard])
|
||||
(flatan [sig [(flonum) (flonum flonum) -> (flonum)]] [flags arith-op mifoldable discard])
|
||||
(flsqrt [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard])
|
||||
(flexpt [sig [(flonum 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 safeongoodargs])
|
||||
(fltruncate [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
|
||||
(flround [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
|
||||
(flexp [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
|
||||
(fllog [sig [(flonum) (flonum flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
|
||||
(flsin [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
|
||||
(flcos [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
|
||||
(fltan [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
|
||||
(flasin [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
|
||||
(flacos [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
|
||||
(flatan [sig [(flonum) (flonum flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
|
||||
(flsqrt [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
|
||||
(flexpt [sig [(flonum flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
|
||||
(make-no-infinities-violation [sig [() -> (ptr)]] [flags pure unrestricted alloc])
|
||||
(no-infinities-violation? [sig [(ptr) -> (ptr)]] [flags pure unrestricted mifoldable discard])
|
||||
(make-no-nans-violation [sig [() -> (ptr)]] [flags pure unrestricted alloc])
|
||||
(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])
|
||||
|
|
@ -192,30 +192,30 @@
|
|||
(real-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])
|
||||
(exact? [sig [(number) -> (boolean)]] [flags pure mifoldable discard ieee r5rs])
|
||||
(inexact? [sig [(number) -> (boolean)]] [flags pure mifoldable discard ieee r5rs])
|
||||
(inexact [sig [(number) -> (inexact-number)]] [flags arith-op mifoldable discard])
|
||||
(exact [sig [(number) -> (exact-number)]] [flags arith-op mifoldable discard])
|
||||
((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 ieee r5rs]) ; restricted to 2+ arguments
|
||||
((r6rs: =) [sig [(number number number ...) -> (boolean)]] [flags pure mifoldable discard 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 ieee r5rs]) ; restricted to 2+ arguments
|
||||
(zero? [sig [(number) -> (boolean)]] [flags pure mifoldable discard ieee r5rs])
|
||||
(positive? [sig [(real) -> (boolean)]] [flags pure mifoldable discard ieee r5rs])
|
||||
(negative? [sig [(real) -> (boolean)]] [flags pure mifoldable discard ieee r5rs])
|
||||
(odd? [sig [(integer) -> (boolean)]] [flags pure mifoldable discard ieee r5rs])
|
||||
(even? [sig [(integer) -> (boolean)]] [flags pure mifoldable discard ieee r5rs])
|
||||
(finite? [sig [(real) -> (boolean)]] [flags pure mifoldable discard])
|
||||
(infinite? [sig [(real) -> (boolean)]] [flags pure mifoldable discard])
|
||||
(nan? [sig [(real) -> (boolean)]] [flags pure mifoldable discard])
|
||||
(max [sig [(real real ...) -> (real)]] [flags arith-op mifoldable discard ieee r5rs])
|
||||
(min [sig [(real real ...) -> (real)]] [flags arith-op mifoldable discard ieee r5rs])
|
||||
(+ [sig [(number ...) -> (number)]] [flags arith-op partial-folder ieee r5rs])
|
||||
(* [sig [(number ...) -> (number)]] [flags arith-op partial-folder ieee r5rs])
|
||||
(- [sig [(number number ...) -> (number)]] [flags arith-op partial-folder ieee r5rs])
|
||||
(exact? [sig [(number) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs])
|
||||
(inexact? [sig [(number) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs])
|
||||
(inexact [sig [(number) -> (inexact-number)]] [flags arith-op mifoldable discard safeongoodargs])
|
||||
(exact [sig [(number) -> (exact-number)]] [flags arith-op mifoldable discard safeongoodargs])
|
||||
((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 safeongoodargs 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 safeongoodargs 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 safeongoodargs ieee r5rs])
|
||||
(positive? [sig [(real) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs])
|
||||
(negative? [sig [(real) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs])
|
||||
(odd? [sig [(integer) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs])
|
||||
(even? [sig [(integer) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs])
|
||||
(finite? [sig [(real) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
|
||||
(infinite? [sig [(real) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
|
||||
(nan? [sig [(real) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
|
||||
(max [sig [(real real ...) -> (real)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs])
|
||||
(min [sig [(real real ...) -> (real)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs])
|
||||
(+ [sig [(number ...) -> (number)]] [flags arith-op partial-folder safeongoodargs ieee r5rs])
|
||||
(* [sig [(number ...) -> (number)]] [flags arith-op partial-folder safeongoodargs 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])
|
||||
(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 [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])
|
||||
(numerator [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])
|
||||
(ceiling [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
|
||||
(truncate [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
|
||||
(round [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
|
||||
(rationalize [sig [(number 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 safeongoodargs ieee r5rs])
|
||||
(truncate [sig [(number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs])
|
||||
(round [sig [(number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs 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])
|
||||
(log [sig [(number) (number 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])
|
||||
(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
|
||||
(make-rectangular [sig [(number number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
|
||||
(make-polar [sig [(number number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
|
||||
(real-part [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
|
||||
(imag-part [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
|
||||
(magnitude [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
|
||||
(angle [sig [(number) -> (real)]] [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 safeongoodargs 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 safeongoodargs ieee r5rs])
|
||||
(magnitude [sig [(number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs 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: 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])
|
||||
(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])
|
||||
(cons [sig [(ptr ptr) -> (#1=(ptr . ptr))]] [flags unrestricted alloc ieee r5rs])
|
||||
; c..r non-alphabetic so marks come before references
|
||||
(car [sig [(#1#) -> (ptr)]] [flags mifoldable discard cp02 ieee r5rs])
|
||||
(cdr [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 safeongoodargs ieee r5rs])
|
||||
(caar [sig [(#2=(#1# . ptr)) -> (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])
|
||||
|
|
@ -297,40 +297,40 @@
|
|||
(map [sig [(procedure list list ...) -> (list)]] [flags cp02 cp03 ieee r5rs true])
|
||||
(for-each [sig [(procedure list list ...) -> (ptr ...)]] [flags cp02 cp03 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=? [sig [(symbol symbol symbol ...) -> (boolean)]] [flags pure mifoldable discard cp03])
|
||||
(string->symbol [sig [(string) -> (symbol)]] [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 safeongoodargs])
|
||||
(string->symbol [sig [(string) -> (symbol)]] [flags true mifoldable discard safeongoodargs 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])
|
||||
((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 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 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 safeongoodargs ieee r5rs]) ; 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 safeongoodargs 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])
|
||||
(make-string [sig [(length) (length char) -> (string)]] [flags alloc ieee r5rs])
|
||||
(string [sig [(char ...) -> (string)]] [flags alloc ieee r5rs cp02])
|
||||
(string-length [sig [(string) -> (length)]] [flags pure true ieee r5rs mifoldable discard])
|
||||
(string [sig [(char ...) -> (string)]] [flags alloc ieee r5rs cp02 safeongoodargs])
|
||||
(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])
|
||||
((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 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 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 safeongoodargs ieee r5rs]) ; 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 safeongoodargs 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])
|
||||
(string-append [sig [(string ...) -> (string)]] [flags alloc ieee r5rs])
|
||||
(string->list [sig [(string) -> (list)]] [flags alloc ieee r5rs])
|
||||
(string-append [sig [(string ...) -> (string)]] [flags alloc safeongoodargs ieee r5rs])
|
||||
(string->list [sig [(string) -> (list)]] [flags alloc safeongoodargs ieee r5rs])
|
||||
(list->string [sig [(sub-list) -> (string)]] [flags alloc ieee r5rs])
|
||||
(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])
|
||||
(make-vector [sig [(length) (length ptr) -> (vector)]] [flags alloc ieee r5rs])
|
||||
(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-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])
|
||||
(vector-fill! [sig [(vector ptr) -> (void)]] [flags true ieee r5rs])
|
||||
(vector-map [sig [(procedure vector vector ...) -> (vector)]] [flags cp03])
|
||||
|
|
@ -353,16 +353,16 @@
|
|||
(native-endianness [sig [() -> (symbol)]] [flags pure unrestricted alloc cp02])
|
||||
(bytevector? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
|
||||
(make-bytevector [sig [(length) (length u8/s8) -> (bytevector)]] [flags alloc])
|
||||
(bytevector-length [sig [(bytevector) -> (length)]] [flags true mifoldable discard])
|
||||
(bytevector=? [sig [(bytevector bytevector) -> (boolean)]] [flags mifoldable discard cp03])
|
||||
(bytevector-length [sig [(bytevector) -> (length)]] [flags true mifoldable discard safeongoodargs])
|
||||
(bytevector=? [sig [(bytevector bytevector) -> (boolean)]] [flags mifoldable discard cp03 safeongoodargs])
|
||||
(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) -> (bytevector)]] [flags alloc])
|
||||
(bytevector-copy [sig [(bytevector) -> (bytevector)]] [flags alloc safeongoodargs])
|
||||
(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-u8-set! [sig [(bytevector sub-index u8) -> (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])
|
||||
(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])
|
||||
|
|
@ -535,9 +535,9 @@
|
|||
(hashtable-hash-function [sig [(hashtable) -> (ptr)]] [flags])
|
||||
(hashtable-mutable? [sig [(hashtable) -> (boolean)]] [flags mifoldable discard])
|
||||
(equal-hash [sig [(ptr) -> (length)]] [flags unrestricted true])
|
||||
(string-hash [sig [(string) -> (length)]] [flags true])
|
||||
(string-ci-hash [sig [(string) -> (length)]] [flags true])
|
||||
(symbol-hash [sig [(symbol) -> (length)]] [flags true])
|
||||
(string-hash [sig [(string) -> (length)]] [flags true safeongoodargs])
|
||||
(string-ci-hash [sig [(string) -> (length)]] [flags true safeongoodargs])
|
||||
(symbol-hash [sig [(symbol) -> (length)]] [flags true safeongoodargs])
|
||||
)
|
||||
|
||||
(define-symbol-flags* ([libraries (rnrs) (rnrs io ports)] [flags keyword])
|
||||
|
|
@ -729,8 +729,8 @@
|
|||
)
|
||||
|
||||
(define-symbol-flags* ([libraries (rnrs r5rs)] [flags primitive proc])
|
||||
(exact->inexact [sig [(number) -> (inexact-number)]] [flags arith-op mifoldable discard ieee r5rs])
|
||||
(inexact->exact [sig [(number) -> (exact-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 safeongoodargs 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])
|
||||
(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)]
|
||||
[(sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum) -> (date)]]
|
||||
[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-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])
|
||||
(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-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-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-object-backreferences [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])
|
||||
(expand-omit-library-invocations [sig [() -> (boolean)] [(ptr) -> (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])
|
||||
(< [sig [(real real ...) -> (boolean)]] [flags pure mifoldable discard]) ; not restricted to 2+ arguments
|
||||
(<= [sig [(real real ...) -> (boolean)]] [flags pure mifoldable discard]) ; not restricted to 2+ arguments
|
||||
(= [sig [(number number ...) -> (boolean)]] [flags pure mifoldable discard]) ; 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]) ; not restricted to 2+ arguments
|
||||
(-1+ [sig [(number) -> (number)]] [flags arith-op mifoldable discard])
|
||||
(1+ [sig [(number) -> (number)]] [flags arith-op mifoldable discard])
|
||||
(1- [sig [(number) -> (number)]] [flags arith-op mifoldable discard])
|
||||
(< [sig [(real real ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; 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 safeongoodargs]) ; 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 safeongoodargs]) ; not restricted to 2+ arguments
|
||||
(-1+ [sig [(number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs])
|
||||
(1+ [sig [(number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs])
|
||||
(1- [sig [(number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs])
|
||||
(abort [sig [() (ptr) -> (bottom)]] [flags abort-op])
|
||||
(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])
|
||||
(annotation? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
|
||||
(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-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])
|
||||
(cfl* [sig [(cflonum ...) -> (cflonum)]] [flags arith-op partial-folder])
|
||||
(cfl+ [sig [(cflonum ...) -> (cflonum)]] [flags arith-op partial-folder])
|
||||
(cfl- [sig [(cflonum 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 safeongoodargs])
|
||||
(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 ...) -> (boolean)]] [flags pure mifoldable discard])
|
||||
(cfl-conjugate [sig [(cflonum) -> (cflonum)]] [flags arith-op mifoldable discard])
|
||||
(cfl-imag-part [sig [(cflonum) -> (flonum)]] [flags arith-op mifoldable discard])
|
||||
(cfl-magnitude-squared [sig [(cflonum) -> (flonum)]] [flags arith-op mifoldable discard])
|
||||
(cfl-real-part [sig [(cflonum) -> (flonum)]] [flags arith-op mifoldable discard])
|
||||
(cfl= [sig [(cflonum cflonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
|
||||
(cfl-conjugate [sig [(cflonum) -> (cflonum)]] [flags arith-op mifoldable discard safeongoodargs])
|
||||
(cfl-imag-part [sig [(cflonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
|
||||
(cfl-magnitude-squared [sig [(cflonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
|
||||
(cfl-real-part [sig [(cflonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
|
||||
(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]) ; 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]) ; not restricted to 2+ arguments
|
||||
(char>? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard]) ; not restricted to 2+ arguments
|
||||
(char- [sig [(char char) -> (fixnum)]] [flags pure mifoldable discard true])
|
||||
(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]) ; 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]) ; not restricted to 2+ arguments
|
||||
(char-ci>? [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 safeongoodargs]) ; 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 safeongoodargs]) ; 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 safeongoodargs])
|
||||
(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 safeongoodargs]) ; 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 safeongoodargs]) ; 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-ready? [sig [() (textual-input-port) -> (boolean)]] [flags ieee r5rs])
|
||||
(chmod [sig [(pathname sub-ufixnum) -> (void)]] [flags])
|
||||
|
|
@ -1299,16 +1300,16 @@
|
|||
(port-file-compressed! [sig [(port) -> (void)]] [flags])
|
||||
(file-regular? [sig [(pathname) (pathname ptr) -> (boolean)]] [flags discard])
|
||||
(file-symbolic-link? [sig [(pathname) -> (boolean)]] [flags discard])
|
||||
(fllp [sig [(flonum) -> (ufixnum)]] [flags arith-op mifoldable discard])
|
||||
(fl-make-rectangular [sig [(flonum flonum) -> (inexactnum)]] [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 safeongoodargs])
|
||||
(flonum->fixnum [sig [(flonum) -> (fixnum)]] [flags arith-op cp02])
|
||||
(flnonpositive? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard])
|
||||
(flnonnegative? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard])
|
||||
(fl= [sig [(flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard]) ; 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]) ; 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]) ; not restricted to 2+ arguments
|
||||
(flnonpositive? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
|
||||
(flnonnegative? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
|
||||
(fl= [sig [(flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; 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 safeongoodargs]) ; 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 safeongoodargs]) ; not restricted to 2+ arguments
|
||||
(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) -> (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
|
||||
(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]) ; 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]) ; 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 safeongoodargs]) ; 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 safeongoodargs]) ; 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])
|
||||
(fxlogand [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder])
|
||||
(fxlogbit? [sig [(ufixnum fixnum) -> (boolean)]] [flags pure cp02])
|
||||
(fxlogbit0 [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])
|
||||
(fxlognot [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02])
|
||||
(fxlogor [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder])
|
||||
(fxlogtest [sig [(fixnum fixnum) -> (boolean)]] [flags pure cp02])
|
||||
(fxlogxor [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 safeongoodargs])
|
||||
(fxlogor [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder safeongoodargs])
|
||||
(fxlogtest [sig [(fixnum fixnum) -> (boolean)]] [flags pure cp02 safeongoodargs])
|
||||
(fxlogxor [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder safeongoodargs])
|
||||
(fxmodulo [sig [(fixnum fixnum) -> (fixnum)]] [flags arith-op cp02])
|
||||
(fxnonnegative? [sig [(fixnum) -> (boolean)]] [flags pure cp02])
|
||||
(fxnonpositive? [sig [(fixnum) -> (boolean)]] [flags pure cp02])
|
||||
(fxnonnegative? [sig [(fixnum) -> (boolean)]] [flags pure cp02 safeongoodargs])
|
||||
(fxnonpositive? [sig [(fixnum) -> (boolean)]] [flags pure cp02 safeongoodargs])
|
||||
(fxquotient [sig [(fixnum fixnum ...) -> (fixnum)]] [flags arith-op partial-folder])
|
||||
(fxremainder [sig [(fixnum fixnum) -> (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])
|
||||
(fxsrl [sig [(fixnum sub-ufixnum) -> (fixnum)]] [flags arith-op cp02])
|
||||
(fxvector [sig [(fixnum ...) -> (fxvector)]] [flags alloc cp02])
|
||||
(fxvector->list [sig [(fxvector) -> (list)]] [flags alloc])
|
||||
(fxvector-copy [sig [(fxvector) -> (fxvector)]] [flags alloc])
|
||||
(fxvector [sig [(fixnum ...) -> (fxvector)]] [flags alloc cp02 safeongoodargs])
|
||||
(fxvector->list [sig [(fxvector) -> (list)]] [flags alloc safeongoodargs])
|
||||
(fxvector-copy [sig [(fxvector) -> (fxvector)]] [flags alloc safeongoodargs])
|
||||
(fxvector-fill! [sig [(fxvector fixnum) -> (void)]] [flags true])
|
||||
(fxvector->immutable-fxvector [sig [(fxvector) -> (fxvector)]] [flags alloc])
|
||||
(fxvector-length [sig [(fxvector) -> (length)]] [flags pure mifoldable discard true])
|
||||
(fxvector->immutable-fxvector [sig [(fxvector) -> (fxvector)]] [flags alloc safeongoodargs])
|
||||
(fxvector-length [sig [(fxvector) -> (length)]] [flags pure mifoldable discard true safeongoodargs])
|
||||
(fxvector-ref [sig [(fxvector sub-index) -> (fixnum)]] [flags mifoldable discard cp02])
|
||||
(fxvector-set! [sig [(fxvector sub-index fixnum) -> (void)]] [flags true])
|
||||
(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->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])
|
||||
|
|
@ -1422,15 +1423,15 @@
|
|||
(lock-object [sig [(ptr) -> (void)]] [flags unrestricted true])
|
||||
(locked-object? [sig [(ptr) -> (boolean)]] [flags unrestricted discard])
|
||||
(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])
|
||||
(logbit1 [sig [(uint sint) -> (sint)]] [flags arith-op mifoldable discard])
|
||||
(logior [sig [(sint ...) -> (sint)]] [flags arith-op partial-folder])
|
||||
(lognot [sig [(sint) -> (sint)]] [flags arith-op mifoldable discard])
|
||||
(logor [sig [(sint ...) -> (sint)]] [flags arith-op partial-folder])
|
||||
(logtest [sig [(sint sint) -> (boolean)]] [flags pure mifoldable discard])
|
||||
(logxor [sig [(sint ...) -> (sint)]] [flags arith-op partial-folder])
|
||||
(magnitude-squared [sig [(number) -> (number)]] [flags arith-op mifoldable discard])
|
||||
(logior [sig [(sint ...) -> (sint)]] [flags arith-op partial-folder safeongoodargs])
|
||||
(lognot [sig [(sint) -> (sint)]] [flags arith-op mifoldable discard safeongoodargs])
|
||||
(logor [sig [(sint ...) -> (sint)]] [flags arith-op partial-folder safeongoodargs])
|
||||
(logtest [sig [(sint sint) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
|
||||
(logxor [sig [(sint ...) -> (sint)]] [flags arith-op partial-folder safeongoodargs])
|
||||
(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-arity-wrapper-procedure [sig [(procedure sint ptr) -> (procedure)]] [flags pure true mifoldable discard])
|
||||
(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-print [sig [(ptr) (ptr textual-output-port) -> (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])
|
||||
(profile-clear-database [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-list [sig [() (ptr) (ptr sub-list) -> (list)]] [flags discard 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-hash-table! [sig [(old-hash-table ptr ptr) -> (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])
|
||||
(putprop [sig [(symbol ptr ptr) -> (void)]] [flags true])
|
||||
(putprop [sig [(symbol ptr ptr) -> (void)]] [flags true safeongoodargs])
|
||||
(putenv [sig [(string string) -> (void)]] [flags true])
|
||||
(profile-query-weight [sig [(ptr) -> (maybe-flonum)]] [flags unrestricted discard])
|
||||
(random [sig [(sub-number) -> (number)]] [flags alloc])
|
||||
|
|
@ -1562,7 +1563,7 @@
|
|||
(remove-hash-table! [sig [(old-hash-table ptr) -> (void)]] [flags true])
|
||||
(remove-registry! [feature windows] [sig [(string) -> (void)]] [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])
|
||||
(remv! [sig [(ptr list) -> (list)]] [flags true])
|
||||
(rename-file [sig [(pathname ptr) -> (void)]] [flags])
|
||||
|
|
@ -1642,21 +1643,21 @@
|
|||
(statistics [sig [() -> (sstats)]] [flags unrestricted alloc])
|
||||
(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<=? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard]) ; 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 cp03]) ; 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]) ; 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 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 ieee r5rs]) ; not restricted to 2+ arguments
|
||||
(string-ci>? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard ieee r5rs]) ; 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 safeongoodargs]) ; 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 safeongoodargs]) ; 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 safeongoodargs 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 safeongoodargs ieee r5rs cp03]) ; 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 safeongoodargs ieee r5rs]) ; not restricted to 2+ arguments
|
||||
(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])
|
||||
(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])
|
||||
(substq [sig [(ptr ptr ptr) -> (ptr)]] [flags alloc])
|
||||
|
|
@ -1699,7 +1700,7 @@
|
|||
(transcript-on [sig [(pathname) -> (void)]] [flags true ieee r5rs])
|
||||
(truncate-file [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-char [sig [(textual-input-port ptr) -> (void)]] [flags true])
|
||||
(unlock-object [sig [(ptr) -> (void)]] [flags unrestricted true])
|
||||
|
|
@ -1708,8 +1709,8 @@
|
|||
(utf-16le-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-copy [sig [(vector) -> (vector)]] [flags alloc])
|
||||
(vector->immutable-vector [sig [(vector) -> (vector)]] [flags alloc])
|
||||
(vector-copy [sig [(vector) -> (vector)]] [flags alloc safeongoodargs])
|
||||
(vector->immutable-vector [sig [(vector) -> (vector)]] [flags alloc safeongoodargs])
|
||||
(vector-set-fixnum! [sig [(vector sub-index fixnum) -> (void)]] [flags true])
|
||||
(virtual-register [sig [(sub-index) -> (ptr)]] [flags discard])
|
||||
(virtual-register-count [sig [() -> (length)]] [flags pure unrestricted true cp02])
|
||||
|
|
@ -1792,6 +1793,7 @@
|
|||
($continuation-attachments [flags])
|
||||
($cp0 [flags])
|
||||
($cpcheck [flags])
|
||||
($cptypes [flags])
|
||||
($cpcheck-prelex-flags [flags])
|
||||
($cpcommonize [flags])
|
||||
($cpletrec [flags])
|
||||
|
|
|
|||
|
|
@ -14,9 +14,9 @@
|
|||
;;; limitations under the License.
|
||||
|
||||
(define-record-type primref
|
||||
(nongenerative #{primref a0xltlrcpeygsahopkplcn-2})
|
||||
(nongenerative #{primref a0xltlrcpeygsahopkplcn-3})
|
||||
(sealed #t)
|
||||
(fields name flags arity))
|
||||
(fields name flags arity signatures))
|
||||
|
||||
(define primref-level
|
||||
(lambda (pr)
|
||||
|
|
|
|||
|
|
@ -18,7 +18,7 @@
|
|||
(include "primref.ss")
|
||||
|
||||
(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))
|
||||
(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)]
|
||||
|
|
@ -27,13 +27,13 @@
|
|||
($oops 'prims "inconsistent single-value information for ~s" prim))
|
||||
($sputprop prim '*flags* flags)
|
||||
(when (any-set? (prim-mask (or primitive system)) flags)
|
||||
($sputprop prim '*prim2* (make-primref prim flags arity))
|
||||
($sputprop prim '*prim3* (make-primref prim (fxlogor flags (prim-mask unsafe)) arity))))))
|
||||
($sputprop prim '*prim2* (make-primref prim flags arity signatures))
|
||||
($sputprop prim '*prim3* (make-primref prim (fxlogor flags (prim-mask unsafe)) arity signatures))))))
|
||||
|
||||
(define-syntax setup
|
||||
(lambda (x)
|
||||
(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-info (vector-map get-priminfo v-prim)])
|
||||
#`(vector-for-each record-prim!
|
||||
|
|
@ -42,7 +42,8 @@
|
|||
'#,(datum->syntax #'* (vector-map priminfo-mask v-info))
|
||||
'#,(datum->syntax #'* (vector-map priminfo-arity 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))
|
||||
setup)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user