WAIT with async

TODO

@@ -1,14 +1,16 b''
 
-* Use async/await
+* Use Parenscript's packages
 * Use Parenscript's minifier
-* WAIT and MENU with async/await
+* Remove dots
+* MENU with async/await
+* Find a way to minify syntax (extra returns at least)
 * Special locations
 * Special variables
 * CLI build for Linux
 * CLI build for Windows
 
 * Build Istreblenie
 * Windows GUI (for the compiler)
 * Save-load game in slots
 * Resizable frames
 ** modifying it to suit compiler specifics

src/api.ps

@@ -1,393 +1,396 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.api.callAct(\"" title "\");'>"
      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>"))
 
 (defm (root api report-error) (text)
   (alert text))
 
+(defm (root api sleep) (msec)
+  (ps:new (*promise (ps:=> resolve (set-timeout resolve msec)))))
+
 (defm (root api init-dom) ()
   ;; Save/load buttons
   (let ((btn (document.get-element-by-id "qsp-btn-save")))
     (setf (ps:@ btn onclick) this.savegame)
     (setf (ps:@ btn href) "#"))
   (let ((btn (document.get-element-by-id "qsp-btn-open")))
     (setf (ps:@ btn onclick) this.opengame)
     (setf (ps:@ btn href) "#"))
   ;; Close image on click
   (setf (ps:@ (document.get-element-by-id "qsp-image-container") onclick)
         (this.show-image nil))
   ;; Close the dropdown on any click
   (setf window.onclick
         (lambda (event)
           (setf (ps:@ (api-call get-frame :dropdown) style display) "none"))))
 
 (defm (root api call-serv-loc) (var-name &rest args)
   (let ((loc-name (api-call get-var name 0 :str)))
     (when loc-name
       (let ((loc (ps:getprop (root locs) loc-name)))
         (when loc
           (funcall loc args))))))
 
 ;;; Misc
 
 (defm (root api newline) (key)
   (this.append-id (this.key-to-id key) "<br>" t))
 
 (defm (root api clear-id) (id)
   (setf (ps:inner-html (document.get-element-by-id id)) ""))
 
 (setf (root api text-escaper) (document.create-element :textarea))
 
 (defm (root api prepare-contents) (s &optional force-html)
   (if (or force-html (var "USEHTML" 0 :num))
       s
       (progn
         (setf (ps:@ (root api text-escaper) text-content) s)
         (ps:inner-html (root api text-escaper)))))
 
 (defm (root api get-id) (id &optional force-html)
   (ps:inner-html (document.get-element-by-id id)))
 
 (defm (root api set-id) (id contents &optional force-html)
   (setf (ps:inner-html (document.get-element-by-id id)) (this.prepare-contents contents force-html)))
 
 (defm (root api append-id) (id contents &optional force-html)
   (when contents
     (incf (ps:inner-html (document.get-element-by-id id)) (this.prepare-contents contents force-html))))
 
 ;;; Function calls
 
 (defm (root api init-args) (args)
   (dotimes (i (length args))
     (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 :str)))
       (var result 0 :str)
       (var result 0 :num)))
 
 (defm (root api call-loc) (name args)
   (with-frame
       (funcall (ps:getprop (root locs) name) args)))
 
 (defm (root api call-act) (title)
   (with-frame
       (funcall (ps:getprop (root acts) title))))
 
 ;;; 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 (this.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 enable-frame) (key enable)
   (let ((obj (this.get-frame key)))
     (setf obj.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")
   (let ((elt (document.get-element-by-id "qsp-acts")))
     (ps:for-in (title (root acts))
       (let ((obj (ps:getprop (root acts) title)))
         (incf (ps:inner-html elt) (this.make-act-html title (ps:getprop obj :img)))))))
       
 
 ;;; "Syntax"
 
 (defm (root api qspfor) (name index from to step body)
   (block nil
     (ps:for ((i from))
             ((< i to))
             ((incf i step))
       (this.set-var name index :num i)
       (unless (funcall body)
         (return)))))
 
 ;;; 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 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) #\$)
       (values (ps:chain name (substr 1)) :str)
       (values name :num)))
 
 (defm (root api ensure-var) (name)
   (let ((store (this.var-ref name)))
     (unless store
       (setf store (ps:new (this.-var name)))
       (setf (ps:getprop (root vars) name) store))
     store))
 
 (defm (root api var-ref) (name)
   (let ((local-store (this.current-local-frame)))
     (cond ((and local-store (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 slot)
   (ps:chain (this.ensure-var name) (get index slot)))
 
 (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)
   (this.var-ref name))
 
 (defm (root api set-array) (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 (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 (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 (ps:inner-html elt) "<ul>")
     (loop :for obj :in (root objs)
        :do (incf (ps:inner-html elt) (+ "<li>" obj)))
     (incf (ps:inner-html elt) "</ul>")))
 
 ;;; Menu
 
 (defm (root api menu) (menu-data)
   (let ((elt (document.get-element-by-id "qsp-dropdown"))
         (i 0))
     (setf (ps:inner-html elt) "")
     (loop :for item :in menu-data
        :do (incf i)
        :do (incf (ps:inner-html elt) (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)))))
 
 (defm (root api show-image) (path)
   (let ((img (document.get-element-by-id "qsp-image")))
     (cond (path
            (setf img.src path)
            (setf img.style.display "flex"))
           (t
            (setf img.src "")
            (setf img.style.display "hidden")))))
 
 ;;; Saves
 
 (defm (root api opengame) ()
   (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 unstash-state)))))
               (reader.read-as-text file))))
     (document.body.append-child element)
     (element.click)
     (document.body.remove-child element)))
 
 (defm (root api savegame) ()
   (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)))
 
 (defm (root api stash-state) (args)
   (api-call call-serv-loc "ONGSAVE")
   (setf (root state-stash)
         (*j-s-o-n.stringify
          (ps:create vars (root vars)
                     objs (root objs)
                     loc-args args
                     msecs (- (*date.now) (root started-at))
                     main-html (ps:inner-html
                                (document.get-element-by-id :qsp-main))
                     stat-html (ps:inner-html
                                (document.get-element-by-id :qsp-stat))
                     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 started-at) (- (*date.now) (ps:@ data msecs)))
     (setf (root objs) (ps:@ data objs))
     (setf (root current-location) (ps:@ data next-location))
     (setf (ps:inner-html (document.get-element-by-id :qsp-main))
           (ps:@ data main-html))
     (setf (ps:inner-html (document.get-element-by-id :qsp-stat))
           (ps:@ data stat-html))
     (this.update-objs)
     (api-call call-serv-loc "ONGLOAD")
     (api-call call-loc (root current-location) (ps:@ data loc-args))
     (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))))
 
 ;;; Timers
 
 (defm (root api set-timer) (interval)
   (setf (root timer-interval) interval)
   (clear-interval (root timer-obj))
   (setf (root timer-obj)
         (set-interval
          (lambda ()
            (api-call call-serv-loc "COUNTER"))
          interval)))

