From 8afcee0b1087dad6c821aa2ee1e917e3301f0e81 Mon Sep 17 00:00:00 2001
From: riton <riton@riton.home>
Date: Sat, 12 Jul 2025 04:27:10 +0300
Subject: refactor: token-type uses deftype instead of int enum

---
 src/token.lisp | 115 +++++++++++++++++++++++++++++++++++++--------------------
 1 file changed, 74 insertions(+), 41 deletions(-)

(limited to 'src/token.lisp')

diff --git a/src/token.lisp b/src/token.lisp
index 7b4f372..f6536ac 100644
--- a/src/token.lisp
+++ b/src/token.lisp
@@ -1,26 +1,63 @@
 (in-package :monkey)
 
 (eval-always
-  (defmacro def-tokens (prefix &body tok-def)
-    (let ((i 0)
-          (hash-sym (gensym))
-          (body (list)))
-      (loop :for def :in tok-def
-            :if (consp def)
-              :do (let ((sym (concat-symbols prefix (car def))))
-                    (push `(defparameter ,sym ,i) body)
-                    (push `(setf (gethash ,sym ,hash-sym) ,(cadr def)) body))
-            :else
-              :do (push `(defparameter ,(concat-symbols prefix def) ,i) body)
-            :do (incf i)
-            :finally (setf body (reverse body)))
-      `(progn (defparameter ,hash-sym (make-hash-table))
-              ,@body
-              (defparameter ,(concat-symbols prefix 'count) ,i)
-              (defun as-token (token-type)
-                (make-token token-type (or (gethash token-type ,hash-sym) "")))))))
+  (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)))))))))
 
-(def-tokens token
+  (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
@@ -41,21 +78,24 @@
   (rparen ")")
   (lbrace "{")
   (rbrace "}")
-  (function "fn")
-  (let "let")
-  (true "true")
-  (false "false")
-  (if "if")
-  (else "else")
-  (return "return"))
+  (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)
-   (literal :reader literal :initarg :literal)))
+  ((_type :reader _type
+          :initarg :type
+          :type token-type)
+   (literal :reader literal
+            :initarg :literal)))
 
 (defmethod token= ((t1 token) (t2 token))
-  (and (= (_type t1) (_type t2))
+  (and (eq (_type t1) (_type t2))
        (string= (literal t1) (literal t2))))
 
 (defun make-token (type literal)
@@ -65,19 +105,12 @@
   (print-unreadable-object (token stream :type t :identity t)
     (princ (literal token) stream)))
 
-(defparameter *keywords*
-  (let ((kw (make-hash-table)))
-    (setf (gethash "fn" kw) token-function)
-    (setf (gethash "let" kw) token-let)
-    (setf (gethash "true" kw) token-true)
-    (setf (gethash "false" kw) token-false)
-    (setf (gethash "if" kw) token-if)
-    (setf (gethash "else" kw) token-else)
-    (setf (gethash "return" kw) token-return)
-    kw))
+(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) (gethash str *keywords*)
+  (multiple-value-bind (val ok) (string->token str)
     (if (not (null ok))
         val
-        token-ident)))
+        :t/ident)))
-- 
cgit v1.2.3