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
|
;; typecheck-gen.lsp - functions to support regression testing
;; of examples that would normally raise errors. This redefines
;; error handling and generates unit tests by running the code.
;; unit tests are written to typechecks<N>.sal
(defun ny:error (src index typ val &optional multi (val2 nil second-val))
(display "ny:error" src index typ val)
(setf *expect-nyerror* (list src index typ))
(setf *error-msg*
(strcat "In " src "," (index-to-string index) " argument"
(if (second typ) (strcat " (" (second typ) ")") "")
" must be a "
(ny:type-list-as-string (first typ) multi)
", got " (param-to-string val)
(if second-val (strcat ", and" (param-to-string val2)) "")))
(throw 'simulated-error))
(defun sal-print (&rest args)
(if (/= (length args) 1)
(error-original "redefined sal-print expects single argument" args))
(setf *expect-print* (car args)))
(defun s-plot (snd &optional (dur 2) (n 1000))
;; these are copied from the "real" s-plot:
(ny:typecheck (not (soundp snd))
(ny:error "S-PLOT (or PLOT command)" 1 '((SOUND) nil) snd))
(ny:typecheck (not (numberp dur))
(ny:error "S-PLOT (or PLOT command)" 2 '((NUMBER) "dur") dur))
(ny:typecheck (not (integerp n))
(ny:error "S-PLOT (or PLOT command)" 3 '((INTEGER) nil) n))
(setf *expect-plot* t))
(setfn error-original error)
(defun error (x &optional y)
(setf *expect-error* x)
(throw 'simulated-error))
(defun print-arg (arg outf)
(cond ((arrayp arg)
(princ "vector(" outf)
(let (need-comma)
(dotimes (i (length arg))
(if need-comma (princ ", " outf) (setf need-comma t))
(print-arg (aref arg i) outf))
(princ ")" outf)))
((listp arg)
(princ "{" outf)
(let (need-space)
(dolist (a arg)
(if need-space (princ " " outf) (setf need-space t))
(print-arg a outf)))
(princ "}" outf))
(t
(prin1 arg outf))))
(defun escaped (line)
(let ((rslt "\"") ch)
(dotimes (i (length line))
(setf ch (char line i))
(setf rslt (strcat rslt (if (equal ch #\") "\\\""
(string ch)))))
(strcat rslt "\"")))
;; this function generates the "unit test" to check for what
;; just happened when we executed the previous command
;; what can be :print :plot :error or :nyerror
;; command looks like:
;; (ny:expect expression what val)
;;
(defun expect-gen (line outf)
(princ "exec ny:expect(" outf)
(princ line outf)
(princ ",\n " outf)
(cond (*expect-print*
(princ ":print, " outf)
(print-arg *expect-print* outf))
(*expect-plot*
(princ ":plot, " outf)
(prin1 *expect-plot* outf))
(*expect-nyerror*
(princ ":nyerror, " outf)
(print-arg *expect-nyerror* outf))
(*expect-error*
(princ ":error, " outf)
(prin1 *expect-error* outf))
(t
(close outf)
(error-original "in expect-gen, nothing happened?")))
(princ ")\n" outf)
(princ "exec #print(" outf)
(princ line outf)
(princ ")\n" outf))
(defun is-a-command (line)
(and (> (length line) 0)
(not (eql #\; (char line 0)))))
(defun generate-line (line outf)
(setf *expect-print* nil *expect-plot* nil
*expect-error* nil *expect-nyerror* nil
*error-msg* nil)
(catch 'simulated-error
(sal-compile line t nil "<typecheck-gen>"))
;; after execution, see what happened and generate unit test
(setf line (escaped line))
(expect-gen line outf)
(format outf "exec catch(quote(simulated-error), ~%")
(format outf " sal-compile(~A, #t, #f,~%" line)
(format outf " \"<in typecheck.sal>\"))~%")
(if *error-msg* (format outf "; ERROR MSG: ~A~%" *error-msg*))
(format outf "~%"))
;; There was a stack overflow problem putting everything into
;; a 3000-line SAL file, so separate the tests into multiple files
(setf *tests-per-file* 100)
(defun generate ()
(let ((inf (open "typechecks.txt"))
(mainf (open "typechecks.lsp" :direction :output))
outf
outf-name
(file-count 0)
(test-count *tests-per-file*)
line)
;; test for successful open file operations
(if (not inf) (error-original "could not open typechecks.txt"))
(if (not mainf) (error-original "could not open for output typechecks.lsp"))
;; write header info
(format mainf "; typechecks.lsp -- unit tests for typechecks~%")
(format mainf "; ~%")
(format mainf "; This code was generated from typechecks.txt by~%")
(format mainf "; typecheck-gen.lsp~%~%")
;; process every test
(while (setf line (read-line inf))
(cond ((is-a-command line)
(cond ((>= test-count *tests-per-file*)
(if outf (close outf))
(setf test-count 0)
(setf file-count (1+ file-count))
(setf outf-name (format nil "typechecks~A.sal" file-count))
(setf outf (open outf-name :direction :output))
(if (not outf) (error-original "could not open" outf-name))
;; add file to main file
(format mainf "(sal-load \"~A\")\n" outf-name)
;; write the header information
(format outf "; ~A -- unit tests for typechecks~%" outf-name)
(format outf "; ~%")
(format outf "; This code was generated from typechecks.txt by~%")
(format outf "; typecheck-gen.lsp~%~%")))
(format t "line: |~s|\n" line)
(generate-line line outf)
(setf test-count (1+ test-count)))))
(close outf)
(close inf)
(close mainf)))
(generate)
|
