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
|
(in-package :monkey)
(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)))
(defmethod token= ((t1 token) (t2 token))
(and (eq (_type t1) (_type t2))
(string= (literal t1) (literal t2))))
(defun make-token (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)
(multiple-value-bind (str ok) (token->string token-type)
(make-token token-type (if (null ok) "" str))))
(defun lookup-identifier (str)
(multiple-value-bind (val ok) (string->token str)
(if (not (null ok))
val
:t/ident)))
|
