48db0a9405
loadability without actually loading; also, support for unregistering
guarded objects.
- improved error reporting for library compilation-instance errors:
now including the name of the object file from which the "wrong"
compilation instance was loaded, if it was loaded from (or compiled
to) an object file and the original importing library, if it was
previously loaded from an object file due to a library import.
syntax.ss, 7.ss, interpret.ss,
8.ms, root-experr*
- removed situation and for-input? arguments from $make-load-binary,
since the only consumer always passes 'load and #f.
7.ss,
scheme.c
- $separate-eval now prints the stderr and stdout of the subprocess
to help in diagnosing separate-eval and separate-compile issues.
mat.ss
- added unregister-guardian, which can be used to unregister
the unressurected objects registered with any guardian. guardian?
can be used to distinguish guardian procedures from other objects.
cp0.ss, cmacros.ss, cpnanopass.ss, ftype.ss, primdata.ss,
prims.ss,
gcwrapper.c, prim.c, externs.h,
4.ms, primvars.ms
release_notes.stex
smgmt.stex, threads.stex
- added verify-loadability. given a situation (visit, revisit,
or load) and zero or more pathnames (each of which may be optionally
paired with a library search path), verity-loadability checks
whether the set of object files named by those pathnames and any
additional object files required by library requirements in the
given situation can be loaded together. it raises an exception
in each case where actually attempting to load the files would
raise an exception and additionally in cases where loading files
would result in the compilation or loading of source files in
place of the object files. if the check is successful,
verity-loadability returns an unspecified value. in either case,
although portions of the object files are read, none of the
information read from the object files is retained, and none of
the object code is read, so there are no side effects other than
the file operations and possibly the raising of an exception.
library and program info records are now moved to the top of each
object file produced by one of the file compilation routines,
just after recompile info, with a marker to allow verity-loadability
to stop reading once it reads all such records. this change is
not entirely backward compatible; the repositioning of the records
can be detected by a call to list-library made from a loaded file
before the definition of one or more libraries. it is fully
backward compatible for typical library files that contain a
single library definition and nothing else. adding this feature
required changes to the object-file format and corresponding
changes in the compiler and library manager. it also required
moving cross-library optimization information from library/ct-info
records (which verity-loadability must read) to the invoke-code
for each library (which verity-loadability does not read) to
avoid reading and permanently associating record-type descriptors
in the code with their uids.
compile.ss, syntax.ss, expand-lang.ss, primdata.ss, 7.ss,
7.ms, misc.ms, root-experr*, patch*,
system.stex, release_notes.stex
- fixed a bug that bit only with the compiler compiled at
optimize-level 2: add-library/rt-records was building a library/ct-info
wrapper rather than a library/rt-info wrapper.
compile.ss
- fixed a bug in visit-library that could result in an indefinite
recursion: it was not checking to make sure the call to $visit
actually added compile-time info to the libdesc record. it's not
clear, however, whether the libdesc record can be missing
compile-time information on entry to visit-library, so the code
that calls $visit (and now checks for compile-time information
having been added) might not be reachable. ditto for
revisit-library.
syntax.ss
syntax.ss, primdata.ss,
7.ms, root-experr*, patch*,
system.stex, release_notes.stex
- added some argument-error checks for library-directories and
library-extensions, and fixed up the error messages a bit.
syntax.ss,
7.ms, root-experr*
- compile-whole-program now inserts the program record into the
object file for the benefit of verify-loadability.
syntax.ss,
7.ms, root-experr*
- changed 'loading' import-notify messages to the more precise
'visiting' or 'revisiting' in a couple of places.
syntax.ss,
7.ms, 8.ms
original commit: b911ed47190727b0e1d6a88c0e473d1757accdcd
911 lines
44 KiB
Scheme
911 lines
44 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*
|
|
*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) (include "../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 '#() #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")))
|
|
)
|
|
|