blob: c36a5f2b37da901e518903d99d89da2c92832391 (
plain)
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
|
(in-package :cl-forth)
(defun drop-file-type (file &key (returns :string))
(let* ((file-str (namestring file))
(dropped (subseq file-str 0 (position #\. file-str))))
(case returns
(:string dropped)
(:file (pathname dropped)))))
(defun change-file-type (file new-type &key (returns :string))
(let* ((pathn (pathname file))
(new-file (format nil "~a.~a"
(drop-file-type pathn)
new-type)))
(case returns
(:string new-file)
(:file (pathname new-file)))))
(defun lex-stream (str)
(iter outer
(for line = (read-line str nil nil))
(until (null line))
(for line-num from 1)
(appending (lex-line line line-num))))
(defun read-form-comment (str)
(read-from-string
(format nil "~{~a~^~%~}"
(iter (for ch = (peek-char t str nil nil))
(while ch)
(cond ((char= ch #\;)
(iter (for ch = (read-char str nil nil))
(while (and ch (char= #\; ch))))
(collect (read-line str)))
(t (finish)))))))
(defun run-test (path)
"File must begin with 2 comments:
First must be TEST
Second must eval to the expected result"
(let ((abs-path (if (cl-fad:pathname-absolute-p path)
path
(from-root path)))
(successful nil))
(with-open-file (str abs-path)
(unless (string-equal "test" (second (uiop:split-string
(read-line str)
:separator '(#\Space))))
(return-from run-test 'not-test))
(let ((expected-output (eval (read-form-comment str))))
(generate-program (parse-tokens (lex-stream str))
:path (change-file-type abs-path "asm")
:compile t :silence t)
(let ((output (run (list (drop-file-type abs-path))
:output :string :silence t)))
(format t "testing ~a... " (pathname-name path))
(if (string= expected-output output)
(progn (format t "successful~%") (setf successful t))
(format t "~{~a~%~}"
(list "failed"
"---expected output---"
expected-output
"---actual output---"
output))))
;; delete generated .asm .o and executable file
(delete-file (probe-file (change-file-type abs-path "asm")))
(delete-file (probe-file (change-file-type abs-path "o")))
(delete-file (probe-file (drop-file-type abs-path)))))
successful))
(defun run-tests ()
(loop for success?
in (mapcar #'run-test
(remove-if-not (lambda (file)
(string= "lorth" (pathname-type file)))
(cl-fad:list-directory
(from-root "test"))))
counting (eq t success?) into succs
counting (null success?) into fails
finally (format t "~a success, ~a fail~%" succs fails)))
;; (defun test-from-string (string expected-output &key (silence t))
;; (generate-program (parse-tokens (lex-string string))
;; :path "test/test.asm" :compile t :silence silence)
;; (let ((output (run '("test/test") :output :string :silence silence)))
;; (if (string= expected-output output)
;; t
;; (format t "~{~a~%~}"
;; (list "test failed"
;; "---expected output---"
;; expected-output
;; "---actual output---"
;; output)))))
;; (defun run-tests ()
;; (test-from-string "3 6 + dump" (format nil "9~%"))
;; (test-from-string
;; "0 döngü eş 4 < iken
;; eş dump
;; 1 +
;; yap"
;; (format nil "~{~a~%~}" '(0 1 2 3)))
;; (test-from-string
;; "bel 0 + 97 yaz
;; bel 1 + 98 yaz
;; bel 2 + 99 yaz
;; bel 3 + 10 yaz
;; 1 bel 4 1 syscall-3
;; bel 0 + eş oku 1 + yaz
;; bel 1 + eş oku 1 + yaz
;; bel 2 + eş oku 1 + yaz
;; 1 bel 4 1 syscall-3
;; 0 60 syscall-1"
;; (format nil "abc~%bcd~%")))
|
