1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
|
;;; check signatures
(set! (hook-functions *unbound-variable-hook*) ())
(set! (*s7* 'print-length) 6)
;(set! (*s7* 'gc-stats) #t)
(if (provided? 'snd)
(begin
(format *stderr* "this won't work in Snd!~%")
(exit)))
(define max-args 3)
(define-constant one 1)
(define-constant auto-constants (list #f #t () #\a (/ (*s7* 'most-positive-fixnum)) (/ -1 (*s7* 'most-positive-fixnum)) 1.5+i
"hi455" :key hi: 'hi (list 1) (list 1 2) (cons 1 2) (list (list 1 2)) (list (list 1)) (list ()) #()
1/0+i 0+0/0i 0+1/0i 1+0/0i 0/0+0i 0/0+0/0i 1+1/0i 0/0+i cons ''2
1+i 1+1e10i 1e15+1e15i 0+1e18i 1e18 #\xff (string #\xff) 1e308
(*s7* 'most-positive-fixnum) (*s7* 'most-negative-fixnum) (- (*s7* 'most-positive-fixnum) 1) (+ (*s7* 'most-negative-fixnum) 1)
-1 0 0.0 1 1.5 1.0-1.0i 3/4 #\null -63 (make-hash-table) (hash-table '(a . 2) '(b . 3))
'((1 2) (3 4)) '((1 (2)) (((3) 4))) "" (list #i(1) "1") '(1 2 . 3) (list (cons 'a 2) (cons 'b 3))
#i(1 2) (vector 1 '(3)) (let ((x 3)) (lambda (y) (+ x y))) abs 'a 'b one
(lambda args args) (lambda* ((a 3) (b 2)) (+ a b)) (lambda () 3)
(sublet () 'a 1) ;(rootlet)
*load-hook* *error-hook* (random-state 123)
quasiquote macroexpand begin let letrec* if case cond (call-with-exit (lambda (goto) goto))
(with-baffle (call/cc (lambda (cc) cc)))
(string #\a #\null #\b) #2d((1 2) (3 4)) (inlet 'a 2 'b 3)
#<undefined> #<unspecified> (make-int-vector 3) (make-float-vector 3 -1.4)
(make-vector '(2 3) "hi") #("hiho" "hi" "hoho") (subvector (make-int-vector '(2 3) 1) '(6))
(subvector (subvector (make-float-vector '(2 3) 1.0) '(6)) '(2 2))
(vector-ref #2d((#i(1 2 3)) (#i(3 4 5))) 0 0) (define-macro (m a) `(+ ,a 1))
(c-pointer 0) (c-pointer -1) :readable :else (define-bacro* (m (a 1)) `(+ ,a 1))
(byte-vector 0 1 2) (byte-vector) (byte-vector 255 0 127) (make-iterator #((a . 2)))
(lambda (dir) 1.0) (float-vector) (make-float-vector '(2 32))
'((a . 1)) #i(1) '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)
#u(0 1 2) (openlet (inlet 'abs (lambda (x) (- x))))
(make-iterator (list 1 2 3)) (make-iterator "1") #<eof> #r2d((.1 .2) (.3 .4))
(dilambda (lambda () 1) (lambda (a) a))
(gensym)
))
(define car-auto-constants (car auto-constants))
(define-constant cdr-auto-constants (cdr auto-constants))
(define low 0)
(define-constant auto-arglists (vector (make-list 1) (make-list 2) (make-list 3) (make-list 4) (make-list 5) (make-list 6)))
(define (any? f sequence)
(and (pair? sequence)
(or (f (car sequence))
(any? f (cdr sequence)))))
(define (sig-ok? val typer)
(if (pair? typer)
(any? (lambda (ok?)
(or (memq ok? '(#t values))
((symbol->value ok?) val)))
typer)
(or (memq typer '(#t values))
((symbol->value typer) val))))
(define last-name1 "")
(define last-name2 "")
(define last-name3 "")
(define last-name4 "")
(define match-cases (list
caar cdar cadr cddr
caaar cdaar cddar cadar cdddr caadr cdadr caddr
caaaar caadar cadaar caddar cdaaar cdadar cddaar cdddar cddddr caaddr cadadr cddar cdaadr caaadr cddadr cadddr cdaddr
string->symbol ; "" as arg
list->string ; '(1) -- 1 is not a char
make-hash-table make-weak-hash-table ; pair of procedures
sublet ; pair of symbol/value
object->string ; wrong key
atan ; x real if y
make-int-vector make-float-vector make-vector make-byte-vector ; improper pair for dims
setter
call-with-output-string with-output-to-string call/cc ; cons etc
inlet ; pair but not (sym . val)
reverse! ; improper-list but its generic
inexact->exact ; NaN
))
(define mismatch-cases (list setter))
(define doc-cases (list any? sig-ok?))
(define-constant (autotest name func args args-now args-left sig)
(unless (negative? args-left)
(let ((c-args (vector-ref auto-arglists args-now)))
(copy args c-args)
(let ((p (list-tail c-args args-now)))
(call-with-exit
(lambda (quit)
(catch #t
(lambda ()
(let ((val (apply func args)))
(when (pair? sig)
(unless (string=? name last-name3)
(unless (sig-ok? val (car sig))
(set! last-name3 name)
(format *stderr* "got ~S from (~A~{~^ ~S~}), (sig: ~S)~%" val name args sig)))
(unless (or (string=? name last-name2)
(memq func mismatch-cases))
(for-each
(lambda (arg typer)
(unless (sig-ok? arg typer)
(set! last-name2 name)
(format *stderr* "mismatch? ~S in (~A~{~^ ~S~}), (sig: ~S in ~S)~%" arg name args typer sig)))
args (cdr sig))))))
(lambda (type info)
(let ((err (apply format #f info)))
(unless (string=? name last-name4)
(unless (string-position name err)
(set! last-name4 name)
(format *stderr* "~S ~S ~S~% ~S from ~S~%" name type (apply format #f info) info args))))
(when (and (not (string=? name last-name1))
(not (memq func match-cases))
(pair? args)
(pair? sig)
(eq? type 'wrong-type-arg))
(let ((pos (- (length args) 1)))
(when (sig-ok? (list-ref args pos) (list-ref (cdr sig) pos))
(set! last-name1 name)
(format *stderr* "incorrect match? ~S in (~A~{~^ ~S~}), (sig: ~S in ~S)~%"
(list-ref args pos) name args (list-ref (cdr sig) pos) sig)))
(quit))
(if (and (positive? args-now)
(memq type '(wrong-type-arg wrong-number-of-args out-of-range syntax-error io-error
division-by-zero format-error missing-method error invalid-escape-function)))
(quit))))
(let ((args-now1 (+ args-now 1))
(args-left1 (- args-left 1)))
(for-each
(lambda (c)
(set-car! p c)
(autotest name func c-args args-now1 args-left1 sig))
auto-constants))))))))
(define baddies '(exit emergency-exit abort autotest s7-optimize
all delete-file system set-cdr! stacktrace test-sym
cutlet varlet gc cond-expand reader-cond
openlet coverlet eval vector list cons hash-table* hash-table values
symbol-table load
global-environment current-environment make-rectangular
copy fill! hash-table-set! vector-set! let-set! list-values apply-values immutable!
mock-number mock-pair mock-string mock-char mock-vector mock-hash-table*
mock-symbol mock-port mock-hash-table m mock->string make-local-method
*mock-number* *mock-pair* *mock-string* *mock-char* *mock-vector*
*mock-symbol* *mock-port* *mock-hash-table* mp ms mv
*unbound-variable-hook* *load-hook* *rootlet-redefinition-hook* *missing-close-paren-hook* *read-error-hook*
tree-count ; signature is kinda silly here
error throw call-with-current-continuation call/cc *s7*
/ call-with-exit read-string *error-hook* make-hook hook-functions symbol vector-append append apply
c-define-1 apropos map-values
outlet-member make-method make-object))
(define (test-sym sym)
(if (and (not (memq sym baddies))
(defined? sym))
(let* ((f (symbol->value sym))
(strname (symbol->string sym))
(argn (and (or (procedure? f) (let? f)) (arity f))))
(when argn
(unless (memq f doc-cases)
(let ((doc (documentation f)))
(if (or (not doc)
(string=? doc ""))
(format *stderr* "~S documentation: ~S~%" sym doc)
(unless (string-position strname doc)
(format *stderr* "~S: doc: ~S~%" sym doc)))))
(let ((bottom (car argn))
(top (min (cdr argn) max-args)))
(if (not (memv (strname 0) '(#\{ #\[ #\()))
(begin
(format *stderr* "-------- ~A --------~%" sym)
(if (< top bottom)
(format *stderr* ";~A (bottom: ~A, top: ~A)...~%" sym bottom top))
;(format *stderr* ";~A...~%" sym))
(set! low bottom)
(if (positive? (cdr argn))
(autotest strname f () 0 top (signature f))))))))))
(define (all)
(let ((st (symbol-table)))
(for-each test-sym st)
;(test-sym 'object->string)
(format *stderr* "~%all done~%")
))
(all)
(exit)
|
