A few parser fixes

README.md

@@ -1,44 +1,44 b''
 (инструкции на Русском - внизу)
 
 # sugar-qsp
 Compiler for QSP games which creates monolithic HTML pages.
 
 ## Usage
 
 There are three mastery levels
 
 1. Just build me the game:<br/>
 `sugar-qsp game.txt`<br/>
 And it will create the game in game.html
 
 2. I know what I'm doing:<br/>
 `sugar-qsp game.txt -o game.html --body body.html --js jquery.js my-js-library.js --css styles/*.css`<br/>
 All options are self-explanatory. The result is a monolithic html specified
 with the `-o` option. Default `body.html` (used by the first mastery level) can
 be found in `extas` directory.
 
 3. I'm a frontend developer!<br/>
 `sugar-qsp game.txt -c -o game.js`<br/>
 It just builds the game script into a js you can put on your website. To run
 the game execute `SugarQSP.start()`
 
 # sugar-qsp
 Компилятор для игр на QSP создающий монолитные страницы на HTML.
 
 ## Инструкции
 
 Есть три уровня мастерства.
 
 1. **Просто собери мне игру**:<br/>
 `sugar-qsp game.txt`<br/>
 Создаст игру в game.html
 
 2. **Я знаю что делаю**:<br/>
 `sugar-qsp game.txt -o game.html --body body.html --js jquery.js my-js-library.js --css styles/*.css`<br/>
-Если вы знаете что делаете, то для вас смысл опций очевиден. `body.html`
-по-умолчанию лежит в каталоге `extras`.
+Если вы знаете что делаете, то для вас смысл опций очевиден. `body.html` и `default.css`
+лежат в каталоге `extras`.
 
 3. **Я - фронтендер!**<br/>
 `sugar-qsp game.txt -c -o game.js`<br/>
 Просто соберёт игру в Javascript файл который вы можете разместить на своём
-сайте как вам угодно. Для запуска игры вызовите `SugarQSP.start()`.
+сайте как вам угодно.

src/intrinsic-macros.lisp

@@ -1,140 +1,144 b''
 
 (in-package sugar-qsp)
 
 ;;;; Macros implementing some intrinsics where it makes sense
 ;;;; E.g. an equivalent JS function exists, or it's a direct API call
 
 ;;; 1loc
 
 ;;; 2var
 
 (ps:defpsmacro killvar (varname &optional (index :whole))
   `(api-call kill-var ,varname ,index))
 
 (ps:defpsmacro killall ()
   `(api-call kill-all))
 
 ;;; 3expr
 
 (ps:defpsmacro obj (name)
   `(funcall (root objs includes) ,name))
 
 (ps:defpsmacro loc (name)
   `(funcall (root locs includes) ,name))
 
 (ps:defpsmacro no (arg)
   `(- -1 ,arg))
 
 ;;; 4code
 
 (ps:defpsmacro qspver ()
   "0.0.1")
 
 (ps:defpsmacro curloc ()
   `(root current-location))
 
 (ps:defpsmacro rnd ()
   `(funcall (root lib rand) 1 1000))
 
 (ps:defpsmacro qspmax (&rest args)
-  `(max ,@args))
+  (if (= 1 (length args))
+      `(*math.max.apply nil ,@args)
+      `(*math.max ,@args)))
 
 (ps:defpsmacro qspmin (&rest args)
-  `(min ,@args))
+  (if (= 1 (length args))
+      `(*math.min.apply nil ,@args)
+      `(*math.min ,@args)))
 
 ;;; 5arrays
 
 (ps:defpsmacro arrsize (name)
   `(api-call array-size ,name))
 
 ;;; 6str
 
 (ps:defpsmacro len (s)
   `(length ,s))
 
 (ps:defpsmacro mid (s from &optional count)
   `(ps:chain ,s (substring ,from ,count)))
 
 (ps:defpsmacro ucase (s)
   `(ps:chain ,s (to-upper-case)))
 
 (ps:defpsmacro lcase (s)
   `(ps:chain ,s (to-lower-case)))
 
 (ps:defpsmacro trim (s)
   `(ps:chain ,s (trim)))
 
 (ps:defpsmacro replace (s from to)
   `(ps:chain ,s (replace ,from ,to)))
 
 (ps:defpsmacro val (s)
   `(parse-int ,s 10))
 
 (ps:defpsmacro qspstr (n)
   `(ps:chain ,n (to-string)))
 
 ;;; 7if
 
 ;;; 8sub
 
 ;;; 9loops
 
 ;; JUMP is in ps-macros.lisp (because it's a part of a huge kludge)
 
 (ps:defpsmacro exit ()
   `(return-from nil (values)))
 
 ;;; 10dynamic
 
 ;;; 11main
 
 (ps:defpsmacro desc (s)
   (declare (ignore s))
   "")
 
 ;;; 12stat
 
 (ps:defpsmacro showstat (enable)
   `(api-call enable-frame :stat ,enable))
 
 ;;; 13diag
 
 (ps:defpsmacro msg (text)
   `(alert ,text))
 
 ;;; 14act
 
 (ps:defpsmacro showacts (enable)
   `(api-call enable-frame :acts ,enable))
 
 (ps:defpsmacro delact (name)
   `(api-call del-act ,name))
 
 (ps:defpsmacro cla ()
   `(api-call clear-act))
 
 ;;; 15objs
 
 (ps:defpsmacro showobjs (enable)
   `(api-call enable-frame :objs ,enable))
 
 (ps:defpsmacro countobj ()
   `(length (root objs)))
 
 (ps:defpsmacro getobj (index)
   `(or (elt (root objs) ,index) ""))
 
 ;;; 16menu
 
 ;;; 17sound
 
 (ps:defpsmacro isplay (filename)
   `(funcall (root playing includes) ,filename))
 
 ;;; 18img
 
 ;;; 19input
 
 ;;; 20time
 
 ;;; misc

src/parser.lisp

@@ -1,571 +1,580 b''
 
 (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))
