This repository has been archived on 2022-08-10. You can view files and clone it, but cannot push or open issues or pull requests.
chez-openbsd/mats/primvars.ms
2022-07-29 15:12:07 +02:00

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")))
)