src/intrinsic-macros.lisp

@@ -1,171 +1,174 b''
 
 (in-package sugar-qsp)
 
 ;;;; Macros implementing some intrinsics where it makes sense
 ;;;; E.g. an equivalent JS function exists, or it's a direct API call
 
 ;;; 1loc
 
 ;;; 2var
 
 (ps:defpsmacro killvar (varname &optional index)
   `(api-call kill-var ,varname ,index))
 
 (ps:defpsmacro killall ()
   `(api-call kill-all))
 
 ;;; 3expr
 
 (ps:defpsmacro obj (name)
   `(funcall (root objs includes) ,name))
 
 (ps:defpsmacro loc (name)
   `(funcall (root locs includes) ,name))
 
 (ps:defpsmacro no (arg)
   `(- -1 ,arg))
 
 ;;; 4code
 
 (ps:defpsmacro qspver ()
   "0.0.1")
 
 (ps:defpsmacro curloc ()
   `(root current-location))
 
 (ps:defpsmacro rnd ()
   `(funcall (root lib rand) 1 1000))
 
 (ps:defpsmacro qspmax (&rest args)
   (if (= 1 (length args))
       `(*math.max.apply nil ,@args)
       `(*math.max ,@args)))
 
 (ps:defpsmacro qspmin (&rest args)
   (if (= 1 (length args))
       `(*math.min.apply nil ,@args)
       `(*math.min ,@args)))
 
 ;;; 5arrays
 
 (ps:defpsmacro arrsize (name)
   `(api-call array-size ,name))
 
 ;;; 6str
 
 (ps:defpsmacro len (s)
   `(length ,s))
 
 (ps:defpsmacro mid (s from &optional count)
   `(ps:chain ,s (substring ,from ,count)))
 
 (ps:defpsmacro ucase (s)
   `(ps:chain ,s (to-upper-case)))
 
 (ps:defpsmacro lcase (s)
   `(ps:chain ,s (to-lower-case)))
 
 (ps:defpsmacro trim (s)
   `(ps:chain ,s (trim)))
 
 (ps:defpsmacro replace (s from to)
   `(ps:chain ,s (replace ,from ,to)))
 
 (ps:defpsmacro val (s)
   `(parse-int ,s 10))
 
 (ps:defpsmacro qspstr (n)
   `(ps:chain ,n (to-string)))
 
 ;;; 7if
 
 ;;; 8sub
 
 ;;; 9loops
 
 ;; JUMP is in ps-macros.lisp (because it's a part of a huge kludge)
 
 (ps:defpsmacro exit ()
   `(return-from nil (values)))
 
 ;;; 10dynamic
 
 ;;; 11main
 
 (ps:defpsmacro desc (s)
   (declare (ignore s))
   "")
 
 ;;; 12stat
 
 (ps:defpsmacro showstat (enable)
   `(api-call enable-frame :stat ,enable))
 
 ;;; 13diag
 
 (ps:defpsmacro msg (text)
   `(alert ,text))
 
 ;;; 14act
 
 (ps:defpsmacro showacts (enable)
   `(api-call enable-frame :acts ,enable))
 
 (ps:defpsmacro delact (name)
   `(api-call del-act ,name))
 
 (ps:defpsmacro cla ()
   `(api-call clear-act))
 
 ;;; 15objs
 
 (ps:defpsmacro showobjs (enable)
   `(api-call enable-frame :objs ,enable))
 
 (ps:defpsmacro countobj ()
   `(length (root objs)))
 
 (ps:defpsmacro getobj (index)
   `(or (elt (root objs) ,index) ""))
 
 ;;; 16menu
 
 ;;; 17sound
 
 (ps:defpsmacro isplay (filename)
   `(funcall (root playing includes) ,filename))
 
 ;;; 18img
 
 (ps:defpsmacro view (&optional path)
   `(api-call show-image ,path))
 
 ;;; 19input
 
 (ps:defpsmacro showinput (enable)
   `(api-call enable-frame :input ,enable))
 
 ;;; 20time
 
+(ps:defpsmacro wait (msec)
+  `(await (api-call sleep ,msec)))
+
 (ps:defpsmacro settimer (interval)
   `(api-call set-timer ,interval))
 
 ;;; 21local
 
 (ps:defpsmacro local (var &optional expr)
   `(progn
      (api-call new-local ,(string (second var)))
      ,@(when expr
          `((set ,var ,expr)))))
 
 ;;; 22for
 
 ;;; misc
 
 (ps:defpsmacro opengame (&optional filename)
   (declare (ignore filename))
   `(api-call opengame))
 
 (ps:defpsmacro savegame (&optional filename)
   (declare (ignore filename))
   `(api-call savegame))

