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,107 +1,106 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")
@@ -109,288 +108,298 b''
     (: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))
+(defun qspfor (name index from to step body)
+  (for ((i from))
             ((< i to))
             ((incf i step))
-      (this.set-var name index :num i)
+       (set-var name index :num i)
       (unless (funcall body)
-        (return)))))
+         (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)
+(setf (@ *var prototype index-num)
+      (lambda (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)
+                   (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) (this.new-value)))
-    num-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)
+(setf (@ *var prototype get)
+      (lambda (index slot)
   (unless (or index (= 0 index))
-    (setf index (1- (length this.values))))
-  (ps:getprop this.values (this.index-num index) slot))
+          (setf index (1- (length (@ this values)))))
+        (getprop (@ this values) (chain this (index-num index)) slot)))
 
-(defm (root api *var prototype set) (index slot value)
+(setf (@ *var prototype set)
+      (lambda (index slot value)
   (unless (or index (= 0 index))
-    (setf index (length store)))
+          (setf index (length (@ this values))))
   (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))
+          (: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
+                        (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)))
+                          (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)
+        (chain *j-s-o-n (stringify
+                         (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))))
+                                 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

@@ -8,21 +8,25 b''
      (asdf:system-source-directory :sugar-qsp)))
   (defun read-code-from-string (string)
     (with-input-from-string (in string)
+      (let ((*package* *package*))
       `(progn
          ,@(loop :for form := (read in nil :eof)
               :until (eq form :eof)
-              :collect form))))
+                :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,5 +1,5 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
@@ -8,74 +8,74 b''
 
 ;;; 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
 
@@ -85,77 +85,77 b''
 
 ;; 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
@@ -165,10 +165,10 b''
 
 ;;; 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,24 +1,22 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))
 
@@ -28,164 +26,166 b''
 
 ;;; 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)
+        (api:var-real-name from)
+      (for ((i start))
+           ((< i (min (api: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: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)
@@ -193,89 +193,89 b''
 
 ;;; 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
+                      (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-call menu menu-data)
+    (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
 
@@ -283,19 +283,19 b''
 
 ;;; 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

@@ -59,8 +59,22 b''
 
 ;;; 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

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

@@ -33,7 +33,7 b''
    (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)
@@ -44,7 +44,7 b''
   (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)
@@ -127,7 +127,7 b''
                        (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))
 
@@ -137,7 +137,7 b''
 
 (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
@@ -162,15 +162,15 b''
 
 (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
 
@@ -181,7 +181,7 b''
 (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)
@@ -246,11 +246,11 b''
 
 (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)
@@ -264,7 +264,7 b''
 
 (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)))))))
 
@@ -274,7 +274,7 b''
 
 (p:defrule block-if (and block-if-head block-if-body)
   (:destructure (head body)
-    `(qspcond (,@head ,@(first body))
+    `(lib:qspcond (,@head ,@(first body))
                 ,@(rest body))))
 
 (p:defrule block-if-head (and (p:~ "if") spaces expression spaces? colon spaces?)
@@ -335,7 +335,7 b''
   (: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)
@@ -352,7 +352,7 b''
   (: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)
@@ -428,12 +428,12 b''
        (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
@@ -583,24 +583,24 b''
 (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))

src/ps-macros.lisp

@@ -1,5 +1,5 b''
 
-(in-package sugar-qsp)
+(in-package sugar-qsp.lib)
 
 ;;;; Parenscript macros which make the parser's intermediate
 ;;;; representation directly compilable by Parenscript
@@ -7,40 +7,9 b''
 
 ;;; 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
@@ -51,7 +20,7 b''
              `((tagbody
                   ,@body))))))
 
-(ps:defpsmacro str (&rest forms)
+(defpsmacro str (&rest forms)
   (cond ((zerop (length forms))
          "")
         ((and (= 1 (length forms))
@@ -62,60 +31,54 b''
 
 ;;; 1loc
 
-(ps:defpsmacro location ((name) &body body)
+(defpsmacro location ((name) &body body)
   `(setf (root locs ,name)
-         (ps:async-lambda (args)
+         (async-lambda (args)
            (label-block ()
-            (api-call init-args args)
-            ,@body
-            (api-call get-result)))))
+                         ,@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
@@ -126,11 +89,11 b''
 ;;; 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)
@@ -146,28 +109,26 b''
            ,@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))))
 
@@ -193,8 +154,8 b''
 
 ;;; 22for
 
-(ps:defpsmacro qspfor (var from to step &body body)
-  `(api-call qspfor
+(defpsmacro qspfor (var from to step &body body)
+  `((intern "QSPFOR" "API")
              ,(string (second var)) ,(third var) ;; name and index
              ,from ,to ,step
              (lambda ()

sugar-qsp.asd

@@ -9,7 +9,10 b''
   :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")