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
|
(in-package :token)
(eval-always
(defun process-line (def prefix)
(labels ((make-token-symbol (prefix def)
(nth-value 0 (intern (format nil "~a~a" prefix def) "KEYWORD"))))
(cond ((symbolp def)
(make-token-symbol prefix def))
((consp def)
(let* ((token-sym (make-token-symbol prefix (car def)))
(hash (cadr def))
(keyword (and (keywordp (caddr def))
(equal :kw (caddr def)))))
(values token-sym
(list (cons token-sym hash))
(if (null keyword)
nil
(list (cons hash token-sym)))))))))
(defun make-token-defs (defs prefix)
(labels ((helper (defs members hashes keywords)
(cond ((null defs)
(values members hashes keywords))
((consp defs)
(multiple-value-bind (token hash keyword)
(process-line (car defs) prefix)
(helper (cdr defs)
(cons token members)
(append hash hashes)
(append keyword keywords)))))))
(helper defs (list) (list) (list))))
(defun def-tokens* (name prefix literal-getter keyword-getter defs)
(let ((hash-sym (gensym "LITERALS"))
(token-type-sym (gensym))
(keyword-sym (gensym "KEYWORDS"))
(str-sym (gensym)))
(multiple-value-bind (members hashes keywords) (make-token-defs defs prefix)
`(progn (deftype ,name () (quote (member ,@members)))
(defparameter ,hash-sym (make-hash-table))
(defparameter ,keyword-sym (make-hash-table :test 'equal))
(defun ,literal-getter (,token-type-sym)
(gethash ,token-type-sym ,hash-sym))
(defun ,keyword-getter (,str-sym)
(gethash ,str-sym ,keyword-sym))
,@(mapcar (lambda (hash)
`(setf (gethash ,(car hash) ,hash-sym) ,(cdr hash)))
hashes)
,@(mapcar (lambda (kw)
`(Setf (gethash ,(car kw) ,keyword-sym) ,(cdr kw)))
keywords)))))
(defmacro def-tokens ((&key name prefix literal-getter keyword-getter)
&body defs)
(def-tokens* name prefix literal-getter keyword-getter defs)))
(def-tokens (:name token-type
:prefix t/
:literal-getter token->string
:keyword-getter string->token)
illegal
eof
ident
int
(= "=")
(+ "+")
(- "-")
(! "!")
(* "*")
(/ "/")
(== "==")
(!= "!=")
(< "<")
(> ">")
(comma ",")
(semicolon ";")
(lparen "(")
(rparen ")")
(lbrace "{")
(rbrace "}")
(function "fn" :kw)
(let "let" :kw)
(true "true" :kw)
(false "false" :kw)
(if "if" :kw)
(else "else" :kw)
(return "return" :kw))
(defclass token ()
((type :reader type
:initarg :type
:type token-type)
(literal :reader literal
:initarg :literal
:type string)))
(defun type= (type1 type2)
(eq type1 type2))
(defmethod type-is ((token token) type)
(type= (type token) type))
(defmethod token= ((t1 token) (t2 token))
(and (type= (type t1) (type t2))
(string= (literal t1) (literal t2))))
(defun make (type literal)
(make-instance 'token :type type :literal (string literal)))
(defmethod print-object ((token token) stream)
(print-unreadable-object (token stream :type t :identity t)
(format stream "\"~a\"" (literal token))))
(defun as-token (token-type)
"Returns TOKEN from a TOKEN-TYPE"
(multiple-value-bind (str ok) (token->string token-type)
(make token-type (if (null ok) "" str))))
(define-compiler-macro as-token (&whole form token-type)
"if TOKEN-TYPE is TOKEN-TYPE, lookup at compile time"
(if (typep token-type 'token-type)
(let ((token (as-token token-type)))
`(make ,(type token) ,(literal token)))
form))
(defun lookup-identifier (str)
"Returns an identifier or keyword as TOKEN-TYPE from STR"
(multiple-value-bind (val ok) (string->token str)
(if (not (null ok))
val
:t/ident)))
|
