Properly handle stringly-indexed arrays

TODO

@@ -1,6 +1,3 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

src/api.ps

@@ -22,29 +22,43 b''
      "</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
 
@@ -52,17 +66,17 b''
   (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)))
 
@@ -70,14 +84,15 b''
 
 (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
 
@@ -134,61 +149,113 b''
       (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
 
@@ -218,19 +285,3 b''
      :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

@@ -9,16 +9,18 b''
 
 ;;; 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
 
@@ -34,23 +36,31 b''
 ;;; 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
@@ -91,32 +101,22 b''
 ;;; 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
 
@@ -307,7 +307,8 b''
                              (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)

src/main.ps

@@ -25,7 +25,8 b''
 (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

src/parser.lisp

@@ -555,11 +555,12 b''
 
 (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)

src/ps-macros.lisp

@@ -16,6 +16,13 b''
 (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)
@@ -33,17 +40,17 b''
 (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))
@@ -58,18 +65,20 b''
 
 (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)
@@ -78,12 +87,12 b''
 
 ;;; 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
 
@@ -110,7 +119,8 b''
 (ps:defpsmacro qspcond (&rest clauses)
   `(cond ,@(loop :for clause :in clauses
               :collect (list (first clause)
-                             `(tagbody ,@(rest clause))))))
+                             `(tagbody
+                                 ,@(rest clause))))))
 
 ;;; 8sub
 
@@ -137,27 +147,29 b''
            ,@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