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
|
(defvar *compile-test*)
(defmacro error-to-sym (expr)
^(catch ,expr
(error (cond) :error)
(warning (cond) :warning)))
(defmacro vtest (:env env expr expected)
(if-match (quote @(as sym @(or :error :warning))) expected
(set expected sym))
(if *compile-test*
(with-compile-opts (nil unused)
(if (meq expected :error :warning)
(with-gensyms (code)
^(let ((,code (catch
(compile-toplevel ',expr)
(error (exc)
(if (eq ,expected :warning)
(error "test case ~s produced error during compilation, expected ~s"
',expr ,expected)))
(warning (exc)
(if (eq ,expected :error)
(error "test case ~s warned during compilation, expected ~s"
',expr ,expected))))))
(ifa (not (equal (error-to-sym (call ,code)) ,expected))
(error "test case ~s failed: produced ~s; expected ~s"
',expr it ,expected))))
(with-gensyms (expval)
^(let ((,expval ,expected))
(ifa (not (equal (call (compile-toplevel ',expr)) ,expval))
(error "test case ~s failed: produced ~s; expected ~s"
',expr it ,expval))))))
(if (meq expected :error :warning)
(catch
(let ((expr-expn (expand expr env)))
^(ifa (not (equal (error-to-sym ,expr-expn) ,expected))
(error "test case ~s failed: produced ~s; expected ~s"
',expr it ,expected)))
(error (exc)
(if (eq expected :warning)
(error "test case ~s produced error during expansion, expected ~s"
expr expected)))
(warning (exc)
(if (eq expected :error)
(error "test case ~s warned during expansion, expected ~s"
expr expected))))
(let ((expr-expn (expand expr env))
(expval (gensym)))
^(let ((,expval ,expected))
(ifa (not (equal ,expr-expn ,expval))
(error "test case ~s failed: produced ~s; expected ~s"
',expr it ,expval)))))))
(defmacro test (expr expected)
^(vtest ,expr ',expected))
(defmacro stest (expr expected)
^(vtest ,^(tostring ,expr) ,expected))
(defmacro sstest (expr expected)
^(vtest ,^(tostring ,expr) ,(tostring expected)))
(defmacro mtest (. pairs)
^(progn ,*(mapcar (op cons 'test) (tuples 2 pairs))))
(defmacro mvtest (. pairs)
^(progn ,*(mapcar (op cons 'vtest) (tuples 2 pairs))))
(defmacro mstest (. pairs)
^(progn ,*(mapcar (op cons 'stest) (tuples 2 pairs))))
(defun os-symbol ()
(if (ignerr (dlsym (dlopen "libandroid.so") "AAsset_close"))
:android
(let ((u (uname)))
[(orf (iff (f^ #/Linux/) (ret :linux))
(iff (f^ #/SunOS/) (ret :solaris))
(iff (f^ #/CYGWIN/) (ret :cygwin))
(iff (f^ #/CYGNAL/) (ret :cygnal))
(iff (f^ #/Darwin/) (ret :macos))
(iff (f^ #/OpenBSD/) (ret :openbsd))
(iff #/BSD/ (ret :bsd))
(ret :unknown))
u.sysname])))
(defun libc ()
(caseql (os-symbol)
((:cygwin :cygnal) (dlopen "cygwin1.dll"))
(t (dlopen nil))))
(defmacro with-temp-file ((name-var stream-var prefix) . body)
^(let* ((,stream-var (mkstemp ,prefix))
(,name-var (stream-get-prop ,stream-var :name)))
(unwind-protect
(progn ,*body)
(close-stream ,stream-var)
(remove-path ,name-var))))
|
