diff options
Diffstat (limited to 'src/token.lisp')
| -rw-r--r-- | src/token.lisp | 115 |
1 files changed, 74 insertions, 41 deletions
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))) |