Properly handle stringly-indexed arrays

TODO

@@ -1,9 +1,6 b''
-
-* string array keys as addition to number keys
-* arr[] notation (i.e. with empty index)
 
 * Windows GUI (for the compiler)
 * Save-load game in slots
 * Resizable frames
 * Build Istreblenie
 ** modifying it to suit compiler specifics
  No newline at end of file

src/api.ps

@@ -1,236 +1,287 b''
 
 (in-package sugar-qsp)
 
 ;;; 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.acts[\"" title "\"].act();'>"
      title
      "</a>"))
 
 (defm (root api make-menu-item-html) (num title img loc)
   (+ "<a href='#' onclick='SugarQSP.api.runMenu(" num ", \"" loc "\")();'>"
      "<img src='" img "'>"
      title
      "</a>"))
 
 ;; To be used in saving game
-(defm (root api stash-state) ()
+(defm (root api stash-state) (args)
   (setf (root state-stash)
         (*j-s-o-n.stringify
          (ps:create vars (root vars)
                     objs (root objs)
+                    loc-args args
+                    main-html (ps:@
+                               (document.get-element-by-id :qsp-main)
+                               inner-h-t-m-l)
+                    stat-html (ps:@
+                               (document.get-element-by-id :qsp-stat)
+                               inner-h-t-m-l)
                     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 objs) (ps:@ data objs))
+    (setf (root current-location) (ps:@ data next-location))
+    (setf (ps:@ (document.get-element-by-id :qsp-main) inner-h-t-m-l)
+          (ps:@ data main-html))
+    (setf (ps:@ (document.get-element-by-id :qsp-stat) inner-h-t-m-l)
+          (ps:@ data stat-html))
+    (funcall (root locs (root current-location)) (ps:@ data loc-args))
+    (this.update-objs)
+    (values)))
+
 (defm (root api state-to-base64) ()
   (btoa (encode-u-r-i-component (root state-stash))))
 
 (defm (root api base64-to-state) (data)
-  (setf (root state-stash) (decode-u-r-i-component (atob data)))
-  (let ((data (*j-s-o-n.parse (root state-stash))))
-    (this.clear-id :qsp-main)
-    (this.clear-id :qsp-stat)
-    (this.clear-act)
-    (setf (root vars) (ps:@ data vars))
-    (setf (root objs) (ps:@ data objs))
-    (setf (root current-location) (ps:@ data next-location))
-    (funcall (root locs (root current-location)))
-    (this.update-objs)
-    (values)))
+  (setf (root state-stash) (decode-u-r-i-component (atob data))))
 
 ;;; Misc
 
 (defm (root api clear-id) (id)
   (setf (ps:chain document (get-element-by-id id) inner-text) ""))
 
 (defm (root api get-id) (id)
-  (if (var "USEHTML" 0)
+  (if (var "USEHTML" 0 :num)
       (ps:chain (document.get-element-by-id id) inner-h-t-m-l)
       (ps:chain (document.get-element-by-id id) inner-text)))
 
 (defm (root api set-id) (id contents)
-  (if (var "USEHTML" 0)
+  (if (var "USEHTML" 0 :num)
       (setf (ps:chain (document.get-element-by-id id) inner-h-t-m-l) contents)
       (setf (ps:chain (document.get-element-by-id id) inner-text) contents)))
 
 (defm (root api append-id) (id contents)
-  (if (var "USEHTML" 0)
+  (if (var "USEHTML" 0 :num)
       (incf (ps:chain (document.get-element-by-id id) inner-h-t-m-l) contents)
       (incf (ps:chain (document.get-element-by-id id) inner-text) contents)))
 
 ;;; Function calls
 
 (defm (root api init-args) (args)
   (dotimes (i (length args))
-    (if (numberp (elt args i))
-        (set (var args i) (elt args i))
-        (set (var $args i) (elt args i)))))
+    (let ((arg (elt args i)))
+      (if (numberp arg)
+          (this.set-var args i :num arg)
+          (this.set-var args i :str arg)))))
 
 (defm (root api get-result) ()
-  (if (not (equal "" (var $result 0)))
-      (var $result 0)
-      (var result 0)))
+  (if (not (equal "" (var result 0 :str)))
+      (var result 0 :str)
+      (var result 0 :num)))
 
 ;;; Text windows
 
 (defm (root api key-to-id) (key)
   (case key
     (:main "qsp-main")
     (:stat "qsp-stat")
     (:objs "qsp-objs")
     (:acts "qsp-acts")
     (:input "qsp-input")
     (:dropdown "qsp-dropdown")
     (t (report-error "Internal error!"))))
 
 (defm (root api get-frame) (key)
   (document.get-element-by-id (this.key-to-id key)))
 
 (defm (root api add-text) (key text)
   (this.append-id (this.key-to-id key) text))
 
 (defm (root api get-text) (key)
   (this.get-id (this.key-to-id key)))
 
 (defm (root api clear-text) (key)
   (this.clear-id (this.key-to-id key)))
 
 (defm (root api newline) (key)
   (let ((div (this.get-frame key)))
     (ps:chain div (append-child (document.create-element "br")))))
 
 (defm (root api enable-frame) (key enable)
   (let ((clss (ps:getprop (this.get-frame key) 'class-list)))
     (setf clss.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))
 
 (defm (root api del-act) (title)
   (delete (ps:getprop (root acts) title))
   (this.update-acts))
 
 (defm (root api clear-act) ()
   (setf (root acts) (ps:create))
   (this.clear-id "qsp-acts"))
 
 (defm (root api update-acts) ()
   (this.clear-id "qsp-acts")
   (ps:for-in (title (root acts))
     (let ((obj (ps:getprop (root acts) title)))
       (this.append-id "qsp-acts"
                 (this.make-act-html title (ps:getprop obj :img))))))
 
-;;; Variables
+;;; Variable class
+
+(defm (root api *var) (name)
+  ;; From strings to numbers
+  (setf this.indexes (ps:create))
+  ;; From numbers to {num: 0, str: ""} objects
+  (setf this.values (list))
+  (values))
+
+(defm (root api *var prototype new-value) ()
+  (ps:create :num 0 :str ""))
 
-(defm (root api var-slot) (name)
-  (if (= (ps:@ name 0) #\$)
-      :str
-      :num))
+(defm (root api *var prototype index-num) (index)
+  (let ((num-index
+         (if (stringp index)
+             (if (in index this.indexes)
+                 (ps:getprop this.indexes index)
+                 (let ((n (length this.values)))
+                   (setf (ps:getprop this.indexes index) n)
+                   n))
+             index)))
+    (unless (in num-index this.values)
+      (setf (elt this.values num-index) (this.new-value)))
+    num-index))
+
+(defm (root api *var prototype get) (index slot)
+  (unless (or index (= 0 index))
+    (setf index (1- (length this.values))))
+  (ps:getprop this.values (this.index-num index) slot))
+
+(defm (root api *var prototype set) (index slot value)
+  (unless (or index (= 0 index))
+    (setf index (length store)))
+  (case slot
+    (:num (setf value (ps:chain *number (parse-int value))))
+    (:str (setf value (ps:chain value (to-string)))))
+  (setf (ps:getprop this.values (this.index-num index) slot) value)
+  (values))
+
+(defm (root api *var prototype kill) (index)
+  (setf (elt this.values (this.index-num index)) (this.new-value)))
+
+;;; Variables
 
 (defm (root api var-real-name) (name)
   (if (= (ps:@ name 0) #\$)
-      (ps:chain name (substr 1))
-      name))
+      (values (ps:chain name (substr 1)) :str)
+      (values name :num)))
 
-(defm (root api ensure-var) (name index)
+(defm (root api ensure-var) (name)
   (let ((store (this.var-ref name)))
     (unless store
-      (setf store (ps:create))
-      (setf (ps:getprop (root vars) name) store)))
-  (unless (in index store)
-    (setf (elt store index) (ps:create :num 0 :str "")))
-  (values))
+      (setf store (ps:new (this.-var name)))
+      (setf (ps:getprop (root vars) name) store))
+    store))
 
 (defm (root api var-ref) (name)
-  (let ((var-name (this.var-real-name name))
-        (local-store (this.current-local-frame)))
-    (cond ((in var-name local-store)
-           (ps:getprop local-store))
-          ((in var-name (root vars))
-           (ps:getprop (root vars) var-name))
+  (let ((local-store (this.current-local-frame)))
+    (cond ((in name local-store)
+           (ps:getprop local-store name))
+          ((in name (root vars))
+           (ps:getprop (root vars) name))
           (t nil))))
 
-(defm (root api get-var) (name index)
-  (this.ensure-var name index)
-  (let ((store (this.var-ref name)))
-    (ps:getprop store index (this.var-slot name))))
+(defm (root api get-var) (name index slot)
+  (ps:chain (this.ensure-var name) (get index slot)))
 
-(defm (root api set-var) (name index value)
-  (this.ensure-var name index)
-  (let ((store (this.var-ref name)))
-    (setf (ps:getprop store index (this.var-slot name)) value)
-    (values)))
+(defm (root api set-var) (name index slot value)
+  (ps:chain (this.ensure-var name) (set index slot value))
+  (values))
 
 (defm (root api get-array) (name)
-  (ps:getprop (root vars) name))
+  (this.var-ref name))
 
 (defm (root api set-array) (name value)
-  (setf (ps:getprop (root vars) name) value))
+  (let ((store (this.var-ref name)))
+    (setf (ps:@ store values) (ps:@ value values))
+    (setf (ps:@ store indexes) (ps:@ value indexes)))
+  (values))
 
 (defm (root api kill-var) (name &optional index)
-  (if index 
-      (ps:delete (ps:getprop (root vars) name index))
+  (if (and index (not (= 0 index))) 
+      (ps:chain (ps:getprop (root vars) name) (kill index))
       (ps:delete (ps:getprop (root vars) name)))
   (values))
 
 (defm (root api array-size) (name)
-  (ps:getprop (root vars) (this.var-real-name name) 'length))
+  (ps:getprop (this.var-ref name) 'length))
+
+;;; Locals
+
+(defm (root api push-local-frame) ()
+  (ps:chain (root locals) (push (ps:create)))
+  (values))
+
+(defm (root api pop-local-frame) ()
+  (ps:chain (root locals) (pop))
+  (values))
+
+(defm (root api current-local-frame) ()
+  (elt (root locals) (1- (length (root locals)))))
+
+(defm (root api new-local) (name)
+  (let ((frame (this.current-local-frame)))
+    (unless (in name frame)
+      (setf (ps:getprop frame name) (ps:create)))
+    (values)))
 
 ;;; Objects
 
 (defm (root api update-objs) ()
   (let ((elt (document.get-element-by-id "qsp-objs")))
     (setf elt.inner-h-t-m-l "<ul>")
     (loop :for obj :in (root objs)
        :do (incf elt.inner-h-t-m-l (+ "<li>" obj)))
     (incf elt.inner-h-t-m-l "</ul>")))
 
 ;;; Menu
 
 (defm (root api menu) (menu-data)
   (let ((elt (document.get-element-by-id "qsp-dropdown"))
         (i 0))
     (setf elt.inner-h-t-m-l "")
     (loop :for item :in menu-data
        :do (incf i)
        :do (incf elt.inner-h-t-m-l (this.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)))))
 
-;;; Locals
-
-(defm (root api push-local-frame) ()
-  (ps:chain (root locals) (push (ps:create))))
-
-(defm (root api pop-local-frame) ()
-  (ps:chain (root locals) (pop)))
-
-(defm (root api current-local-frame) ()
-  (elt (root locals) (1- (length (root locals)))))
-
-(defm (root api new-local) (name)
-  (let ((frame (this.current-local-frame))
-        (var-name (this.var-real-name name)))
-    (unless (in var-name frame)
-      (setf (ps:getprop frame var-name) (ps:create)))))

src/intrinsics.ps

@@ -1,323 +1,324 b''
 
 (in-package sugar-qsp)
 
 ;;;; 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 &rest args)
+(defm (root lib goto) (target args)
   (api-call clear-text :main)
-  (apply (root lib xgoto) target args))
+  (funcall (root lib xgoto) target (or args (list)))
+  (values))
 
-(defm (root lib xgoto) (target &rest args)
+(defm (root lib xgoto) (target args)
   (api-call clear-act)
-  (api-call init-args args)
   (setf (root current-location) (ps:chain target (to-upper-case)))
-  (api-call stash-state)
-  (funcall (ps:getprop (root locs) (root current-location))))
+  (api-call stash-state args)
+  (funcall (ps:getprop (root locs) (root current-location))
+           (or args (list)))
+  (values))
 
 ;;; 2var
 
 ;;; 3expr
 
 ;;; 4code
 
 (defm (root lib rand) (a &optional (b 1))
   (let ((min (min a b))
         (max (max a b)))
     (+ min (ps:chain *math (random (- max min))))))
 
 ;;; 5arrays
 
 (defm (root lib copyarr) (to from start count)
-  (ps:for ((i start))
-          ((< i (min (api-call array-size from)
-                     (+ start count))))
-          ((incf i))
-    (api-call set-var to (+ start i)
-              (api-call get-var from (+ start i)))))
+  (multiple-value-bind (to-name to-slot)
+      (api-call var-real-name to)
+    (multiple-value-bind (from-name from-slot)
+        (api-call var-real-name from)
+      (ps:for ((i start))
+              ((< i (min (api-call array-size from-name)
+                         (+ start count))))
+              ((incf i))
+              (api-call set-var to-name (+ start i) to-slot
+                        (api-call get-var from-name (+ start i) from-slot))))))
 
 (defm (root lib arrpos) (name value &optional (start 0))
-  (ps:for ((i start)) ((< i (api-call array-size name))) ((incf i))
-    (when (eq (api-call get-var name i) value)
-      (return i)))
+  (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))))
   -1)
 
 (defm (root lib arrcomp) (name pattern &optional (start 0))
-  (ps:for ((i start)) ((< i (api-call array-size name))) ((incf i))
-    (when (funcall (ps:getprop (api-call get-var name i) 'match) pattern)
-      (return i)))
+  (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))))
   -1)
 
 ;;; 6str
 
 (defm (root lib instr) (s subs &optional (start 1))
   (+ start (ps:chain s (substring (- start 1)) (search subs))))
 
 (defm (root lib isnum) (s)
   (if (is-na-n s)
       0
       -1))
 
 (defm (root lib strcomp) (s pattern)
   (if (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)))
 
 (defm (root lib strpos) (s pattern &optional (group 0))
   (let* ((re (ps:new (*reg-exp pattern)))
          (match (re.exec s))
          (found (match.group group)))
     (if found
         (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)
   (if cond-expr then-expr else-expr))
 
 ;;; 8sub
 
 (defm (root lib gosub) (target &rest args)
-  (conserving-vars (__funcall args result)
-    (api-call init-args args)
-    (funcall (ps:getprop (root locs) target))
-    (values)))
+  (funcall (ps:getprop (root locs) target) args)
+  (values))
 
 (defm (root lib func) (target &rest args)
-  (conserving-vars (__funcall args result)
-    (api-call init-args args)
-    (funcall (ps:getprop (root locs) target))
-    (api-call get-result)))
+  (funcall (ps:getprop (root locs) target) args))
 
 ;;; 9loops
 
 ;;; 10dynamic
 
