diff --git a/TODO b/TODO --- a/TODO +++ b/TODO @@ -1,6 +1,3 @@ - -* 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 diff --git a/src/api.ps b/src/api.ps --- a/src/api.ps +++ b/src/api.ps @@ -22,29 +22,43 @@ "")) ;; 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 @@ (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 @@ (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 @@ (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 @@ :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))))) diff --git a/src/intrinsics.ps b/src/intrinsics.ps --- a/src/intrinsics.ps +++ b/src/intrinsics.ps @@ -9,16 +9,18 @@ ;;; 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 @@ ;;; 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 @@ ;;; 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 @@ (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) diff --git a/src/main.ps b/src/main.ps --- a/src/main.ps +++ b/src/main.ps @@ -25,7 +25,8 @@ (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 diff --git a/src/parser.lisp b/src/parser.lisp --- a/src/parser.lisp +++ b/src/parser.lisp @@ -555,11 +555,12 @@ (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) diff --git a/src/ps-macros.lisp b/src/ps-macros.lisp --- a/src/ps-macros.lisp +++ b/src/ps-macros.lisp @@ -16,6 +16,13 @@ (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 @@ (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 @@ (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 @@ ;;; 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 @@ (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 @@ ,@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