John Lorentzson
928cdfd318
It ingests tokens via a "token stream", and feeds out a node tree. It's a mostly handwritten recursive descent parser with the occasional Lisp macros for convenience.
332 lines
13 KiB
Common Lisp
332 lines
13 KiB
Common Lisp
(in-package #:user-side-compiler)
|
|
|
|
(defvar *parser-debug* nil
|
|
"Parser will try to print with FORMAT here. Bind it to a stream to see the
|
|
parser's debug output.")
|
|
|
|
;;; Token stream
|
|
|
|
(defvar *token-stream*)
|
|
(defvar *token-comment* nil)
|
|
|
|
(defun previous-token ()
|
|
(cdr *token-stream*))
|
|
|
|
(defun peek-token ()
|
|
(caar *token-stream*))
|
|
|
|
(defun match-token (token)
|
|
(labels
|
|
((pop-token ()
|
|
(setf (cdr *token-stream*) (pop (car *token-stream*)))
|
|
(let ((got (previous-token)))
|
|
(if (comment-p (peek-token))
|
|
(setf *token-comment* (pop (car *token-stream*)))
|
|
(setf *token-comment* nil))
|
|
got)))
|
|
(cond ((and (keywordp token)
|
|
(typep (peek-token) 'token-name)
|
|
(eql token (name (peek-token))))
|
|
(prog1
|
|
(pop-token)
|
|
(format *parser-debug* "Matched a keyword token ~A (Context: ~A)~%"
|
|
token
|
|
(if (boundp '*current-matcher*)
|
|
*current-matcher*
|
|
nil))))
|
|
((and (not (keywordp token))
|
|
(typep (peek-token) token))
|
|
(prog1
|
|
(pop-token)
|
|
(format *parser-debug* "Matched a token ~A against type ~A (Context: ~A)~%"
|
|
(previous-token) token
|
|
(if (boundp '*current-matcher*)
|
|
*current-matcher*
|
|
nil))))
|
|
(t nil))))
|
|
|
|
(defun consume-token (token &optional error-message)
|
|
(unless (match-token token)
|
|
(error (if (null error-message)
|
|
(format nil "Expected token of type ~A, got a ~A.~%Source: ~A"
|
|
token (type-of (peek-token))
|
|
(source (previous-token)))
|
|
(format nil "~A~%Got ~A.~%Source: ~A"
|
|
error-message
|
|
(previous-token)
|
|
(source (previous-token)))))))
|
|
|
|
(defun make-token-stream (tokens)
|
|
(cons tokens nil))
|
|
|
|
;;; Matcher
|
|
|
|
(defparameter *syntax-matchers* (make-hash-table))
|
|
(defvar *syntax-source*)
|
|
(defvar *current-matcher*)
|
|
|
|
(defmacro define-syntax-matcher (name (&rest vars) &body body)
|
|
`(setf (gethash ',name *syntax-matchers*)
|
|
(lambda ()
|
|
(let (,@vars
|
|
(*syntax-source* (source (peek-token)))
|
|
(*current-matcher* ',name))
|
|
,@body))))
|
|
|
|
(defun %match-syntax (matcher-name)
|
|
(multiple-value-bind (function existsp)
|
|
(gethash matcher-name *syntax-matchers*)
|
|
(unless existsp
|
|
(error "No such syntax matcher ~A" matcher-name))
|
|
(format *parser-debug* "Entering matcher ~A~%" matcher-name)
|
|
(prog1
|
|
(funcall function)
|
|
(format *parser-debug* "Exiting matcher ~A~%" matcher-name))))
|
|
|
|
(defmacro match-syntax (matcher-name)
|
|
`(%match-syntax ',matcher-name))
|
|
|
|
;;; Syntax patterns
|
|
|
|
(defclass node-expr-equality (node-expr-binary)
|
|
((%operator :accessor operator :initarg :operator)
|
|
(%operands :accessor operands :initarg :operands)))
|
|
|
|
(defmacro define-binary-expr-matcher (name next &rest operator-node-pairs)
|
|
`(define-syntax-matcher ,name (left operator right)
|
|
(setf left (match-syntax ,next))
|
|
(loop :while (or ,@(loop :for (operator node) :in operator-node-pairs
|
|
:collect `(match-token ',operator)))
|
|
:do (setf operator (previous-token))
|
|
:do (setf right (match-syntax ,next))
|
|
:do (setf left (make-instance (etypecase operator
|
|
,@(mapcar (lambda (pair)
|
|
`(,(car pair) ',(cadr pair)))
|
|
operator-node-pairs))
|
|
:operator-token operator
|
|
:source *syntax-source*
|
|
:operands (list left right))))
|
|
left))
|
|
|
|
(define-syntax-matcher expression ()
|
|
(match-syntax call))
|
|
|
|
(define-syntax-matcher arglist (arguments)
|
|
(setf arguments (list (match-syntax expression)))
|
|
(loop :while (match-token 'token-comma)
|
|
:do (push (match-syntax expression) arguments))
|
|
(nreverse arguments))
|
|
|
|
(define-syntax-matcher call (name arguments)
|
|
(setf name (match-syntax equality))
|
|
(cond ((and (typep name 'token-name)
|
|
(match-token 'token-open-paren))
|
|
(setf arguments (match-syntax arglist))
|
|
(consume-token 'token-close-paren
|
|
"Close parenthesis ')' is required to end function call argument list.")
|
|
(make-instance 'node-call
|
|
:source *syntax-source*
|
|
:comment *token-comment*
|
|
:callee (transform name 'asm-function)
|
|
:arguments arguments))
|
|
(t name)))
|
|
|
|
(define-binary-expr-matcher equality comparison
|
|
(token-equal-equal node-expr-test-equal)
|
|
(token-not-equal node-expr-test-not-equal))
|
|
|
|
(define-binary-expr-matcher comparison term
|
|
;; TODO: The rest
|
|
(token-less-than node-expr-test-equal)
|
|
(token-greater-than node-expr-test-not-equal))
|
|
|
|
(define-binary-expr-matcher term factor
|
|
(token-plus node-expr-plus)
|
|
(token-minus node-expr-minus))
|
|
|
|
(define-binary-expr-matcher factor unary
|
|
(token-star node-expr-multiply)
|
|
(token-slash node-expr-divide))
|
|
|
|
(define-syntax-matcher unary ()
|
|
(let ((unary-tokens '(token-not token-minus)))
|
|
(if (some #'match-token unary-tokens)
|
|
(make-instance (etypecase (previous-token)
|
|
(token-not 'node-expr-not)
|
|
(token-minus 'node-expr-negate))
|
|
:source *syntax-source*
|
|
:comment *token-comment*
|
|
:operator-token (previous-token)
|
|
:operand (match-syntax primary))
|
|
(match-syntax primary))))
|
|
|
|
(define-syntax-matcher primary ()
|
|
(cond ((or (match-token 'token-name)
|
|
(match-token 'token-number))
|
|
(previous-token))
|
|
((match-token 'token-open-paren)
|
|
(let ((expr (match-syntax expression)))
|
|
(unless (match-token 'token-close-paren)
|
|
;; TODO
|
|
(error "Parser error: Closing parenthesis ')' required after expression."))
|
|
(make-instance 'node-expr-grouping
|
|
:source *syntax-source*
|
|
:comment *token-comment*
|
|
:expression expr)))
|
|
((match-token 'token-end-of-statement)
|
|
(error "End-of-statement in the middle of an expression"))
|
|
(t (error "What token?! Is this?! (DAH DAH DAAAAH)~%~S~%" (peek-token)))))
|
|
|
|
(define-syntax-matcher assignment (l-value r-value)
|
|
(setf l-value (match-syntax expression))
|
|
(if (and (typep l-value 'token-name)
|
|
(match-token 'token-equal))
|
|
(progn
|
|
(setf r-value (match-syntax expression))
|
|
(make-instance 'node-assignment
|
|
:source *syntax-source*
|
|
:comment *token-comment*
|
|
:variable (transform l-value 'reference-variable)
|
|
:value r-value))
|
|
l-value))
|
|
|
|
(define-syntax-matcher statement ()
|
|
(cond ((match-token :if)
|
|
(prog1
|
|
(match-syntax if)
|
|
(unless (or (match-token 'token-end-of-statement)
|
|
(null (peek-token)))
|
|
(error "EOS required after IF, got ~A"
|
|
(peek-token)))))
|
|
((match-token :for)
|
|
(prog1
|
|
(match-syntax for-do-times)
|
|
(unless (or (match-token 'token-end-of-statement)
|
|
(null (peek-token)))
|
|
(error "EOS required after FOR, got ~A"
|
|
(peek-token)))))
|
|
((match-token 'token-end-of-statement)
|
|
;; Empty statement, might contain comment
|
|
(make-instance 'node-nop
|
|
:source *syntax-source*
|
|
:comment *token-comment*))
|
|
(t
|
|
(let ((expr (match-syntax assignment)))
|
|
(setf (comment expr) *token-comment*)
|
|
(consume-token 'token-end-of-statement
|
|
(format nil "Couldn't find end of expression. ~A found instead."
|
|
(peek-token)))
|
|
expr))))
|
|
|
|
(defun wire-up-statements (statements)
|
|
(loop :for statement :in statements
|
|
:for rest := (rest statements) :then (rest rest)
|
|
:for next := (first rest)
|
|
:do (setf (normal-next statement) next))
|
|
statements)
|
|
|
|
(define-syntax-matcher block (statements)
|
|
(loop :for statement := (match-syntax statement)
|
|
:unless (typep statement 'node-nop)
|
|
:do (push statement statements)
|
|
:until (or (match-token :end)
|
|
(match-token :else)))
|
|
(setf statements (wire-up-statements (nreverse statements)))
|
|
(make-instance 'node-block
|
|
:source *syntax-source*
|
|
:statements statements
|
|
:next (first statements)))
|
|
|
|
(defmacro match-syntax-pattern (syntax-list error-messages)
|
|
(append
|
|
'(progn)
|
|
(loop :for syntax :in syntax-list
|
|
:collect (cond ((symbolp syntax)
|
|
;; Match token, ignore everything except its existence
|
|
`(consume-token ',syntax
|
|
,(cadr (assoc syntax error-messages))))
|
|
((and (listp syntax) (symbolp (second syntax))
|
|
(not (keywordp (second syntax))))
|
|
;; Match a variable via a matcher
|
|
`(setf ,(first syntax) (match-syntax ,(second syntax))))
|
|
((and (listp syntax) (listp (second syntax))
|
|
(eql (first (second syntax)) :token))
|
|
;; Match a variable to a token
|
|
(let ((var (first syntax))
|
|
(desired-token (second (second syntax))))
|
|
`(progn
|
|
(setf ,var (match-token ',desired-token))
|
|
(when (null ,var)
|
|
(error ,(cadr (assoc var error-messages)))))))))))
|
|
|
|
(define-syntax-matcher for-do-times (var n code)
|
|
(match-syntax-pattern
|
|
((var (:token token-name)) :do (n expression) :times
|
|
token-end-of-statement
|
|
(code block))
|
|
((:do "FOR requires a DO.")
|
|
(:times "FOR loop count must be followed by TIMES.")
|
|
(var "A loop index variable must be supplied.")))
|
|
(unless (eql (name (previous-token)) :end)
|
|
(error "FOR DO TIMES loop may only end with END. Found ~A." (previous-token)))
|
|
(make-instance 'node-dotimes
|
|
:source *syntax-source*
|
|
:counter-ref (transform var 'reference-variable)
|
|
:stop-ref (transform n 'reference)
|
|
:loopee-node (transform code 'node)))
|
|
|
|
(defclass node-conditional (node)
|
|
((%test :accessor test-node :initarg :test)
|
|
(%then :accessor then-node :initarg :then)
|
|
(%else :accessor else-node :initarg :else :initform nil)))
|
|
|
|
(defmethod node-nexts ((node node-conditional))
|
|
(append (list (test-node node) (then-node node))
|
|
(unless (null (else-node node))
|
|
(list (else-node node)))
|
|
(call-next-method)))
|
|
|
|
(define-syntax-matcher if (test then else)
|
|
(match-syntax-pattern
|
|
((test expression) :then token-end-of-statement (then block))
|
|
((token-end-of-statement "THEN must be followed by a line break")
|
|
(:then "IF condition must be followed by THEN")))
|
|
(cond ((eql (name (previous-token)) :end))
|
|
((eql (name (previous-token)) :else)
|
|
(setf else (match-syntax block))
|
|
#+(or)
|
|
(unless (match-token :end)
|
|
(error "An IF's ELSE block must be followed by END.~%Found ~A instead.~%ELSE IF is not yet supported."
|
|
(peek-token))))
|
|
(t (error "IF block ended very strangely, found ~A."
|
|
(peek-token))))
|
|
(make-instance 'node-conditional
|
|
:source *syntax-source*
|
|
:test (transform test 'node-expr)
|
|
:then (transform then 'node)
|
|
:else (if (null else) nil
|
|
(transform else 'node))))
|
|
|
|
(define-syntax-matcher program (statements)
|
|
(let ((*token-comment* nil))
|
|
(loop :for statement := (match-syntax statement)
|
|
:unless (typep statement 'node-nop)
|
|
:do (push statement statements)
|
|
:until (null (peek-token)))
|
|
(setf statements (wire-up-statements (nreverse statements)))
|
|
(make-instance 'node-program
|
|
:source *syntax-source*
|
|
:statements statements
|
|
:next (first statements))))
|
|
|
|
;;; Testing jigs
|
|
|
|
(defmacro do-node-tree ((node start-node) &body body)
|
|
(let ((stack (gensym))
|
|
(current (gensym)))
|
|
`(loop :with ,stack := (list (normal-next ,start-node))
|
|
:for ,current := (pop ,stack)
|
|
:until (null ,current)
|
|
:do (setf ,stack (append (remove nil (node-nexts ,current)) ,stack))
|
|
:do (let ((,node ,current))
|
|
,@body))))
|