feat: 9.5.9
This commit is contained in:
tmtt
parent
cb1753732b
commit
35f43a7909
1084 changed files with 558985 additions and 0 deletions
918
mats/primvars.ms
Normal file
918
mats/primvars.ms
Normal file
|
|
@ -0,0 +1,918 @@
|
|||
;;; primvars.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.
|
||||
|
||||
(mat primvars
|
||||
(let ([ls (oblist)])
|
||||
(define (mat-id? x)
|
||||
(memq x
|
||||
'(equivalent-expansion? mat-run mat mat/cf
|
||||
mat-file mat-output enable-cp0 windows? embedded?
|
||||
*examples-directory* *scheme* *mats-dir*
|
||||
*fuzz* ~= fl~= cfl~= == nan pi +pi +pi/2 +pi/4 -pi -pi/2 -pi/4 +e -e
|
||||
separate-eval-tools separate-compile separate-eval run-script patch-exec-path $record->vector
|
||||
$cat_flush
|
||||
test-cp0-expansion
|
||||
mkfile rm-rf touch
|
||||
heap-check-interval
|
||||
preexisting-profile-dump-entry?
|
||||
coverage-table record-run-coverage load-coverage-files combine-coverage-files coverage-percent
|
||||
parameters)))
|
||||
(define (canonical-label x)
|
||||
(let ([s (symbol->string x)])
|
||||
(#%$intern3 (format "~a*top*:~a" s s) (string-length s) (+ 6 (* 2 (string-length s))))))
|
||||
(unless (find (lambda (x) (#%$sgetprop x '*top* #f)) ls)
|
||||
(errorf #f "no symbols found with property ~s" '*top*))
|
||||
(let loop ([ls ls] [bad '()])
|
||||
(if (null? ls)
|
||||
(or (null? bad)
|
||||
(begin
|
||||
(pretty-print bad)
|
||||
(errorf #f "incorrect top-level bindings for symbols ~s" bad)))
|
||||
(loop (cdr ls)
|
||||
(let ([x (car ls)])
|
||||
(if (gensym? x)
|
||||
(let ([name (#%$symbol-name x)])
|
||||
(if name
|
||||
(let ([pname (cdr name)] [uname (car name)])
|
||||
(if (and pname uname (string=? uname (format "*top*:~a" pname)))
|
||||
(if (mat-id? (string->symbol pname)) bad (cons x bad))
|
||||
bad))
|
||||
bad))
|
||||
(if (let ([loc (#%$sgetprop x '*top* #f)])
|
||||
(case (#%$symbol-type x)
|
||||
[(keyword library-uid) (eq? loc x)]
|
||||
[(primitive)
|
||||
(and
|
||||
(top-level-bound? x)
|
||||
(eq? (top-level-value x) (top-level-value x (scheme-environment)))
|
||||
(eq? loc x))]
|
||||
[else
|
||||
(if (mat-id? x)
|
||||
(or loc (guard (c [else #f]) (#2%$top-level-value (canonical-label x)) #t))
|
||||
(and
|
||||
(not loc)
|
||||
(not (top-level-bound? x))
|
||||
(guard (c [else #t])
|
||||
(#2%top-level-value x)
|
||||
#f)
|
||||
(guard (c [else #t])
|
||||
(#2%$top-level-value (canonical-label x))
|
||||
#f)))]))
|
||||
bad
|
||||
(cons x bad))))))))
|
||||
|
||||
(let ([ls (remp gensym? (oblist))])
|
||||
(define (get-cte x) (#%$sgetprop x '*cte* #f))
|
||||
(define (keyword? x)
|
||||
(cond
|
||||
[(get-cte x) => (lambda (b) (not (eq? (car b) 'primitive)))]
|
||||
[else #f]))
|
||||
(define (variable? x)
|
||||
(cond
|
||||
[(get-cte x) => (lambda (b) (eq? (car b) 'primitive))]
|
||||
[else #t]))
|
||||
(define (scheme? x) (eq? (#%$sgetprop x '*scheme* #f) x))
|
||||
(unless (find (lambda (x) (#%$sgetprop x '*cte* #f)) ls)
|
||||
(errorf #f "no symbols found with property ~s" '*cte*))
|
||||
(unless (find (lambda (x) (#%$sgetprop x '*scheme* #f)) ls)
|
||||
(errorf #f "no symbols found with property ~s" '*scheme*))
|
||||
(let loop ([ls ls] [bad '()])
|
||||
(if (null? ls)
|
||||
(or (null? bad)
|
||||
(begin
|
||||
(pretty-print bad)
|
||||
(errorf #f "incorrect system/scheme bindings for symbols ~s" bad)))
|
||||
(let ([x (car ls)])
|
||||
(if (case (#%$symbol-type x)
|
||||
[(system)
|
||||
(and (#%$top-level-bound? x)
|
||||
(top-level-syntax? x)
|
||||
(not (top-level-syntax? x (scheme-environment)))
|
||||
(variable? x)
|
||||
(not (keyword? x))
|
||||
(not (scheme? x)))]
|
||||
[(system-keyword)
|
||||
(and (not (#%$top-level-bound? x))
|
||||
(top-level-syntax? x)
|
||||
(not (top-level-syntax? x (scheme-environment)))
|
||||
(not (variable? x))
|
||||
(keyword? x)
|
||||
(not (scheme? x)))]
|
||||
[(primitive)
|
||||
(and (#%$top-level-bound? x)
|
||||
(top-level-syntax? x)
|
||||
(top-level-syntax? x (scheme-environment))
|
||||
(variable? x)
|
||||
(not (keyword? x))
|
||||
(scheme? x))]
|
||||
[(keyword)
|
||||
(and (not (#%$top-level-bound? x))
|
||||
(top-level-syntax? x)
|
||||
(top-level-syntax? x (scheme-environment))
|
||||
(not (variable? x))
|
||||
(keyword? x)
|
||||
(scheme? x))]
|
||||
[(library-uid) ; same as keyword, except top-evel-bound
|
||||
(and (#%$top-level-bound? x)
|
||||
(top-level-syntax? x)
|
||||
(top-level-syntax? x (scheme-environment))
|
||||
(not (variable? x))
|
||||
(keyword? x)
|
||||
(scheme? x))]
|
||||
[(system-library-uid)
|
||||
(and (#%$top-level-bound? x) ; same as system-keyword, except top-evel-bound
|
||||
(top-level-syntax? x)
|
||||
(not (top-level-syntax? x (scheme-environment)))
|
||||
(not (variable? x))
|
||||
(keyword? x)
|
||||
(not (scheme? x)))]
|
||||
[else
|
||||
(and (not (#%$top-level-bound? x))
|
||||
(top-level-syntax? x)
|
||||
(not (top-level-syntax? x (scheme-environment)))
|
||||
(not (get-cte x))
|
||||
(not (scheme? x)))])
|
||||
(loop (cdr ls) bad)
|
||||
(loop (cdr ls) (cons x bad))))))
|
||||
#t)
|
||||
)
|
||||
|
||||
(mat arity
|
||||
(or (= (optimize-level) 3)
|
||||
(let ([ls (oblist)])
|
||||
(define oops #f)
|
||||
(define (arity->mask a*)
|
||||
(fold-left (lambda (mask a)
|
||||
(logor mask
|
||||
(if (< a 0)
|
||||
(ash -1 (- -1 a))
|
||||
(ash 1 a))))
|
||||
0 a*))
|
||||
(define prim-arity
|
||||
(lambda (x)
|
||||
(module (primref-arity)
|
||||
(define-syntax include-from-s
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
[(k ?path)
|
||||
(string? (datum ?path))
|
||||
(let ([s-path (format "~a/../s/~a" *mats-dir* (datum ?path))])
|
||||
(datum->syntax #'k `(include ,s-path)))])))
|
||||
(include-from-s "primref.ss"))
|
||||
(let ([primref2 (#%$sgetprop x '*prim2* #f)] [primref3 (#%$sgetprop x '*prim3* #f)])
|
||||
(if primref2
|
||||
(if primref3
|
||||
(let ([arity2 (primref-arity primref2)]
|
||||
[arity3 (primref-arity primref3)])
|
||||
(unless (equal? arity2 arity3)
|
||||
(errorf #f "unequal *prim2* and *prim3* arity for ~s" x))
|
||||
(and arity2 (arity->mask arity2)))
|
||||
(errorf #f "found *prim2* but not *prim3* for ~s" x))
|
||||
(if primref3
|
||||
(errorf #f "found *prim2* but not *prim3* for ~s" x)
|
||||
#f)))))
|
||||
(define (prefix=? prefix str)
|
||||
(let ([n (string-length prefix)])
|
||||
(and (>= (string-length str) n)
|
||||
(string=? (substring str 0 n) prefix))))
|
||||
(define (okay-condition? prim c)
|
||||
(and (violation? c)
|
||||
(message-condition? c)
|
||||
(irritants-condition? c)
|
||||
(let ([msg (condition-message c)] [args (condition-irritants c)])
|
||||
(or (and (prefix=? "incorrect number of arguments" msg)
|
||||
(and (list? args) (= (length args) 1))
|
||||
(let ([unprefixed (#%$sgetprop prim '*unprefixed* prim)])
|
||||
(or (and (procedure? (car args))
|
||||
(let ([name (#%$procedure-name (car args))])
|
||||
(or (not name) (equal? name (symbol->string unprefixed)))))
|
||||
(and (pair? (car args)) (eq? (caar args) unprefixed)))))
|
||||
(and (prefix=? "incorrect argument count" msg)
|
||||
(and (list? args) (= (length args) 1) (string? (car args)))
|
||||
(let ([unprefixed (#%$sgetprop prim '*unprefixed* prim)])
|
||||
(prefix=? (format "(~s" unprefixed) (car args))))))))
|
||||
(define (check prim n)
|
||||
(let ([call `(,prim ,@(make-list n `',(void)))])
|
||||
(unless (guard (c [else (okay-condition? prim c)])
|
||||
(eval `(begin ,call #f)))
|
||||
(set! oops #t)
|
||||
(printf "no argcount error for ~s\n" call)))
|
||||
(let ([call `(,prim ,@(make-list n '(void)))])
|
||||
(define (write-and-load x)
|
||||
(with-output-to-file "testfile.ss"
|
||||
(lambda () (pretty-print x))
|
||||
'replace)
|
||||
(load "testfile.ss"))
|
||||
(let ([warn? #f] [error? #f])
|
||||
(guard (c [(okay-condition? prim c) (set! error? #t)])
|
||||
(with-exception-handler
|
||||
(lambda (x) (if (warning? x) (begin (set! warn? #t) (values)) (raise-continuable x)))
|
||||
(lambda () (write-and-load `(begin ,call #f)) #f)))
|
||||
(unless (or warn? (#%$suppress-primitive-inlining)) (printf "no argcount warning for ~s\n" call) (set! oops #t))
|
||||
(unless error? (printf "no argcount error for ~s\n" call) (set! oops #t)))))
|
||||
(unless (find (lambda (x) (#%$sgetprop x '*prim3* #f)) ls)
|
||||
(printf "no symbols found with property ~s" '*prim3*))
|
||||
(for-each
|
||||
(lambda (prim)
|
||||
(let ([mask (prim-arity prim)])
|
||||
(when mask
|
||||
(let ([pam (procedure-arity-mask (top-level-value prim (scheme-environment)))])
|
||||
(unless (= mask pam)
|
||||
(printf "primref arity mask ~s differs from procedure-arity-mask return value ~s for ~s\n"
|
||||
mask pam prim)
|
||||
(set! oops #t)))
|
||||
(let loop ([n 0] [mask mask])
|
||||
(cond
|
||||
[(eqv? mask 0) (check prim n)]
|
||||
[(eqv? mask -1) (void)]
|
||||
[else
|
||||
(unless (bitwise-bit-set? mask 0) (check prim n))
|
||||
(loop (fx+ n 1) (ash mask -1))])))))
|
||||
ls)
|
||||
(not oops)))
|
||||
)
|
||||
|
||||
(mat check-prim-arg-errors
|
||||
(or (= (optimize-level) 3)
|
||||
(let ()
|
||||
; check-prim-arg-errors use the signatures in primdata.ss, when possible, to verify that
|
||||
; primitives perform required argument type checks. for each argument to each primitive
|
||||
; and for each specified 'bad' value, it passes the 'bad' value for that argument and
|
||||
; 'good' values for each other argument. for some arguments to some primitives, e.g., the
|
||||
; first argument to remove, there is no 'bad' value, so that argument is not checked.
|
||||
;
|
||||
; the test has several deficiencies:
|
||||
; - for arguments labeled sub-<type>, it cannot determine a 'good' value. this can be
|
||||
; addressed only by refining the types given in primdata.ss, including adding
|
||||
; dependent types for things like list-ref, the range of whose second argument
|
||||
; depends on its first.
|
||||
; - it doesn't verify that the raised condition is appropriate, other than ruling out
|
||||
; warning conditions, non-violation conditions, and invalid memory references.
|
||||
(meta define feature*
|
||||
(call-with-port
|
||||
(open-input-file (let ([fn (format "../s/~a.def" (machine-type))])
|
||||
(if (file-exists? fn) fn (format "../~a" fn))))
|
||||
(lambda (ip)
|
||||
(let loop ()
|
||||
(let ([x (read ip)])
|
||||
(cond
|
||||
[(eof-object? x) '()]
|
||||
[(and (list? x) (eq? (car x) 'features)) (cdr x)]
|
||||
[else (loop)]))))))
|
||||
(define-syntax define-symbol-flags*
|
||||
(lambda (x)
|
||||
(define construct-name
|
||||
(lambda (template-identifier . args)
|
||||
(datum->syntax
|
||||
template-identifier
|
||||
(string->symbol
|
||||
(apply string-append
|
||||
(map (lambda (x) (format "~a" (syntax->datum x)))
|
||||
args))))))
|
||||
(syntax-case x (libraries flags)
|
||||
[(_ ([libraries lib ...] [flags shared-flag ...]) entry ...)
|
||||
(andmap identifier? #'(shared-flag ...))
|
||||
(let ()
|
||||
(define prim-name
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
[(prefix prim)
|
||||
(and (identifier? #'prefix) (identifier? #'prim))
|
||||
(with-syntax ([prefix:prim (construct-name #'prim #'prefix #'prim)])
|
||||
#'(prim . prefix:prim))]
|
||||
[prim (identifier? #'prim) #'(prim . prim)])))
|
||||
(define ins-and-outs
|
||||
(lambda (ins outs)
|
||||
(syntax-case ins (->)
|
||||
[((in ...) ...) #`(((in ...) #,outs) ...)])))
|
||||
(define do-entry
|
||||
(lambda (x)
|
||||
(syntax-case x (feature sig flags ->)
|
||||
[(prim [feature f] . more)
|
||||
(if (memq (datum f) feature*)
|
||||
(do-entry #'(prim . more))
|
||||
#'(void))]
|
||||
[(prim [flags flag ...]) (do-entry #'(prim [sig] [flags flag ...]))]
|
||||
[(prim [sig [(in ...) ... -> (out ...)] ...] [flags flag ...])
|
||||
(with-syntax ([(unprefixed . prim) (prim-name #'prim)])
|
||||
(with-syntax ([((((in ...) (out ...)) ...) ...)
|
||||
(map ins-and-outs #'(((in ...) ...) ...) #'((out ...) ...))])
|
||||
#'(fuzz-prim-args 'prim 'unprefixed '(lib ...)
|
||||
'(shared-flag ... flag ...)
|
||||
'([(in ...) . (out ...)] ... ...))))])))
|
||||
#`(begin #,@(map do-entry #'(entry ...))))])))
|
||||
(define env
|
||||
(let ([env (copy-environment (scheme-environment) #t)])
|
||||
(define-syntax def
|
||||
(syntax-rules ()
|
||||
[(_ name val)
|
||||
(define-top-level-value 'name val env)]))
|
||||
(def *env env)
|
||||
(let* ([bv (string->utf8 "(if #f #f)")]
|
||||
[binary-input-port (open-bytevector-input-port bv)]
|
||||
[sfd (make-source-file-descriptor "foo" binary-input-port #t)]
|
||||
[source-object (make-source-object sfd 2 3)]
|
||||
[annotation (make-annotation '(if #f #f) source-object '(source expr))]
|
||||
[textual-input-port (transcoded-port binary-input-port (native-transcoder))])
|
||||
(def *binary-input-port binary-input-port)
|
||||
(def *sfd sfd)
|
||||
(def *source-object source-object)
|
||||
(def *annotation annotation)
|
||||
(def *textual-input-port textual-input-port))
|
||||
(let*-values ([(binary-output-port getter) (open-bytevector-output-port)]
|
||||
[(textual-output-port) (transcoded-port binary-output-port (native-transcoder))])
|
||||
(def *binary-output-port binary-output-port)
|
||||
(def *binary-port binary-output-port)
|
||||
(def *textual-output-port textual-output-port)
|
||||
(def *textual-port textual-output-port))
|
||||
(def *cost-center (make-cost-center))
|
||||
(def *date (current-date))
|
||||
(def *eq-hashtable (make-eq-hashtable))
|
||||
(def *ftype-pointer (make-ftype-pointer double 0))
|
||||
(def *symbol-hashtable (make-hashtable symbol-hash eq?))
|
||||
(def *genny (gensym))
|
||||
(def *old-hash-table (make-hash-table))
|
||||
(let ()
|
||||
(define rtd (make-record-type-descriptor 'foo #f #f #f #f '#((mutable x))))
|
||||
(define rcd (make-record-constructor-descriptor rtd #f #f))
|
||||
(def *rtd rtd)
|
||||
(def *rcd rcd)
|
||||
(def *record ((record-constructor rcd) 3)))
|
||||
(def *sstats (statistics))
|
||||
(def *time (make-time 'time-duration 0 5))
|
||||
(def *time-utc (make-time 'time-utc 0 5))
|
||||
(cond
|
||||
[(fx< (fixnum-width) 32)
|
||||
(def *max-iptr (- (expt 2 31) 1))
|
||||
(def *min-iptr (- (expt 2 31)))
|
||||
(def *max-uptr (- (expt 2 32) 1))]
|
||||
[(fx< (fixnum-width) 64)
|
||||
(def *max-iptr (- (expt 2 63) 1))
|
||||
(def *min-iptr (- (expt 2 63)))
|
||||
(def *max-uptr (- (expt 2 64) 1))]
|
||||
[else (errorf 'fuzz-prim-args "unexpected fixnum width ~s" (fixnum-width))])
|
||||
env))
|
||||
(define type-table
|
||||
(let ()
|
||||
(define ht (make-hashtable symbol-hash eq?))
|
||||
(define-syntax declare-types
|
||||
(syntax-rules ()
|
||||
[(_ ((type ...) good bad ...) ...)
|
||||
(begin
|
||||
(let ([payload '(good bad ...)])
|
||||
(for-each
|
||||
(lambda (t) (symbol-hashtable-set! ht t payload))
|
||||
'(type ...)))
|
||||
...)]))
|
||||
(declare-types
|
||||
[(annotation) *annotation '() #f]
|
||||
[(annotation-options) (annotation-options debug) 1/2 #f]
|
||||
[(binary-input-port) *binary-input-port 0 *binary-output-port (current-input-port) #f]
|
||||
[(binary-output-port) *binary-output-port *binary-input-port (current-output-port) #f]
|
||||
[(binary-port) *binary-output-port (current-input-port) #f]
|
||||
[(bit) 0 7 1.0 'a #f]
|
||||
[(boolean) #f '()]
|
||||
[(box) &a '((a)) #f]
|
||||
[(bytevector) '#vu8(0) "a" #f]
|
||||
[(cflonum) 0.0+1.0i 0 'a #f]
|
||||
[(char) #\a 0 #f]
|
||||
[(codec) (latin-1-codec) 0 #f]
|
||||
[(code) (closure-code 'values) 0 #f]
|
||||
[(compile-time-value) (make-compile-time-value 17) #f]
|
||||
[(condition) (make-who-condition 'me) 'the-who #f]
|
||||
[(continuation-condition) (call/cc make-continuation-condition) (make-who-condition 'who) #f]
|
||||
[(cost-center) *cost-center '(a) #f]
|
||||
[(source-table) (make-source-table) *time #f]
|
||||
[(date) *date *time #f]
|
||||
[(endianness) 'big 'giant #f]
|
||||
[(enum-set) (file-options compressed) 0 #f]
|
||||
[(environment) *env '((a . b)) #f]
|
||||
[(eq-hashtable) *eq-hashtable *symbol-hashtable #f]
|
||||
[(exact-integer) (- (most-negative-fixnum) 1) 2.0 1/2 #f]
|
||||
[(exception-state) (current-exception-state) 0 #f]
|
||||
[(fasl-strip-options) (fasl-strip-options inspector-source) (file-options compressed) #f]
|
||||
[(file-options) (file-options compressed) 1/2 #f]
|
||||
[(fixnum) -1 'q (+ (most-positive-fixnum) 1) (- (most-negative-fixnum) 1) #f]
|
||||
[(flonum) 0.0 0 0.0+1.0i 'a #f]
|
||||
[(ftype-pointer) *ftype-pointer 0 *time #f]
|
||||
[(fxvector) '#vfx(0) "a" #f]
|
||||
[(gensym) *genny 'sym #f]
|
||||
[(guardian) (make-guardian) values "oops" #f]
|
||||
[(hashtable) *eq-hashtable '((a . b)) #f]
|
||||
[(identifier) #'x 'x 17 #f]
|
||||
[(import-spec) '(chezscheme) 0 '(a . b) #f]
|
||||
[(input-port) (current-input-port) 0 *binary-output-port *textual-output-port #f]
|
||||
[(integer) 0.0 1/2 1.0+0.0i 'a #f]
|
||||
[(i/o-encoding-error) (make-i/o-encoding-error 17 23) (make-who-condition 'who) 1/2 #f]
|
||||
[(i/o-filename-error) (make-i/o-filename-error 17) (make-who-condition 'who) 3 #f]
|
||||
[(i/o-invalid-position-error) (make-i/o-invalid-position-error 17) (make-who-condition 'who) "" #f]
|
||||
[(i/o-port-error) (make-i/o-port-error 17) (make-who-condition 'who) '(a) #f]
|
||||
[(irritants-condition) (make-irritants-condition 17) (make-who-condition 'who) 'a #f]
|
||||
[(length) 0 -1 (+ (most-positive-fixnum) 1) 'a #f]
|
||||
[(library-path) '(a) "hereiam" #f]
|
||||
[(library-requirements-options) (library-requirements-options import invoke) 1/2 #f]
|
||||
[(list) '(a) '#1=(a . #1#) 17 '#() #'(1 2 3) #f]
|
||||
[(list-of-string-pairs) '(("a" . "b")) '("a") #f]
|
||||
[(list-of-symbols) '(a b c) '("a") #f]
|
||||
[(maybe-binary-output-port) *binary-output-port *binary-input-port (current-output-port)]
|
||||
[(maybe-char) #\a 0]
|
||||
[(maybe-pathname) "a" 'a]
|
||||
[(maybe-procedure) values 0]
|
||||
[(maybe-rtd) *rtd *record ""]
|
||||
[(maybe-sfd) *sfd '(q)]
|
||||
[(maybe-source-table) (make-source-table) *time]
|
||||
[(maybe-string) "a" 'a]
|
||||
[(maybe-symbol) 'a 0 "a"]
|
||||
[(maybe-textual-output-port) (current-output-port) 0 *binary-output-port *textual-input-port]
|
||||
[(maybe-transcoder) (native-transcoder) 0]
|
||||
[(maybe-ufixnum) 0 -1 (+ (most-positive-fixnum) 1) 'a]
|
||||
[(maybe-uint) 0 -1 'a]
|
||||
[(maybe-timeout) *time 371]
|
||||
[(message-condition) (make-message-condition 17) (make-who-condition 'who) 'q #f]
|
||||
[(number) 1+2i 'oops #f]
|
||||
[(nzuint) 1 0 'a #f]
|
||||
[(old-hash-table) *old-hash-table '((a . b)) #f]
|
||||
[(output-port) (current-output-port) 0 *binary-input-port *textual-input-port #f]
|
||||
[(pair) '(a . b) 'a #f]
|
||||
[(pathname) "a" 'a #f]
|
||||
[(pfixnum) 1 0 #f]
|
||||
[(port) (current-input-port) 0 #f]
|
||||
[(procedure) values 0 #f]
|
||||
[(ptr) 1.0+2.0i]
|
||||
[(rational) 1/2 1+2i #f]
|
||||
[(rcd) *rcd *rtd "" #f]
|
||||
[(real) 1/2 1+2i #f]
|
||||
[(record) *record '#(a) #f]
|
||||
[(rtd) *rtd *record "" #f]
|
||||
[(s16) -1 'q (expt 2 15) (- -1 (expt 2 15)) #f]
|
||||
[(s24) -1 'q (expt 2 23) (- -1 (expt 2 23)) #f]
|
||||
[(s32) -1 'q (expt 2 31) (- -1 (expt 2 31)) #f]
|
||||
[(s40) -1 'q (expt 2 39) (- -1 (expt 2 39)) #f]
|
||||
[(s48) -1 'q (expt 2 47) (- -1 (expt 2 47)) #f]
|
||||
[(s56) -1 'q (expt 2 55) (- -1 (expt 2 55)) #f]
|
||||
[(s64) -1 'q (expt 2 63) (- -1 (expt 2 63)) #f]
|
||||
[(s8) -1 'q (expt 2 7) (- -1 (expt 2 7)) #f]
|
||||
[(sfd) *sfd '(q) #f]
|
||||
[(sint) -1 'q #f]
|
||||
[(source-condition) (make-source-condition 17) (make-who-condition 'who) #f]
|
||||
[(source-object) *source-object '#&a #f]
|
||||
[(sstats) *sstats '#(0 2 7 3) #f]
|
||||
[(string) "a" 'a #f]
|
||||
[(sub-ptr) no-good]
|
||||
[(sub-uint sub-ufixnum sub-index sub-length sub-list sub-fixnum sub-flonum sub-integer sub-number sub-port sub-rtd sub-sint sub-string sub-symbol sub-textual-output-port sub-vector) no-good #!eof #f]
|
||||
[(maybe-sub-rcd maybe-sub-symbol) no-good #!eof]
|
||||
[(symbol) 'a 0 "a" #f]
|
||||
[(symbol-hashtable) *symbol-hashtable *eq-hashtable '() #f]
|
||||
[(syntax-violation) (make-syntax-violation '(if) #f) 'oops #f]
|
||||
[(textual-input-port) (current-input-port) 0 *binary-input-port *textual-output-port #f]
|
||||
[(textual-output-port) (current-output-port) 0 *binary-output-port *textual-input-port #f]
|
||||
[(time) *time "no-time" #f]
|
||||
[(time-utc) *time-utc "no-time" #f]
|
||||
[(timeout) *time "no-time" #f]
|
||||
[(transcoder) (native-transcoder) 0 #f]
|
||||
[(u16) 0 -1 (expt 2 16) "a" #f]
|
||||
[(u24) 0 -1 (expt 2 24) "a" #f]
|
||||
[(u32) 0 -1 (expt 2 32) "a" #f]
|
||||
[(u40) 0 -1 (expt 2 40) "a" #f]
|
||||
[(u48) 0 -1 (expt 2 48) "a" #f]
|
||||
[(u56) 0 -1 (expt 2 56) "a" #f]
|
||||
[(u64) 0 -1 (expt 2 64) "a" #f]
|
||||
[(u8) 0 -1 (expt 2 8) "a" #f]
|
||||
[(u8/s8) -1 'q (expt 2 8) (- -1 (expt 2 7)) #f]
|
||||
[(ufixnum) 0 -1 (+ (most-positive-fixnum) 1) 'a #f]
|
||||
[(uint) 0 -1 'a #f]
|
||||
[(uinteger) 9.0 -1 -1.0 'a #f]
|
||||
[(uptr) 0 -1 'a (+ *max-uptr 1) #f]
|
||||
[(uptr/iptr) -1 'q (+ *max-uptr 1) (- *min-iptr 1) #f]
|
||||
[(vector) '#(a) "a" #f]
|
||||
[(who-condition) (make-who-condition 'me) (make-message-condition "hello") 'the-who #f]
|
||||
[(who) 'who 17])
|
||||
(meta-cond
|
||||
[(memq 'pthreads feature*)
|
||||
(declare-types
|
||||
[(condition-object) (make-condition) "not a mutex" #f]
|
||||
[(mutex) (make-mutex) "not a mutex" #f])])
|
||||
ht))
|
||||
(define (fuzz-prim-args name unprefixed-name lib* flag* in*/out**)
|
||||
(define (prefix=? prefix str)
|
||||
(let ([n (string-length prefix)])
|
||||
(and (>= (string-length str) n)
|
||||
(string=? (substring str 0 n) prefix))))
|
||||
(define (who=? x y)
|
||||
(define ->string (lambda (x) (if (symbol? x) (symbol->string x) x)))
|
||||
(equal? (->string x) (->string y)))
|
||||
(define-syntax flags-set? (syntax-rules () [(_ x ...) (and (memq 'x flag*) ...)]))
|
||||
(define good/bad
|
||||
(lambda (in* k)
|
||||
(unless (null? (remq '... (remq 'ptr in*)))
|
||||
(let loop ([in* in*] [rgood* '()] [rbad** '()])
|
||||
(if (null? in*)
|
||||
(k (reverse rgood*) (reverse rbad**))
|
||||
(let ([in (car in*)] [in* (cdr in*)])
|
||||
(cond
|
||||
[(eq? in '...)
|
||||
(assert (not (null? rgood*)))
|
||||
(let ([good (car rgood*)] [bad* (car rbad**)])
|
||||
(loop in* (cdr rgood*) (cdr rbad**))
|
||||
(loop in* rgood* rbad**)
|
||||
(loop in* (cons good rgood*) (cons bad* rbad**))
|
||||
(loop in* (cons* good good rgood*) (cons* bad* bad* rbad**)))]
|
||||
[(pair? in)
|
||||
(loop in*
|
||||
(cons `'(quote ,(let f ([x in])
|
||||
(cond
|
||||
[(pair? x) (cons (f (car x)) (f (cdr x)))]
|
||||
[(eq? x 'ptr) 0]
|
||||
[else (errorf 'fuzz-prim-args "unhandled type ~s" in)])))
|
||||
rgood*)
|
||||
(cons '((quote ())) rbad**))]
|
||||
[(symbol-hashtable-ref type-table in #f) =>
|
||||
(lambda (good.bad*)
|
||||
(loop in* (cons (car good.bad*) rgood*) (cons (cdr good.bad*) rbad**)))]
|
||||
[else (errorf 'fuzz-prim-args "unhandled type ~s" in)])))))))
|
||||
(when (flags-set? primitive proc)
|
||||
(for-each
|
||||
(lambda (in*)
|
||||
(good/bad in*
|
||||
(lambda (good* bad**)
|
||||
(let loop ([good* good*] [bad** bad**] [rgood* '()])
|
||||
(unless (null? good*)
|
||||
(unless (or (memq 'no-good rgood*) (memq 'no-good (cdr good*)))
|
||||
(for-each
|
||||
(lambda (bad)
|
||||
(let ([bad (eval bad env)])
|
||||
(let ([call `(,name ,@(reverse rgood*) ',bad ,@(cdr good*))])
|
||||
(printf "testing ~s\n" call)
|
||||
(flush-output-port)
|
||||
(let ([c (call/cc
|
||||
(lambda (k)
|
||||
(with-exception-handler
|
||||
(lambda (c) (unless (warning? c) (k c)))
|
||||
(lambda () (eval call env) #f))))])
|
||||
(if c
|
||||
(if (and (violation? c)
|
||||
(not (and (syntax-violation? c)
|
||||
(message-condition? c)
|
||||
(equal? (condition-message c) "invalid syntax")))
|
||||
(not (and (irritants-condition? c)
|
||||
; split up so we can grep for "invalid memory reference" in mat output and not see this
|
||||
(member (string-append "invalid" " " "memory reference") (condition-irritants c)))))
|
||||
(begin
|
||||
; try to weed out common error messages
|
||||
(if (or (and (message-condition? c)
|
||||
(format-condition? c)
|
||||
(irritants-condition? c)
|
||||
(string=? (condition-message c) "attempt to apply non-procedure ~s")
|
||||
(equal? (condition-irritants c) (list bad)))
|
||||
(and (who-condition? c)
|
||||
(message-condition? c)
|
||||
(format-condition? c)
|
||||
(irritants-condition? c)
|
||||
(or (who=? (condition-who c) name)
|
||||
(who=? (condition-who c) (#%$sgetprop name '*unprefixed* #f)))
|
||||
(or (and (or (prefix=? "~s is not a" (condition-message c))
|
||||
(prefix=? "~s is not #f or a" (condition-message c))
|
||||
(prefix=? "index ~s is not a" (condition-message c))
|
||||
(member (condition-message c)
|
||||
'("~s is circular"
|
||||
"incorrect list structure ~s"
|
||||
"improper list structure ~s"
|
||||
"attempt to apply non-procedure ~s"
|
||||
"undefined for ~s"
|
||||
"invalid endianness ~s"
|
||||
"invalid start value ~s"
|
||||
"invalid count value ~s"
|
||||
"invalid count ~s"
|
||||
"invalid size ~s"
|
||||
"invalid index ~s"
|
||||
"invalid report specifier ~s"
|
||||
"invalid record name ~s"
|
||||
"invalid parent ~s"
|
||||
"invalid uid ~s"
|
||||
"invalid field vector ~s"
|
||||
"invalid field specifier ~s"
|
||||
"invalid record constructor descriptor ~s"
|
||||
"invalid size argument ~s"
|
||||
"invalid count argument ~s"
|
||||
"cyclic list structure ~s"
|
||||
"invalid time-zone offset ~s"
|
||||
"unrecognized time type ~s"
|
||||
"invalid number of seconds ~s"
|
||||
"invalid nanosecond ~s"
|
||||
"invalid generation ~s"
|
||||
"invalid limit ~s"
|
||||
"invalid level ~s"
|
||||
"invalid buffer argument ~s"
|
||||
"invalid space ~s"
|
||||
"invalid value ~s"
|
||||
"invalid library name ~s"
|
||||
"invalid extension list ~s"
|
||||
"invalid eval-when list ~s"
|
||||
"invalid dump ~s"
|
||||
"invalid argument ~s"
|
||||
"invalid bit index ~s"
|
||||
"invalid situation ~s"
|
||||
"invalid foreign address ~s"
|
||||
"invalid foreign type specifier ~s"
|
||||
"invalid foreign address ~s"
|
||||
"invalid path ~s"
|
||||
"invalid path list ~s"
|
||||
"~s is not between 2 and 36"
|
||||
"invalid palette ~s"
|
||||
"bit argument ~s is not 0 or 1"
|
||||
"unrecognized type ~s"
|
||||
"invalid code page ~s")))
|
||||
(equal? (condition-irritants c) (list bad)))
|
||||
(and (or (member (condition-message c)
|
||||
'("~s is not a valid index for ~s"
|
||||
"~s is not a valid size for ~s"
|
||||
"invalid index ~s for bytevector ~s"
|
||||
"invalid new length ~s for ~s"))
|
||||
(prefix=? "invalid message argument ~s" (condition-message c))
|
||||
(prefix=? "invalid who argument ~s" (condition-message c)))
|
||||
(let ([ls (condition-irritants c)])
|
||||
(and (not (null? ls)) (equal? (car ls) bad)))))))
|
||||
; if it looks good, print to stdout
|
||||
(fprintf (mat-output) "seemingly appropriate argument-type error testing ~s: " call)
|
||||
; otherwise, mark it as an expected error for user audit
|
||||
(fprintf (mat-output) "Expected error testing ~s: " call))
|
||||
(display-condition c (mat-output))
|
||||
(newline (mat-output)))
|
||||
(errorf 'fuzz-prim-args "unexpected exception occurred evaluating ~s: ~a" call
|
||||
(with-output-to-string (lambda () (display-condition c)))))
|
||||
(errorf 'fuzz-prim-args "no exception occurred evaluating ~s" call))))))
|
||||
(car bad**)))
|
||||
(loop (cdr good*) (cdr bad**) (cons (car good*) rgood*)))))))
|
||||
(map car in*/out**))))
|
||||
(meta-cond
|
||||
[(file-exists? "../s/primdata.ss") (include "../s/primdata.ss")]
|
||||
[else (include "../../s/primdata.ss")])
|
||||
#t))
|
||||
)
|
||||
|
||||
(mat nonprocedure-value
|
||||
(begin
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(guard (c [else (unless (equal? (condition-message c) "variable ~:s is not bound")
|
||||
(errorf #f "wrong error for ~s (~a)" x (with-output-to-string (lambda () (display-condition c)))))])
|
||||
(parameterize ([optimize-level 2])
|
||||
(eval `(,x)))
|
||||
(errorf #f "no error for ~s" x)))
|
||||
(remp (lambda (x) (or (top-level-bound? x) (top-level-syntax? x))) (oblist)))
|
||||
#t)
|
||||
(begin
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(guard (c [else (unless (equal? (condition-message c) "attempt to apply non-procedure ~s")
|
||||
(errorf #f "wrong error for ~s (~a)" x (with-output-to-string (lambda () (display-condition c)))))])
|
||||
(parameterize ([optimize-level 2])
|
||||
(eval `(,x)))
|
||||
(errorf #f "no error for ~s" x)))
|
||||
(filter (lambda (x) (and (top-level-bound? x) (not (procedure? (top-level-value x))))) (oblist)))
|
||||
#t)
|
||||
)
|
||||
|
||||
(mat make-parameter
|
||||
(begin (define p (make-parameter #f not)) #t)
|
||||
(p)
|
||||
(begin (p #f) (p))
|
||||
(begin (p #t) (not (p)))
|
||||
(begin (define q (make-parameter #t)) #t)
|
||||
(q)
|
||||
(begin (q #f) (not (q)))
|
||||
(begin (q #t) (q))
|
||||
(error? (make-parameter 1 2))
|
||||
(begin
|
||||
(define p
|
||||
(make-parameter 5
|
||||
(lambda (x) (+ x 1))))
|
||||
#t)
|
||||
(eqv? (p) 6)
|
||||
(error? (p 'a))
|
||||
(error? (make-parameter 3 (lambda (x y) x)))
|
||||
)
|
||||
|
||||
(mat parameterize
|
||||
(begin (define p (make-parameter #f not)) #t)
|
||||
(begin (define q (make-parameter #t)) #t)
|
||||
(begin (p #f) (p))
|
||||
(begin (q #t) (q))
|
||||
(parameterize ([p #t] [q #f])
|
||||
(and (not (p)) (not (q))))
|
||||
(not (p))
|
||||
(q)
|
||||
(parameterize () #t)
|
||||
(eq? (parameterize () (define x 4) x) 4)
|
||||
(let* ((x (make-parameter 'a)) (f (lambda () (x))))
|
||||
(and
|
||||
(parameterize ((x 'b))
|
||||
(and (eq? (x) 'b) (eq? (f) 'b)))
|
||||
(eq? (x) 'a)
|
||||
(eq? (f) 'a)))
|
||||
(let* ((x (make-parameter 'a)) (f (lambda () (x))))
|
||||
(and
|
||||
(call/cc
|
||||
(lambda (return)
|
||||
(parameterize ((x 'b))
|
||||
(return (and (eq? (x) 'b) (eq? (f) 'b))))))
|
||||
(eq? (x) 'a)
|
||||
(eq? (f) 'a)))
|
||||
(equal?
|
||||
(let* ((x (make-parameter 'a)) (f (lambda () (x))))
|
||||
((call/cc
|
||||
(lambda (return)
|
||||
(parameterize ((x 'b))
|
||||
(call/cc
|
||||
(lambda (back)
|
||||
(return back)))
|
||||
(let ((ans (f))) (lambda (y) (list ans (x)))))))
|
||||
'()))
|
||||
'(b a))
|
||||
(error? ; invalid number of arguments to #<procedure x>
|
||||
(let ([x (lambda (x) #t)]) (parameterize ([x 7]) 4)))
|
||||
; make sure nothing silly happens if we parameterize the same parameter
|
||||
(begin (define q (make-parameter 0)) #t)
|
||||
(eqv? (parameterize ([q 2] [q 2]) (q)) 2)
|
||||
(eqv? (q) 0)
|
||||
)
|
||||
|
||||
(define id (lambda (x) x))
|
||||
|
||||
(define $big (+ (most-positive-fixnum) 1))
|
||||
|
||||
(define ok
|
||||
(lambda (p v)
|
||||
(parameterize ([p v]) (equal? (p) v))))
|
||||
|
||||
(mat case-sensitive
|
||||
(case-sensitive)
|
||||
(ok case-sensitive #f)
|
||||
(ok case-sensitive #t)
|
||||
)
|
||||
|
||||
(mat collect-generation-radix
|
||||
(fxpositive? (collect-generation-radix))
|
||||
(ok collect-generation-radix 1)
|
||||
(error? (collect-generation-radix 'a))
|
||||
(error? (collect-generation-radix -1))
|
||||
(error? (collect-generation-radix 0))
|
||||
)
|
||||
|
||||
(mat collect-notify
|
||||
(not (collect-notify))
|
||||
(ok collect-notify #t)
|
||||
(ok collect-notify #f)
|
||||
)
|
||||
|
||||
(mat collect-request-handler
|
||||
(procedure? (collect-request-handler))
|
||||
(ok collect-request-handler (collect-request-handler))
|
||||
(error? (collect-request-handler #f))
|
||||
)
|
||||
|
||||
(mat collect-trip-bytes
|
||||
(fxpositive? (collect-trip-bytes))
|
||||
(ok collect-trip-bytes 100)
|
||||
(error? (collect-trip-bytes -100))
|
||||
(error? (collect-trip-bytes $big))
|
||||
)
|
||||
|
||||
(mat current-eval
|
||||
(procedure? (current-eval))
|
||||
(ok current-eval id)
|
||||
(error? (current-eval '#()))
|
||||
)
|
||||
|
||||
(mat current-input-port
|
||||
(input-port? (current-input-port))
|
||||
(ok current-input-port (open-input-string ""))
|
||||
(error? (current-input-port (open-output-string)))
|
||||
)
|
||||
|
||||
(mat current-output-port
|
||||
(output-port? (current-output-port))
|
||||
(ok current-output-port (open-output-string))
|
||||
(error? (current-output-port (open-input-string "hello")))
|
||||
)
|
||||
|
||||
(mat eval-syntax-expanders-when
|
||||
(= (length (eval-syntax-expanders-when)) 3)
|
||||
(equal?
|
||||
(andmap (lambda (x) (memq x '(compile load eval)))
|
||||
(eval-syntax-expanders-when))
|
||||
'(eval))
|
||||
(ok eval-syntax-expanders-when '(compile))
|
||||
(ok eval-syntax-expanders-when '())
|
||||
(error? (eval-syntax-expanders-when '(compiling)))
|
||||
)
|
||||
|
||||
(mat generate-interrupt-trap
|
||||
(generate-interrupt-trap)
|
||||
(ok generate-interrupt-trap #t)
|
||||
(ok generate-interrupt-trap #f)
|
||||
)
|
||||
|
||||
(mat gensym-count
|
||||
(nonnegative? (gensym-count))
|
||||
(ok gensym-count 0)
|
||||
(ok gensym-count $big)
|
||||
(error? (gensym-count "g"))
|
||||
)
|
||||
|
||||
(mat gensym-prefix
|
||||
(string? (gensym-prefix))
|
||||
(ok gensym-prefix "hi")
|
||||
)
|
||||
|
||||
(mat keyboard-interrupt-handler
|
||||
(procedure? (keyboard-interrupt-handler))
|
||||
(ok keyboard-interrupt-handler id)
|
||||
(error? (keyboard-interrupt-handler 0))
|
||||
)
|
||||
|
||||
(mat optimize-level
|
||||
(fx<= 0 (optimize-level) 3)
|
||||
(ok optimize-level 0)
|
||||
(ok optimize-level 1)
|
||||
(ok optimize-level 2)
|
||||
(ok optimize-level 3)
|
||||
(error? (optimize-level 4))
|
||||
)
|
||||
|
||||
(mat pretty-line-length
|
||||
(fxpositive? (pretty-line-length))
|
||||
(ok pretty-line-length 10)
|
||||
(error? (pretty-line-length -1))
|
||||
(error? (pretty-line-length $big))
|
||||
)
|
||||
|
||||
(mat pretty-one-line-limit
|
||||
(fxpositive? (pretty-one-line-limit))
|
||||
(ok pretty-one-line-limit 100)
|
||||
(error? (pretty-one-line-limit 0))
|
||||
(error? (pretty-one-line-limit $big))
|
||||
)
|
||||
|
||||
(mat print-gensym
|
||||
(print-gensym)
|
||||
(ok print-gensym #f)
|
||||
(ok print-gensym #t)
|
||||
(ok print-gensym 'pretty)
|
||||
)
|
||||
|
||||
(mat print-graph
|
||||
(not (print-graph))
|
||||
(ok print-graph #f)
|
||||
(ok print-graph #t)
|
||||
)
|
||||
|
||||
(mat print-length
|
||||
(not (print-length))
|
||||
(ok print-length 100)
|
||||
(ok print-length #f)
|
||||
(error? (print-length -1))
|
||||
(error? (print-length $big))
|
||||
(error? (print-length '()))
|
||||
)
|
||||
|
||||
(mat print-level
|
||||
(not (print-level))
|
||||
(ok print-level 100)
|
||||
(ok print-level #f)
|
||||
(error? (print-level -1))
|
||||
(error? (print-level $big))
|
||||
)
|
||||
|
||||
(mat print-radix
|
||||
(fx= (print-radix) 10)
|
||||
(ok print-radix 2)
|
||||
(ok print-radix 36)
|
||||
(error? (print-radix 37))
|
||||
(error? (print-radix 1))
|
||||
)
|
||||
|
||||
(mat timer-interrupt-handler
|
||||
(procedure? (timer-interrupt-handler))
|
||||
(ok timer-interrupt-handler id)
|
||||
(error? (timer-interrupt-handler 'midnight))
|
||||
)
|
||||
|
||||
(mat trace-output-port
|
||||
(eq? (trace-output-port) (console-output-port))
|
||||
(ok trace-output-port (open-output-string))
|
||||
(error? (trace-output-port (open-input-string "hello")))
|
||||
)
|
||||
|
||||
Reference in a new issue