919 lines
45 KiB
Scheme
919 lines
45 KiB
Scheme
;;; 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")))
|
|
)
|
|
|