+(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 trim-$ (str)
+  (if (char= #\$ (elt str 0))
+      (subseq str 1)
+      str))
 
 (defun qsp-keyword-p (id)
-  (member (intern (string-upcase id)) *keywords*))
+  (member (intern (trim-$ (string-upcase id))) *keywords*))
 
 (defun not-qsp-keyword-p (id)
-  (not (member (intern (string-upcase id)) *keywords*)))
+  (not (member (intern (trim-$ (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)))))
+    (intern (string-upcase (p:text list)))))
 
 (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 #\- (* not-newline) #\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)))
+(p:defrule comment (and #\! (* (or qsp-string brace-comment text-spaces not-newline)))
+  (:constant nil))
+
+(p:defrule brace-comment (and #\{ (* (not-brace character)) #\})
   (: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:& #\&))
+(p:defrule no-arguments (or (and spaces? (p:& #\newline))
+                            (and spaces? (p:& #\&))
+                            spaces?)
   (:constant nil))
-(p:defrule base-arguments (and first-argument (* next-argument))
-  (:destructure (first rest)
-    (list* first rest)))
+(p:defrule base-arguments (or (and first-argument (* next-argument)) spaces?)
+  (:lambda (list)
+    (if (null list)
+        nil
+        (list* (first list) (second list)))))
 
 ;;; 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")
+  (main-p   nil 1 1 "*p")
   (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")
+  (stat-p    nil 1 1 "p")
   (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 0)
   (savegame nil 0 0)
   ;; 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 "<>" "<=" ">=" "=<" "=>"
-                                                          #\= #\< #\> #\!)
+(p:defrule eq-expr (and sum-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)
+(p:defrule assignment (or kw-assignment plain-assignment op-assignment)
   (:destructure (var eq expr)
     (declare (ignore eq))
     (list 'set var expr)))
 
+(p:defrule kw-assignment (and (or (p:~ "let") (p:~ "set")) spaces? (or op-assignment plain-assignment))
+  (:function third))
+
+(p:defrule op-assignment (and variable spaces? (or "+" "-" "*" "/") #\= spaces? expression)
+  (:destructure (var ws1 op eq ws2 expr)
+                (declare (ignore ws1 ws2))
+                (list var eq (intern-first (list op 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))))