# HG changeset patch # User Nolan Prescott # Date 1617666600 0 # Mon Apr 05 23:50:00 2021 +0000 # Node ID 51f36a762157ab1525d995b1d073f3659dbbbca7 # Parent 90aedaf35b59220c001b7d19da309d0822cf8fa1 revamp tokenizing diff --git a/ttc.lisp b/ttc.lisp --- a/ttc.lisp +++ b/ttc.lisp @@ -1,9 +1,6 @@ -;;; a teeny tiny compiler: -;;; https://web.eecs.utk.edu/~azh/blog/teenytinycompiler1.html - ;;; lexer -(defstruct (token) text kind) +(defstruct (token) text kind (value nil)) (defclass lexer () ((source :accessor source :initarg :source) @@ -36,94 +33,99 @@ (loop while (member (current-char l) '(#\Return #\Tab #\Space nil) :test #'equal) do (next-char l)))) -(defgeneric skip-comment (lexer) - (:method ((l lexer)) - (if (equal (current-char l) #\#) - (loop until (or (char= (current-char l) #\Nul) - (char= (current-char l) #\Newline)) - do (next-char l))))) +(defmacro string-switch (arg (&rest key-values)) + `(cond + ,@(loop for (k v) in key-values + collect + `((string= ,arg ,k) ,v)))) + +(defun keyword? (str) + (string-switch (string-upcase str) + ( + ;; constants + ("HR" (make-token :text str :kind :constant :value 0)) + ("ENGINEERING" (make-token :text str :kind :constant :value 1)) + ("LEGAL" (make-token :text str :kind :constant :value 2)) + ("PR" (make-token :text str :kind :constant :value 3)) + ("FINANCE" (make-token :text str :kind :constant :value 4)) + ("MARKETING" (make-token :text str :kind :constant :value 5)) + ("R&D" (make-token :text str :kind :constant :value 6)) + ("SALES" (make-token :text str :kind :constant :value 7)) + ("MANUFACTURING" (make-token :text str :kind :constant :value 8)) + ("EXECUTIVE MANAGEMENT" (make-token :text str :kind :constant :value 9)) -(defun is-keyword (s) - (cadar (member (string-upcase s) '(("LABEL" :LABEL) - ("GOTO" :GOTO) - ("PRINT" :PRINT) - ("INPUT" :INPUT) - ("LET" :LET) - ("IF" :IF) - ("THEN" :THEN) - ("ENDIF" :ENDIF) - ("WHILE" :WHILE) - ("REPEAT" :REPEAT) - ("ENDWHILE" :ENDWHILE)) - :key #'car :test #'equal))) + ;; registers + ("CUSTOMER EXPERIENCE" (make-token :text str :kind :register :value "r0")) + ("REVENUE STREAMS" (make-token :text str :kind :register :value "r1")) + ("CORE COMPETENCIES" (make-token :text str :kind :register :value "r2")) + ("BEST PRACTICES" (make-token :text str :kind :register :value "r3")) + ("STAKEHOLDER ENGAGEMENT" (make-token :text str :kind :register :value "r4")) + ("KEY PERFORMANCE INDICATORS" (make-token :text str :kind :register :value "r5")) + ("RETURN ON INVESTMENT" (make-token :text str :kind :register :value "r6")) + ("ASSETS" (make-token :text str :kind :register :value "r7")) + + ;; operations + ("INNOVATE" (make-token :text str :kind :operation :value :increment)) + ("VALUE-ADD" (make-token :text str :kind :operation :value :increment)) + ("STREAMLINE" (make-token :text str :kind :operation :value :decrement)) + ("OPTIMIZE" (make-token :text str :kind :operation :value :decrement)) + ("REVAMP" (make-token :text str :kind :operation :value :negate)) + ("OVERHAUL" (make-token :text str :kind :operation :value :negate)) + ("AMPLIFY" (make-token :text str :kind :operation :value :double)) + ("INCENTIVIZE" (make-token :text str :kind :operation :value :double)) + ("BACKBURNER" (make-token :text str :kind :operation :value :halve)) + ("PARADIGM SHIFT" (make-token :text str :kind :operation :value :random)) + ("ALIGN" (make-token :text str :kind :operation :value :assignment)) + ("WITH" (make-token :text str :kind :operation :value :designator)) + ("SYNERGIZE" (make-token :text str :kind :operation :value :add)) + ("INTEGRATE" (make-token :text str :kind :operation :value :add)) + ("AND" (make-token :text str :kind :operation :value :NOOP)) + ("DIFFERENTIATE" (make-token :text str :kind :operation :value :subtract)) + ("CROWDSOURCE" (make-token :text str :kind :operation :value :input)) + ("DELIVER" (make-token :text str :kind :operation :value :output)) + ("PRODUCE" (make-token :text str :kind :operation :value :output)) + ("MOVING FORWARD" (make-token :text str :kind :operation :value :label)) + ("GOING FORWARD" (make-token :text str :kind :operation :value :label)) + ("CIRCLE BACK TO" (make-token :text str :kind :operation :value :jump)) + ("REVISIT" (make-token :text str :kind :operation :value :jump)) + ("PIVOT" (make-token :text str :kind :operation :value :jz)) + ("TO" (make-token :text str :kind :operation :value :target)) + ("RESTRUCTURE" (make-token :text str :kind :operation :value :jneg))))) (defgeneric get-token (lexer) (:method ((l lexer)) (skip-whitespace l) - (skip-comment l) (let* ((c (current-char l)) (token (case c - (#\+ (make-token :text c :kind :PLUS)) - (#\- (make-token :text c :kind :MINUS)) - (#\* (make-token :text c :kind :ASTERISK)) - (#\/ (make-token :text c :kind :SLASH)) + (#\, (make-token :text c :kind :NOOP)) (#\Newline (make-token :text c :kind :NEWLINE)) (#\Nul (make-token :text c :kind :EOF)) - - (#\= (if (equal (peek l) #\=) - (progn (next-char l) (make-token :text "==" :kind :EQEQ)) - (make-token :text "=" :kind :EQ))) - - (#\> (if (equal (peek l) #\=) - (progn (next-char l) (make-token :text ">=" :kind :GTEQ)) - (make-token :text ">" :kind :GT))) - - (#\< (if (equal (peek l) #\=) - (progn (next-char l) (make-token :text "<=" :kind :LTEQ)) - (make-token :text "<" :kind :LT))) - - (#\! (if (equal (peek l) #\=) - (progn (next-char l) (make-token :text "!=" :kind :NOTEQ)) - (error 'lexing-error - :text (format nil "Expected != instead got: ~a" c)))) - ;; strings - (#\" (progn (next-char l) - (let ((start-position (current-position l))) - (loop until (equal #\" (current-char l)) - if (member (current-char l) '(#\Return #\Newline #\Tab #\\ #\%) :test #'equal) - do (error 'lexing-error - :text (format nil "illegal character in string: ~a" (current-char l))) - do (next-char l)) - (make-token :text (subseq (source l) start-position (current-position l)) - :kind :STRING)))) - - ;; numbers - ((#\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\0) - (let ((start-position (current-position l))) - (loop while (digit-char-p (peek l)) - do (next-char l)) - (if (equal (peek l) #\.) - (progn - (next-char l) - (if (digit-char-p (peek l)) - (loop while (digit-char-p (peek l)) - do (next-char l)) - (error 'lexing-error - :text "illegal character in number")))) - (make-token :text (subseq (source l) start-position (1+ (current-position l))) :kind :NUMBER))) - - ;; identifiers and keywords - (otherwise (cond ((alpha-char-p c) - (let ((start-position (current-position l))) - (loop while (alphanumericp (peek l)) - do (next-char l)) - (let* ((str (subseq (source l) start-position (1+ (current-position l)))) - (keyword (is-keyword str))) - (if keyword - (make-token :text str :kind keyword) - (make-token :text str :kind :IDENTIFIER))))) - (t (error 'lexing-error - :text (format nil "unknown token: ~a" c)))))))) + (otherwise + (cond ((alpha-char-p c) + (let ((start-position (current-position l))) + (loop while (or (alpha-char-p (peek l)) + (member (peek l) '(#\& #\-) :test #'equal) + (and (member (peek l) '(#\Space) :test #'equal) + ;; this *looks* horrible but seems to work: + ;; next char is a space but the preceding string is part of a multi-word token + (member (string-upcase (subseq (source l) start-position (1+ (current-position l)))) + '("EXECUTIVE" "PARADIGM" "MOVING" "GOING" "CIRCLE" + "CIRCLE BACK" "CUSTOMER" "REVENUE" "CORE" "BEST" + "STAKEHOLDER" "KEY" "KEY PERFORMANCE" "RETURN" "RETURN ON") + :test #'equal))) + do (next-char l)) + (let* ((str (subseq (source l) start-position (1+ (current-position l)))) + (keyword (keyword? str))) + (if keyword + keyword + (progn + (loop until (equal #\Newline (current-char l)) + do (next-char l)) + ;; FIXME: I think there's a condition here that says strings should disallow keywords + (make-token :text (subseq (source l) start-position (current-position l)) + :kind :STRING)))))) + (t (error 'lexing-error + :text (format nil "unknown token: ~a" c)))))))) (next-char l) token))) @@ -137,14 +139,13 @@ (defclass parser () ((lexer :accessor lexer :initarg :lexer) - (emitter :accessor emitter :initarg :emitter) (current-token :accessor current-token :initform nil) (peek-token :accessor peek-token :initform nil) (symbols :accessor symbols :initform '()) (labels-declared :accessor labels-declared :initform '()) (labels-gotoed :accessor labels-gotoed :initform '()))) -(defmethod initialize-instance :after ((p parser) &rest args) +(defmethod initialize-instance :after ((p parser) &rest args) ; how do you suppress unused arguments warnings? (next-token p) (next-token p)) @@ -353,32 +354,15 @@ (:method ((e emitter) new-code) (setf (header e) (format nil "~a~a~%" (header e) new-code)))) -;;; sample program +;;; testing (let* ((l (make-instance 'lexer :source " - -# Compute average of given values. - -LET a = 0 -WHILE a < 1 REPEAT - PRINT \"Enter number of scores: \" - INPUT a -ENDWHILE - -LET b = 0 -LET s = 0 -PRINT \"Enter one value at a time: \" -WHILE b < a REPEAT - INPUT c - LET s = s + c - LET b = b + 1 -ENDWHILE - -PRINT \"Average: \" -PRINT s / a - -")) - (e (make-instance 'emitter)) - (p (make-instance 'parser :lexer l :emitter e))) - (program p) - (format t "~a~a~%" (header (emitter p)) (code (emitter p)))) +Engineering, Marketing, and HR +Executive Management stakeholder engagement +align R&D Engineering and HR with stakeholder engagement +"))) + (let ((ct nil) (list nil)) + (loop until (and ct (eq (token-kind ct) :EOF)) + do (setf ct (get-token l)) + (push ct list) + (format t "~a~%" (if (token-value ct) (token-value ct) (token-kind ct))))))