Locals

examples/21locals.txt

@@ -0,0 +1,8 b''
+
+# locals
+
+var = 1
+dynamic { local var = 2 & *pl var }
+*pl var
+
+----- locals ---------------

TODO

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

src/api.ps

@@ -147,35 +147,49 b''
       name))
 
 (defm (root api ensure-var) (name index)
-  (unless (in name (root vars))
-    (setf (ps:getprop (root vars) name)
-          (ps:create)))
-  (unless (in index (ps:getprop (root vars) name))
-    (setf (ps:getprop (root vars) name index)
-          (ps:create :num 0 :str "")))
+  (let ((store (api-call 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))
 
+(defm (root api var-ref) (name)
+  (let ((var-name (api-call var-real-name name))
+        (local-store (api-call current-local-frame)))
+    (cond ((in var-name local-store)
+           (ps:getprop local-store))
+          ((in var-name (root vars))
+           (ps:getprop (root vars) var-name))
+          (t nil))))
+
 (defm (root api get-var) (name index)
-  (let ((var-name (api-call var-real-name name)))
-    (api-call ensure-var var-name index)
-    (ps:getprop (root vars) var-name index
-                (api-call var-slot name))))
+  (let ((store (var-ref name)))
+    (if store
+        (if (in index store)
+            (ps:getprop store index (api-call var-slot name))
+            (report-error (+ "Non-existing index: " name "[" index "]")))
+        (report-error (+ "Unknown variable: " name)))))
 
 (defm (root api set-var) (name index value)
-  (let ((var-name (api-call var-real-name name)))
+  (let ((store (var-ref name)))
     (api-call ensure-var var-name index)
-    (setf (ps:getprop (root vars) var-name index
+    (setf (ps:getprop store index
                       (api-call var-slot name))
           value)
     (values)))
 
-(defm (root api get-array) (name type)
-  (ps:getprop (root vars) (api-call var-real-name name)))
+(defm (root api get-array) (name)
+  (ps:getprop (root vars) name))
 
-(defm (root api kill-var) (name index)
-  (if (eq index :whole)
-      (ps:delete (ps:getprop (root vars) name))
-      (ps:delete (ps:getprop (root vars) name index)))
+(defm (root api set-array) (name value)
+  (setf (ps:getprop (root vars) name) value))
+
+(defm (root api kill-var) (name &optional index)
+  (if index 
+      (ps:delete (ps:getprop (root vars) name index))
+      (ps:delete (ps:getprop (root vars) name)))
   (values))
 
 (defm (root api array-size) (name)
@@ -208,3 +222,20 b''
      :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 (api-call current-local-frame))
+        (var-name (api-call var-real-name name)))
+    (unless (in var-name frame)
+      (setf (ps:getprop frame var-name) (ps:create)))))

src/intrinsic-macros.lisp

@@ -8,7 +8,7 b''
 
 ;;; 2var
 
-(ps:defpsmacro killvar (varname &optional (index :whole))
+(ps:defpsmacro killvar (varname &optional index)
   `(api-call kill-var ,varname ,index))
 
 (ps:defpsmacro killall ()
@@ -141,4 +141,10 b''
 
 ;;; 20time
 
-;;; misc
+;;; 21local
+
+(ps:defpsmacro local (var &optional expr)
+  `(progn
+     (api-call new-local ,(string (second var)))
+     ,@(when expr
+         `((set ,var ,expr)))))

src/intrinsics.ps

@@ -91,13 +91,13 b''
 ;;; 8sub
 
 (defm (root lib gosub) (target &rest args)
-  (conserving-vars (args result)
+  (conserving-vars (__funcall args result)
     (api-call init-args args)
     (funcall (ps:getprop (root locs) target))
     (values)))
 
 (defm (root lib func) (target &rest args)
-  (conserving-vars (args result)
+  (conserving-vars (__funcall args result)
     (api-call init-args args)
     (funcall (ps:getprop (root locs) target))
     (api-call get-result)))
@@ -107,13 +107,13 b''
 ;;; 10dynamic
 
 (defm (root lib dyneval) (block &rest args)
-  (conserving-vars (args result)
+  (conserving-vars (__funcall args result)
     (api-call init-args args)
     (funcall block)
     (api-call get-result)))
 
 (defm (root lib dynamic) (&rest args)
-  (conserving-vars (args result)
+  (conserving-vars (__funcall args result)
     (api-call init-args args)
     (funcall block)
     (values)))
@@ -211,7 +211,7 b''
 
 (defm (root lib menu) (menu-name)
   (let ((menu-data (list)))
-    (loop :for item :in (api-call get-array menu-name)
+    (loop :for item :in (api-call get-array (api-call var-real-name menu-name))
        :do (cond ((string= item "")
                   (break))
                  ((string= item "-:-")
@@ -276,6 +276,8 b''
 
 (defm (root lib settimer) ())
 
+;;; 21local
+
 ;;; misc
 
 (defm (root lib rgb) ())

src/main.ps

@@ -13,6 +13,8 b''
        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)

src/parser.lisp

@@ -103,7 +103,7 b''
 ;;; 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 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))
+(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))
@@ -234,8 +234,8 b''
 
 (p:defrule statement% (and not-a-non-statement
                            (or label comment string-output
-                               block non-returning-intrinsic assignment
-                               expression-output))
+                               block non-returning-intrinsic local
+                               assignment expression-output))
   (:function second))
 
 (p:defrule expr-stopper (or comment block non-returning-intrinsic))
@@ -258,6 +258,12 b''
 (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))

src/ps-macros.lisp

@@ -16,19 +16,6 b''
 (ps:defpsmacro in (key obj)
   `(ps:chain ,obj (has-own-property ,key)))
 
-(ps:defpsmacro conserving-vars (vars &body body)
-  "Calls body with safely stored away VARS (whole arrays, both namespaces), and restores their values after that returning what BODY returns."
-  `(let ((__conserved (list ,@(loop :for var :in vars
-                                 :collect `(root vars ,var)))))
-     ,@(loop :for var :in vars
-          :collect `(setf (root vars ,var) (ps:create :num 0 :str "")))
-     (unwind-protect
-          (progn ,@body)
-       (progn
-         ,@(loop :for var :in vars
-              :for i from 0
-              :collect `(setf (root vars ,var) (ps:@ __conserved ,i)))))))
-
 ;;; Common
 
 (defmacro defpsintrinsic (name)
@@ -47,12 +34,16 b''
   `(funcall (root api ,func) ,@args))
 
 (ps:defpsmacro label-block (&body body)
-  `(block nil
-     ,@(when (some #'keywordp body)
-         '((defvar __labels)))
-     (tagbody
-        ,@body)
-     (values)))
+  (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))))
 
 (ps:defpsmacro str (&rest forms)
   (cond ((zerop (length forms))
@@ -186,3 +177,5 b''
 ;;; 19input
 
 ;;; 20time
+
+;;; 21local