parser.lisp
571 lines
| 17.5 KiB
| text/x-common-lisp
|
CommonLispLexer
/ src / parser.lisp
r1 | ||||
(in-package sugar-qsp) | ||||
;;;; Parses TXT source to an intermediate representation | ||||
;;; Utility | ||||
(defun remove-nth (list nth) | ||||
(append (subseq list 0 nth) | ||||
(subseq list (1+ nth)))) | ||||
(defun not-quote (char) | ||||
(not (eql #\' char))) | ||||
(defun not-doublequote (char) | ||||
(not (eql #\" char))) | ||||
(defun not-brace (char) | ||||
(not (eql #\} char))) | ||||
(defun not-integer (string) | ||||
(when (find-if-not #'digit-char-p string) | ||||
t)) | ||||
(defun not-newline (char) | ||||
(not (eql #\newline char))) | ||||
(defun id-any-char (char) | ||||
(and | ||||
(not (digit-char-p char)) | ||||
(not (eql #\newline char)) | ||||
(not (find char " !:&=<>+-*/,'\"()[]{}")))) | ||||
(defun intern-first (list) | ||||
(list* (intern (string-upcase (first list))) | ||||
(rest list))) | ||||
r6 | (eval-when (:compile-toplevel :load-toplevel :execute) | |||
(defun remove-nil (list) | ||||
(remove nil list))) | ||||
r1 | ||||
(defun binop-rest (list) | ||||
(destructuring-bind (ws1 operator ws2 operand2) | ||||
list | ||||
(declare (ignore ws1 ws2)) | ||||
(list (intern (string-upcase operator)) operand2))) | ||||
(defun do-binop% (left-op other-ops) | ||||
(if (null other-ops) | ||||
left-op | ||||
(destructuring-bind ((operator right-op) &rest rest-ops) | ||||
other-ops | ||||
r6 | (if (and (listp left-op) | |||
(eq (first left-op) | ||||
operator)) | ||||
r1 | (do-binop% (append left-op (list right-op)) rest-ops) | |||
(do-binop% (list operator left-op right-op) rest-ops))))) | ||||
(defun do-binop (list) | ||||
(destructuring-bind (left-op rest-ops) | ||||
list | ||||
(do-binop% left-op | ||||
(mapcar #'binop-rest rest-ops)))) | ||||
(p:defrule line-continuation (and #\_ #\newline) | ||||
(:constant nil)) | ||||
(p:defrule text-spaces (+ (or #\space #\tab line-continuation)) | ||||
(:text t)) | ||||
(p:defrule spaces (+ (or #\space #\tab line-continuation)) | ||||
(:constant nil)) | ||||
(p:defrule spaces? (* (or #\space #\tab line-continuation)) | ||||
(:constant nil)) | ||||
(p:defrule colon #\: | ||||
(:constant nil)) | ||||
(p:defrule alphanumeric (alphanumericp character)) | ||||
(p:defrule not-newline (not-newline character)) | ||||
(p:defrule squote-esc "''" | ||||
(:lambda (list) | ||||
(p:text (elt list 0)))) | ||||
(p:defrule dquote-esc "\"\"" | ||||
(:lambda (list) | ||||
(p:text (elt list 0)))) | ||||
(p:defrule sstring-chars (+ (and (and (p:! "<<") (p:! (p:~ "\"exec:"))) | ||||
(or squote-esc (not-quote character)))) | ||||
(:lambda (list) | ||||
(p:text (mapcar #'second list)))) | ||||
(p:defrule dstring-chars (+ (and (and (p:! "<<") (p:! (p:~ "'exec:"))) | ||||
(or dquote-esc (not-doublequote character)))) | ||||
(:lambda (list) | ||||
(p:text (mapcar #'second list)))) | ||||
;;; Identifiers | ||||
;; From the official docs | ||||
r6 | (defparameter *keywords* '(act addlib addobj addqst and arrcomp arrpos arrsize cla clear *clear close clr *clr cls cmdclear cmdclr copyarr $counter countobj $curacts curloc debug delact dellib delobj desc disablescroll disablesubex dynamic dyneval else elseif end exit fcolor $fname freelib fsize func getobj gosub goto gs gt if iif inclib input instr isnum isplay jump killall killobj killqst killvar lcase lcolor len let loc $maintxt max menu mid min mod msecscount msg nl *nl no nosave obj $onactsel $ongload $ongsave $onnewloc $onobjadd $onobjdel $onobjsel opengame openqst or p *p pl *pl play qspver rand refint replace rgb rnd savegame selact selobj set settimer showacts showinput showobjs showstat $stattxt str strcomp strfind strpos trim ucase unsel unselect $usercom user_text usrtxt val view wait xgoto xgt)) | |||
r1 | ||||
(defun qsp-keyword-p (id) | ||||
(member (intern (string-upcase id)) *keywords*)) | ||||
(defun not-qsp-keyword-p (id) | ||||
(not (member (intern (string-upcase id)) *keywords*))) | ||||
(p:defrule qsp-keyword (qsp-keyword-p identifier-raw)) | ||||
(p:defrule id-first (id-any-char character)) | ||||
(p:defrule id-next (or (id-any-char character) | ||||
(digit-char-p character))) | ||||
(p:defrule identifier-raw (and id-first (* id-next)) | ||||
(:lambda (list) | ||||
(let ((id (p:text list))) | ||||
(when (member id *keywords*) | ||||
(error "~A is a keyword" id)) | ||||
(intern (string-upcase id))))) | ||||
(p:defrule identifier (not-qsp-keyword-p identifier-raw)) | ||||
;;; Strings | ||||
(p:defrule qsp-string (or normal-string brace-string)) | ||||
(p:defrule normal-string (or sstring dstring) | ||||
(:lambda (str) | ||||
(list* 'str (or str (list ""))))) | ||||
(p:defrule sstring (and #\' (* (or string-interpol | ||||
sstring-exec | ||||
sstring-chars)) | ||||
#\') | ||||
(:function second)) | ||||
(p:defrule dstring (and #\" (* (or string-interpol | ||||
dstring-exec | ||||
dstring-chars)) | ||||
#\") | ||||
(:function second)) | ||||
(p:defrule string-interpol (and "<<" expression ">>") | ||||
(:function second)) | ||||
(p:defrule sstring-exec-body (+ (or squote-esc (not-doublequote character))) | ||||
(:text t)) | ||||
(p:defrule dstring-exec-body (+ (or dquote-esc (not-quote character))) | ||||
(:text t)) | ||||
(p:defrule sstring-exec (and (p:~ "\"exec:") sstring-exec-body #\") | ||||
(:lambda (list) | ||||
(list* 'exec (p:parse 'exec-body (second list))))) | ||||
(p:defrule dstring-exec (and (p:~ "'exec:") dstring-exec-body #\') | ||||
(:lambda (list) | ||||
(list* 'exec (p:parse 'exec-body (second list))))) | ||||
(p:defrule brace-string (and #\{ before-statement block-body #\}) | ||||
(:lambda (list) | ||||
(list* 'qspblock (third list)))) | ||||
;;; Location | ||||
(p:defrule sugar-qsp-grammar (and (* (or spaces #\newline)) | ||||
(* location)) | ||||
(:function second)) | ||||
(p:defrule location (and location-header block-body location-end) | ||||
(:destructure (header body end) | ||||
(declare (ignore end)) | ||||
`(location (,header) ,@body))) | ||||
(p:defrule location-header (and #\# | ||||
(+ not-newline) | ||||
(and #\newline spaces? before-statement)) | ||||
(:destructure (spaces1 name spaces2) | ||||
(declare (ignore spaces1 spaces2)) | ||||
(string-upcase (string-trim " " (p:text name))))) | ||||
(p:defrule location-end (and #\- #\newline before-statement) | ||||
(:constant nil)) | ||||
;;; Block body | ||||
(p:defrule newline-block-body (and #\newline spaces? block-body) | ||||
(:function third)) | ||||
(p:defrule block-body (* statement) | ||||
(:function remove-nil)) | ||||
;; Just for <a href="exec:...'> | ||||
;; Explicitly called from that rule's production | ||||
(p:defrule exec-body (and before-statement line-body) | ||||
(:function second)) | ||||
(p:defrule line-body (and inline-statement (* next-inline-statement)) | ||||
(:lambda (list) | ||||
(list* (first list) (second list)))) | ||||
(p:defrule before-statement (* (or #\newline spaces)) | ||||
(:constant nil)) | ||||
(p:defrule statement-end (or statement-end-real statement-end-block-close)) | ||||
(p:defrule statement-end-real (and (or #\newline | ||||
(and #\& spaces? (p:& statement%))) | ||||
before-statement) | ||||
(:constant nil)) | ||||
(p:defrule statement-end-block-close (or (p:& #\})) | ||||
(:constant nil)) | ||||
(p:defrule inline-statement (and statement% spaces?) | ||||
(:function first)) | ||||
(p:defrule next-inline-statement (and #\& spaces? inline-statement) | ||||
(:function third)) | ||||
(p:defrule not-a-non-statement (and (p:! (p:~ "elseif")) | ||||
(p:! (p:~ "else")) | ||||
(p:! (p:~ "end")))) | ||||
(p:defrule statement (and inline-statement statement-end) | ||||
(:function first)) | ||||
(p:defrule statement% (and not-a-non-statement | ||||
(or label comment string-output | ||||
block non-returning-intrinsic assignment | ||||
expression-output)) | ||||
(:function second)) | ||||
(p:defrule expr-stopper (or comment block non-returning-intrinsic)) | ||||
(p:defrule string-output qsp-string | ||||
(:lambda (string) | ||||
(list 'main-pl string))) | ||||
(p:defrule expression-output expression | ||||
(:lambda (list) | ||||
(list 'main-pl list))) | ||||
(p:defrule label (and colon identifier) | ||||
(:lambda (list) | ||||
(intern (string (second list)) :keyword))) | ||||
(p:defrule comment (and #\! (* (or text-spaces qsp-string brace-string not-newline))) | ||||
(:constant nil)) | ||||
;;; Blocks | ||||
(p:defrule block (or block-act block-if)) | ||||
(p:defrule block-if (and block-if-head block-if-body) | ||||
(:destructure (head body) | ||||
`(qspcond (,@head ,@(first body)) | ||||
,@(rest body)))) | ||||
(p:defrule block-if-head (and (p:~ "if") spaces expression spaces? colon spaces?) | ||||
(:function remove-nil) | ||||
(:function cdr)) | ||||
(p:defrule block-if-body (or block-if-ml block-if-sl) | ||||
(:destructure (if-body elseifs else &rest ws) | ||||
(declare (ignore ws)) | ||||
`(,(remove-nil if-body) ,@elseifs ,@(when else `((else ,@else)))))) | ||||
(p:defrule block-if-sl (and line-body | ||||
(p:? block-if-elseif-inline) | ||||
(p:? block-if-else-inline) | ||||
spaces?)) | ||||
(p:defrule block-if-ml (and (and #\newline spaces?) | ||||
block-body | ||||
(p:? block-if-elseif) | ||||
(p:? block-if-else) | ||||
block-if-end) | ||||
(:lambda (list) | ||||
(cdr list))) | ||||
(p:defrule block-if-elseif-inline (and block-if-elseif-head line-body (p:? block-if-elseif-inline)) | ||||
(:destructure (head statements elseif) | ||||
`((,@(rest head) ,@(remove-nil statements)) ,@elseif))) | ||||
(p:defrule block-if-elseif (and block-if-elseif-head statement-end block-body (p:? block-if-elseif)) | ||||
(:destructure (head ws statements elseif) | ||||
(declare (ignore ws)) | ||||
`((,@(rest head) ,@(remove-nil statements)) ,@elseif))) | ||||
(p:defrule block-if-elseif-head (and (p:~ "elseif") spaces expression spaces? colon spaces?) | ||||
(:function remove-nil) | ||||
(:function intern-first)) | ||||
(p:defrule block-if-else-inline (and block-if-else-head line-body) | ||||
(:function second)) | ||||
(p:defrule block-if-else (and block-if-else-head #\newline spaces? block-body) | ||||
(:function fourth)) | ||||
(p:defrule block-if-else-head (and (p:~ "else") spaces?) | ||||
(:constant nil)) | ||||
(p:defrule block-if-end (and (p:~ "end") | ||||
(p:? (and spaces (p:~ "if")))) | ||||
(:constant nil)) | ||||
(p:defrule block-act (and block-act-head (or block-act-ml block-act-sl)) | ||||
(:lambda (list) | ||||
(apply #'append list))) | ||||
r6 | (p:defrule block-act-sl line-body) | |||
r1 | ||||
(p:defrule block-act-ml (and newline-block-body block-act-end) | ||||
(:lambda (list) | ||||
(apply #'list* (butlast list)))) | ||||
(p:defrule block-act-head (and (p:~ "act") spaces qsp-string spaces? | ||||
(p:? block-act-head-img) | ||||
colon spaces?) | ||||
(:lambda (list) | ||||
r6 | (intern-first (list (first list) | |||
(third list) | ||||
(or (fifth list) '(str "")))))) | ||||
r1 | ||||
(p:defrule block-act-head-img (and #\, spaces? qsp-string spaces?) | ||||
(:lambda (list) | ||||
(or (third list) ""))) | ||||
(p:defrule block-act-end (and (p:~ "end")) | ||||
(:constant nil)) | ||||
;;; Calls | ||||
(p:defrule first-argument (and expression spaces?) | ||||
(:function first)) | ||||
(p:defrule next-argument (and "," spaces? expression) | ||||
(:function third)) | ||||
(p:defrule arguments (or parenthesized-arguments plain-arguments no-arguments)) | ||||
(p:defrule parenthesized-arguments (and spaces? #\( base-arguments #\)) | ||||
(:function third)) | ||||
(p:defrule plain-arguments (and spaces base-arguments) | ||||
(:function second)) | ||||
(p:defrule no-arguments (or spaces (p:& #\newline) (p:& #\&)) | ||||
(:constant nil)) | ||||
(p:defrule base-arguments (and first-argument (* next-argument)) | ||||
(:destructure (first rest) | ||||
(list* first rest))) | ||||
;;; Intrinsics | ||||
(defmacro defintrinsics ((rule-name returning-rule-name non-returning-rule-name) &body clauses) | ||||
`(progn | ||||
,@(loop :for clause :in clauses | ||||
:collect `(defintrinsic ,@clause)) | ||||
(p:defrule ,returning-rule-name (or ,@(remove-nil | ||||
(mapcar (lambda (clause) | ||||
(when (second clause) | ||||
(alexandria:symbolicate | ||||
'intrinsic- (first clause)))) | ||||
clauses)))) | ||||
(p:defrule ,non-returning-rule-name (or ,@(remove-nil | ||||
(mapcar (lambda (clause) | ||||
(unless (second clause) | ||||
(alexandria:symbolicate | ||||
'intrinsic- (first clause)))) | ||||
clauses)))) | ||||
(p:defrule ,rule-name (or ,returning-rule-name ,non-returning-rule-name)))) | ||||
(defmacro defintrinsic (sym returning &optional (min-arity 0) (max-arity 10) &rest names) | ||||
(declare (ignore returning)) | ||||
(setf names | ||||
(if names | ||||
(mapcar #'string-upcase names) | ||||
(list (string sym)))) | ||||
`(p:defrule ,(alexandria:symbolicate 'intrinsic- sym) | ||||
(and (p:? #\$) (or ,@(loop :for name :in names :collect `(p:~ ,name))) | ||||
arguments) | ||||
(:destructure (dollar name arguments) | ||||
(declare (ignore dollar)) | ||||
(unless (<= ,min-arity (length arguments) ,max-arity) | ||||
(error "Intrinsic ~A expects between ~A and ~A arguments but ~A were provided:~%~S" | ||||
name ,min-arity ,max-arity (length arguments) arguments)) | ||||
(list* ',sym arguments)))) | ||||
(defintrinsics (intrinsic returning-intrinsic non-returning-intrinsic) | ||||
;; Transitions | ||||
(goto nil 0 10 "gt" "goto") | ||||
(xgoto nil 0 10 "xgt" "xgoto") | ||||
;; Variables | ||||
(killvar nil 0 2) | ||||
;; Expressions | ||||
(obj t 1 1) | ||||
(loc t 1 1) | ||||
(no t 1 1) | ||||
;; Basic | ||||
(qspver t 0 0) | ||||
(curloc t 0 0) | ||||
(rand t 1 2) | ||||
(rnd t 0 0) | ||||
(qspmax t 1 10 "max") | ||||
(qspmin t 1 10 "min") | ||||
;; Arrays | ||||
(killall nil 0 0) | ||||
(copyarr nil 2 4) | ||||
(arrsize t 1 1) | ||||
(arrpos t 2 3) | ||||
(arrcomp t 2 3) | ||||
;; Strings | ||||
(len t 1 1) | ||||
(mid t 2 3) | ||||
(ucase t 1 1) | ||||
(lcase t 1 1) | ||||
(trim t 1 1) | ||||
(replace t 2 3) | ||||
(instr t 2 3) | ||||
(isnum t 1 1) | ||||
(val t 1 1) | ||||
(qspstr t 1 1 "str") | ||||
(strcomp t 2 2) | ||||
(strfind t 2 3) | ||||
(strpos t 2 3) | ||||
;; IF | ||||
(iif t 2 3) | ||||
;; Subs | ||||
(gosub nil 1 10 "gosub" "gs") | ||||
(func t 1 10) | ||||
(exit nil 0 0) | ||||
;; Jump | ||||
(jump nil 1 1) | ||||
;; Dynamic | ||||
(dynamic nil 1 10) | ||||
(dyneval t 1 10) | ||||
;; Main window | ||||
(main-p nil 1 1 "*p") | ||||
(main-pl nil 1 1 "*pl") | ||||
(main-nl nil 0 1 "*nl") | ||||
(maintxt t 0 0) | ||||
(desc t 1 1) | ||||
(main-clear nil 0 0 "*clear" "*clr") | ||||
;; Aux window | ||||
(showstat nil 1 1) | ||||
(stat-p nil 1 1 "p") | ||||
(stat-pl nil 1 1 "pl") | ||||
(stat-nl nil 0 1 "nl") | ||||
(stattxt t 0 0) | ||||
(stat-clear nil 0 0 "clear" "clr") | ||||
(cls nil 0 0) | ||||
;; Dialog | ||||
(msg nil 1 1) | ||||
;; Acts | ||||
(showacts nil 1 1) | ||||
(delact nil 1 1 "delact" "del act") | ||||
(curacts t 0 0) | ||||
(cla nil 0 0) | ||||
;; Objects | ||||
(showobjs nil 1 1) | ||||
(addobj nil 1 3 "addobj" "add obj") | ||||
(delobj nil 1 1 "delobj" "del obj") | ||||
(killobj nil 0 1) | ||||
(countobj t 0 0) | ||||
(getobj t 1 1) | ||||
;; Menu | ||||
(menu nil 1 1) | ||||
;; Sound | ||||
(play nil 1 2) | ||||
(isplay t 1 1) | ||||
(close nil 1 1) | ||||
(closeall nil 0 0 "close all") | ||||
;; Images | ||||
(refint nil 0 0) | ||||
(view nil 0 1) | ||||
;; Fonts | ||||
(rgb t 3 3) | ||||
;; Input | ||||
(showinput nil 1 1) | ||||
(usertxt t 0 0 "user_text" "usrtxt") | ||||
(cmdclear nil 0 0 "cmdclear" "cmdclr") | ||||
(input t 1 1) | ||||
;; Files | ||||
(openqst nil 1 1) | ||||
(addqst nil 1 1 "addqst" "addlib" "inclib") | ||||
(killqst nil 1 1 "killqst" "dellib" "freelib") | ||||
(opengame nil 0 1) | ||||
(savegame nil 0 1) | ||||
;; Real time | ||||
(wait nil 1 1) | ||||
(msecscount t 0 0) | ||||
(settimer nil 1 1)) | ||||
;;; Expression | ||||
(p:defrule expression or-expr) | ||||
(p:defrule or-expr (and and-expr (* (and spaces? or-op spaces? and-expr))) | ||||
(:function do-binop)) | ||||
(p:defrule and-expr (and eq-expr (* (and spaces? and-op spaces? eq-expr))) | ||||
(:function do-binop)) | ||||
(p:defrule eq-expr (and cat-expr (* (and spaces? (or "<>" "<=" ">=" "=<" "=>" | ||||
#\= #\< #\> #\!) | ||||
spaces? cat-expr))) | ||||
(:function do-binop)) | ||||
(p:defrule cat-expr (and sum-expr (* (and spaces? #\& spaces? (p:! expr-stopper) sum-expr))) | ||||
(:lambda (list) | ||||
(do-binop (list (first list) (mapcar (lambda (l) | ||||
(remove-nth l 3)) | ||||
(second list)))))) | ||||
(p:defrule sum-expr (and mod-expr (* (and spaces? (or #\+ #\-) spaces? mod-expr))) | ||||
(:function do-binop)) | ||||
(p:defrule mod-expr (and mul-expr (* (and spaces? (p:~ "mod") spaces? mul-expr))) | ||||
(:function do-binop)) | ||||
(p:defrule mul-expr (and unary-expr (* (and spaces? (or #\* #\/) spaces? unary-expr))) | ||||
(:function do-binop)) | ||||
(p:defrule unary-expr (and (p:? (or #\+ #\-)) atom-expr) | ||||
(:lambda (list) | ||||
(let ((expr (remove-nil list))) | ||||
(if (= 1 (length expr)) | ||||
(first expr) | ||||
(intern-first expr))))) | ||||
r6 | (p:defrule atom-expr (and (or variable literal returning-intrinsic paren-expr) spaces?) | |||
r1 | (:function first)) | |||
(p:defrule paren-expr (and #\( spaces? expression spaces? #\)) | ||||
(:function third)) | ||||
(p:defrule or-op (p:~ "or") | ||||
(:constant "or")) | ||||
(p:defrule and-op (p:~ "and") | ||||
(:constant "and")) | ||||
;;; Variables | ||||
(p:defrule variable (and identifier (p:? array-index)) | ||||
(:destructure (id idx) | ||||
(list 'var id (or idx 0)))) | ||||
(p:defrule array-index (and #\[ spaces? (p:? expression) spaces? #\]) | ||||
(:lambda (list) | ||||
(or (third list) :end))) | ||||
(p:defrule assignment (or kw-assignment plain-assignment) | ||||
(:destructure (var eq expr) | ||||
(declare (ignore eq)) | ||||
(list 'set var expr))) | ||||
(p:defrule plain-assignment (and variable spaces? #\= spaces? expression) | ||||
(:function remove-nil)) | ||||
(p:defrule kw-assignment (and (or (p:~ "let") (p:~ "set")) spaces? plain-assignment) | ||||
(:function third)) | ||||
;;; Non-string literals | ||||
(p:defrule literal (or qsp-string brace-string number)) | ||||
(p:defrule number (+ (or #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) | ||||
(:lambda (list) | ||||
(parse-integer (p:text list)))) | ||||