src/parser.lisp

(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)))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun remove-nil (list)
    (remove nil list)))

(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
        (if (and (listp left-op)
                 (eq (first left-op)
                     operator))
            (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
(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))

(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)))

(p:defrule block-act-sl line-body)

(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)
    (intern-first (list (first list)
                        (third list)
                        (or (fifth list) '(str ""))))))

(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)))))

(p:defrule atom-expr (and (or variable literal returning-intrinsic paren-expr) spaces?)
  (: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))))