314 lines
13 KiB
Common Lisp
314 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*)
|
|
|
|
(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)))
|
|
got)))
|
|
(cond ((and (keywordp token)
|
|
(typep (peek-token) 'token-keyword)
|
|
(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))))
|
|
((null (peek-token))
|
|
(error-parser (source (previous-token))
|
|
"Ran out of tokens while parsing."))
|
|
(t nil))))
|
|
|
|
(defun consume-token (token &optional error-message)
|
|
(unless (match-token token)
|
|
(if (null error-message)
|
|
(error-parser (source (previous-token))
|
|
"Expected token of type ~A, got a ~A."
|
|
token (type-of (peek-token)))
|
|
(error-parser (source (previous-token))
|
|
"~A~%Got token ~A instead."
|
|
error-message (previous-token)
|
|
(source (previous-token))))))
|
|
|
|
(defun make-token-stream (tokens)
|
|
;; Appending an end-of-statement if one is missing so that we always
|
|
;; have something to latch onto when dealing with syntax errors at the end
|
|
;; of the program's text. It has the same source location as the actual
|
|
;; last token.
|
|
(let ((last (last tokens)))
|
|
(unless (typep (car last) 'token-end-of-statement)
|
|
(setf (cdr last) (cons (make-instance 'token-end-of-statement
|
|
:source (source (car last)))
|
|
nil))))
|
|
(assert (every (complement #'null) 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
|
|
|
|
(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 equality))
|
|
|
|
(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
|
|
(token-less-than node-expr-test-less)
|
|
(token-less-or-equal node-expr-test-less-or-equal)
|
|
(token-greater-than node-expr-test-greater)
|
|
(token-greater-or-equal node-expr-test-greater-or-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*
|
|
:operator-token (previous-token)
|
|
:operand (match-syntax primary))
|
|
(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 primary))
|
|
(cond ((and (typep name 'token-name)
|
|
(match-token 'token-open-paren))
|
|
(cond ((match-token 'token-close-paren)
|
|
(setf arguments '()))
|
|
(t
|
|
(setf arguments (match-syntax arglist))
|
|
(consume-token 'token-close-paren
|
|
"Close parenthesis ')' is required to end function call argument list,
|
|
comma ',' is required to separate arguments.")))
|
|
(make-instance 'node-call
|
|
:source *syntax-source*
|
|
:callee (transform name 'asm-function)
|
|
:arguments arguments))
|
|
(t name)))
|
|
|
|
(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)))
|
|
(consume-token 'token-close-paren
|
|
"Closing parenthesis ')' required after grouping expression.")
|
|
(make-instance 'node-expr-grouping
|
|
:source *syntax-source*
|
|
:expression expr)))
|
|
((match-token 'token-end-of-statement)
|
|
(error-parser (source (previous-token))
|
|
"End-of-statement in the middle of an expression."))
|
|
(t (error-parser (source (peek-token))
|
|
"Unexpected token ~S in unexpected situation."
|
|
(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*
|
|
: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-parser (source (previous-token))
|
|
"End-of-statement required after IF's THEN, 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-parser (source (previous-token))
|
|
"End-of-statement required after FOR's THEN, got ~A"
|
|
(peek-token)))))
|
|
((match-token 'token-end-of-statement)
|
|
;; Empty statement
|
|
(make-instance 'node-nop :source *syntax-source*))
|
|
(t
|
|
(let ((expr (match-syntax assignment)))
|
|
(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))
|
|
statements)
|
|
|
|
(define-syntax-matcher block (statements)
|
|
(loop :for statement := (match-syntax statement)
|
|
:unless (typep statement 'node-nop)
|
|
:do (push statement statements)
|
|
:when (null (peek-token))
|
|
:do (error-parser (source (previous-token))
|
|
"Unterminated block, check for missing ENDs and ELSEs.")
|
|
:until (or (match-token :end)
|
|
(match-token :else)))
|
|
(setf statements (wire-up-statements (nreverse statements)))
|
|
(make-instance 'node-block
|
|
:source *syntax-source*
|
|
:statements 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-parser (source (previous-token))
|
|
,(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-parser (source (previous-token))
|
|
"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)))
|
|
|
|
(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)))
|
|
(t (error-parser (source (previous-token))
|
|
"IF block must be closed with END, found ~A."
|
|
(previous-token))))
|
|
(make-instance 'node-conditional
|
|
:source *syntax-source*
|
|
:test test
|
|
:then (transform then 'node)
|
|
:else (if (null else) nil
|
|
(transform else 'node))))
|
|
|
|
(define-syntax-matcher program (statements)
|
|
(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))
|