-(defm (root lib dyneval) (block &rest args)
-  (conserving-vars (__funcall args result)
-    (api-call init-args args)
-    (funcall block)
-    (api-call get-result)))
+(defm (root lib dynamic) (block &rest args)
+  (funcall block args)
+  (values))
 
-(defm (root lib dynamic) (&rest args)
-  (conserving-vars (__funcall args result)
-    (api-call init-args args)
-    (funcall block)
-    (values)))
+(defm (root lib dyneval) (block &rest args)
+  (funcall block args))
 
 ;;; 11main
 
 (defm (root lib main-p) (s)
   (api-call add-text :main s)
   (values))
 
 (defm (root lib main-pl) (s)
   (api-call add-text :main s)
   (api-call newline :main)
   (values))
 
 (defm (root lib main-nl) (s)
   (api-call newline :main)
   (api-call add-text :main s)
   (values))
 
 (defm (root lib maintxt) (s)
   (api-call get-text :main)
   (values))
 
 ;; For clarity (it leaves a lib.desc() call in JS)
 (defm (root lib desc) (s)
   "")
 
 (defm (root lib main-clear) ()
   (api-call clear-text :main)
   (values))
 
 ;;; 12stat
 
 (defm (root lib stat-p) (s)
   (api-call add-text :stat s)
   (values))
 
 (defm (root lib stat-pl) (s)
   (api-call add-text :stat s)
   (api-call newline :stat)
   (values))
 
 (defm (root lib stat-nl) (s)
   (api-call newline :stat)
   (api-call add-text :stat s)
   (values))
 
 (defm (root lib stattxt) (s)
   (api-call get-text :stat)
   (values))
 
 (defm (root lib stat-clear) ()
   (api-call 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))
   (values))
 
 ;;; 13diag
 
 ;;; 14act
 
 (defm (root lib curacts) ()
   (let ((acts (root acts)))
     (lambda ()
       (setf (root acts) acts)
       (values))))
 
 ;;; 15objs
 
 (defm (root lib addobj) (name)
   (ps:chain (root objs) (push name))
   (api-call update-objs)
   (values))
 
 (defm (root lib delobj) (name)
   (let ((index (ps:chain (root objs) (index-of name))))
     (when (> index -1)
       (funcall (root lib killobj) (1+ index))))
   (values))
 
 (defm (root lib killobj) (&optional (num nil))
   (if (eq nil num)
       (setf (root objs) (list))
       (ps:chain (root objs) (splice (1- num) 1)))
   (api-call update-objs)
   (values))
 
 ;;; 16menu
 
 (defm (root lib menu) (menu-name)
   (let ((menu-data (list)))
     (loop :for item :in (api-call get-array (api-call var-real-name menu-name))
        :do (cond ((string= item "")
                   (break))
                  ((string= item "-:-")
                   (ps:chain menu-data (push :delimiter)))
                  (t
                   (let* ((tokens (ps:chain item (split ":"))))
                     (when (= (length tokens) 2)
                       (tokens.push ""))
                     (let* ((text (ps:chain tokens (splice 0 (- tokens.length 2)) (join ":")))
                            (loc (ps:getprop tokens (- tokens.length 2)))
                            (icon (ps:getprop tokens (- tokens.length 1))))
                       (ps:chain menu-data
                                 (push (ps:create text text
                                                  loc loc
                                                  icon icon))))))))
     (api-call menu menu-data)
     (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))))
 
 (defm (root lib close) (filename)
   (funcall (root playing filename) stop)
   (ps:delete (root playing filename)))
 
 (defm (root lib closeall) ()
   (loop :for k :in (*object.keys (root playing))
      :for v := (ps:getprop (root playing) k)
      :do (funcall v stop))
   (setf (root playing) (ps:create)))
 
 ;;; 18img
 
 (defm (root lib refint) ())
 
 (defm (root lib view) ())
 
 ;;; 19input
 
 (defm (root lib showinput) ())
 
 (defm (root lib usertxt) ())
 
 (defm (root lib cmdclear) ())
 
 (defm (root lib input) ())
 
 ;;; 20time
 
 ;; I wonder if there's a better solution than busy-wait
 (defm (root lib wait) (msec)
   (let* ((now (ps:new (*date)))
          (exit-time (+ (funcall now.get-time) msec)))
     (loop :while (< (funcall now.get-time) exit-time))))
 
 (defm (root lib msecscount) ())
 
 (defm (root lib settimer) ())
 
 ;;; 21local
 
 ;;; misc
 
 (defm (root lib rgb) ())
 
 (defm (root lib openqst) ())
 
 (defm (root lib addqst) ())
 
 (defm (root lib killqst) ())
 
 (defm (root lib opengame) (&optional filename)
   (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
           (lambda (event)
             (let* ((file (elt event.target.files 0))
                    (reader (ps:new (*file-reader))))
               (setf reader.onload
                     (lambda (ev)
                       (block nil
                              (let ((target ev.current-target))
                                (unless target.result
                                  (return))
-                               (api-call base64-to-state target.result)))))
+                               (api-call 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)))
 
 (defm (root lib savegame) (&optional filename)
   (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)))

src/main.ps

@@ -1,34 +1,35 b''
 
 (in-package sugar-qsp)
 
 (setf (root)
       (ps:create
        ;;; Game session state
        ;; Variables
        vars (ps:create)
        ;; Inventory (objects)
        objs (list)
        ;;; Transient state
        ;; Savegame data
        state-stash (ps:create)
        ;; List of audio files being played
        playing (ps:create)
        ;; Local variables stack (starts with an empty frame)
        locals (list)
        ;;; Game data
        ;; ACTions
        acts (ps:create)
        ;; Locations
        locs (ps:create)))
 
 ;; Launch the game from the first location
 (setf window.onload
       (lambda ()
         (funcall (ps:getprop (root locs)
-                             (ps:chain *object (keys (root locs)) 0)))
+                             (ps:chain *object (keys (root locs)) 0))
+                 (list))
         (values)))
 
 ;; Close the dropdown on any click
 (setf window.onclick
       (lambda (event)
         (setf (ps:@ (api-call get-frame :dropdown) style display) "none")))

