Globals instead of ROOT object

src/api.ps

@@ -1,481 +1,481 b''
 
 (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
 
 ;;; Utils
 
 (defun make-act-html (title img)
   (+ "<a class='qsp-act' href='" (href-call call-act title) "' onmouseover='" (inline-call select-act title) "'>"
      (if img (+ "<img src='" img "'>") "")
      title
      "</a>"))
 
 (defun make-menu-item-html (num title img loc)
   (+ "<a href='" (href-call finish-menu loc) "'>"
      (if img (+ "<img src='" img "'>") "")
      title
      "</a>"))
 
 (defun make-obj (title img selected)
   (+ "<li onclick='" (inline-call select-obj title img) "'>"
      "<a class='qsp-obj" (if selected " qsp-obj-selected" "") "'>"
      (if img (+ "<img src='" img "'>") "")
      title
      "</a>"))
 
 (defun make-menu-delimiter ()
   "<hr>")
 
 (defun report-error (text)
   (alert text))
 
 (defun start-sleeping ()
   (chain (by-id "qsp") class-list (add "disable")))
 
 (defun finish-sleeping ()
   (chain (by-id "qsp") class-list (remove "disable")))
 
 (defun sleep (msec)
   (with-sleep (resume)
     (set-timeout resume msec)))
 
 (defun init-dom ()
   ;; Save/load buttons
   (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 (@ (by-id "qsp-image-container") onclick)
         show-image)
   ;; Enter in input field
   (setf (@ (get-frame :input) onkeyup)
         on-input-key)
   ;; Close the dropdown on any click
   (setf (@ window onclick)
         (lambda (event)
           (setf (@ window mouse)
                 (list (@ event page-x)
                       (@ event page-y)))
           (finish-menu nil))))
 
 (defun call-serv-loc (var-name &rest args)
   (let ((loc-name (get-global var-name 0)))
     (when loc-name
-      (let ((loc (getprop (root locs) loc-name)))
+      (let ((loc (getprop *locs loc-name)))
         (when loc
           (call-loc loc-name args))))))
 
 (defun filename-game (filename)
   (let ((game-name (chain filename (match "(.*/)?([^.]+)(\\.[a-zA-Z]+)?") 2))))
-  (getprop (root games) game-name))
+  (getprop *games game-name))
 
 (defun run-game (name)
   (let ((game (filename-game name)))
-    (setf (root main-game) name)
+    (setf *main-game name)
     ;; Replace locations with the new game's 
-    (setf (root locs) game)
+    (setf *locs game)
     (funcall (getprop game
                       (chain *object (keys game) 0))
              (list))))
 
 ;;; Misc
 
 (defun newline (key)
   (append-id (key-to-id key) "<br>" t))
 
 (defun clear-id (id)
   (setf (inner-html (by-id id)) ""))
 
 (defun escape-html (text)
   (chain text
          (replace (regex "/&/g") "&amp;")
          (replace (regex "/</g") "&lt;")
          (replace (regex "/>/g") "&gt;")
          (replace (regex "/\"/g") "&quot;")
          (replace (regex "/'/g") "&apos;")))
 
 (defun prepare-contents (s &optional force-html)
   (setf s (chain s (to-string)))
   (if (or force-html (get-global "USEHTML" 0))
       s
       (escape-html s)))
 
 (defun get-id (id &optional force-html)
   (inner-html (by-id id)))
 
 (defun set-id (id contents &optional force-html)
   (setf (inner-html (by-id id)) (prepare-contents contents force-html)))
 
 (defun append-id (id contents &optional force-html)
   (when contents
     (incf (inner-html (by-id id)) (prepare-contents contents force-html))))
 
 (defun on-input-key (ev)
   (when (= 13 (@ ev key-code))
     (chain ev (prevent-default))
     (call-serv-loc "$USERCOM")))
 
 ;;; Function calls
 
 (defun init-args (args)
   (dotimes (i (length args))
     (let ((arg (elt args i)))
       (if (numberp arg)
           (set-var args i :num arg)
           (set-var args i :str arg)))))
 
 (defun get-result ()
   (or (get-global "$RESULT" 0)
       (get-global "RESULT" 0)))
 
 (defun call-loc (name args)
   (setf name (chain name (to-upper-case)))
   (with-frame
       (with-call-args args
-        (funcall (getprop (root locs) name)))))
+        (funcall (getprop *locs name)))))
 
 (defun call-act (title)
   (with-frame
-      (funcall (getprop (root acts) title :act))))
+      (funcall (getprop *acts title :act))))
 
 ;;; Text windows
 
 (defun key-to-id (key)
   (case key
     (:all "qsp")
     (:main "qsp-main")
     (:stat "qsp-stat")
     (:objs "qsp-objs")
     (:acts "qsp-acts")
     (:input "qsp-input")
     (:image "qsp-image")
     (:dropdown "qsp-dropdown")
     (t (report-error "Internal error!"))))
 
 (defun get-frame (key)
   (by-id (key-to-id key)))
 
 (defun add-text (key text)
   (append-id (key-to-id key) text))
 
 (defun get-text (key)
   (get-id (key-to-id key)))
 
 (defun clear-text (key)
   (clear-id (key-to-id key)))
 
 (defun enable-frame (key enable)
   (let ((obj (get-frame key)))
     (setf (@ obj style display) (if enable "block" "none"))
     (void)))
 
 ;;; Actions
 
 (defun add-act (title img act)
-  (setf (getprop (root acts) title)
+  (setf (getprop *acts title)
         (create :title title :img img :act act :selected nil))
   (update-acts))
 
 (defun del-act (title)
-  (delete (getprop (root acts) title))
+  (delete (getprop *acts title))
   (update-acts))
 
 (defun clear-act ()
-  (setf (root acts) (create))
+  (setf *acts (create))
   (update-acts))
 
 (defun update-acts ()
   (clear-id "qsp-acts")
   (let ((elt (by-id "qsp-acts")))
-    (for-in (title (root acts))
-            (let ((obj (getprop (root acts) title)))
+    (for-in (title *acts)
+            (let ((obj (getprop *acts title)))
               (incf (inner-html elt) (make-act-html title (getprop obj :img)))))))
 
 (defun select-act (title)
-  (loop :for (k v) :of (root acts)
+  (loop :for (k v) :of *acts
      :do (setf (getprop v :selected) nil))
-  (setf (getprop (root acts) title :selected) t)
+  (setf (getprop *acts title :selected) t)
   (call-serv-loc "$ONACTSEL"))
 
 ;;; "Syntax"
 
 (defun qspfor (name index from to step body)
   (for ((i from))
        ((< i to))
        ((incf i step))
        (set-var name index :num i)
        (unless (await (funcall body))
          (return-from qspfor))))
 
 ;;; Variables
 
 (defun new-var (slot &rest indexes)
   (let ((v (list)))
     (dolist (index indexes)
       (setf (elt v index) (if (eq #\$ (elt slot 0)) "" 0)))
     (setf (@ v :indexes) (create))
     v))
 
 (defun set-str-element (slot index value)
   (if (in index (getprop slot :indexes))
       (setf (elt (getprop slot) 
                  (getprop slot :indexes index))
             value)
       (progn
         (chain slot (push value))
         (setf (elt slot index)
               (length slot)))))
 
 (defun set-any-element (slot index value)
   (if (numberp index)
       (setf (elt slot index) value)
       (set-str-element slot index value)))
 
 (defun get-element (slot index)
   (if (numberp index)
       (elt slot index)
       (elt slot (getprop slot :indexes index))))
 
 (defun get-global (name index)
-  (elt (getprop (root vars) name) index))
+  (elt (getprop *globals name) index))
 
 (defun kill-var (store name &optional index)
   (setf name (chain name (to-upper-case)))
   (if (and index (not (= 0 index))) 
-      (chain (getprop (root vars) name) (kill index))
-      (delete (getprop (root vars) name)))
+      (chain (getprop *vars name) (kill index))
+      (delete (getprop *vars name)))
   (void))
 
 (defun array-size (name)
   (@ (var-ref name) :values length))
 
 ;;; Locals
 
 (defun push-local-frame ()
-  (chain (root locals) (push (create)))
+  (chain *locals (push (create)))
   (void))
 
 (defun pop-local-frame ()
-  (chain (root locals) (pop))
+  (chain *locals (pop))
   (void))
 
 (defun current-local-frame ()
-  (elt (root locals) (1- (length (root locals)))))
+  (elt *locals (1- (length *locals))))
 
 ;;; Objects
 
 (defun select-obj (title img)
-  (loop :for (k v) :of (root objs)
+  (loop :for (k v) :of *objs
      :do (setf (getprop v :selected) nil))
-  (setf (getprop (root objs) title :selected) t)
+  (setf (getprop *objs title :selected) t)
   (call-serv-loc "$ONOBJSEL" title img))
 
 (defun update-objs ()
   (let ((elt (by-id "qsp-objs")))
     (setf (inner-html elt) "<ul>")
-    (loop :for (name obj) :of (root objs)
+    (loop :for (name obj) :of *objs
        :do (incf (inner-html elt)
                  (make-obj name (@ obj :img) (@ obj :selected))))
     (incf (inner-html elt) "</ul>")))
 
 ;;; Menu
 
 (defun open-menu (menu-data)
   (let ((elt (get-frame :dropdown))
         (i 0))
     (loop :for item :in menu-data
        :do (incf i)
        :do (incf (inner-html elt)
                  (if (eq item :delimiter)
                      (make-menu-delimiter i)
                      (make-menu-item-html i
                                           (@ item :text)
                                           (@ item :icon)
                                           (@ item :loc)))))
     (let ((mouse (@ window mouse)))
       (setf (@ elt style left) (+ (elt mouse 0) "px"))
       (setf (@ elt style top) (+ (elt mouse 1) "px"))
       ;; Make sure it's inside the viewport
       (when (> (@ document body inner-width)
                (+ (elt mouse 0) (@ elt inner-width)))
         (incf (@ elt style left) (@ elt inner-width)))
       (when (> (@ document body inner-height)
                (+ (elt mouse 0) (@ elt inner-height)))
         (incf (@ elt style top) (@ elt inner-height))))
     (setf (@ elt style display) "block")))
 
 (defun finish-menu (loc)
-  (when (root menu-resume)
+  (when *menu-resume
     (let ((elt (get-frame :dropdown)))
       (setf (inner-html elt) "")
       (setf (@ elt style display) "none")
-      (funcall (root menu-resume))
-      (setf (root menu-resume) nil))
+      (funcall *menu-resume)
+      (setf *menu-resume nil))
     (when loc
       (call-loc loc)))
   (void))
 
 (defun menu (menu-data)
   (with-sleep (resume)
     (open-menu menu-data)
-    (setf (root menu-resume) resume))
+    (setf *menu-resume resume))
   (void))
 
 ;;; Content
 
 (defun clean-audio ()
-  (loop :for k :in (chain *object (keys (root playing)))
-     :for v := (getprop (root playing) k)
+  (loop :for k :in (chain *object (keys *playing))
+     :for v := (getprop *playing k)
      :do (when (@ v ended)
-           (delete (@ (root playing) k)))))
+           (delete (@ *playing k)))))
 
 (defun show-image (path)
   (let ((img (get-frame :image)))
     (cond (path
            (setf (@ img src) path)
            (setf (@ img style display) "flex"))
           (t
            (setf (@ img src) "")
            (setf (@ img style display) "hidden")))))
 
 (defun show-inline-images (frame-name images)
   (let ((frame (get-frame frame-name))
         (text ""))
     (incf text "<div style='position:relative; display: inline-block'>")
     (incf text (+ "<img src='" (@ images 0) "'>"))
     (loop :for image :in (chain images (slice 1))
        :do (incf text
                  (+ "<img style='position:absolute' src='" image "'>")))
     (incf text "</div>")
     (incf (inner-html frame) text)))
 
 (defun rgb-string (rgb)
   (let ((red (ps::>> rgb 16))
         (green (logand (ps::>> rgb 8) 255))
         (blue (logand rgb 255)))
     (flet ((rgb-to-hex (comp)
              (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)))))
 
 ;;; Saves
 
 (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 (@ event target files 0))
                    (reader (new (*file-reader))))
               (setf (@ reader onload)
                     (lambda (ev)
                       (block nil
                         (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))))
 
 (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))))
 
 (defun stash-state (args)
   (call-serv-loc "$ONGSAVE")
-  (setf (root state-stash)
+  (setf *state-stash
         (chain *j-s-o-n (stringify
-                         (create :vars (root vars)
-                                 :objs (root objs)
+                         (create :vars *vars
+                                 :objs *objs
                                  :loc-args args
-                                 :msecs (- (chain *date (now)) (root started-at))
-                                 :timer-interval (root timer-interval)
+                                 :msecs (- (chain *date (now)) *started-at)
+                                 :timer-interval *timer-interval
                                  :main-html (inner-html
                                              (get-frame :main))
                                  :stat-html (inner-html
                                              (get-frame :stat))
-                                 :next-location (root current-location)))))
+                                 :next-location *current-location))))
   (void))
 
 (defun unstash-state ()
-  (let ((data (chain *j-s-o-n (parse (root state-stash)))))
+  (let ((data (chain *j-s-o-n (parse *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)
+    (setf *vars (@ data :vars))
+    (loop :for k :in (chain *object (keys *vars))
+       :do (chain *object (set-prototype-of (getprop *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 *started-at (- (chain *date (now)) (@ data :msecs)))
+    (setf *objs (@ data :objs))
+    (setf *current-location (@ data :next-location))
     (setf (inner-html (get-frame :main))
           (@ data :main-html))
     (setf (inner-html (get-frame :stat))
           (@ data :stat-html))
     (update-objs)
     (set-timer (@ data :timer-interval))
     (call-serv-loc "$ONGLOAD")
-    (call-loc (root current-location) (@ data :loc-args))
+    (call-loc *current-location (@ data :loc-args))
     (void)))
 
 (defun state-to-base64 ()
-  (btoa (encode-u-r-i-component (root state-stash))))
+  (btoa (encode-u-r-i-component *state-stash)))
 
 (defun base64-to-state (data)
-  (setf (root state-stash) (decode-u-r-i-component (atob data))))
+  (setf *state-stash (decode-u-r-i-component (atob data))))
 
 ;;; Timers
 
 (defun set-timer (interval)
-  (setf (root timer-interval) interval)
-  (clear-interval (root timer-obj))
-  (setf (root timer-obj)
+  (setf *timer-interval interval)
+  (clear-interval *timer-obj)
+  (setf *timer-obj
         (set-interval
          (lambda ()
            (call-serv-loc "$COUNTER"))
          interval)))
 
 ;;; Special variables
 
 (defvar serv-vars (create))
 
 (define-serv-var backimage (:str path)
   (setf (@ (get-frame :main) style background-image) path))
 
 (define-serv-var bcolor (:num color)
   (setf (@ (get-frame :all) style background-color) (rgb-string color)))
 
 (define-serv-var fcolor (:num color)
   (setf (@ (get-frame :all) style color) (rgb-string color)))
 
 (define-serv-var lcolor (:num color)
   (setf (@ (get-frame :style) inner-text)
         (+ "a { color: " (rgb-string color) ";}")))
 
 (define-serv-var fsize (:num size)
   (setf (@ (get-frame :all) style font-size) size))
 
 (define-serv-var fname (:str font-name)
   (setf (@ (get-frame :all) style font-family) (+ font-name ",serif")))

src/intrinsic-macros.lisp

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

src/intrinsics.ps

@@ -1,314 +1,314 b''
 
 (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.
 
 ;;; 1loc
 
 (defun goto (target args)
   (api:clear-text :main)
   (funcall xgoto target args)
   (void))
 
 (defun xgoto (target args)
   (setf args (or args (list)))
   (api:clear-act)
-  (setf (root current-location) (chain target (to-upper-case)))
+  (setf *current-location (chain target (to-upper-case)))
   (api:stash-state args)
-  (api:call-loc (root current-location) args)
+  (api:call-loc *current-location args)
   (api:call-serv-loc "ONNEWLOC")
   (void))
 
 ;;; 2var
 
 ;;; 3expr
 
 ;;; 4code
 
 (defun rand (a &optional (b 1))
   (let ((min (min a b))
         (max (max a b)))
     (+ min (chain *math (random (- max min))))))
 
 ;;; 5arrays
 
 (defun copyarr (to from start count)
   (multiple-value-bind (to-name to-slot)
       (api:var-real-name to)
     (multiple-value-bind (from-name 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))))))
 
 (defun arrpos (name value &optional (start 0))
   (multiple-value-bind (real-name slot)
       (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)
 
 (defun arrcomp (name pattern &optional (start 0))
   (multiple-value-bind (real-name slot)
       (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
 
 (defun instr (s subs &optional (start 1))
   (+ start (chain s (substring (- start 1)) (search subs))))
 
 (defun isnum (s)
   (if (is-na-n s)
       0
       -1))
 
 (defun strcomp (s pattern)
   (if (chain s (match pattern))
       -1
       0))
 
 (defun strfind (s pattern group)
   (let* ((re (new (*reg-exp pattern)))
          (match (chain re (exec s))))
     (chain 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
         (chain s (search found))
         0)))
 
 ;;; 7if
 
 ;; Has to be a function because it always evaluates all three of its
 ;; arguments
 (defun iif (cond-expr then-expr else-expr)
   (if cond-expr then-expr else-expr))
 
 ;;; 8sub
 
 (defun gosub (target &rest args)
   (api:call-loc target args)
   (void))
 
 (defun func (target &rest args)
   (api:call-loc target args))
 
 ;;; 9loops
 
 ;;; 10dynamic
 
 (defun dynamic (block &rest args)
   (when (stringp block)
     (api:report-error "DYNAMIC can't evaluate arbitrary strings.\\nUse {braces} to create blocks for DYNAMIC."))
   (api:with-call-args args
     (funcall block args))
   (void))
 
 (defun dyneval (block &rest args)
   (when (stringp block)
     (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
 
 (defun main-p (s)
   (api:add-text :main s)
   (void))
 
 (defun main-pl (s)
   (api:add-text :main s)
   (api:newline :main)
   (void))
 
 (defun main-nl (s)
   (api:newline :main)
   (api:add-text :main s)
   (void))
 
 (defun maintxt (s)
   (api:get-text :main)
   (void))
 
 (defun desc (s)
   "")
 
 (defun main-clear ()
   (api:clear-text :main)
   (void))
 
 ;;; 12stat
 
 (defun stat-p (s)
   (api:add-text :stat s)
   (void))
 
 (defun stat-pl (s)
   (api:add-text :stat s)
   (api:newline :stat)
   (void))
 
 (defun stat-nl (s)
   (api:newline :stat)
   (api:add-text :stat s)
   (void))
 
 (defun stattxt (s)
   (api:get-text :stat)
   (void))
 
 (defun stat-clear ()
   (api:clear-text :stat)
   (void))
 
 (defun cls ()
   (stat-clear)
   (main-clear)
   (cla)
   (cmdclear)
   (void))
 
 ;;; 13diag
 
 ;;; 14act
 
 (defun curacts ()
-  (let ((acts (root acts)))
+  (let ((acts *acts))
     (lambda ()
-      (setf (root acts) acts)
+      (setf *acts acts)
       (void))))
 
 ;;; 15objs
 
 (defun addobj (name img)
   (setf img (or img ""))
-  (setf (getprop (root objs) name)
+  (setf (getprop *objs name)
         (create :name name :img img :selected nil))
   (api:update-objs)
   (api-call call-serv-loc "ONOBJADD" name img)
   (void))
 
 (defun delobj (name)
-  (delete (getprop (root objs) name))
+  (delete (getprop *objs name))
   (api-call call-serv-loc "ONOBJDEL" name)
   (void))
 
 (defun killobj (&optional (num nil))
   (if (eq nil num)
-      (setf (root objs) (create))
-      (delobj (elt (chain *object (keys (root objs))) num)))
+      (setf *objs (create))
+      (delobj (elt (chain *object (keys *objs)) num)))
   (api:update-objs)
   (void))
 
 (defun selobj ()
-  (loop :for (k v) :of (root objs)
+  (loop :for (k v) :of *objs
      :do (when (@ v :selected)
            (return-from selobj (@ v :name)))))
 
 ;;; 16menu
 
 (defun menu (menu-name)
   (let ((menu-data (list)))
     (loop :for item-obj :in (@ (api:get-array (api:var-real-name menu-name)) values)
        :for item := (@ item-obj :str)
        :do (cond ((string= item "")
                   (break))
                  ((string= item "-:-")
                   (chain menu-data (push :delimiter)))
                  (t
                   (let* ((tokens (chain item (split ":"))))
                     (when (= (length tokens) 2)
                       (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)
     (void)))
 
 ;;; 17sound
 
 (defun play (filename &optional (volume 100))
   (let ((audio (new (*audio filename))))
-    (setf (getprop (root playing) filename) audio)
+    (setf (getprop *playing filename) audio)
     (setf (@ audio volume) (* volume 0.01))
     (chain audio (play))))
 
 (defun close (filename)
-  (funcall (root playing filename) stop)
-  (delete (root playing filename))
+  (funcall (getprop *playing filename) stop)
+  (delete (getprop *playing filename))
   (void))
 
 (defun closeall ()
-  (loop :for k :in (chain *object (keys (root playing)))
-     :for v := (getprop (root playing) k)
+  (loop :for k :in (chain *object (keys *playing))
+     :for v := (getprop *playing k)
      :do (funcall v stop))
-  (setf (root playing) (create)))
+  (setf *playing (create)))
 
 ;;; 18img
 
 (defun refint ()
   ;; "Force interface update" Uh... what exactly do we do here?
   ;(api:report-error "REFINT is not supported")
   )
 
 ;;; 19input
 
 (defun usertxt ()
   (let ((input (by-id "qsp-input")))
     (@ input value)))
 
 (defun cmdclear ()
   (let ((input (by-id "qsp-input")))
     (setf (@ input value) "")))
 
 (defun input (text)
   (chain window (prompt text)))
 
 ;;; 20time
 
 (defun msecscount ()
-  (- (chain *date (now)) (root started-at)))
+  (- (chain *date (now)) *started-at))
 
 ;;; 21local
 
 ;;; 22for
 
 ;;; misc
 
 (defun rgb (red green blue)
   (+ (<< red 16)
      (<< green 8)
      blue))
 
 (defun openqst (name)
   (api-call run-game name))
 
 (defun addqst (name)
   (let ((game (api-call filename-game name)))
     ;; Add the game's locations
-    (chain *object (assign (root locs)
-                           (getprop (root games) name)))))
+    (chain *object (assign *locs
+                           (getprop *games name)))))
 
 (defun killqst ()
   ;; Delete all locations not from the current main game
-  (loop :for (k v) :in (root games)
-     :do (unless (string= k (root main-game))
-           (delete (getprop (root locs) k)))))
+  (loop :for (k v) :in *games
+     :do (unless (string= k *main-game)
+           (delete (getprop *locs k)))))
 

src/main-macros.lisp

@@ -1,15 +1,12 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/main.ps

@@ -1,51 +1,48 b''
 
 (in-package sugar-qsp.main)
 
-(setf (root)
-      (create
-       ;;; Game session state (saved in savegames)
-       ;; Variables
-       vars (create)
-       ;; Inventory (objects)
-       objs (create)
-       current-location nil
-       ;; Game time
-       started-at (chain *date (now))
-       ;; Timers
-       timer-interval 500
-       timer-obj nil
-       ;; Games
-       loaded-games (list)
+;;; Game session state (saved in savegames)
+;; Variables
+(var *globals (create))
+;; Inventory (objects)
+(var *objs (create))
+(var *current-location nil)
+;; Game time
+(var *started-at (chain *date (now)))
+;; Timers
+(var *timer-interval 500)
+(var *timer-obj nil)
+;; Games
+(var *loaded-games (list))
 
-       ;;; Transient state
-       ;; ACTions
-       acts (create)
-       ;; Savegame data
-       state-stash (create)
-       ;; List of audio files being played
-       playing (create)
-       ;; Local variables stack (starts with an empty frame)
-       locals (list)
+;;; Transient state
+;; ACTions
+(var *acts (create))
+;; Savegame data
+(var *state-stash (create))
+;; List of audio files being played
+(var *playing (create))
+;; Local variables stack (starts with an empty frame)
+(var *locals (list))
 
-       ;;; Game data
-       ;; Games (filename -> [locations])
-       games (list)
-       ;; The main (non library) game. Updated by openqst
-       main-game nil
-       ;; Active locations
-       locs (create)))
+;;; Game data
+;; Games (filename -> [locations])
+(var *games (list))
+;; The main (non library) game. Updated by openqst
+(var *main-game nil)
+;; Active locations
+(var *locs (create))
 
 ;; Launch the game from the first location
 (setf (@ window onload)
       (lambda ()
         (#.(intern "INIT-DOM" "SUGAR-QSP.API"))
         ;; For MSECCOUNT
-        (setf (root started-at) (chain *date (now)))
+        (setf *started-at (chain *date (now)))
         ;; For $COUNTER and SETTIMER
         (#.(intern "SET-TIMER" "SUGAR-QSP.API")
-           (root timer-interval))
+           *timer-interval)
         ;; Start the first game
         (#.(intern "RUN-GAME" "SUGAR-QSP.API")
-           (chain *object (keys (root games)) 0))
+           (chain *object (keys *games) 0))
         (values)))
-

src/package.lisp

@@ -1,104 +1,108 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 #:games))
+           #:in
+
+           #:*globals #:*objs #:*current-location
+           #:*started-at #:*timer-interval #:*timer-obj #:*loaded-games
+
+           #:*acts #:*state-stash #:*playing #:*locals
+
+           #:*games #:*main-game #:*locs
+           ))
 
 (defpackage :code-walker
   (:use :cl)
   (:export #:deftransform
            #:deftransform-stop
            #:walk
            #:whole
            #:walk-continue))
 
 ;;; 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
            #:set-str-element #:set-any-element
            #:*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)
                     (#:walker :code-walker))
   (:export #:str #:exec #:qspblock #:qspfor #:game #:location
            #:qspcond #:qspvar #:set #:local #:jump
 
            #: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
            ))
 
 (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_")
 
 ;;; The compiler
 (defpackage :sugar-qsp
   (:use :cl)
   (:local-nicknames (#:p #:esrap)
                     (#:lib :sugar-qsp.lib)
                     (#:api :sugar-qsp.api)
                     (#:main :sugar-qsp.main)
                     (#:walker :code-walker))
   (:export #:parse-file #:entry-point))
 

src/ps-macros.lisp

@@ -1,372 +1,372 b''
 
 (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.
 
 ;;;; Block type | Has own locals | Has labels | async
 ;;;  Location   | TRUE           | TRUE       | TRUE
 ;;;  Act        | TRUE           | TRUE       | TRUE
 ;;;  {}         | TRUE           | TRUE       | TRUE
 ;;;  IF         | FALSE          | TRUE       | TRUE
 ;;;  FOR        | FALSE          | TRUE       | TRUE
 ;;;  
 
 ;;; Utils
 
 ;;; Common
 
 (defpsmacro label-block (() &body body)
   (let ((has-labels (some #'keywordp body)))
     `(block nil
        ,@(when has-labels
            '((var _labels (list))))
        (tagbody
           ,@body
           (void)))))
 
 (defpsmacro str (&rest forms)
   (cond ((zerop (length forms))
          "")
         ((and (= 1 (length forms))
               (stringp (first forms)))
          (first forms))
         (t
          `(& ,@forms))))
 
 (defpsmacro locals-block (&body body)
   "Includes labels too (through qsp-lambda)"
   (let ((*locals* nil))
     (walker:walk 'locals body)
     `(qsp-lambda
       (create-locals ,*locals*)
       ,@(walker:walk 'apply-vars body))))
 
 ;;; 1loc
 
 (defparameter *service-variables*
   '((usehtml 0)
     (result 0)
     ($result 0)
     ($ongload 0)
     ($ongsave 0)
     ($onobjadd 0)
     ($onobjdel 0)
     ($onobjsel 0)
     ($onnewloc 0)
     ($onactsel 0)
     ($counter 0)
     ($usercom 0)))
 
 (defpsmacro game ((name) &body body)
   (setf body (walker:walk 'for-transform body))
   (setf *globals* *service-variables*)
   (walker:walk 'globals body)
   `(progn
      ;; Game object
-     (setf (root games ,name)
+     (setf (@ *games ,name)
            (create))
      ;; Global variables from this game
      (create-globals ,*globals*)
      ;; Locations
      ,@(loop :for location :in body
-          :collect `(setf (root games ,name ,(caadr location))
+          :collect `(setf (@ *games ,name ,(caadr location))
                           ,location))))
 
 (defpsmacro location ((name) &body body)
   (declare (ignore name))
   "Name is used by the game macro above"
   `(locals-block ,@body))
 
 (defpsmacro goto% (target &rest args)
   `(progn
      (goto ,target ,args)
      (exit)))
 
 (defpsmacro xgoto% (target &rest args)
   `(progn
      (xgoto ,target ,args)
      (exit)))
 
 ;;; 2var
 
 (defvar *globals* nil)
 (defvar *locals* nil)
 
 (defpsmacro create-globals (globals)
   (flet ((indexes (name)
            (remove nil
                    (remove-if #'listp
                               (mapcar #'second
                                       (remove name globals
                                               :key #'first
                                               :test-not #'eq))))))
     (let ((names (remove-duplicates (mapcar #'first globals))))
       `(chain *object
-              (assign (root vars)
+              (assign *globals
                       (create
                        ,@(loop :for sym :in names
                             :for indexes := (indexes sym)
                             :for name := (string-upcase sym)
                             :append `(,name
                                       (api-call new-var ,name ,@indexes)))))))))
 
 (walker:deftransform globals qspvar (&rest var)
   (pushnew var *globals* :test #'equal)
   (walker:walk-continue))
 
 (walker:deftransform globals local (var &rest expr)
   (declare (ignore var))
   (walker:walk 'globals expr))
 
 (defpsmacro create-locals (locals)
   (when locals
     `(progn
        (var locals (create
                     ,@(loop :for (sym index) :in locals
                          :for name := (string-upcase sym)
                          :append `(,name (api-call new-var ,name))))))))
 
 ;; locations, blocks, and acts all have their own locals namespace
 (walker:deftransform-stop locals qspblock)
 (walker:deftransform-stop locals act)
 
 (walker:deftransform locals local (var &optional expr)
   (declare (ignore expr))
   (pushnew (rest var) *locals* :test #'equal)
   nil)
 
 ;; index types:
 ;; literal number
 ;; literal string
 ;; variable number
 ;; variable string
 ;; expression (may be possible to determine if it's a string or a number)
 
 (defun $-var-p (sym)
   (char= #\$ (elt (string-upcase (symbol-name sym)) 0)))
 
 (defun literal-string-p (form)
   (and (listp form)
        (= 2 (length form))
        (eq 'str (first form))
        (stringp (second form))))
 
 (defun variable-number-p (form)
   (and (listp form)
        (eq 'qspvar (first form))
        (not ($-var-p (second form)))))
 
 (defun variable-string-p (form)
   (and (listp form)
        (eq 'qspvar (first form))
        ($-var-p (second form))))
 
 (walker:deftransform apply-vars set (var expr)
   (destructuring-bind (qspvar name index)
       var
     (declare (ignore qspvar))
     (let ((slot `(getprop
                   ,(if (member name *locals* :key #'first)
-                       'locals '(root vars))
+                       'locals '*globals)
                   ,(string-upcase name))))
       (cond
         ((null index)
          `(chain (elt ,slot) (push ,expr)))
         ((or (numberp index)
              (variable-number-p index))
          `(setf (elt ,slot ,index)
                 ,(walker:walk 'apply-vars expr)))
         ((or (literal-string-p index)
              (variable-string-p index))
          `(api:set-str-element ,slot ,(walker:walk 'apply-vars index)
                                ,(walker:walk-continue expr)))
         (t
          `(api:set-any-element ,slot ,(walker:walk 'apply-vars index)
                                ,(walker:walk-continue expr)))))))
 
 (walker:deftransform apply-vars local (var &optional expr)
   (when expr
     (walker:walk 'apply-vars (list 'set var expr))))
 
 (walker:deftransform apply-vars qspvar (name index)
   (let ((slot `(getprop
-                ,(if (member name *locals* :key #'first) 'locals '(root vars))
+                ,(if (member name *locals* :key #'first) 'locals '*globals)
                 ,(string-upcase name))))
     (cond
       ((null index)
        `(elt ,slot (1- (length ,slot))))
       ((or (numberp index)
            (variable-number-p index))
        `(elt ,slot ,(walker:walk-continue index)))
       ((or (literal-string-p index)
            (variable-string-p index))
        `(elt ,slot (@ ,slot :indexes ,(walker:walk-continue index))))
       (t
        `(get-element ,slot ,(walker:walk-continue index))))))
 
 (walker:deftransform apply-vars qspblock (&rest block)
   (declare (ignore block))
   (walker:whole))
 (walker:deftransform apply-vars act (&rest block)
   (declare (ignore block))
   (walker:whole))
 (walker:deftransform apply-vars qspfor (var from to step body)
   (list* 'qspfor var (mapcar #'walker:walk-continue (list from to step body))))
 
 ;;; 3expr
 
 (defpsmacro <> (op1 op2)
   `(not (equal ,op1 ,op2)))
 
 (defpsmacro ! (op1 op2)
   `(not (equal ,op1 ,op2)))
 
 ;;; 4code
 
 (defpsmacro exec (&body body)
   (format nil "javascript: ~{~A~^~%~}" (mapcar #'ps* body)))
 
 ;;; 5arrays
 
 ;;; 6str
 
 (defpsmacro & (&rest args)
   `(chain "" (concat ,@args)))
 
 ;;; 7if
 
 (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
 
 (defpsmacro jump (target)
   `(return-from label-body ,(string-upcase (second target))))
 
 (defpsmacro tagbody (&body body)
   (let ((create-locals (if (eq (caar body) 'create-locals)
                            (list (car body))))
         (void (if (equal (car (last body)) '(void))
                   '((void)))))
     (when create-locals
       (setf body (cdr body)))
     (when void
       (setf body (butlast body)))
     (let ((funcs (list nil "_nil")))
       (dolist (form body)
         (cond ((keywordp form)
                (setf (first funcs) (reverse (first funcs)))
                (push (string-upcase form) funcs)
                (push nil funcs))
               (t
                (push form (first funcs)))))
       (setf (first funcs) (reverse (first funcs)))
       (setf funcs (reverse funcs))
       `(progn
          ,@create-locals
          ,(if (= 2 (length funcs))
               `(progn
                  ,@body)
               `(progn
                  (tagbody-blocks ,funcs)
                  (loop
                     :for _nextblock
                       := :_nil
                     :then (await (funcall (getprop _labels _nextblock)))
                     :while _nextblock)))
          ,@void))))
 
 (defvar *current-label*)
 (defvar *has-jump-back*)
 (walker:deftransform optimize-jump jump (target)
   (cond ((string= (string-upcase (second target)) *current-label*)
          (setf *has-jump-back* t)
          '(continue))
         (t
          (walker:walk-continue))))
 
 (defpsmacro tagbody-blocks (funcs)
   `(setf ,@(loop :for (label code . rest-labels) :on funcs :by #'cddr
               :append `((@ _labels ,label)
                         (async-lambda ()
                           (block label-body
                             (tagbody-block-body ,label ,code
                                                 ,(first rest-labels))))))))
 
 (defpsmacro tagbody-block-body (label code next-label)
   (let ((*current-label* label)
         (*has-jump-back* nil))
     (let ((code (walker:walk 'optimize-jump code)))
       (if *has-jump-back*
           `(progn
              (loop :do (progn
                          ,@code
                          (break)))
              ,@(if next-label
                    (list next-label)
                    nil))
           `(progn
              ,@code
              ,@(if next-label
                    (list next-label)
                    nil))))))
 
 (defpsmacro exit ()
   '(return-from nil (values)))
 
 ;;; 10dynamic
 
 (defpsmacro qspblock (&body body)
   `(locals-block
     ,@body))
 
 (defpsmacro qsp-lambda (&body body)
   `(async-lambda (args)
      (label-block ()
        ,@body)))
 
 ;;; 11main
 
 (defpsmacro act (name img &body body)
   `(api-call add-act ,name ,img
              (locals-block
                ,@body)))
 
 ;;; 12aux
 
 ;;; 13diag
 
 ;;; 14act
 
 ;;; 15objs
 
 ;;; 16menu
 
 ;;; 17sound
 
 ;;; 18img
 
 ;;; 19input
 
 ;;; 20time
 
 ;;; 21local
 
 ;;; 22for
 
 ;; Transform because it creates a (set ...) hence it has to be processed
 ;; before the apply-vars transform. And macros are processed *after* all
 ;; the transforms
 (walker:deftransform for-transform qspfor (var from to step &rest body)
   `(loop :for i :from ,from :to ,to :by ,step
       :do (set ,var i)
       :do (block nil
             ,@(walker:walk-continue body))))