src/intrinsics.ps

@@ -1,307 +1,301 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 args)
   (api-call clear-text :main)
   (funcall (root lib xgoto) target (or args (list)))
   (values))
 
 (defm (root lib xgoto) (target args)
   (api-call clear-act)
   (setf (root current-location) (ps:chain target (to-upper-case)))
   (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)
   (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))
   (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))
   (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)
   (funcall (ps:getprop (root locs) target) args)
   (values))
 
 (defm (root lib func) (target &rest args)
   (funcall (ps:getprop (root locs) target) args))
 
 ;;; 9loops
 
 ;;; 10dynamic
 
 (defm (root lib dynamic) (block &rest args)
   (when (stringp block)
     (api-call report-error "DYNAMIC can't evaluate arbitrary strings.\nUse {braces} to create blocks for DYNAMIC."))
   (funcall block args)
   (values))
 
 (defm (root lib dyneval) (block &rest args)
   (when (stringp block)
     (api-call report-error "DYNEVAL can't evaluate arbitrary strings.\nUse {braces} to create blocks for DYNEVAL."))
   (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) ()
   ;; "Force interface update" Uh... what exactly do we do here?
   (api-call report-error "REFINT is not supported")
   )
 
 ;;; 19input
 
 (defm (root lib usertxt) ()
   (let ((input (document.get-element-by-id "qsp-input")))
     (ps:@ input value)))
 
 (defm (root lib cmdclear) ()
   (let ((input (document.get-element-by-id "qsp-input")))
     (setf (ps:@ input value) "")))
 
 (defm (root lib input) (text)
   (window.prompt text))
 
 ;;; 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) ()
   (- (*date.now) (root started-at)))
 
 ;;; 21local
 
 ;;; 22for
 
 ;;; misc
 
 (defm (root lib rgb) (red green blue)
   (flet ((rgb-to-hex (comp)
            (let ((hex (ps: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))))
 
 (defm (root lib openqst) ()
   (api-call report-error "OPENQST is not supported."))
 
 (defm (root lib addqst) ()
   (api-call report-error "ADDQST is not supported. Bundle the library with the main game."))
 
 (defm (root lib killqst) ()
   (api-call report-error "KILLQST is not supported."))

src/ps-macros.lisp

@@ -1,203 +1,203 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 ((&key (locals t)) &body body)
   (let ((has-labels (some #'keywordp body)))
     `(block nil
        ,@(when has-labels
            '((defvar __labels)))
        ,@(if locals
              `((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 (args)
+         (ps:async-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)
      (exit)))
 
 (ps:defpsmacro xgoto (target &rest args)
   `(progn
      (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 slot)
   `(api-call get-var ,(string name) ,index ,slot))
 
 (ps:defpsmacro set ((var vname vindex vslot) value)
   (assert (eq var 'var))
   `(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))))))
 
 ;;; 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 `((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 (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 ()
                 ,@body))))
 
 ;;; 12aux
 
 ;;; 13diag
 
 ;;; 14act
 
 ;;; 15objs
 
 ;;; 16menu
 
 ;;; 17sound
 
 ;;; 18img
 
 ;;; 19input
 
 ;;; 20time
 
 ;;; 21local
 
 ;;; 22for
 
 (ps:defpsmacro qspfor (var from to step &body body)
   `(api-call qspfor
              ,(string (second var)) ,(third var) ;; name and index
              ,from ,to ,step
              (lambda ()
                (block nil
                  ,@body
                  t))))