src/parser.lisp

@@ -1,586 +1,587 b''
 
 (in-package sugar-qsp)
 
 ;;;; Parses TXT source to an intermediate representation
 
 ;;; Utility
 
 (defun remove-nth (list nth)
   (append (subseq list 0 nth)
           (subseq list (1+ nth))))
 
 (defun not-quote (char)
   (not (eql #\' char)))
 
 
 (defun not-doublequote (char)
   (not (eql #\" char)))
 
 (defun not-brace (char)
   (not (eql #\} char)))
 
 (defun not-integer (string)
   (when (find-if-not #'digit-char-p string)
     t))
 
 (defun not-newline (char)
   (not (eql #\newline char)))
 
 (defun id-any-char (char)
   (and
    (not (digit-char-p char))
    (not (eql #\newline char))
    (not (find char " 	!:&=<>+-*/,'\"()[]{}"))))
 
 (defun intern-first (list)
   (list* (intern (string-upcase (first list)))
          (rest list)))
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defun remove-nil (list)
     (remove nil list)))
 
 (defun binop-rest (list)
   (destructuring-bind (ws1 operator ws2 operand2)
       list
     (declare (ignore ws1 ws2))
     (list (intern (string-upcase operator)) operand2)))
 
 (defun do-binop% (left-op other-ops)
   (if (null other-ops)
       left-op
       (destructuring-bind ((operator right-op) &rest rest-ops)
           other-ops
         (if (and (listp left-op)
                  (eq (first left-op)
                      operator))
             (do-binop% (append left-op (list right-op)) rest-ops)
             (do-binop% (list operator left-op right-op) rest-ops)))))
 
 (defun do-binop (list)
   (destructuring-bind (left-op rest-ops)
       list
     (do-binop% left-op
       (mapcar #'binop-rest rest-ops))))
 
 (p:defrule line-continuation (and #\_ #\newline)
   (:constant nil))
 
 (p:defrule text-spaces (+ (or #\space #\tab line-continuation))
   (:text t))
 
 (p:defrule spaces (+ (or #\space #\tab line-continuation))
   (:constant nil))
 
 (p:defrule spaces? (* (or #\space #\tab line-continuation))
   (:constant nil))
 
 (p:defrule colon #\:
   (:constant nil))
 
 (p:defrule alphanumeric (alphanumericp character))
 
 (p:defrule not-newline (not-newline character))
 
 (p:defrule squote-esc "''"
   (:lambda (list)
     (p:text (elt list 0))))
 
 (p:defrule dquote-esc "\"\""
   (:lambda (list)
     (p:text (elt list 0))))
 
 (p:defrule sstring-chars (+ (and (and (p:! "<<") (p:! (p:~ "\"exec:")))
                                  (or squote-esc (not-quote character))))
   (:lambda (list)
     (p:text (mapcar #'second list))))
 
 (p:defrule dstring-chars (+ (and (and (p:! "<<") (p:! (p:~ "'exec:")))
                                  (or dquote-esc (not-doublequote character))))
   (:lambda (list)
     (p:text (mapcar #'second list))))
 
 ;;; Identifiers
 
 ;; From the official docs
 (defparameter *keywords* '(act addlib addobj addqst and arrcomp arrpos arrsize cla clear *clear close clr *clr cls cmdclear cmdclr copyarr counter countobj curacts curloc debug delact dellib delobj desc disablescroll disablesubex dynamic dyneval else elseif end exit fcolor fname freelib fsize func getobj gosub goto gs gt if iif inclib input instr isnum isplay jump killall killobj killqst killvar lcase lcolor len let loc local maintxt max menu mid min mod msecscount msg nl *nl no nosave obj onactsel ongload ongsave onnewloc onobjadd onobjdel onobjsel opengame openqst or p *p pl *pl play qspver rand refint replace rgb rnd savegame selact selobj set settimer showacts showinput showobjs showstat stattxt str strcomp strfind strpos trim ucase unsel unselect usercom user_text usrtxt val view wait xgoto xgt))
 
 (defun trim-$ (str)
   (if (char= #\$ (elt str 0))
       (subseq str 1)
       str))
 
 (defun qsp-keyword-p (id)
   (member (intern (trim-$ (string-upcase id))) *keywords*))
 
 (defun not-qsp-keyword-p (id)
   (not (member (intern (trim-$ (string-upcase id))) *keywords*)))
 
 (p:defrule qsp-keyword (qsp-keyword-p identifier-raw))
 
 (p:defrule id-first (id-any-char character))
 (p:defrule id-next (or (id-any-char character)
                        (digit-char-p character)))
 (p:defrule identifier-raw (and id-first (* id-next))
   (:lambda (list)
     (intern (string-upcase (p:text list)))))
 
 (p:defrule identifier (not-qsp-keyword-p identifier-raw))
 
 ;;; Strings
 
 (p:defrule qsp-string (or normal-string brace-string))
 
 (p:defrule normal-string (or sstring dstring)
   (:lambda (str)
     (list* 'str (or str (list "")))))
 
 (p:defrule sstring (and #\' (* (or string-interpol
                                    sstring-exec
                                    sstring-chars))
                         #\')
   (:function second))
 
 (p:defrule dstring (and #\" (* (or string-interpol
                                    dstring-exec
                                    dstring-chars))
                         #\")
   (:function second))
 
 (p:defrule string-interpol (and "<<" expression ">>")
   (:function second))
 
 (p:defrule sstring-exec-body (+ (or squote-esc (not-doublequote character)))
   (:text t))
 
 (p:defrule dstring-exec-body (+ (or dquote-esc (not-quote character)))
   (:text t))
 
 (p:defrule sstring-exec (and (p:~ "\"exec:") sstring-exec-body #\")
   (:lambda (list)
     (list* 'exec (p:parse 'exec-body (second list)))))
 
 (p:defrule dstring-exec (and (p:~ "'exec:") dstring-exec-body #\')
   (:lambda (list)
     (list* 'exec (p:parse 'exec-body (second list)))))
 
 (p:defrule brace-string (and #\{ before-statement block-body #\})
   (:lambda (list)
     (list* 'qspblock (third list))))
 
 ;;; Location
 
 (p:defrule sugar-qsp-grammar (and (* (or spaces #\newline))
                                   (* location))
   (:function second))
 
 (p:defrule location (and location-header block-body location-end)
   (:destructure (header body end)
     (declare (ignore end))
     `(location (,header) ,@body)))
 
 (p:defrule location-header (and #\#
                                 (+ not-newline)
                                 (and #\newline spaces? before-statement))
   (:destructure (spaces1 name spaces2)
     (declare (ignore spaces1 spaces2))
     (string-upcase (string-trim " " (p:text name)))))
 
 (p:defrule location-end (and #\- (* not-newline) #\newline before-statement)
   (:constant nil))
 
 ;;; Block body
 
 (p:defrule newline-block-body (and #\newline spaces? block-body)
   (:function third))
 
 (p:defrule block-body (* statement)
   (:function remove-nil))
 
 ;; Just for <a href="exec:...'>
 ;; Explicitly called from that rule's production
 (p:defrule exec-body (and before-statement line-body)
   (:function second))
 
 (p:defrule line-body (and inline-statement (* next-inline-statement))
   (:lambda (list)
     (list* (first list) (second list))))
 
 (p:defrule before-statement (* (or #\newline spaces))
   (:constant nil))
 
 (p:defrule statement-end (or statement-end-real statement-end-block-close))
 
 (p:defrule statement-end-real (and (or #\newline
                                        (and #\& spaces? (p:& statement%)))
                                    before-statement)
   (:constant nil))
 
 (p:defrule statement-end-block-close (or (p:& #\}))
   (:constant nil))
 
 (p:defrule inline-statement (and statement% spaces?)
   (:function first))
 
 (p:defrule next-inline-statement (and #\& spaces? inline-statement)
   (:function third))
 
 (p:defrule not-a-non-statement (and (p:! (p:~ "elseif"))
                                     (p:! (p:~ "else"))
                                     (p:! (p:~ "end"))))
 
 (p:defrule statement (and inline-statement statement-end)
   (:function first))
 
 (p:defrule statement% (and not-a-non-statement
                            (or label comment string-output
                                block non-returning-intrinsic local
                                assignment expression-output))
   (:function second))
 
 (p:defrule expr-stopper (or comment block non-returning-intrinsic))
 
 (p:defrule string-output qsp-string
   (:lambda (string)
     (list 'main-pl string)))
 
 (p:defrule expression-output expression
   (:lambda (list)
     (list 'main-pl list)))
 
 (p:defrule label (and colon identifier)
   (:lambda (list)
     (intern (string (second list)) :keyword)))
 
 (p:defrule comment (and #\! (* (or qsp-string brace-comment text-spaces not-newline)))
   (:constant nil))
 
 (p:defrule brace-comment (and #\{ (* (not-brace character)) #\})
   (:constant nil))
 
 (p:defrule local (and (p:~ "local") spaces variable (p:? (and spaces? #\= spaces? expression)))
   (:lambda (list)
     (list* 'local (third list)
            (when (fourth list)
              (list (fourth (fourth list)))))))
 
 ;;; Blocks
 
 (p:defrule block (or block-act block-if))
 
 (p:defrule block-if (and block-if-head block-if-body)
   (:destructure (head body)
     `(qspcond (,@head ,@(first body))
                 ,@(rest body))))
 
 (p:defrule block-if-head (and (p:~ "if") spaces expression spaces? colon spaces?)
   (:function remove-nil)
   (:function cdr))
 
 (p:defrule block-if-body (or block-if-ml block-if-sl)
   (:destructure (if-body elseifs else &rest ws)
     (declare (ignore ws))
     `(,(remove-nil if-body) ,@elseifs ,@(when else `((else ,@else))))))
 
 (p:defrule block-if-sl (and line-body
                             (p:? block-if-elseif-inline)
                             (p:? block-if-else-inline)
                             spaces?))
 
 (p:defrule block-if-ml (and (and #\newline spaces?)
                             block-body
                             (p:? block-if-elseif)
                             (p:? block-if-else)
                             block-if-end)
   (:lambda (list)
     (cdr list)))
 
 (p:defrule block-if-elseif-inline (and block-if-elseif-head line-body (p:? block-if-elseif-inline))
   (:destructure (head statements elseif)
     `((,@(rest head) ,@(remove-nil statements)) ,@elseif)))
 
 (p:defrule block-if-elseif (and block-if-elseif-head statement-end block-body (p:? block-if-elseif))
   (:destructure (head ws statements elseif)
     (declare (ignore ws))
     `((,@(rest head) ,@(remove-nil statements)) ,@elseif)))
 
 (p:defrule block-if-elseif-head (and (p:~ "elseif") spaces expression spaces? colon spaces?)
   (:function remove-nil)
   (:function intern-first))
 
 (p:defrule block-if-else-inline (and block-if-else-head line-body)
   (:function second))
 
 (p:defrule block-if-else (and block-if-else-head #\newline spaces? block-body)
   (:function fourth))
 
 (p:defrule block-if-else-head (and (p:~ "else") spaces?)
   (:constant nil))
 
 (p:defrule block-if-end (and (p:~ "end") 
                              (p:? (and spaces (p:~ "if"))))
   (:constant nil))
 
 (p:defrule block-act (and block-act-head (or block-act-ml block-act-sl))
   (:lambda (list)
     (apply #'append list)))
 
 (p:defrule block-act-sl line-body)
 
 (p:defrule block-act-ml (and newline-block-body block-act-end)
   (:lambda (list)
     (apply #'list* (butlast list))))
 
 (p:defrule block-act-head (and (p:~ "act") spaces qsp-string spaces?
                                (p:? block-act-head-img)
                                colon spaces?)
   (:lambda (list)
     (intern-first (list (first list)
                         (third list)
                         (or (fifth list) '(str ""))))))
 
 (p:defrule block-act-head-img (and #\, spaces? qsp-string spaces?)
   (:lambda (list)
     (or (third list) "")))
 
 (p:defrule block-act-end (and (p:~ "end"))
   (:constant nil))
 
 ;;; Calls
 
 (p:defrule first-argument (and expression spaces?)
   (:function first))
 (p:defrule next-argument (and "," spaces? expression)
   (:function third))
 (p:defrule arguments (or parenthesized-arguments plain-arguments no-arguments))
 (p:defrule parenthesized-arguments (and spaces? #\( base-arguments #\))
   (:function third))
 (p:defrule plain-arguments (and spaces base-arguments)
   (:function second))
 (p:defrule no-arguments (or (and spaces? (p:& #\newline))
                             (and spaces? (p:& #\&))
                             spaces?)
   (:constant nil))
 (p:defrule base-arguments (or (and first-argument (* next-argument)) spaces?)
   (:lambda (list)
     (if (null list)
         nil
         (list* (first list) (second list)))))
 
 ;;; Intrinsics
 
 (defmacro defintrinsics ((rule-name returning-rule-name non-returning-rule-name) &body clauses)
   `(progn
      ,@(loop :for clause :in clauses
           :collect `(defintrinsic ,@clause))
      (p:defrule ,returning-rule-name (or ,@(remove-nil
                                             (mapcar (lambda (clause)
                                                       (when (second clause)
                                                         (alexandria:symbolicate
                                                          'intrinsic- (first clause))))
                                                     clauses))))
      (p:defrule ,non-returning-rule-name (or ,@(remove-nil
                                                 (mapcar (lambda (clause)
                                                           (unless (second clause)
                                                             (alexandria:symbolicate
                                                              'intrinsic- (first clause))))
                                                         clauses))))
      (p:defrule ,rule-name (or ,returning-rule-name ,non-returning-rule-name))))
 
 (defmacro defintrinsic (sym returning &optional (min-arity 0) (max-arity 10) &rest names)
   (declare (ignore returning))
   (setf names 
         (if names
             (mapcar #'string-upcase names)
             (list (string sym))))
   `(p:defrule ,(alexandria:symbolicate 'intrinsic- sym)
        (and (p:? #\$) (or ,@(loop :for name :in names :collect `(p:~ ,name)))
             arguments)
      (:destructure (dollar name arguments)
        (declare (ignore dollar))
        (unless (<= ,min-arity (length arguments) ,max-arity)
          (error "Intrinsic ~A expects between ~A and ~A arguments but ~A were provided:~%~S"
                 name ,min-arity ,max-arity (length arguments) arguments))
        (list* ',sym arguments))))
 
 (defintrinsics (intrinsic returning-intrinsic non-returning-intrinsic)
   ;; Transitions
   (goto     nil 0 10 "gt" "goto")
   (xgoto    nil 0 10 "xgt" "xgoto")
   ;; Variables
   (killvar  nil 0 2)
   ;; Expressions
   (obj      t   1 1)
   (loc      t   1 1)
   (no       t   1 1)
   ;; Basic
   (qspver   t   0 0)
   (curloc   t   0 0)
   (rand     t   1 2)
   (rnd      t   0 0)
   (qspmax   t   1 10 "max")
   (qspmin   t   1 10 "min")
   ;; Arrays
   (killall  nil 0 0)
   (copyarr  nil 2 4)
   (arrsize  t   1 1)
   (arrpos   t   2 3)
   (arrcomp  t   2 3)
   ;; Strings
   (len      t   1 1)
   (mid      t   2 3)
   (ucase    t   1 1)
   (lcase    t   1 1)
   (trim     t   1 1)
   (replace  t   2 3)
   (instr    t   2 3)
   (isnum    t   1 1)
   (val      t   1 1)
   (qspstr   t   1 1 "str")
   (strcomp  t   2 2)
   (strfind  t   2 3)
   (strpos   t   2 3)
   ;; IF
   (iif      t   2 3)
   ;; Subs
   (gosub    nil 1 10 "gosub" "gs")
   (func     t   1 10)
   (exit     nil 0 0)
   ;; Jump
   (jump     nil 1 1)
   ;; Dynamic
   (dynamic  nil 1 10)
   (dyneval  t   1 10)
   ;; Main window
   (main-pl  nil 1 1 "*pl")
   (main-nl  nil 0 1 "*nl")
   (main-p   nil 1 1 "*p")
   (maintxt  t   0 0)
   (desc     t   1 1)
   (main-clear   nil 0 0 "*clear" "*clr")
   ;; Aux window
   (showstat nil 1 1)
   (stat-pl   nil 1 1 "pl")
   (stat-nl   nil 0 1 "nl")
   (stat-p    nil 1 1 "p")
   (stattxt  t   0 0)
   (stat-clear    nil 0 0 "clear" "clr")
   (cls      nil 0 0)
   ;; Dialog
   (msg      nil 1 1)
   ;; Acts
   (showacts nil 1 1)
   (delact   nil 1 1 "delact" "del act")
   (curacts  t   0 0)
   (cla      nil 0 0)
   ;; Objects
   (showobjs nil 1 1)
   (addobj   nil 1 3 "addobj" "add obj")
   (delobj   nil 1 1 "delobj" "del obj")
   (killobj  nil 0 1)
   (countobj t   0 0)
   (getobj   t 1 1)
   ;; Menu
   (menu     nil 1 1)
   ;; Sound
   (play     nil 1 2)
   (isplay   t   1 1)
   (close    nil 1 1)
   (closeall nil 0 0 "close all")
   ;; Images
   (refint   nil 0 0)
   (view     nil 0 1)
   ;; Fonts
   (rgb      t   3 3)
   ;; Input
   (showinput nil 1 1)
   (usertxt  t   0 0 "user_text" "usrtxt")
   (cmdclear nil 0 0 "cmdclear" "cmdclr")
   (input    t   1 1)
   ;; Files
   (openqst  nil 1 1)
   (addqst   nil 1 1 "addqst" "addlib" "inclib")
   (killqst  nil 1 1 "killqst" "dellib" "freelib")
   (opengame nil 0 0)
   (savegame nil 0 0)
   ;; Real time
   (wait     nil 1 1)
   (msecscount t 0 0)
   (settimer nil 1 1))
 
 ;;; Expression
 
 (p:defrule expression or-expr)
 
 (p:defrule or-expr (and and-expr (* (and spaces? or-op spaces? and-expr)))
   (:function do-binop))
 
 (p:defrule and-expr (and eq-expr (* (and spaces? and-op spaces? eq-expr)))
   (:function do-binop))
 
 (p:defrule eq-expr (and sum-expr (* (and spaces? (or "<=" ">=" "=<" "=>" "<>"
                                                      "=" "<" ">" "!")
                                          spaces? cat-expr)))
   (:function do-binop))
 
 (p:defrule sum-expr (and mod-expr (* (and spaces? (or #\+ #\-) spaces? mod-expr)))
   (:function do-binop))
 
 (p:defrule mod-expr (and mul-expr (* (and spaces? (p:~ "mod") spaces? mul-expr)))
   (:function do-binop))
 
 (p:defrule mul-expr (and unary-expr (* (and spaces? (or #\* #\/) spaces? unary-expr)))
   (:function do-binop))
 
 (p:defrule unary-expr (and (p:? (or #\+ #\-)) atom-expr)
   (:lambda (list)
     (let ((expr (remove-nil list)))
       (if (= 1 (length expr))
           (first expr)
           (intern-first expr)))))
 
 (p:defrule atom-expr (and (or variable literal returning-intrinsic paren-expr) spaces?)
   (:function first))
 
 (p:defrule paren-expr (and #\( spaces? expression spaces? #\))
   (:function third))
 
 (p:defrule or-op (p:~ "or")
   (:constant "or"))
 
 (p:defrule and-op (p:~ "and")
   (:constant "and"))
 
 ;;; Variables
 
 (p:defrule variable (and identifier (p:? array-index))
   (:destructure (id idx)
-    (list 'var id (or idx 0))))
+    (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))))
 
 (p:defrule array-index (and #\[ spaces? (p:? expression) spaces? #\])
-  (:lambda (list)
-    (or (third list) :end)))
+  (:function third))
 
 (p:defrule assignment (or kw-assignment plain-assignment op-assignment)
   (:destructure (var eq expr)
     (declare (ignore eq))
     (list 'set var expr)))
 
 (p:defrule kw-assignment (and (or (p:~ "let") (p:~ "set")) spaces? (or op-assignment plain-assignment))
   (:function third))
 
 (p:defrule op-assignment (and variable spaces? (or "+" "-" "*" "/") #\= spaces? expression)
   (:destructure (var ws1 op eq ws2 expr)
                 (declare (ignore ws1 ws2))
                 (list var eq (intern-first (list op var expr)))))
 
 (p:defrule plain-assignment (and variable spaces? #\= spaces? expression)
   (:function remove-nil))
 
 ;;; Non-string literals
 
 (p:defrule literal (or qsp-string brace-string number))
 
 (p:defrule number (+ (or #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
   (:lambda (list)
     (parse-integer (p:text list))))

src/ps-macros.lisp

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