blob: 2def1e0d5d652e1e6c7629396ab76440e05a2f5f (
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
|
(in-package :monkey/test)
(defparameter *tests* (make-hash-table))
(defparameter *test-name* nil)
(eval-always
(defun make-tokens (&rest tokens)
(loop :for token :in tokens
:if (consp token)
:collect (token:make (car token) (cadr token))
:if (typep token 'token:token-type)
:collect (token:as-token token)))
(defun test-lexer (str expected-tokens)
(labels ((expected-next ()
(prog1 (car expected-tokens)
(setf expected-tokens (cdr expected-tokens)))))
(format t "Testing ~s..." *test-name*)
(let* ((lexer (lexer:make str))
(tokens (lexer:lex lexer))
(expected-token (expected-next))
(ok t))
(loop :for token :in tokens
:for i :from 1
:if (not (token:token= token expected-token))
:do (format t "~&token ~d: expected ~a but got ~a~%" i expected-token token)
(setf ok nil)
:else :do (setf expected-token (expected-next)))
(unless (null ok)
(format t " ok~%")))))
(defun tokenize (designator)
(cond ((typep designator 'token:token-type)
(token:as-token designator))
((stringp designator)
(token:make :t/ident designator))
((integerp designator)
(token:make :t/int (princ-to-string designator)))
((characterp designator)
(case designator
(#\( (token:as-token :t/lparen))
(#\) (token:as-token :t/rparen))
(#\; (token:as-token :t/semicolon))
(#\{ (token:as-token :t/lbrace))
(#\} (token:as-token :t/rbrace))))
((consp designator)
(apply #'token:make designator))))
(defun define-lexer-test (name string tokens)
`(progn
(setf (gethash ',name *tests*) t)
(defun ,name ()
(let ((*test-name* ',name))
(test-lexer ,string (list ,@(mapcar (lambda (tok) `(tokenize ',tok))
tokens)))))))
(defmacro deftest ((type &optional name) &body args)
(case type
(:lexer (apply #'define-lexer-test
(or name (gensym "LEXER-TEST"))
args)))))
(defun run-tests ()
(let ((ok t) key val)
(with-hash-table-iterator (it *tests*)
(loop :do (multiple-value-setq (ok key val) (it))
:while ok
:do (funcall (symbol-function key))))))
|
