Use Parenscript's minifier and obfuscator... and namespaces. SAVES CURRENTLY BROKEN

src/api-macros.lisp

@@ -0,0 +1,15 b''
+
+(in-package sugar-qsp.api)
+
+(defpsmacro with-call-args (args &body body)
+  `(progn
+     (init-args ,args)
+     ,@body
+     (get-result)))
+
+(defpsmacro with-frame (&body body)
+  `(progn
+     (push-local-frame)
+     (unwind-protect
+          ,@body
+       (pop-local-frame))))

src/js-syms.lisp

@@ -0,0 +1,37 b''
+
+(in-package sugar-qsp.js)
+
+;;; Contains symbols from standard JS library to avoid obfuscating
+;;; and/or namespacing them
+
+(cl:defmacro syms (cl:&rest syms)
+  `(cl:progn
+     ,@(cl:loop :for sym :in syms
+          :collect `(cl:export ',sym))))
+
+(syms
+ ;; main
+ window
+ *object
+ now
+ onload
+ keys includes
+ has-own-property
+ ;; api
+ document get-element-by-id
+ onclick onchange
+ atob btoa
+ alert prompt
+ set-timeout set-interval clear-interval
+ *promise *j-s-o-n
+ href parse
+ set-prototype-of
+ body append-child remove-child
+ create-element set-attribute
+ *file-reader read-as-text
+ style display src
+ ;; lib
+ *number parse-int
+ to-upper-case concat
+ click target current-target files index-of
+ )

src/main-macros.lisp

@@ -0,0 +1,15 b''
+
+(in-package sugar-qsp.main)
+
+
+(defpsmacro by-id (id)
+  `(chain document (get-element-by-id ,id)))
+
+(defmacro+ps api-call (name &rest args)
+  `(,(intern (string-upcase name) "API") ,@args))
+
+(defpsmacro root (&rest path)
+  `(@ data ,@path))
+
+(defpsmacro in (key obj)
+  `(chain ,obj (has-own-property ,key)))

src/api.ps

@@ -1,396 +1,405 b''
 
-(in-package sugar-qsp)
+(in-package sugar-qsp.api)
 
 ;;; API deals with DOM manipulation and some bookkeeping for the
 ;;; intrinsics, namely variables
 ;;; API is an implementation detail and has no QSP documentation. It
 ;;; doesn't call intrinsics
 
-(setf (root api) (ps:create))
-
 ;;; Utils
 
-(defm (root api make-act-html) (title img)
-  (+ "<a class='qsp-act' href='#' onclick='SugarQSP.api.callAct(\"" title "\");'>"
+(defun make-act-html (title img)
+  (+ "<a class='qsp-act' href='" (ps-inline call-act) "(\"" title "\");'>"
      title
      "</a>"))
 
-(defm (root api make-menu-item-html) (num title img loc)
-  (+ "<a href='#' onclick='SugarQSP.api.runMenu(" num ", \"" loc "\")();'>"
+(defun make-menu-item-html (num title img loc)
+  (+ "<a href='" (ps-inline run-menu) "(" num ", \"" loc "\")();'>"
      "<img src='" img "'>"
      title
      "</a>"))
 
-(defm (root api report-error) (text)
+(defun report-error (text)
   (alert text))
 
-(defm (root api sleep) (msec)
-  (ps:new (*promise (ps:=> resolve (set-timeout resolve msec)))))
+(defun sleep (msec)
+  (new (*promise (=> resolve (set-timeout resolve msec)))))
 
-(defm (root api init-dom) ()
+(defun init-dom ()
   ;; Save/load buttons
-  (let ((btn (document.get-element-by-id "qsp-btn-save")))
-    (setf (ps:@ btn onclick) this.savegame)
-    (setf (ps:@ btn href) "#"))
-  (let ((btn (document.get-element-by-id "qsp-btn-open")))
-    (setf (ps:@ btn onclick) this.opengame)
-    (setf (ps:@ btn href) "#"))
+  (let ((btn (by-id "qsp-btn-save")))
+    (setf (@ btn onclick) savegame)
+    (setf (@ btn href) "#"))
+  (let ((btn (by-id "qsp-btn-open")))
+    (setf (@ btn onclick) opengame)
+    (setf (@ btn href) "#"))
   ;; Close image on click
-  (setf (ps:@ (document.get-element-by-id "qsp-image-container") onclick)
-        (this.show-image nil))
+  (setf (@ (by-id "qsp-image-container") onclick)
+        (show-image nil))
   ;; Close the dropdown on any click
-  (setf window.onclick
+  (setf (@ window onclick)
         (lambda (event)
-          (setf (ps:@ (api-call get-frame :dropdown) style display) "none"))))
+          (setf (@ (get-frame :dropdown) style display) "none"))))
 
-(defm (root api call-serv-loc) (var-name &rest args)
-  (let ((loc-name (api-call get-var name 0 :str)))
+(defun call-serv-loc (var-name &rest args)
+  (let ((loc-name (get-var var-name 0 :str)))
     (when loc-name
-      (let ((loc (ps:getprop (root locs) loc-name)))
+      (let ((loc (getprop (root locs) loc-name)))
         (when loc
           (funcall loc args))))))
 
 ;;; Misc
 
-(defm (root api newline) (key)
-  (this.append-id (this.key-to-id key) "<br>" t))
+(defun newline (key)
+  (append-id (key-to-id key) "<br>" t))
 
-(defm (root api clear-id) (id)
-  (setf (ps:inner-html (document.get-element-by-id id)) ""))
+(defun clear-id (id)
+  (setf (inner-html (by-id id)) ""))
 
-(setf (root api text-escaper) (document.create-element :textarea))
+(defvar text-escaper (chain document (create-element :textarea)))
 
-(defm (root api prepare-contents) (s &optional force-html)
-  (if (or force-html (var "USEHTML" 0 :num))
+(defun prepare-contents (s &optional force-html)
+  (if (or force-html (get-var "USEHTML" 0 :num))
       s
       (progn
-        (setf (ps:@ (root api text-escaper) text-content) s)
-        (ps:inner-html (root api text-escaper)))))
+        (setf (@ text-escaper text-content) s)
+        (inner-html text-escaper))))
 
-(defm (root api get-id) (id &optional force-html)
-  (ps:inner-html (document.get-element-by-id id)))
+(defun get-id (id &optional force-html)
+  (inner-html (by-id id)))
 
-(defm (root api set-id) (id contents &optional force-html)
-  (setf (ps:inner-html (document.get-element-by-id id)) (this.prepare-contents contents force-html)))
+(defun set-id (id contents &optional force-html)
+  (setf (inner-html (by-id id)) (prepare-contents contents force-html)))
 
-(defm (root api append-id) (id contents &optional force-html)
+(defun append-id (id contents &optional force-html)
   (when contents
-    (incf (ps:inner-html (document.get-element-by-id id)) (this.prepare-contents contents force-html))))
+    (incf (inner-html (by-id id)) (prepare-contents contents force-html))))
 
 ;;; Function calls
 
-(defm (root api init-args) (args)
+(defun init-args (args)
   (dotimes (i (length args))
     (let ((arg (elt args i)))
       (if (numberp arg)
-          (this.set-var args i :num arg)
-          (this.set-var args i :str arg)))))
+          (set-var args i :num arg)
+          (set-var args i :str arg)))))
 
-(defm (root api get-result) ()
-  (if (not (equal "" (var result 0 :str)))
-      (var result 0 :str)
-      (var result 0 :num)))
+(defun get-result ()
+  (if (not (equal "" (get-var result 0 :str)))
+      (get-var result 0 :str)
+      (get-var result 0 :num)))
 
-(defm (root api call-loc) (name args)
+(defun call-loc (name args)
   (with-frame
-      (funcall (ps:getprop (root locs) name) args)))
+      (with-call-args args
+        (funcall (getprop (root locs) name) args))))
 
-(defm (root api call-act) (title)
+(defun call-act (title)
   (with-frame
-      (funcall (ps:getprop (root acts) title))))
+      (funcall (getprop (root acts) title 'act))))
 
 ;;; Text windows
 
-(defm (root api key-to-id) (key)
+(defun key-to-id (key)
   (case key
     (:main "qsp-main")
     (:stat "qsp-stat")
     (:objs "qsp-objs")
     (:acts "qsp-acts")
     (:input "qsp-input")
     (:dropdown "qsp-dropdown")
-    (t (this.report-error "Internal error!"))))
+    (t (report-error "Internal error!"))))
 
-(defm (root api get-frame) (key)
-  (document.get-element-by-id (this.key-to-id key)))
+(defun get-frame (key)
+  (by-id (key-to-id key)))
 
-(defm (root api add-text) (key text)
-  (this.append-id (this.key-to-id key) text))
+(defun add-text (key text)
+  (append-id (key-to-id key) text))
 
-(defm (root api get-text) (key)
-  (this.get-id (this.key-to-id key)))
+(defun get-text (key)
+  (get-id (key-to-id key)))
 
-(defm (root api clear-text) (key)
-  (this.clear-id (this.key-to-id key)))
+(defun clear-text (key)
+  (clear-id (key-to-id key)))
 
-(defm (root api enable-frame) (key enable)
-  (let ((obj (this.get-frame key)))
-    (setf obj.style.display (if enable "block" "none"))
+(defun enable-frame (key enable)
+  (let ((obj (get-frame key)))
+    (setf (@ obj style display) (if enable "block" "none"))
     (values)))
 
 ;;; Actions
 
-(defm (root api add-act) (title img act)
-  (setf (ps:getprop (root acts) title)
-        (ps:create :img img :act act))
-  (this.update-acts))
+(defun add-act (title img act)
+  (setf (getprop (root acts) title)
+        (create img img act act))
+  (update-acts))
 
-(defm (root api del-act) (title)
-  (delete (ps:getprop (root acts) title))
-  (this.update-acts))
+(defun del-act (title)
+  (delete (getprop (root acts) title))
+  (update-acts))
 
-(defm (root api clear-act) ()
-  (setf (root acts) (ps:create))
-  (this.clear-id "qsp-acts"))
+(defun clear-act ()
+  (setf (root acts) (create))
+  (clear-id "qsp-acts"))
 
-(defm (root api update-acts) ()
-  (this.clear-id "qsp-acts")
-  (let ((elt (document.get-element-by-id "qsp-acts")))
-    (ps:for-in (title (root acts))
-      (let ((obj (ps:getprop (root acts) title)))
-        (incf (ps:inner-html elt) (this.make-act-html title (ps:getprop obj :img)))))))
-      
+(defun update-acts ()
+  (clear-id "qsp-acts")
+  (let ((elt (by-id "qsp-acts")))
+    (for-in (title (root acts))
+            (let ((obj (getprop (root acts) title)))
+              (incf (inner-html elt) (make-act-html title (getprop obj :img)))))))
+
 
 ;;; "Syntax"
 
-(defm (root api qspfor) (name index from to step body)
-  (block nil
-    (ps:for ((i from))
-            ((< i to))
-            ((incf i step))
-      (this.set-var name index :num i)
-      (unless (funcall body)
-        (return)))))
+(defun qspfor (name index from to step body)
+  (for ((i from))
+       ((< i to))
+       ((incf i step))
+       (set-var name index :num i)
+       (unless (funcall body)
+         (return-from qspfor))))
 
 ;;; Variable class
 
-(defm (root api *var) (name)
+(defun *var (name)
   ;; From strings to numbers
-  (setf this.indexes (ps:create))
+  (setf (@ this indexes) (create))
   ;; From numbers to {num: 0, str: ""} objects
-  (setf this.values (list))
+  (setf (@ this values) (list))
   (values))
 
-(defm (root api *var prototype new-value) ()
-  (ps:create :num 0 :str ""))
+(defun new-value ()
+  (create :num 0 :str ""))
 
-(defm (root api *var prototype index-num) (index)
-  (let ((num-index
-         (if (stringp index)
-             (if (in index this.indexes)
-                 (ps:getprop this.indexes index)
-                 (let ((n (length this.values)))
-                   (setf (ps:getprop this.indexes index) n)
-                   n))
-             index)))
-    (unless (in num-index this.values)
-      (setf (elt this.values num-index) (this.new-value)))
-    num-index))
+(setf (@ *var prototype index-num)
+      (lambda (index)
+        (let ((num-index
+               (if (stringp index)
+                   (if (in index (@ this indexes))
+                       (getprop (@ this indexes) index)
+                       (let ((n (length (@ this values))))
+                         (setf (getprop (@ this indexes) index) n)
+                         n))
+                   index)))
+          (unless (in num-index (@ this values))
+            (setf (elt (@ this values) num-index) (new-value)))
+          num-index)))
 
-(defm (root api *var prototype get) (index slot)
-  (unless (or index (= 0 index))
-    (setf index (1- (length this.values))))
-  (ps:getprop this.values (this.index-num index) slot))
+(setf (@ *var prototype get)
+      (lambda (index slot)
+        (unless (or index (= 0 index))
+          (setf index (1- (length (@ this values)))))
+        (getprop (@ this values) (chain this (index-num index)) slot)))
 
-(defm (root api *var prototype set) (index slot value)
-  (unless (or index (= 0 index))
-    (setf index (length store)))
-  (case slot
-    (:num (setf value (ps:chain *number (parse-int value))))
-    (:str (setf value (ps:chain value (to-string)))))
-  (setf (ps:getprop this.values (this.index-num index) slot) value)
-  (values))
+(setf (@ *var prototype set)
+      (lambda (index slot value)
+        (unless (or index (= 0 index))
+          (setf index (length (@ this values))))
+        (case slot
+          (:num (setf value (chain *number (parse-int value))))
+          (:str (setf value (chain value (to-string)))))
+        (setf (getprop (@ this values)
+                       (chain this (index-num index))
+                       slot) value)
+        (values)))
 
-(defm (root api *var prototype kill) (index)
-  (setf (elt this.values (this.index-num index)) (this.new-value)))
+(setf (@ *var prototype kill)
+      (lambda (index)
+        (setf (elt (@ this values) (chain this (index-num index)))
+              (new-value))
+        (delete (getprop 'this 'indexes index))))
 
 ;;; Variables
 
-(defm (root api var-real-name) (name)
-  (if (= (ps:@ name 0) #\$)
-      (values (ps:chain name (substr 1)) :str)
+(defun var-real-name (name)
+  (if (= (@ name 0) #\$)
+      (values (chain name (substr 1)) :str)
       (values name :num)))
 
-(defm (root api ensure-var) (name)
-  (let ((store (this.var-ref name)))
+(defun ensure-var (name)
+  (let ((store (var-ref name)))
     (unless store
-      (setf store (ps:new (this.-var name)))
-      (setf (ps:getprop (root vars) name) store))
+      (setf store (new (-var name)))
+      (setf (getprop (root vars) name) store))
     store))
 
-(defm (root api var-ref) (name)
-  (let ((local-store (this.current-local-frame)))
+(defun var-ref (name)
+  (let ((local-store (current-local-frame)))
     (cond ((and local-store (in name local-store))
-           (ps:getprop local-store name))
+           (getprop local-store name))
           ((in name (root vars))
-           (ps:getprop (root vars) name))
+           (getprop (root vars) name))
           (t nil))))
 
-(defm (root api get-var) (name index slot)
-  (ps:chain (this.ensure-var name) (get index slot)))
+(defun get-var (name index slot)
+  (chain (ensure-var name) (get index slot)))
 
-(defm (root api set-var) (name index slot value)
-  (ps:chain (this.ensure-var name) (set index slot value))
+(defun set-var (name index slot value)
+  (chain (ensure-var name) (set index slot value))
   (values))
 
-(defm (root api get-array) (name)
-  (this.var-ref name))
+(defun get-array (name)
+  (var-ref name))
 
-(defm (root api set-array) (name value)
-  (let ((store (this.var-ref name)))
-    (setf (ps:@ store values) (ps:@ value values))
-    (setf (ps:@ store indexes) (ps:@ value indexes)))
+(defun set-array (name value)
+  (let ((store (var-ref name)))
+    (setf (@ store values) (@ value values))
+    (setf (@ store indexes) (@ value indexes)))
   (values))
 
-(defm (root api kill-var) (name &optional index)
+(defun kill-var (name &optional index)
   (if (and index (not (= 0 index))) 
-      (ps:chain (ps:getprop (root vars) name) (kill index))
-      (ps:delete (ps:getprop (root vars) name)))
+      (chain (getprop (root vars) name) (kill index))
+      (delete (getprop (root vars) name)))
   (values))
 
-(defm (root api array-size) (name)
-  (ps:getprop (this.var-ref name) 'length))
+(defun array-size (name)
+  (getprop (var-ref name) 'length))
 
 ;;; Locals
 
-(defm (root api push-local-frame) ()
-  (ps:chain (root locals) (push (ps:create)))
+(defun push-local-frame ()
+  (chain (root locals) (push (create)))
   (values))
 
-(defm (root api pop-local-frame) ()
-  (ps:chain (root locals) (pop))
+(defun pop-local-frame ()
+  (chain (root locals) (pop))
   (values))
 
-(defm (root api current-local-frame) ()
+(defun current-local-frame ()
   (elt (root locals) (1- (length (root locals)))))
 
-(defm (root api new-local) (name)
-  (let ((frame (this.current-local-frame)))
+(defun new-local (name)
+  (let ((frame (current-local-frame)))
     (unless (in name frame)
-      (setf (ps:getprop frame name) (ps:create)))
+      (setf (getprop frame name) (create)))
     (values)))
 
 ;;; Objects
 
-(defm (root api update-objs) ()
-  (let ((elt (document.get-element-by-id "qsp-objs")))
-    (setf (ps:inner-html elt) "<ul>")
+(defun update-objs ()
+  (let ((elt (by-id "qsp-objs")))
+    (setf (inner-html elt) "<ul>")
     (loop :for obj :in (root objs)
-       :do (incf (ps:inner-html elt) (+ "<li>" obj)))
-    (incf (ps:inner-html elt) "</ul>")))
+       :do (incf (inner-html elt) (+ "<li>" obj)))
+    (incf (inner-html elt) "</ul>")))
 
 ;;; Menu
 
-(defm (root api menu) (menu-data)
-  (let ((elt (document.get-element-by-id "qsp-dropdown"))
+(defun menu (menu-data)
+  (let ((elt (by-id "qsp-dropdown"))
         (i 0))
-    (setf (ps:inner-html elt) "")
+    (setf (inner-html elt) "")
     (loop :for item :in menu-data
        :do (incf i)
-       :do (incf (ps:inner-html elt) (this.make-menu-item-html i item.text item.icon item.loc)))
-    (setf elt.style.display "block")))
+       :do (incf (inner-html elt) (make-menu-item-html i
+                                                       (@ item text)
+                                                       (@ item icon)
+                                                       (@ item loc))))
+    (setf (@ elt style display) "block")))
 
 ;;; Content
 
-(defm (root api clean-audio) ()
-  (loop :for k :in (*object.keys (root playing))
-     :for v := (ps:getprop (root playing) k)
-     :do (when (ps:@ v ended)
-           (ps:delete (ps:@ (root playing) k)))))
+(defun clean-audio ()
+  (loop :for k :in (chain *object (keys (root playing)))
+     :for v := (getprop (root playing) k)
+     :do (when (@ v ended)
+           (delete (@ (root playing) k)))))
 
-(defm (root api show-image) (path)
-  (let ((img (document.get-element-by-id "qsp-image")))
+(defun show-image (path)
+  (let ((img (by-id "qsp-image")))
     (cond (path
-           (setf img.src path)
-           (setf img.style.display "flex"))
+           (setf (@ img src) path)
+           (setf (@ img style display) "flex"))
           (t
-           (setf img.src "")
-           (setf img.style.display "hidden")))))
+           (setf (@ img src) "")
+           (setf (@ img style display) "hidden")))))
 
 ;;; Saves
 
-(defm (root api opengame) ()
-  (let ((element (document.create-element :input)))
-    (element.set-attribute :type :file)
-    (element.set-attribute :id :qsp-opengame)
-    (element.set-attribute :tabindex -1)
-    (element.set-attribute "aria-hidden" t)
-    (setf element.style.display :block)
-    (setf element.style.visibility :hidden)
-    (setf element.style.position :fixed)
-    (setf element.onchange
+(defun opengame ()
+  (let ((element (chain document (create-element :input))))
+    (chain element (set-attribute :type :file))
+    (chain element (set-attribute :id :qsp-opengame))
+    (chain element (set-attribute :tabindex -1))
+    (chain element (set-attribute "aria-hidden" t))
+    (setf (@ element style display) :block)
+    (setf (@ element style visibility) :hidden)
+    (setf (@ element style position) :fixed)
+    (setf (@ element onchange)
           (lambda (event)
-            (let* ((file (elt event.target.files 0))
-                   (reader (ps:new (*file-reader))))
-              (setf reader.onload
+            (let* ((file (@ event target files 0))
+                   (reader (new (*file-reader))))
+              (setf (@ reader onload)
                     (lambda (ev)
                       (block nil
-                             (let ((target ev.current-target))
-                               (unless target.result
-                                 (return))
-                               (api-call base64-to-state target.result)
-                               (api-call unstash-state)))))
-              (reader.read-as-text file))))
-    (document.body.append-child element)
-    (element.click)
-    (document.body.remove-child element)))
+                        (let ((target (@ ev current-target)))
+                          (unless (@ target result)
+                            (return))
+                          (base64-to-state (@ target result))
+                          (unstash-state)))))
+              (chain reader (read-as-text file)))))
+    (chain document body (append-child element))
+    (chain element (click))
+    (chain document body (remove-child element))))
 
-(defm (root api savegame) ()
-  (let ((element (document.create-element :a)))
-    (element.set-attribute :href (+ "data:text/plain;charset=utf-8," (api-call state-to-base64)))
-    (element.set-attribute :download "savegame.sav")
-    (setf element.style.display :none)
-    (document.body.append-child element)
-    (element.click)
-    (document.body.remove-child element)))
+(defun savegame ()
+  (let ((element (chain document (create-element :a))))
+    (chain element (set-attribute :href (+ "data:text/plain;charset=utf-8," (state-to-base64))))
+    (chain element (set-attribute :download "savegame.sav"))
+    (setf (@ element style display) :none)
+    (chain document body (append-child element))
+    (chain element (click))
+    (chain document body (remove-child element))))
 
-(defm (root api stash-state) (args)
-  (api-call call-serv-loc "ONGSAVE")
+(defun stash-state (args)
+  (call-serv-loc "ONGSAVE")
   (setf (root state-stash)
-        (*j-s-o-n.stringify
-         (ps:create vars (root vars)
-                    objs (root objs)
-                    loc-args args
-                    msecs (- (*date.now) (root started-at))
-                    main-html (ps:inner-html
-                               (document.get-element-by-id :qsp-main))
-                    stat-html (ps:inner-html
-                               (document.get-element-by-id :qsp-stat))
-                    next-location (root current-location))))
+        (chain *j-s-o-n (stringify
+                         (create vars (root vars)
+                                 objs (root objs)
+                                 loc-args args
+                                 msecs (- (chain *date (now)) (root started-at))
+                                 main-html (inner-html
+                                            (by-id :qsp-main))
+                                 stat-html (inner-html
+                                            (by-id :qsp-stat))
+                                 next-location (root current-location)))))
   (values))
 
-(defm (root api unstash-state) ()
-  (let ((data (*j-s-o-n.parse (root state-stash))))
-    (this.clear-act)
-    (setf (root vars) (ps:@ data vars))
-    (loop :for k :in (*object.keys (root vars))
-       :do (*object.set-prototype-of (ps:getprop (root vars) k)
-                                     (root api *var prototype)))
-    (setf (root started-at) (- (*date.now) (ps:@ data msecs)))
-    (setf (root objs) (ps:@ data objs))
-    (setf (root current-location) (ps:@ data next-location))
-    (setf (ps:inner-html (document.get-element-by-id :qsp-main))
-          (ps:@ data main-html))
-    (setf (ps:inner-html (document.get-element-by-id :qsp-stat))
-          (ps:@ data stat-html))
-    (this.update-objs)
-    (api-call call-serv-loc "ONGLOAD")
-    (api-call call-loc (root current-location) (ps:@ data loc-args))
+(defun unstash-state ()
+  (let ((data (chain *j-s-o-n (parse (root state-stash)))))
+    (clear-act)
+    (setf (root vars) (@ data vars))
+    (loop :for k :in (chain *object (keys (root vars)))
+       :do (chain *object (set-prototype-of (getprop (root vars) k)
+                                            (@ *var prototype))))
+    (setf (root started-at) (- (chain *date (now)) (@ data msecs)))
+    (setf (root objs) (@ data objs))
+    (setf (root current-location) (@ data next-location))
+    (setf (inner-html (by-id :qsp-main))
+          (@ data main-html))
+    (setf (inner-html (by-id :qsp-stat))
+          (@ data stat-html))
+    (update-objs)
+    (call-serv-loc "ONGLOAD")
+    (call-loc (root current-location) (@ data loc-args))
     (values)))
 
-(defm (root api state-to-base64) ()
+(defun state-to-base64 ()
   (btoa (encode-u-r-i-component (root state-stash))))
 
-(defm (root api base64-to-state) (data)
+(defun base64-to-state (data)
   (setf (root state-stash) (decode-u-r-i-component (atob data))))
 
 ;;; Timers
 
-(defm (root api set-timer) (interval)
+(defun set-timer (interval)
   (setf (root timer-interval) interval)
   (clear-interval (root timer-obj))
   (setf (root timer-obj)
         (set-interval
          (lambda ()
-           (api-call call-serv-loc "COUNTER"))
+           (call-serv-loc "COUNTER"))
          interval)))

src/class.lisp

@@ -1,28 +1,32 b''
 
 (in-package sugar-qsp)
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defun src-file (filename)
     (uiop/pathname:merge-pathnames*
      filename
      (asdf:system-source-directory :sugar-qsp)))
   (defun read-code-from-string (string)
     (with-input-from-string (in string)
-      `(progn
-         ,@(loop :for form := (read in nil :eof)
-              :until (eq form :eof)
-              :collect form))))
+      (let ((*package* *package*))
+        `(progn
+           ,@(loop :for form := (read in nil :eof)
+                :until (eq form :eof)
+                :when (eq (first form) 'cl:in-package)
+                :do (setf *package* (find-package (second form)))
+                :else
+                :collect form)))))
   (defun load-src (filename)
     (alexandria:read-file-into-string (src-file filename))))
 
 (defclass compiler ()
   ((body :accessor body :initform #.(load-src "extras/body.html"))
    (css  :accessor css  :initform (list #.(load-src "extras/default.css")))
-   (js   :accessor js   :initform '#.(mapcar #'read-code-from-string
-                                             (mapcar #'load-src
-                                                     (list "src/intrinsics.ps"
-                                                           "src/api.ps"
-                                                           "src/main.ps"))))
+   (js   :accessor js   :initform (reverse
+                                   (list
+                                    '#.(read-code-from-string (load-src "src/main.ps"))
+                                    '#.(read-code-from-string (load-src "src/api.ps"))
+                                    '#.(read-code-from-string (load-src "src/intrinsics.ps")))))
    (compile :accessor compile-only :initarg :compile)
    (target  :accessor target :initarg :target)
    (beautify :accessor beautify :initarg :beautify)))

src/intrinsic-macros.lisp

@@ -1,174 +1,174 b''
 
-(in-package sugar-qsp)
+(in-package sugar-qsp.lib)
 
 ;;;; 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)
-  `(api-call kill-var ,varname ,index))
+(defpsmacro killvar (varname &optional index)
+  `(kill-var ,varname ,index))
 
-(ps:defpsmacro killall ()
+(defpsmacro killall ()
   `(api-call kill-all))
 
 ;;; 3expr
 
-(ps:defpsmacro obj (name)
+(defpsmacro obj (name)
   `(funcall (root objs includes) ,name))
 
-(ps:defpsmacro loc (name)
+(defpsmacro loc (name)
   `(funcall (root locs includes) ,name))
 
-(ps:defpsmacro no (arg)
+(defpsmacro no (arg)
   `(- -1 ,arg))
 
 ;;; 4code
 
-(ps:defpsmacro qspver ()
+(defpsmacro qspver ()
   "0.0.1")
 
-(ps:defpsmacro curloc ()
+(defpsmacro curloc ()
   `(root current-location))
 
-(ps:defpsmacro rnd ()
-  `(funcall (root lib rand) 1 1000))
+(defpsmacro rnd ()
+  `(funcall rand 1 1000))
 
-(ps:defpsmacro qspmax (&rest args)
+(defpsmacro qspmax (&rest args)
   (if (= 1 (length args))
       `(*math.max.apply nil ,@args)
       `(*math.max ,@args)))
 
-(ps:defpsmacro qspmin (&rest args)
+(defpsmacro qspmin (&rest args)
   (if (= 1 (length args))
       `(*math.min.apply nil ,@args)
       `(*math.min ,@args)))
 
 ;;; 5arrays
 
-(ps:defpsmacro arrsize (name)
+(defpsmacro arrsize (name)
   `(api-call array-size ,name))
 
 ;;; 6str
 
-(ps:defpsmacro len (s)
+(defpsmacro len (s)
   `(length ,s))
 
-(ps:defpsmacro mid (s from &optional count)
-  `(ps:chain ,s (substring ,from ,count)))
+(defpsmacro mid (s from &optional count)
+  `(chain ,s (substring ,from ,count)))
 
-(ps:defpsmacro ucase (s)
-  `(ps:chain ,s (to-upper-case)))
+(defpsmacro ucase (s)
+  `(chain ,s (to-upper-case)))
 
-(ps:defpsmacro lcase (s)
-  `(ps:chain ,s (to-lower-case)))
+(defpsmacro lcase (s)
+  `(chain ,s (to-lower-case)))
 
-(ps:defpsmacro trim (s)
-  `(ps:chain ,s (trim)))
+(defpsmacro trim (s)
+  `(chain ,s (trim)))
 
-(ps:defpsmacro replace (s from to)
-  `(ps:chain ,s (replace ,from ,to)))
+(defpsmacro replace (s from to)
+  `(chain ,s (replace ,from ,to)))
 
-(ps:defpsmacro val (s)
+(defpsmacro val (s)
   `(parse-int ,s 10))
 
-(ps:defpsmacro qspstr (n)
-  `(ps:chain ,n (to-string)))
+(defpsmacro qspstr (n)
+  `(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 ()
+(defpsmacro exit ()
   `(return-from nil (values)))
 
 ;;; 10dynamic
 
 ;;; 11main
 
-(ps:defpsmacro desc (s)
+(defpsmacro desc (s)
   (declare (ignore s))
   "")
 
 ;;; 12stat
 
-(ps:defpsmacro showstat (enable)
+(defpsmacro showstat (enable)
   `(api-call enable-frame :stat ,enable))
 
 ;;; 13diag
 
-(ps:defpsmacro msg (text)
+(defpsmacro msg (text)
   `(alert ,text))
 
 ;;; 14act
 
-(ps:defpsmacro showacts (enable)
+(defpsmacro showacts (enable)
   `(api-call enable-frame :acts ,enable))
 
-(ps:defpsmacro delact (name)
+(defpsmacro delact (name)
   `(api-call del-act ,name))
 
-(ps:defpsmacro cla ()
+(defpsmacro cla ()
   `(api-call clear-act))
 
 ;;; 15objs
 
-(ps:defpsmacro showobjs (enable)
+(defpsmacro showobjs (enable)
   `(api-call enable-frame :objs ,enable))
 
-(ps:defpsmacro countobj ()
+(defpsmacro countobj ()
   `(length (root objs)))
 
-(ps:defpsmacro getobj (index)
+(defpsmacro getobj (index)
   `(or (elt (root objs) ,index) ""))
 
 ;;; 16menu
 
 ;;; 17sound
 
-(ps:defpsmacro isplay (filename)
+(defpsmacro isplay (filename)
   `(funcall (root playing includes) ,filename))
 
 ;;; 18img
 
-(ps:defpsmacro view (&optional path)
+(defpsmacro view (&optional path)
   `(api-call show-image ,path))
 
 ;;; 19input
 
-(ps:defpsmacro showinput (enable)
+(defpsmacro showinput (enable)
   `(api-call enable-frame :input ,enable))
 
 ;;; 20time
 
-(ps:defpsmacro wait (msec)
+(defpsmacro wait (msec)
   `(await (api-call sleep ,msec)))
 
-(ps:defpsmacro settimer (interval)
+(defpsmacro settimer (interval)
   `(api-call set-timer ,interval))
 
 ;;; 21local
 
-(ps:defpsmacro local (var &optional expr)
+(defpsmacro local (var &optional expr)
   `(progn
      (api-call new-local ,(string (second var)))
      ,@(when expr
          `((set ,var ,expr)))))
 
 ;;; 22for
 
 ;;; misc
 
-(ps:defpsmacro opengame (&optional filename)
+(defpsmacro opengame (&optional filename)
   (declare (ignore filename))
   `(api-call opengame))
 
-(ps:defpsmacro savegame (&optional filename)
+(defpsmacro savegame (&optional filename)
   (declare (ignore filename))
   `(api-call savegame))

src/intrinsics.ps

@@ -1,301 +1,301 b''
 
-(in-package sugar-qsp)
+(in-package sugar-qsp.lib)
 
 ;;;; Functions and procedures defined by the QSP language.
 ;;;; They can call api and deal with locations and other data directly.
 ;;;; Except vars. Use VAR and SET or GET-VAR and SET-VAR api calls.
 
-(setf (root lib) (ps:create))
-
 ;;; 1loc
 
-(defm (root lib goto) (target args)
-  (api-call clear-text :main)
-  (funcall (root lib xgoto) target (or args (list)))
+(defun goto (target args)
+  (api:clear-text :main)
+  (funcall xgoto target (or args (list)))
   (values))
 
-(defm (root lib xgoto) (target args)
-  (api-call clear-act)
-  (setf (root current-location) (ps:chain target (to-upper-case)))
-  (api-call stash-state args)
-  (funcall (ps:getprop (root locs) (root current-location))
+(defun xgoto (target args)
+  (api:clear-act)
+  (setf (root current-location) (chain target (to-upper-case)))
+  (api:stash-state args)
+  (funcall (getprop (root locs) (root current-location))
            (or args (list)))
   (values))
 
 ;;; 2var
 
 ;;; 3expr
 
 ;;; 4code
 
-(defm (root lib rand) (a &optional (b 1))
+(defun rand (a &optional (b 1))
   (let ((min (min a b))
         (max (max a b)))
-    (+ min (ps:chain *math (random (- max min))))))
+    (+ min (chain *math (random (- max min))))))
 
 ;;; 5arrays
 
-(defm (root lib copyarr) (to from start count)
+(defun copyarr (to from start count)
   (multiple-value-bind (to-name to-slot)
-      (api-call var-real-name to)
+      (api:var-real-name to)
     (multiple-value-bind (from-name from-slot)
-        (api-call var-real-name from)
-      (ps:for ((i start))
-              ((< i (min (api-call array-size from-name)
-                         (+ start count))))
-              ((incf i))
-              (api-call set-var to-name (+ start i) to-slot
-                        (api-call get-var from-name (+ start i) from-slot))))))
+        (api:var-real-name from)
+      (for ((i start))
+           ((< i (min (api:array-size from-name)
+                      (+ start count))))
+           ((incf i))
+           (api:set-var to-name (+ start i) to-slot
+                        (api:get-var from-name (+ start i) from-slot))))))
 
-(defm (root lib arrpos) (name value &optional (start 0))
+(defun arrpos (name value &optional (start 0))
   (multiple-value-bind (real-name slot)
-      (api-call var-real-name name)
-    (ps:for ((i start)) ((< i (api-call array-size name))) ((incf i))
-      (when (eq (api-call get-var real-name i slot) value)
-        (return i))))
+      (api:var-real-name name)
+    (for ((i start)) ((< i (api:array-size name))) ((incf i))
+         (when (eq (api:get-var real-name i slot) value)
+           (return-from arrpos i))))
   -1)
 
-(defm (root lib arrcomp) (name pattern &optional (start 0))
+(defun arrcomp (name pattern &optional (start 0))
   (multiple-value-bind (real-name slot)
-      (api-call var-real-name name)
-    (ps:for ((i start)) ((< i (api-call array-size name))) ((incf i))
-      (when (funcall (ps:getprop (api-call get-var real-name i slot) 'match) pattern)
-        (return i))))
+      (api:var-real-name name)
+    (for ((i start)) ((< i (api:array-size name))) ((incf i))
+         (when (funcall (getprop (api:get-var real-name i slot) 'match) pattern)
+           (return-from arrcomp i))))
   -1)
 
 ;;; 6str
 
-(defm (root lib instr) (s subs &optional (start 1))
-  (+ start (ps:chain s (substring (- start 1)) (search subs))))
+(defun instr (s subs &optional (start 1))
+  (+ start (chain s (substring (- start 1)) (search subs))))
 
-(defm (root lib isnum) (s)
+(defun isnum (s)
   (if (is-na-n s)
       0
       -1))
 
-(defm (root lib strcomp) (s pattern)
-  (if (s.match pattern)
+(defun strcomp (s pattern)
+  (if (chain s (match pattern))
       -1
       0))
 
-(defm (root lib strfind) (s pattern group)
-  (let* ((re (ps:new (*reg-exp pattern)))
-         (match (re.exec s)))
-    (match.group group)))
+(defun strfind (s pattern group)
+  (let* ((re (new (*reg-exp pattern)))
+         (match (chain re (exec s))))
+    (chain match (group group))))
 
-(defm (root lib strpos) (s pattern &optional (group 0))
-  (let* ((re (ps:new (*reg-exp pattern)))
-         (match (re.exec s))
-         (found (match.group group)))
+(defun strpos (s pattern &optional (group 0))
+  (let* ((re (new (*reg-exp pattern)))
+         (match (chain re (exec s)))
+         (found (chain match (group group))))
     (if found
-        (s.search found)
+        (chain s (search found))
         0)))
 
 ;;; 7if
 
 ;; Has to be a function because it always evaluates all three of its
 ;; arguments
-(defm (root lib iif) (cond-expr then-expr else-expr)
+(defun iif (cond-expr then-expr else-expr)
   (if cond-expr then-expr else-expr))
 
 ;;; 8sub
 
-(defm (root lib gosub) (target &rest args)
-  (funcall (ps:getprop (root locs) target) args)
+(defun gosub (target &rest args)
+  (funcall (getprop (root locs) target) args)
   (values))
 
-(defm (root lib func) (target &rest args)
-  (funcall (ps:getprop (root locs) target) args))
+(defun func (target &rest args)
+  (funcall (getprop (root locs) target) args))
 
 ;;; 9loops
 
 ;;; 10dynamic
 
-(defm (root lib dynamic) (block &rest args)
+(defun dynamic (block &rest args)
   (when (stringp block)
-    (api-call report-error "DYNAMIC can't evaluate arbitrary strings.\nUse {braces} to create blocks for DYNAMIC."))
-  (funcall block args)
+    (api:report-error "DYNAMIC can't evaluate arbitrary strings.\nUse {braces} to create blocks for DYNAMIC."))
+  (api:with-call-args args
+    (funcall block args))
   (values))
 
-(defm (root lib dyneval) (block &rest args)
+(defun dyneval (block &rest args)
   (when (stringp block)
-    (api-call report-error "DYNEVAL can't evaluate arbitrary strings.\nUse {braces} to create blocks for DYNEVAL."))
-  (funcall block args))
+    (api:report-error "DYNEVAL can't evaluate arbitrary strings.\nUse {braces} to create blocks for DYNEVAL."))
+  (api:with-call-args args
+    (funcall block args)))
 
 ;;; 11main
 
-(defm (root lib main-p) (s)
-  (api-call add-text :main s)
+(defun main-p (s)
+  (api:add-text :main s)
   (values))
 
-(defm (root lib main-pl) (s)
-  (api-call add-text :main s)
-  (api-call newline :main)
+(defun main-pl (s)
+  (api:add-text :main s)
+  (api:newline :main)
   (values))
 
-(defm (root lib main-nl) (s)
-  (api-call newline :main)
-  (api-call add-text :main s)
+(defun main-nl (s)
+  (api:newline :main)
+  (api:add-text :main s)
   (values))
 
-(defm (root lib maintxt) (s)
-  (api-call get-text :main)
+(defun maintxt (s)
+  (api:get-text :main)
   (values))
 
 ;; For clarity (it leaves a lib.desc() call in JS)
-(defm (root lib desc) (s)
+(defun desc (s)
   "")
 
-(defm (root lib main-clear) ()
-  (api-call clear-text :main)
+(defun main-clear ()
+  (api:clear-text :main)
   (values))
 
 ;;; 12stat
 
-(defm (root lib stat-p) (s)
-  (api-call add-text :stat s)
+(defun stat-p (s)
+  (api:add-text :stat s)
   (values))
 
-(defm (root lib stat-pl) (s)
-  (api-call add-text :stat s)
-  (api-call newline :stat)
+(defun stat-pl (s)
+  (api:add-text :stat s)
+  (api:newline :stat)
   (values))
 
-(defm (root lib stat-nl) (s)
-  (api-call newline :stat)
-  (api-call add-text :stat s)
+(defun stat-nl (s)
+  (api:newline :stat)
+  (api:add-text :stat s)
   (values))
 
-(defm (root lib stattxt) (s)
-  (api-call get-text :stat)
+(defun stattxt (s)
+  (api:get-text :stat)
   (values))
 
-(defm (root lib stat-clear) ()
-  (api-call clear-text :stat)
+(defun stat-clear ()
+  (api:clear-text :stat)
   (values))
 
-(defm (root lib cls) ()
-  (funcall (root lib stat-clear))
-  (funcall (root lib main-clear))
-  (funcall (root lib cla))
-  (funcall (root lib cmdclear))
+(defun cls ()
+  (stat-clear)
+  (main-clear)
+  (cla)
+  (cmdclear)
   (values))
 
 ;;; 13diag
 
 ;;; 14act
 
-(defm (root lib curacts) ()
+(defun curacts ()
   (let ((acts (root acts)))
     (lambda ()
       (setf (root acts) acts)
       (values))))
 
 ;;; 15objs
 
-(defm (root lib addobj) (name)
-  (ps:chain (root objs) (push name))
-  (api-call update-objs)
+(defun addobj (name)
+  (chain (root objs) (push name))
+  (api:update-objs)
   (values))
 
-(defm (root lib delobj) (name)
-  (let ((index (ps:chain (root objs) (index-of name))))
+(defun delobj (name)
+  (let ((index (chain (root objs) (index-of name))))
     (when (> index -1)
-      (funcall (root lib killobj) (1+ index))))
+      (killobj (1+ index))))
   (values))
 
-(defm (root lib killobj) (&optional (num nil))
+(defun killobj (&optional (num nil))
   (if (eq nil num)
       (setf (root objs) (list))
-      (ps:chain (root objs) (splice (1- num) 1)))
-  (api-call update-objs)
+      (chain (root objs) (splice (1- num) 1)))
+  (api:update-objs)
   (values))
 
 ;;; 16menu
 
-(defm (root lib menu) (menu-name)
+(defun menu (menu-name)
   (let ((menu-data (list)))
-    (loop :for item :in (api-call get-array (api-call var-real-name menu-name))
+    (loop :for item :in (api:get-array (api:var-real-name menu-name))
        :do (cond ((string= item "")
                   (break))
                  ((string= item "-:-")
-                  (ps:chain menu-data (push :delimiter)))
+                  (chain menu-data (push :delimiter)))
                  (t
-                  (let* ((tokens (ps:chain item (split ":"))))
+                  (let* ((tokens (chain item (split ":"))))
                     (when (= (length tokens) 2)
-                      (tokens.push ""))
-                    (let* ((text (ps:chain tokens (splice 0 (- tokens.length 2)) (join ":")))
-                           (loc (ps:getprop tokens (- tokens.length 2)))
-                           (icon (ps:getprop tokens (- tokens.length 1))))
-                      (ps:chain menu-data
-                                (push (ps:create text text
-                                                 loc loc
-                                                 icon icon))))))))
-    (api-call menu menu-data)
+                      (chain tokens (push "")))
+                    (let* ((text (chain tokens (splice 0 (- (length tokens) 2)) (join ":")))
+                           (loc (getprop tokens (- (length tokens) 2)))
+                           (icon (getprop tokens (- (length tokens) 1))))
+                      (chain menu-data
+                             (push (create text text
+                                           loc loc
+                                           icon icon))))))))
+    (api:menu menu-data)
     (values)))
 
 ;;; 17sound
 
-(defm (root lib play) (filename &optional (volume 100))
-  (let ((audio (ps:new (*audio filename))))
-    (setf (ps:getprop (root playing) filename) audio)
-    (setf (ps:@ audio volume) (* volume 0.01))
-    (ps:chain audio (play))))
+(defun play (filename &optional (volume 100))
+  (let ((audio (new (*audio filename))))
+    (setf (getprop (root playing) filename) audio)
+    (setf (@ audio volume) (* volume 0.01))
+    (chain audio (play))))
 
-(defm (root lib close) (filename)
+(defun close (filename)
   (funcall (root playing filename) stop)
-  (ps:delete (root playing filename)))
+  (delete (root playing filename)))
 
-(defm (root lib closeall) ()
-  (loop :for k :in (*object.keys (root playing))
-     :for v := (ps:getprop (root playing) k)
+(defun closeall ()
+  (loop :for k :in (chain *object (keys (root playing)))
+     :for v := (getprop (root playing) k)
      :do (funcall v stop))
-  (setf (root playing) (ps:create)))
+  (setf (root playing) (create)))
 
 ;;; 18img
 
-(defm (root lib refint) ()
+(defun refint ()
   ;; "Force interface update" Uh... what exactly do we do here?
-  (api-call report-error "REFINT is not supported")
+  (api:report-error "REFINT is not supported")
   )
 
 ;;; 19input
 
-(defm (root lib usertxt) ()
-  (let ((input (document.get-element-by-id "qsp-input")))
-    (ps:@ input value)))
+(defun usertxt ()
+  (let ((input (by-id "qsp-input")))
+    (@ input value)))
 
-(defm (root lib cmdclear) ()
-  (let ((input (document.get-element-by-id "qsp-input")))
-    (setf (ps:@ input value) "")))
+(defun cmdclear ()
+  (let ((input (by-id "qsp-input")))
+    (setf (@ input value) "")))
 
-(defm (root lib input) (text)
-  (window.prompt text))
+(defun input (text)
+  (chain window (prompt text)))
 
 ;;; 20time
 
-(defm (root lib msecscount) ()
-  (- (*date.now) (root started-at)))
+(defun msecscount ()
+  (- (chain *date (now)) (root started-at)))
 
 ;;; 21local
 
 ;;; 22for
 
 ;;; misc
 
-(defm (root lib rgb) (red green blue)
+(defun rgb (red green blue)
   (flet ((rgb-to-hex (comp)
-           (let ((hex (ps:chain (*number comp) (to-string 16))))
+           (let ((hex (chain (*number comp) (to-string 16))))
              (if (< (length hex) 2)
                  (+ "0" hex)
                  hex))))
     (+ "#" (rgb-to-hex red) (rgb-to-hex green) (rgb-to-hex red))))
 
-(defm (root lib openqst) ()
-  (api-call report-error "OPENQST is not supported."))
+(defun openqst ()
+  (api:report-error "OPENQST is not supported."))
 
-(defm (root lib addqst) ()
-  (api-call report-error "ADDQST is not supported. Bundle the library with the main game."))
+(defun addqst ()
+  (api:report-error "ADDQST is not supported. Bundle the library with the main game."))
 
-(defm (root lib killqst) ()
-  (api-call report-error "KILLQST is not supported."))
+(defun killqst ()
+  (api:report-error "KILLQST is not supported."))

src/main.lisp

@@ -1,121 +1,135 b''
 
 (in-package sugar-qsp)
 
 (defun entry-point-no-args ()
   (entry-point uiop:*command-line-arguments*))
 
 (defun entry-point (args)
   (catch :terminate
     (let ((compiler (apply #'make-instance 'compiler (parse-opts args))))
       (write-compiled-file compiler)))
   (values))
 
 (defun parse-opts (args)
   (let ((mode :source)
         (data (list :source nil :target nil :js nil :css nil :body nil :compile nil :beautify nil)))
     (loop :for arg :in args
        :do (alexandria:switch (arg :test #'string=)
              ("-o" (setf mode :target))
              ("--js" (setf mode :js))
              ("--css" (setf mode :css))
              ("--body" (setf mode :body))
              ("-c" (setf (getf data :compile) t))
              ("--beautify" (setf (getf data :beautify) t))
              (t (push arg (getf data mode)))))
     (unless (= 1 (length (getf data :source)))
       (print-usage)
       (report-error "There should be exactly one source"))
     (unless (> 1 (length (getf data :target)))
       (print-usage)
       (report-error "There should be no more than one target"))
     (unless (> 1 (length (getf data :body)))
       (print-usage)
       (report-error "There should be no more than one body"))
     (unless (getf data :target)
       (setf (getf data :target)
             (let* ((source (first (getf data :source)))
                    (tokens (uiop:split-string source :separator "."))
                    (target (format nil "~{~A~^.~}.html"
                                    (butlast tokens))))
               (list target))))
     (list :source (first (getf data :source))
           :target (first (getf data :target))
           :js (getf data :js)
           :css (getf data :css)
           :body (first (getf data :body))
           :compile (getf data :compile)
           :beautify (getf data :beautify))))
 
 (defun print-usage ()
   (format t "USAGE: "))
 
 (defun parse-file (filename)
   (p:parse 'sugar-qsp-grammar
            (alexandria:read-file-into-string filename)))
 
 (defun report-error (fmt &rest args)
   (apply #'format t fmt args)
   (throw :terminate nil))
 
 ;;; JS
 
+(defun minify-package (package-designator minify prefix)
+  (setf (ps:ps-package-prefix package-designator) prefix)
+  (if minify
+      (ps:obfuscate-package package-designator)
+      (ps:unobfuscate-package package-designator)))
+
 (defmethod js-sources ((compiler compiler))
   (let ((ps:*ps-print-pretty* (beautify compiler)))
+    (cond ((beautify compiler)
+           (minify-package "SUGAR-QSP.MAIN" nil "qsp_")
+           (minify-package "SUGAR-QSP.API"  nil "qsp_api_")
+           (minify-package "SUGAR-QSP.LIB"  nil "qsp_lib_"))
+          (t
+           (minify-package "SUGAR-QSP.MAIN" t   "_")
+           (minify-package "SUGAR-QSP.API"  t   "a_")
+           (minify-package "SUGAR-QSP.LIB"  t   "l_")))
     (format nil "~{~A~^~%~%~}" (mapcar #'ps:ps* (reverse (js compiler))))))
 
 ;;; CSS
 
 (defmethod css-sources ((compiler compiler))
   (format nil "~{~A~^~%~%~}" (css compiler)))
 
 ;;; HTML
 
 (defmethod html-sources ((compiler compiler))
   (let ((flute:*escape-html* nil)
         (body-template (body compiler))
         (js (js-sources compiler))
         (css (css-sources compiler)))
     (with-output-to-string (out)
       (write
        (flute:h
          (html
           (head
            (title "SugarQSP"))
           (body
            body-template
            (style css)
            (script js))))
        :stream out
        :pretty nil))))
 
 (defmethod initialize-instance ((compiler compiler) &key source ((:js js-files)) ((:css css-files)) ((:body body-file)) compile &allow-other-keys)
   (call-next-method)
   (with-slots (body css js)
       compiler
     ;; Compile the game's JS
     (push (list* 'progn (parse-file source)) js)
     ;; Does the user need us to do anything else
     (unless compile
       ;; Read in body
       (when body-file
         (setf body
               (alexandria:read-file-into-string body-file)))
       ;; Include js files
       (dolist (js-file js-files)
         (push (format nil "////// Included file ~A~%~A" js-file
                       (alexandria:read-file-into-string js-file))
               js))
       ;; Include css files
       (dolist (css-file css-files)
         (push (format nil "////// Included file ~A~%~A" css-file
                       (alexandria:read-file-into-string css-file))
               css)))))
 
 (defmethod write-compiled-file ((compiler compiler))
   (alexandria:write-string-into-file
    (if (compile-only compiler)
        ;; Just the JS
        (preprocess-js (js-sources compiler) (beautify compiler))
        ;; All of it
        (html-sources compiler))
    (target compiler) :if-exists :supersede))

src/main.ps

@@ -1,41 +1,43 b''
 
-(in-package sugar-qsp)
+(in-package sugar-qsp.main)
 
 (setf (root)
-      (ps:create
+      (create
        ;;; Game session state
        ;; Variables
-       vars (ps:create)
+       vars (create)
        ;; Inventory (objects)
        objs (list)
+       current-location nil
        ;; Game time
-       started-at (*date.now)
+       started-at (chain *date (now))
        ;; Timers
        timer-interval 500
        timer-obj nil
        ;;; Transient state
        ;; Savegame data
-       state-stash (ps:create)
+       state-stash (create)
        ;; List of audio files being played
-       playing (ps:create)
+       playing (create)
        ;; Local variables stack (starts with an empty frame)
        locals (list)
        ;;; Game data
        ;; ACTions
-       acts (ps:create)
+       acts (create)
        ;; Locations
-       locs (ps:create)))
+       locs (create)))
 
 ;; Launch the game from the first location
-(setf window.onload
+(setf (@ window onload)
       (lambda ()
-        (api-call init-dom)
+        (#.(intern "INIT-DOM" "SUGAR-QSP.API"))
         ;; For MSECCOUNT
-        (setf (root started-at) (*date.now))
+        (setf (root started-at) (chain *date (now)))
         ;; For $COUNTER and SETTIMER
-        (api-call set-timer (root timer-interval))
-        (funcall (ps:getprop (root locs)
-                             (ps:chain *object (keys (root locs)) 0))
+        (#.(intern "SET-TIMER" "SUGAR-QSP.API")
+           (root timer-interval))
+        (funcall (getprop (root locs)
+                          (chain *object (keys (root locs)) 0))
                  (list))
         (values)))
 

src/package.lisp

@@ -1,7 +1,93 b''
 
 (in-package cl-user)
 
+(defpackage :sugar-qsp.js)
+
+(defpackage :sugar-qsp.main
+  (:use :cl :ps :sugar-qsp.js)
+  (:export #:api-call #:by-id
+           #:root #:in
+           #:vars #:objs #:current-location
+           #:started-at #:timer-interval #:timer-obj
+           #:state-stash #:playing #:locals
+           #:acts #:locs))
+
+;;; API functions
+(defpackage :sugar-qsp.api
+  (:use :cl :ps :sugar-qsp.main :sugar-qsp.js)
+  (:export #:with-frame #:with-call-args
+           #:stash-state
+
+           #:report-error #:sleep #:init-dom #:call-serv-loc
+           #:newline #:clear-id #:prepare-contents #:get-id #:set-id #:append-id
+           #:init-args #:get-result #:call-loc #:call-act
+           #:get-frame #:add-text #:get-text #:clear-text #:enable-frame
+           #:add-act #:del-act #:clear-act #:update-acts
+           #:qspfor
+           #:*var #:new-value #:index-num #:get #:set #:kill
+           #:var-real-name #:ensure-var #:var-ref #:get-var #:set-var
+           #:get-array #:set-array #:kill-var #:array-size
+           #:push-local-frame #:pop-local-frame #:current-local-frame #:new-local
+           #:update-objs
+           #:menu
+           #:clean-audio
+           #:show-image
+           #:opengame #:savegame
+           ))
+
+;;; QSP library functions and macros
+(defpackage :sugar-qsp.lib
+  (:use :cl :ps :sugar-qsp.main :sugar-qsp.js)
+  (:local-nicknames (#:api :sugar-qsp.api))
+  (:export #:str #:exec #:qspblock #:qspfor #:location
+           #:qspcond #:qspvar #:set #:local
+
+           #:killvar #:killall
+           #:obj #:loc #:no
+           #:qspver #:curloc
+           #:rnd #:qspmax #:qspmin
+           #:arrsize #:len
+           #:mid #:ucase #:lcase #:trim #:replace #:val #:qspstr
+           #:exit #:desc
+           #:showstat #:msg
+           #:showacts #:delact #:cla
+           #:showobjs #:countobj #:getobj
+           #:isplay
+           #:view
+           #:showinput
+           #:wait #:settimer
+           #:local
+           #:opengame #:savegame
+
+           #:goto #:xgoto
+           #:rand
+           #:copyarr #:arrpos #:arrcomp
+           #:instr #:isnum #:strcomp #:strfind #:strpos
+           #:iif
+           #:gosub #:func
+           #:dynamic #:dyneval
+           #:main-p #:main-pl #:main-nl #:maintxt #:desc #:main-clear
+           #:stat-p #:stat-pl #:stat-nl #:stattxt #:stat-clear #:cls
+           #:curacts
+           #:addobj #:delobj #:killobj
+           #:menu
+           #:play #:close #:closeall
+           #:refint
+           #:usertxt #:cmdclear #:input
+           #:msecscount
+           #:rgb
+           #:openqst #:addqst #:killqst
+           ))
+
+;;; The compiler
 (defpackage :sugar-qsp
   (:use :cl)
-  (:local-nicknames (#:p #:esrap))
+  (:local-nicknames (#:p #:esrap)
+                    (#:lib :sugar-qsp.lib)
+                    (#:api :sugar-qsp.api)
+                    (#:main :sugar-qsp.main))
   (:export #:parse-file #:entry-point))
+
+(setf (ps:ps-package-prefix "SUGAR-QSP.MAIN") "qsp_")
+(setf (ps:ps-package-prefix "SUGAR-QSP.API") "qsp_api_")
+(setf (ps:ps-package-prefix "SUGAR-QSP.LIB") "qsp_lib_")

src/parser.lisp

@@ -1,614 +1,614 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)))
+  (list* (intern (string-upcase (first list)) :lib)
          (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)))
+    (list (intern (string-upcase operator) :lib) 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)
   (:error-report nil))
 
 (p:defrule spaces? (* (or #\space #\tab line-continuation))
   (:constant nil)
   (:error-report nil))
 
 (p:defrule colon #\:
   (:constant nil))
 
 (p:defrule equal #\=
   (: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
 
 (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 for freelib func getobj gosub goto gs gt if iif inclib input instr isnum isplay jump killall killobj killqst killvar lcase lcolor len let loc local maintxt max menu mid min mod msecscount msg nl *nl no nosave obj opengame openqst or p *p pl *pl play qspver rand refint replace rgb rnd savegame selact selobj set settimer showacts showinput showobjs showstat stattxt step str strcomp strfind strpos to 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 (trim-$ (string-upcase id))) *keywords*))
 
 (defun not-qsp-keyword-p (id)
   (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)
-    (intern (string-upcase (p:text list)))))
+    (intern (string-upcase (p:text list)) :lib)))
 
 (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 "")))))
+    (list* 'lib: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)))))
+    (list* 'lib: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)))))
+    (list* 'lib:exec (p:parse 'exec-body (second list)))))
 
 (p:defrule brace-string (and #\{ before-statement block-body #\})
   (:lambda (list)
-    (list* 'qspblock (third list))))
+    (list* 'lib: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)))
+    `(lib: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 local
                                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)))
+    (list 'lib:main-pl string)))
 
 (p:defrule expression-output expression
   (:lambda (list)
-    (list 'main-pl list)))
+    (list 'lib:main-pl list)))
 
 (p:defrule label (and colon identifier)
   (:lambda (list)
     (intern (string (second list)) :keyword)))
 
 (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))
 
 (p:defrule local (and (p:~ "local") spaces variable (p:? (and spaces? #\= spaces? expression)))
   (:lambda (list)
-    (list* 'local (third list)
+    (list* 'lib:local (third list)
            (when (fourth list)
              (list (fourth (fourth list)))))))
 
 ;;; Blocks
 
 (p:defrule block (or block-act block-if block-for))
 
 (p:defrule block-if (and block-if-head block-if-body)
   (:destructure (head body)
-    `(qspcond (,@head ,@(first body))
-                ,@(rest body))))
+    `(lib: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-ml block-sl))
   (:lambda (list)
     (apply #'append 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 ""))))))
+                        (or (fifth list) '(lib:str ""))))))
 
 (p:defrule block-act-head-img (and #\, spaces? qsp-string spaces?)
   (:lambda (list)
     (or (third list) "")))
 
 (p:defrule block-for (and block-for-head (or block-ml block-sl))
   (:lambda (list)
     (apply #'append list)))
 
 (p:defrule block-for-head (and (p:~ "for") spaces variable spaces? equal spaces? expression 
                                (p:~ "to") spaces expression
                                block-for-head-step
                                colon spaces?)
   (:lambda (list)
     (unless (eq (fourth (third list)) :num)
       (error "For counter variable must be numeric."))
-    (list 'qspfor
+    (list 'lib:qspfor
           (elt list 2)
           (elt list 6)
           (elt list 9)
           (elt list 10))))
 
 (p:defrule block-for-head-step (p:? (and (p:~ "step") spaces expression spaces?))
   (:lambda (list)
     (if list
         (third list)
         1)))
 
 (p:defrule block-sl line-body)
 
 (p:defrule block-ml (and newline-block-body block-end)
   (:lambda (list)
     (apply #'list* (butlast list))))
 
 (p:defrule block-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 (and spaces? (p:& #\newline))
                             (and spaces? (p:& #\&))
                             spaces?)
   (:constant nil))
 (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))))
+       (list* ',(intern (string sym) :lib) arguments))))
 
 (defintrinsics (intrinsic returning-intrinsic non-returning-intrinsic)
   ;; Transitions
-  (goto     nil 0 10 "gt" "goto")
-  (xgoto    nil 0 10 "xgt" "xgoto")
+  (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)
   ;; Sound
   (play     nil 1 2)
   (isplay   t   1 1)
   (close    nil 1 1)
   (closeall nil 0 0 "close all")
   ;; Main window
   (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-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)
   ;; 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 sum-expr (* (and spaces? (or "<=" ">=" "=<" "=>" "<>"
                                                      "=" "<" ">" "!")
                                          spaces? sum-expr)))
   (:function do-binop))
 
 (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)
     (if (char= #\$ (elt (string id) 0))
-        (list 'var (intern (subseq (string-upcase id) 1)) (or idx 0) :str)
-        (list 'var id (or idx 0) :num))))
+        (list 'lib:qspvar (intern (subseq (string-upcase id) 1) :lib) (or idx 0) :str)
+        (list 'lib:qspvar id (or idx 0) :num))))
 
 (p:defrule array-index (and #\[ spaces? (p:? expression) spaces? #\])
   (:function third))
 
 (p:defrule assignment (or kw-assignment plain-assignment op-assignment)
-  (:destructure (var eq expr)
+  (:destructure (qspvar eq expr)
     (declare (ignore eq))
-    (list 'set var expr)))
+    (list 'lib:set qspvar 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)
+  (:destructure (qspvar ws1 op eq ws2 expr)
                 (declare (ignore ws1 ws2))
-                (list var eq (intern-first (list op var expr)))))
+                (list qspvar eq (intern-first (list op qspvar expr)))))
 
 (p:defrule plain-assignment (and variable spaces? #\= spaces? expression)
   (:function remove-nil))
 
 ;;; 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))))

src/ps-macros.lisp

@@ -1,203 +1,164 b''
 
-(in-package sugar-qsp)
+(in-package sugar-qsp.lib)
 
 ;;;; Parenscript macros which make the parser's intermediate
 ;;;; representation directly compilable by Parenscript
 ;;;; Some utility macros for other .ps sources too.
 
 ;;; Utils
 
-(ps:defpsmacro defm (path args &body body)
-  `(setf ,path (lambda ,args ,@body)))
-
-(ps:defpsmacro root (&rest path)
-  `(ps:@ *sugar-q-s-p ,@path))
-
-(ps:defpsmacro in (key obj)
-  `(ps:chain ,obj (has-own-property ,key)))
-
-(ps:defpsmacro with-frame (&body body)
-  `(progn
-     (api-call push-local-frame)
-     (unwind-protect
-          ,@body
-       (api-call pop-local-frame))))
-
 ;;; Common
 
-(defmacro defpsintrinsic (name)
-  `(ps:defpsmacro ,name (&rest args)
-     `(funcall (root lib ,',name)
-               ,@args)))
-
-(defmacro defpsintrinsics (() &rest names)
-  `(progn ,@(loop :for name :in names
-                 :collect `(defpsintrinsic ,name))))
-
-(defpsintrinsics ()
-    rand copyarr arrpos arrcomp instr isnum strcomp strfind strpos iif gosub func dynamic dyneval main-p main-pl main-nl maintxt main-clear stat-p stat-pl stat-nl stattxt stat-clear cls curacts addobj delobj killobj menu play isplay close closeall refint view rgb showinput usertxt cmdclear input openqst addqst killqst opengame savegame wait msecscount settimer)
-
-(ps:defpsmacro api-call (func &rest args)
-  `(funcall (root api ,func) ,@args))
-
-(ps:defpsmacro label-block ((&key (locals t)) &body body)
+(defpsmacro label-block ((&key (locals t)) &body body)
   (let ((has-labels (some #'keywordp body)))
     `(block nil
        ,@(when has-labels
            '((defvar __labels)))
        ,@(if locals
              `((tagbody
                   ,@body))
              `((tagbody
                   ,@body))))))
 
-(ps:defpsmacro str (&rest forms)
+(defpsmacro str (&rest forms)
   (cond ((zerop (length forms))
          "")
         ((and (= 1 (length forms))
               (stringp (first forms)))
          (first forms))
         (t
          `(& ,@forms))))
 
 ;;; 1loc
 
-(ps:defpsmacro location ((name) &body body)
+(defpsmacro location ((name) &body body)
   `(setf (root locs ,name)
-         (ps:async-lambda (args)
-           (label-block ()
-            (api-call init-args args)
-            ,@body
-            (api-call get-result)))))
+         (async-lambda (args)
+                       (label-block ()
+                         ,@body))))
 
-(ps:defpsmacro goto (target &rest args)
+(defpsmacro goto% (target &rest args)
   `(progn
-     (funcall (root lib goto) ,target ,args)
+     (goto ,target ,args)
      (exit)))
 
-(ps:defpsmacro xgoto (target &rest args)
+(defpsmacro xgoto% (target &rest args)
   `(progn
-     (funcall (root lib xgoto) ,target ,args)
+     (xgoto ,target ,args)
      (exit)))
 
-(ps:defpsmacro desc (target)
-  (declare (ignore target))
-  (report-error "DESC is not supported"))
-
 ;;; 2var
 
-(ps:defpsmacro var (name index slot)
+(defpsmacro qspvar (name index slot)
   `(api-call get-var ,(string name) ,index ,slot))
 
-(ps:defpsmacro set ((var vname vindex vslot) value)
-  (assert (eq var 'var))
+(defpsmacro set ((var vname vindex vslot) value)
+  (assert (eq var 'qspvar))
   `(api-call set-var ,(string vname) ,vindex ,vslot ,value))
 
 ;;; 3expr
 
-(ps:defpsmacro <> (op1 op2)
+(defpsmacro <> (op1 op2)
   `(not (equal ,op1 ,op2)))
 
-(ps:defpsmacro ! (op1 op2)
+(defpsmacro ! (op1 op2)
   `(not (equal ,op1 ,op2)))
 
 ;;; 4code
 
-(ps:defpsmacro exec (&body body)
-  (format nil "javascript: ~{~A~^~%~}" (mapcar #'ps:ps* body)))
+(defpsmacro exec (&body body)
+  (format nil "javascript: ~{~A~^~%~}" (mapcar #'ps* body)))
 
 ;;; 5arrays
 
 ;;; 6str
 
-(ps:defpsmacro & (&rest args)
-  `(ps:chain "" (concat ,@args)))
+(defpsmacro & (&rest args)
+  `(chain "" (concat ,@args)))
 
 ;;; 7if
 
-(ps:defpsmacro qspcond (&rest clauses)
+(defpsmacro qspcond (&rest clauses)
   `(cond ,@(loop :for clause :in clauses
               :collect (list (first clause)
                              `(tagbody
                                  ,@(rest clause))))))
 
 ;;; 8sub
 
 ;;; 9loops
 ;;; Yep, that's a huge kludge since Javascript doesn't support arbitrary labels
 
-(ps:defpsmacro jump (target)
+(defpsmacro jump (target)
   `(return-from ,(intern (string-upcase (second target)))
-     (funcall (ps:getprop __labels ,target))))
+     (funcall (getprop __labels ,target))))
 
-(ps:defpsmacro tagbody (&body body)
+(defpsmacro tagbody (&body body)
   (let ((funcs (list nil :__nil)))
     (dolist (form body)
       (cond ((keywordp form)
              (setf (first funcs) (reverse (first funcs)))
              (push form funcs)
              (push nil funcs))
             (t
              (push form (first funcs)))))
     (setf (first funcs) (reverse (first funcs)))
     (setf funcs (reverse funcs))
     (if (= 2 (length funcs))
         `(progn
            ,@body)
         `(progn
            (setf ,@(loop :for f :on funcs :by #'cddr
-                      :append `((ps:@ __labels ,(first f))
+                      :append `((@ __labels ,(first f))
                                 (block ,(intern (string-upcase (string (first f))))
                                   ,@(second f)
                                   ,@(when (third f)
                                       `((funcall
-                                         (ps:getprop __labels ,(third f)))))))))
+                                         (getprop __labels ,(third f)))))))))
            (jump (str "__nil"))))))
 
 ;;; 10dynamic
 
-(ps:defpsmacro qspblock (&body body)
-  `(lambda (args)
+(defpsmacro qspblock (&body body)
+  `(async-lambda (args)
      (label-block ()
-      (api-call init-args args)
-      ,@body
-      (api-call get-result))))
+       ,@body)))
 
 ;;; 11main
 
-(ps:defpsmacro act (name img &body body)
+(defpsmacro act (name img &body body)
   `(api-call add-act ,name ,img
-             (lambda ()
+             (async-lambda ()
                (label-block ()
-                ,@body))))
+                            ,@body))))
 
 ;;; 12aux
 
 ;;; 13diag
 
 ;;; 14act
 
 ;;; 15objs
 
 ;;; 16menu
 
 ;;; 17sound
 
 ;;; 18img
 
 ;;; 19input
 
 ;;; 20time
 
 ;;; 21local
 
 ;;; 22for
 
-(ps:defpsmacro qspfor (var from to step &body body)
-  `(api-call qspfor
-             ,(string (second var)) ,(third var) ;; name and index
-             ,from ,to ,step
-             (lambda ()
-               (block nil
-                 ,@body
-                 t))))
+(defpsmacro qspfor (var from to step &body body)
+  `((intern "QSPFOR" "API")
+    ,(string (second var)) ,(third var) ;; name and index
+    ,from ,to ,step
+    (lambda ()
+      (block nil
+        ,@body
+        t))))

sugar-qsp.asd

@@ -1,16 +1,19 b''
 
 (defsystem sugar-qsp
   :description "QSP compiler to monolithic HTML page"
   :depends-on (:alexandria ;; General
                :esrap ;; Parsing
                :parenscript :flute ;; Codegening
                )
   :pathname "src/"
   :serial t
   :components ((:file "package")
                (:file "patches")
+               (:file "js-syms")
+               (:file "main-macros")
                (:file "ps-macros")
+               (:file "api-macros")
                (:file "intrinsic-macros")
                (:file "class")
                (:file "main")
                (:file "parser")))