Fix two regressions

tests/regression-1.qsps

@@ -0,0 +1,8 b''
+# begin
+    x = -1
+    gt 'loc', x
+-
+# loc
+    if args[0]: 'args[0] = -1'
+    'end'
+-

tests/regression-2.qsps

@@ -0,0 +1,19 b''
+# begin
+    func('getObjByKey', 'item')
+-
+
+# getObjByKey
+    $needle = $args[0]
+    i = 1
+    :lab
+    if i <= countobj:
+        if $getobj(i) = $needle:
+            result = i
+            exit
+        else
+            i += 1
+            jump 'lab'
+        end
+    end
+    result = -1
+-

src/api.ps

@@ -1,510 +1,523 b''
 
 (in-package txt2web.api)
 
 ;;; 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
 
 ;;; Utils
 
 (defun make-act-html (title img)
   (+ "<a class='qsp-act' href='" (href-call call-act title) "' onmouseover='" (inline-call select-act title) "'>"
      (if img (+ "<img src='" img "'>") "")
      title
      "</a>"))
 
 (defun make-menu-item-html (num title img loc)
   (+ "<a href='" (href-call finish-menu loc) "'>"
      (if img (+ "<img src='" img "'>") "")
      title
      "</a>"))
 
 (defun make-obj (title img selected)
   (+ "<li onclick='" (inline-call select-obj title img) "'>"
      "<a class='qsp-obj" (if selected " qsp-obj-selected" "") "'>"
      (if img (+ "<img src='" img "'>") "")
      title
      "</a>"))
 
 (defun make-menu-delimiter ()
   "<hr>")
 
 (defun copy-obj (obj)
   (chain *j-s-o-n (parse (chain *j-s-o-n (stringify obj)))))
 
 (defun report-error (text)
   (alert text))
 
 (defun start-sleeping ()
   (chain (by-id "qsp") class-list (add "disable")))
 
 (defun finish-sleeping ()
   (chain (by-id "qsp") class-list (remove "disable")))
 
 (defun sleep (msec)
   (with-sleep (resume)
     (set-timeout resume msec)))
 
 (defun init-dom ()
   ;; Save/load buttons
   (let ((btn (by-id "qsp-btn-save")))
     (setf (@ btn onclick) savegame)
     (setf (@ btn href) "#"))
   (let ((btn (by-id "qsp-btn-open")))
     (setf (@ btn onclick) opengame)
     (setf (@ btn href) "#"))
   ;; Close image on click
   (setf (@ (by-id "qsp-image-container") onclick)
         show-image)
   ;; Enter in input field
   (setf (@ (get-frame :input) onkeyup)
         on-input-key)
   ;; Close the dropdown on any click
   (setf (@ window onclick)
         (lambda (event)
           (setf (@ window mouse)
                 (list (@ event page-x)
                       (@ event page-y)))
           (finish-menu nil))))
 
+(defun init-globals (game-name)
+  (chain *object (assign *globals (getprop *default-globals game-name))))
+
 (defun call-serv-loc (var-name &rest args)
   (let ((loc-name (get-global var-name 0)))
     (when loc-name
       (let ((loc (getprop *locs loc-name)))
         (when loc
           (call-loc loc-name args))))))
 
 (defun filename-game (filename)
   (let ((game-name (chain filename (match "(.*/)?([^.]+)(\\.[a-zA-Z]+)?") 2))))
   (getprop *games game-name))
 
 (defun run-game (name)
   (let ((game (filename-game name)))
     (setf *main-game name)
     ;; Replace locations with the new game's 
     (setf *locs game)
     (funcall (getprop game
                       (chain *object (keys game) 0))
              (list))))
 
 ;;; Misc
 
 (defun newline (key)
   (append-id (key-to-id key) "<br>" t))
 
 (defun clear-id (id)
   (setf (inner-html (by-id id)) ""))
 
 (defun escape-html (text)
   (chain text
          (replace (regex "/&/g") "&amp;")
          (replace (regex "/</g") "&lt;")
          (replace (regex "/>/g") "&gt;")
          (replace (regex "/\"/g") "&quot;")
          (replace (regex "/'/g") "&apos;")))
 
 (defun prepare-contents (s &optional force-html)
   (setf s (chain s (to-string)))
   (if (or force-html (get-global "USEHTML" 0))
       s
       (escape-html s)))
 
 (defun get-id (id &optional force-html)
   (inner-html (by-id id)))
 
 (defun set-id (id contents &optional force-html)
   (setf (inner-html (by-id id)) (prepare-contents contents force-html)))
 
 (defun append-id (id contents &optional force-html)
   (when contents
     (incf (inner-html (by-id id)) (prepare-contents contents force-html))))
 
 (defun on-input-key (ev)
   (when (= 13 (@ ev key-code))
     (chain ev (prevent-default))
     (call-serv-loc "$USERCOM")))
 
 ;;; Function calls
 
 (defun init-args (args)
-  (dotimes (i (length args))
-    (let ((arg (elt args i)))
-      (if (numberp arg)
-          (set-var args i :num arg)
-          (set-var args i :str arg)))))
+  (dotimes (i 10)
+    (set-global "ARGS"  i 0)
+    (set-global "$ARGS" i "")
+    (when (< i (length args))
+      (let ((arg (elt args i)))
+        (if (numberp arg)
+            (set-global "ARGS"  i arg)
+            (set-global "$ARGS" i arg))))))
 
 (defun get-result ()
   (or (get-global "$RESULT" 0)
       (get-global "RESULT" 0)))
 
 (defun call-loc (name args)
   (setf name (chain name (to-upper-case)))
   (with-frame
       (with-call-args args
         (funcall (getprop *locs name))))
   (void))
 
 (defun call-act (title)
   (with-frame
       (funcall (getprop *acts title :act)))
   (void))
 
 ;;; Text windows
 
 (defun key-to-id (key)
   (case key
     (:all "qsp")
     (:main "qsp-main")
     (:stat "qsp-stat")
     (:objs "qsp-objs")
     (:acts "qsp-acts")
     (:input "qsp-input")
     (:image "qsp-image")
     (:dropdown "qsp-dropdown")
     (t (report-error "Internal error!"))))
 
 (defun get-frame (key)
   (by-id (key-to-id key)))
 
 (defun add-text (key text)
   (append-id (key-to-id key) text))
 
 (defun get-text (key)
   (get-id (key-to-id key)))
 
 (defun clear-text (key)
   (clear-id (key-to-id key)))
 
 (defun enable-frame (key enable)
   (let ((obj (get-frame key)))
     (setf (@ obj style display) (if enable "block" "none"))
     (void)))
 
 ;;; Actions
 
 (defun add-act (title img act)
   (setf (getprop *acts title)
         (create :title title :img img :act act :selected nil))
   (update-acts))
 
 (defun del-act (title)
   (delete (getprop *acts title))
   (update-acts))
 
 (defun clear-act ()
   (setf *acts (create))
   (update-acts))
 
 (defun update-acts ()
   (clear-id "qsp-acts")
   (let ((elt (by-id "qsp-acts")))
     (for-in (title *acts)
             (let ((obj (getprop *acts title)))
               (incf (inner-html elt) (make-act-html title (getprop obj :img)))))))
 
 (defun select-act (title)
   (loop :for (k v) :of *acts
      :do (setf (getprop v :selected) nil))
   (setf (getprop *acts title :selected) t)
   (call-serv-loc "$ONACTSEL"))
 
 ;;; Variables
 
 (defun new-var (slot &rest indexes)
   (let ((v (list)))
     (dolist (index indexes)
       (setf (elt v index) (if (eq #\$ (elt slot 0)) "" 0)))
     (setf (@ v :indexes) (create))
     v))
 
 (defun set-str-element (slot index value)
   (if (has index (getprop slot :indexes))
       (setf (elt (getprop slot) 
                  (getprop slot :indexes index))
             value)
       (progn
         (chain slot (push value))
         (setf (elt slot index)
               (length slot))))
   (void))
 
 (defun set-any-element (slot index value)
   (cond ((null index)
          (chain (elt slot) (push value)))
         ((numberp index)
          (setf (elt slot index) value))
         ((stringp index)
          (set-str-element slot index value))
         (t (report-error "INTERNAL ERROR")))
   (void))
 
 (defun set-serv-var (name index value)
   (let ((slot (getprop *globals name)))
     (set-any-element slot index value))
   (funcall (getprop serv-vars name :body) value index)
   (void))
 
 (defun get-element (slot index)
   (if (numberp index)
       (elt slot index)
       (elt slot (getprop slot :indexes index))))
 
+(defun set-global (name index value)
+  (set-any-element (getprop *globals name) index value))
+
 (defun get-global (name index)
-  (elt (getprop *globals name) index))
+  (get-element (getprop *globals name) index))
 
-(defun kill-var (store name &optional index)
-  (setf name (chain name (to-upper-case)))
-  (if (and index (not (= 0 index))) 
-      (chain (getprop *globals name) (kill index))
-      (delete (getprop *globals name)))
+(defun kill-var (&optional name index)
+  (cond (name
+         (setf name (chain name (to-upper-case)))
+         (if (and index (not (= 0 index))) 
+             (chain (getprop *globals name) (kill index))
+             (delete (getprop *globals name))))
+        (t
+         (setf *globals (create))
+         (init-globals *main-game)))
   (void))
 
 (defun array-size (name)
   (@ (var-ref name) :values length))
 
 ;;; Locals
 
 (defun push-local-frame ()
   (chain *locals (push (create)))
   (void))
 
 (defun pop-local-frame ()
   (chain *locals (pop))
   (void))
 
 (defun current-local-frame ()
   (elt *locals (1- (length *locals))))
 
 ;;; Objects
 
 (defun select-obj (title img)
   (loop :for (k v) :of *objs
      :do (setf (getprop v :selected) nil))
   (setf (getprop *objs title :selected) t)
   (call-serv-loc "$ONOBJSEL" title img))
 
 (defun update-objs ()
   (let ((elt (by-id "qsp-objs")))
     (setf (inner-html elt) "<ul>")
     (loop :for (name obj) :of *objs
        :do (incf (inner-html elt)
                  (make-obj name (@ obj :img) (@ obj :selected))))
     (incf (inner-html elt) "</ul>")))
 
 ;;; Menu
 
 (defun open-menu (menu-data)
   (let ((elt (get-frame :dropdown))
         (i 0))
     (loop :for item :in menu-data
        :do (incf i)
        :do (incf (inner-html elt)
                  (if (eq item :delimiter)
                      (make-menu-delimiter i)
                      (make-menu-item-html i
                                           (@ item :text)
                                           (@ item :icon)
                                           (@ item :loc)))))
     (let ((mouse (@ window mouse)))
       (setf (@ elt style left) (+ (elt mouse 0) "px"))
       (setf (@ elt style top) (+ (elt mouse 1) "px"))
       ;; Make sure it's inside the viewport
       (when (> (@ document body inner-width)
                (+ (elt mouse 0) (@ elt inner-width)))
         (incf (@ elt style left) (@ elt inner-width)))
       (when (> (@ document body inner-height)
                (+ (elt mouse 0) (@ elt inner-height)))
         (incf (@ elt style top) (@ elt inner-height))))
     (setf (@ elt style display) "block")))
 
 (defun finish-menu (loc)
   (when *menu-resume
     (let ((elt (get-frame :dropdown)))
       (setf (inner-html elt) "")
       (setf (@ elt style display) "none")
       (funcall *menu-resume)
       (setf *menu-resume nil))
     (when loc
       (call-loc loc)))
   (void))
 
 (defun menu (menu-data)
   (with-sleep (resume)
     (open-menu menu-data)
     (setf *menu-resume resume))
   (void))
 
 ;;; Content
 
 (defun clean-audio ()
   (loop :for k :in (chain *object (keys *playing))
      :for v := (getprop *playing k)
      :do (when (@ v ended)
            (delete (@ *playing k)))))
 
 (defun show-image (path)
   (let ((img (get-frame :image)))
     (cond (path
            (setf (@ img src) path)
            (setf (@ img style display) "flex"))
           (t
            (setf (@ img src) "")
            (setf (@ img style display) "hidden")))))
 
 (defun rgb-string (rgb)
   (let ((red (ps::>> rgb 16))
         (green (logand (ps::>> rgb 8) 255))
         (blue (logand rgb 255)))
     (flet ((rgb-to-hex (comp)
              (let ((hex (chain (*number comp) (to-string 16))))
                (if (< (length hex) 2)
                    (+ "0" hex)
                    hex))))
       (+ "#" (rgb-to-hex red) (rgb-to-hex green) (rgb-to-hex blue)))))
 
 (defun store-obj (key obj)
   (store-str key (btoa (encode-u-r-i-component (chain *j-s-o-n (stringify obj)))))
   (void))
 (defun store-str (key str)
   (chain local-storage (set-item (+ "qsp_" key) str))
   (void))
 
 (defun load-obj (key)
   (chain *j-s-o-n (parse (encode-u-r-i-component (atob (load-str key))))))
 (defun load-str (key)
   (chain local-storage (get-item (+ "qsp_" key))))
 
 ;;; Saves
 
 (defun slot-savegame (slot comment)
   (let ((saves (load-obj "saves")))
     (setf (@ saves slot) comment)
     (store-obj saves))
   (store-str slot (state-to-base64))
   (void))
 
 (defun slot-loadgame (slot)
   (base64-to-state (load-str slot))
   (void))
 
 (defun slot-deletegame (slot)
   (let ((saves (load-obj "saves")))
     (setf (@ saves slot) undefined)
     (store-obj saves))
   (store-str slot undefined)
   (void))
 
 (defun slot-listgames ()
   (load-obj "saves"))
 
 (defun opengame ()
   (let ((element (chain document (create-element :input))))
     (chain element (set-attribute :type :file))
     (chain element (set-attribute :id :qsp-opengame))
     (chain element (set-attribute :tabindex -1))
     (chain 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 (@ event target files 0))
                    (reader (new (*file-reader))))
               (setf (@ reader onload)
                     (lambda (ev)
                       (block nil
                         (let ((target (@ ev current-target)))
                           (unless (@ target result)
                             (return))
                           (base64-to-state (@ target result))
                           (unstash-state)))))
               (chain reader (read-as-text file)))))
     (chain document body (append-child element))
     (chain element (click))
     (chain document body (remove-child element))))
 
 (defun savegame ()
   (let ((element (chain document (create-element :a))))
     (chain element (set-attribute :href (+ "data:text/plain;charset=utf-8," (state-to-base64))))
     (chain element (set-attribute :download "savegame.sav"))
     (setf (@ element style display) :none)
     (chain document body (append-child element))
     (chain element (click))
     (chain document body (remove-child element))))
 
 (defun stash-state (args)
   (call-serv-loc "$ONGSAVE")
   (setf *state-stash
         (chain *j-s-o-n (stringify
                          (create :vars *globals
                                  :objs *objs
                                  :loc-args args
                                  :msecs (- (chain *date (now)) *started-at)
                                  :timer-interval *timer-interval
                                  :main-html (inner-html
                                              (get-frame :main))
                                  :stat-html (inner-html
                                              (get-frame :stat))
                                  :next-location *current-location))))
   (void))
 
 (defun unstash-state ()
   (let ((data (chain *j-s-o-n (parse *state-stash))))
     (clear-act)
     (setf *globals (@ data :vars))
     (loop :for k :in (chain *object (keys *globals))
        :do (chain *object (set-prototype-of (getprop *globals k)
                                             (@ *var prototype))))
     (setf *started-at (- (chain *date (now)) (@ data :msecs)))
     (setf *objs (@ data :objs))
     (setf *current-location (@ data :next-location))
     (setf (inner-html (get-frame :main))
           (@ data :main-html))
     (setf (inner-html (get-frame :stat))
           (@ data :stat-html))
     (update-objs)
     (set-timer (@ data :timer-interval))
     (call-serv-loc "$ONGLOAD")
     (call-loc *current-location (@ data :loc-args))
     (void)))
 
 (defun state-to-base64 ()
   (btoa (encode-u-r-i-component *state-stash)))
 
 (defun base64-to-state (data)
   (setf *state-stash (decode-u-r-i-component (atob data))))
 
 ;;; Timers
 
 (defun set-timer (interval)
   (setf *timer-interval interval)
   (clear-interval *timer-obj)
   (setf *timer-obj
         (set-interval
          (lambda ()
            (call-serv-loc "$COUNTER"))
          interval)))
 
 ;;; Special variables
 
 (defvar serv-vars (create))
 
 (define-serv-var $backimage (path)
   (setf (@ (get-frame :main) style background-image) path))
 
 (define-serv-var bcolor (color)
   (setf (@ (get-frame :all) style background-color) (rgb-string color)))
 
 (define-serv-var fcolor (color)
   (setf (@ (get-frame :all) style color) (rgb-string color)))
 
 (define-serv-var lcolor (color)
   (setf (@ (get-frame :style) inner-text)
         (+ "a { color: " (rgb-string color) ";}")))
 
 (define-serv-var fsize (size)
   (setf (@ (get-frame :all) style font-size) size))
 
 (define-serv-var $fname (font-name)
   (setf (@ (get-frame :all) style font-family) (+ font-name ",serif")))

src/intrinsic-macros.lisp

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

src/intrinsics.ps

@@ -1,330 +1,317 b''
 
 (in-package txt2web.lib)
 
 ;;;; 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.
 
 ;;; 1loc
 
 (defun goto (target args)
   (api:clear-text :main)
   (funcall xgoto target args)
   (void))
 
 (defun xgoto (target args)
   (setf args (or args (list)))
   (api:clear-act)
   (setf *current-location (chain target (to-upper-case)))
   (api:stash-state args)
   (api:call-loc *current-location args)
   (api:call-serv-loc "$ONNEWLOC")
   (void))
 
 ;;; 2var
 
 ;;; 3expr
 
 (defun obj (name)
   (has name *objs))
 
 (defun loc (name)
   (has name *locs))
 
 ;;; 4code
 
 (defun rand (a &optional (b 1))
   (let ((min (min a b))
         (max (max a b)))
     (+ min (chain *math (random (- max min))))))
 
 ;;; 5arrays
 
 (defun copyarr (to from start count)
   (multiple-value-bind (to-name to-slot)
       (api:var-real-name to)
     (multiple-value-bind (from-name from-slot)
         (api:var-real-name from)
       (loop :for i :from start :to (min (api:array-size from-name)
                                         (+ start count))
          :do (api:set-var to-name (+ start i) to-slot
                           (api:get-var from-name (+ start i) from-slot))))))
 
 (defun arrpos (name value &optional (start 0))
   (multiple-value-bind (real-name slot)
       (api:var-real-name name)
     (loop :for i :from start :to (api:array-size name)
        :do (when (eq (api:get-var real-name i slot) value)
              (return-from arrpos i))))
   -1)
 
 (defun arrcomp (name pattern &optional (start 0))
   (multiple-value-bind (real-name slot)
       (api:var-real-name name)
     (loop :for i :from start :to (api:array-size name)
        :do (when (funcall (getprop (api:get-var real-name i slot)
                                    'match)
                           pattern)
              (return-from arrcomp i))))
   -1)
 
 ;;; 6str
 
 (defun instr (s subs &optional (start 1))
   (+ start (chain s (substring (- start 1)) (search subs))))
 
 (defun isnum (s)
   (if (is-na-n s)
       0
       -1))
 
 (defun strcomp (s pattern)
   (if (chain s (match pattern))
       -1
       0))
 
 (defun strfind (s pattern group)
   (let* ((re (new (*reg-exp pattern)))
          (match (chain re (exec s))))
     (chain match (group group))))
 
 (defun strpos (s pattern &optional (group 0))
   (let* ((re (new (*reg-exp pattern)))
          (match (chain re (exec s)))
          (found (chain match (group group))))
     (if found
         (chain s (search found))
         0)))
 
 ;;; 7if
 
 ;; Has to be a function because it always evaluates all three of its
 ;; arguments
 (defun iif (cond-expr then-expr else-expr)
   (if cond-expr then-expr else-expr))
 
 ;;; 8sub
 
 (defun gosub (target &rest args)
   (api:call-loc target args)
   (void))
 
 (defun func (target &rest args)
   (api:call-loc target args))
 
 ;;; 9loops
 
 ;;; 10dynamic
 
-(defun dynamic (block &rest args)
-  (when (stringp block)
-    (api:report-error "DYNAMIC can't evaluate arbitrary strings.\\nUse {braces} to create blocks for DYNAMIC."))
-  (api:with-call-args args
-    (funcall block args))
-  (void))
-
-(defun dyneval (block &rest args)
-  (when (stringp block)
-    (api:report-error "DYNEVAL can't evaluate arbitrary strings.\\nUse {braces} to create blocks for DYNEVAL."))
-  (api:with-call-args args
-    (funcall block args)))
-
 ;;; 11main
 
 (defun main-p (s)
   (api:add-text :main s)
   (void))
 
 (defun main-pl (s)
   (api:add-text :main s)
   (api:newline :main)
   (void))
 
 (defun main-nl (s)
   (api:newline :main)
   (api:add-text :main s)
   (void))
 
 (defun maintxt (s)
   (api:get-text :main)
   (void))
 
 (defun desc (s)
   "")
 
 (defun main-clear ()
   (api:clear-text :main)
   (void))
 
 ;;; 12stat
 
 (defun stat-p (s)
   (api:add-text :stat s)
   (void))
 
 (defun stat-pl (s)
   (api:add-text :stat s)
   (api:newline :stat)
   (void))
 
 (defun stat-nl (s)
   (api:newline :stat)
   (api:add-text :stat s)
   (void))
 
 (defun stattxt (s)
   (api:get-text :stat)
   (void))
 
 (defun stat-clear ()
   (api:clear-text :stat)
   (void))
 
 (defun cls ()
   (stat-clear)
   (main-clear)
   (cla)
   (cmdclear)
   (void))
 
 ;;; 13diag
 
 ;;; 14act
 
 (defun selact ()
   (loop :for (k v) :of *acts
      :do (when (@ v :selected)
            (return-from selact (@ v :name)))))
 
 (defun curacts ()
   (let ((acts (api-call copy-obj *acts)))
     (lambda ()
       (setf *acts acts)
       (void))))
 
 ;;; 15objs
 
 (defun addobj (name img)
   (setf img (or img ""))
   (setf (getprop *objs name)
         (create :name name :img img :selected nil))
   (api:update-objs)
   (api-call call-serv-loc "$ONOBJADD" name img)
   (void))
 
 (defun delobj (name)
   (delete (getprop *objs name))
   (api:update-objs)
   (api-call call-serv-loc "$ONOBJDEL" name)
   (void))
 
 (defun killobj (&optional (num nil))
-  (if (eq nil num)
+  (if (eq undefined num)
       (setf *objs (create))
       (delobj (elt (chain *object (keys *objs)) num)))
   (api:update-objs)
   (void))
 
 (defun selobj ()
   (loop :for (k v) :of *objs
      :do (when (@ v :selected)
            (return-from selobj (@ v :name)))))
 
 (defun unsel ()
   (loop :for (k v) :of *objs
      :do (setf (@ v :selected) nil)))
 
 ;;; 16menu
 
 (defun menu (menu-name)
   (let ((menu-data (list)))
     (loop :for item-obj :in (@ (api:get-array (api:var-real-name menu-name)) values)
        :for item := (@ item-obj :str)
        :do (cond ((string= item "")
                   (break))
                  ((string= item "-:-")
                   (chain menu-data (push :delimiter)))
                  (t
                   (let* ((tokens (chain item (split ":"))))
                     (when (= (length tokens) 2)
                       (chain tokens (push "")))
                     (let* ((text (chain tokens (splice 0 (- (length tokens) 2)) (join ":")))
                            (loc (getprop tokens (- (length tokens) 2)))
                            (icon (getprop tokens (- (length tokens) 1))))
                       (chain menu-data
                              (push (create :text text
                                            :loc loc
                                            :icon icon))))))))
     (api:menu menu-data)
     (void)))
 
 ;;; 17sound
 
 (defun play (filename &optional (volume 100))
   (let ((audio (new (*audio filename))))
     (setf (getprop *playing filename) audio)
     (setf (@ audio volume) (* volume 0.01))
     (chain audio (play))))
 
 (defun close (filename)
   (funcall (getprop *playing filename) stop)
   (delete (getprop *playing filename))
   (void))
 
 (defun closeall ()
   (loop :for k :in (chain *object (keys *playing))
      :for v := (getprop *playing k)
      :do (funcall v stop))
   (setf *playing (create)))
 
 ;;; 18img
 
 (defun refint ()
   ;; "Force interface update" Uh... what exactly do we do here?
   ;(api:report-error "REFINT is not supported")
   )
 
 ;;; 19input
 
 (defun usertxt ()
   (let ((input (by-id "qsp-input")))
     (@ input value)))
 
 (defun cmdclear ()
   (let ((input (by-id "qsp-input")))
     (setf (@ input value) "")))
 
 (defun input (text)
   (chain window (prompt text)))
 
 ;;; 20time
 
 (defun msecscount ()
   (- (chain *date (now)) *started-at))
 
 ;;; 21local
 
 ;;; 22for
 
 ;;; misc
 
 (defun rgb (red green blue)
   (+ (<< red 16)
      (<< green 8)
      blue))
 
 (defun openqst (name)
   (api-call run-game name))
 
 (defun addqst (name)
   (let ((game (api-call filename-game name)))
     ;; Add the game's locations
     (chain *object (assign *locs
                            (getprop *games name)))))
 
 (defun killqst ()
   ;; Delete all locations not from the current main game
   (loop :for (k v) :in *games
      :do (unless (string= k *main-game)
            (delete (getprop *locs k)))))
 

src/main.ps

@@ -1,56 +1,58 b''
 
 (in-package txt2web.main)
 
 ;;; Game session state (saved in savegames)
 ;; Variables
 (var *globals (create))
+(var *default-globals (create))
 ;; Inventory (objects)
 (var *objs (create))
 (var *current-location nil)
 ;; Game time
 (var *started-at (chain *date (now)))
 ;; Timers
 (var *timer-interval 500)
 (var *timer-obj nil)
 ;; Games
 (var *loaded-games (list))
 
 ;;; Transient state
 ;; ACTions
 (var *acts (create))
 ;; Savegame data
 (var *state-stash (create))
 ;; List of audio files being played
 (var *playing (create))
 ;; Local variables stack (starts with an empty frame)
 (var *locals (list))
 ;; Promise to continue running the game after menu
 (var *menu-resume nil)
 
 ;;; Game data
 ;; Games (filename -> [locations])
 (var *games (list))
 ;; The main (non library) game. Updated by openqst
 (var *main-game nil)
 ;; Active locations
 (var *locs (create))
 
 (setf (@ window onload)
       #'start)
 
 (defun start ()
   (#.(intern "INIT-DOM" "TXT2WEB.API"))
   ;; For MSECCOUNT
   (setf *started-at (chain *date (now)))
   ;; For $COUNTER and SETTIMER
   (#.(intern "SET-TIMER" "TXT2WEB.API")
      *timer-interval)
   ;; Start the first game
-  (#.(intern "RUN-GAME" "TXT2WEB.API")
-     (chain *object (keys *games) 0))
+  (let ((first-game (chain *object (keys *games) 0)))
+    (#.(intern "INIT-GLOBALS" "TXT2WEB.API") first-game)
+    (#.(intern "RUN-GAME"     "TXT2WEB.API") first-game))
   (values))
 
 ;;; Some very common utilities (for both api and lib)
 
 (defun by-id (id)
   (chain document (get-element-by-id id)))

src/package.lisp

@@ -1,108 +1,109 b''
 
 (in-package cl-user)
 
 (defpackage :txt2web.js)
 
 (defpackage :txt2web.main
   (:use :cl :ps :txt2web.js)
   (:export #:api-call #:by-id
            #:has
 
-           #:*globals #:*objs #:*current-location
+           #:*globals #:*default-globals #:*objs #:*current-location
            #:*started-at #:*timer-interval #:*timer-obj #:*loaded-games
 
            #:*acts #:*state-stash #:*playing #:*locals
 
            #:*games #:*main-game #:*locs #:*menu-resume
            ))
 
 (defpackage :code-walker
   (:use :cl)
   (:export #:deftransform
            #:deftransform-stop
            #:walk
            #:whole
            #:walk-continue))
 
 ;;; API functions
 (defpackage :txt2web.api
   (:use :cl :ps :txt2web.main :txt2web.js)
   (:export #:with-frame #:with-call-args
            #:stash-state
 
            #:report-error #:sleep #:init-dom #:call-serv-loc #:*serv-vars*
            #:newline #:clear-id #:prepare-contents #:get-id #:set-id #:append-id
-           #:init-args #:get-result #:call-loc #:call-act
+           #:get-result #:call-loc #:call-act
            #:get-frame #:add-text #:get-text #:clear-text #:enable-frame
            #:add-act #:del-act #:clear-act #:update-acts
            #:set-str-element #:set-any-element #:set-serv-var
            #:*var #:new-value #:index-num #:get #:set #:kill
            #:var-real-name #:ensure-var #:var-ref #:get-var #:set-var
            #:get-array #:set-array #:kill-var #:array-size
            #:push-local-frame #:pop-local-frame #:current-local-frame #:new-local
            #:update-objs
            #:menu
            #:clean-audio
            #:show-image
            #:opengame #:savegame
+           #:init-globals
            ))
 
 ;;; QSP library functions and macros
 (defpackage :txt2web.lib
   (:use :cl :ps :txt2web.main :txt2web.js)
   (:local-nicknames (#:api :txt2web.api)
                     (#:walker :code-walker))
   (:export #:str #:exec #:qspblock #:qsploop #:game #:location
            #:qspcond #:qspvar #:set #:local #:jump
 
            #:killvar #:killall
            #:obj #:loc #:no
            #:qspver #:curloc
            #:rnd #:qspmax #:qspmin
            #:arrsize #:len
            #:mid #:ucase #:lcase #:trim #:replace #:val #:qspstr
            #:exit #:desc
            #:showstat #:msg
            #:showacts #:delact #:cla
            #:showobjs #:countobj #:getobj
            #:isplay
            #:view
            #:showinput
            #:wait #:settimer
            #:local
            #:opengame #:savegame
 
            #:goto #:xgoto
            #:rand
            #:copyarr #:arrpos #:arrcomp
            #:instr #:isnum #:strcomp #:strfind #:strpos
            #:iif
            #:gosub #:func
            #:dynamic #:dyneval
            #:main-p #:main-pl #:main-nl #:maintxt #:desc #:main-clear
            #:stat-p #:stat-pl #:stat-nl #:stattxt #:stat-clear #:cls
            #:curacts
            #:addobj #:delobj #:killobj
            #:menu
            #:play #:close #:closeall
            #:refint
            #:usertxt #:cmdclear #:input
            #:msecscount
            #:rgb
            #:openqst #:addqst #:killqst
            ))
 
 (setf (ps:ps-package-prefix "TXT2WEB.MAIN") "qsp_")
 (setf (ps:ps-package-prefix "TXT2WEB.API") "qsp_api_")
 (setf (ps:ps-package-prefix "TXT2WEB.LIB") "qsp_lib_")
 
 ;;; The compiler
 (defpackage :txt2web
   (:use :cl)
   (:local-nicknames (#:p #:esrap)
                     (#:lib :txt2web.lib)
                     (#:api :txt2web.api)
                     (#:main :txt2web.main)
                     (#:walker :code-walker))
   (:export #:parse-file #:entry-point))
 

src/parser.lisp

@@ -1,664 +1,669 b''
 
 (in-package txt2web)
 
 ;;;; Parses TXT source to an intermediate representation
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defparameter *max-args* 10))
 
 ;;; 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)) "TXT2WEB.LIB")
          (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) "TXT2WEB.LIB") 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)))))
 
 (walker:deftransform parser-qspmod mod (&rest args)
   (list* 'qspmod (mapcar #'walker:walk-continue args)))
 
 (defun do-binop (list)
   (walker:walk 'parser-qspmod
                (destructuring-bind (left-op rest-ops)
                    list
                  (do-binop% left-op
                    (mapcar #'binop-rest rest-ops)))))
 
 (defun maybe-text (list)
   "Leaves lists in place and applies esrap:text to everything else"
   (let ((parts nil)
         (part (list 'text)))
     (loop :for token :in list
        :do (cond ((listp token)
                   (push (nreverse part) parts)
                   (setf part (list 'text))
                   (push token parts))
                  (t (push token part))))
     (push (nreverse part) parts)
     (remove ""
             (loop :for part :in (nreverse parts)
                :collect (case (first part)
                           ('text (p:text (rest part)))
                           (t part)))
             :test #'equal)))
 
 (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)
   (:error-report nil))
 
 (p:defrule spaces? (* (or #\space #\tab line-continuation))
   (:constant nil)
   (:error-report nil))
 
 (p:defrule colon #\:
   (:constant nil))
 
 (p:defrule equal #\=
   (: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-char (or squote-esc (not-quote character))
   (:text t))
 
 (p:defrule dstring-char (or dquote-esc (not-doublequote character))
   (:text t))
 
 ;;; Identifiers
 
 (defparameter *keywords* '(act addlib addobj addqst and arrcomp arrpos arrsize cla clear *clear close clr *clr cls cmdclear cmdclr copyarr countobj curact curacts curloc debug delact dellib delobj desc disablescroll dynamic dyneval else elseif end exit loop freelib func getobj gosub goto gs gt if iif img *img inclib input instr isnum isplay jump killall killobj killqst killvar lcase len let loc local maintxt max menu mid min mod msecscount msg nl *nl no nosave obj opengame openqst or p *p pl *pl play qspver rand refint replace rgb rnd savegame selact selobj set settimer showacts showinput showobjs showstat stattxt step str strcomp strfind strpos to trim ucase unsel unselect user_text usrtxt val view wait while 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)) "TXT2WEB.LIB")))
 
 (p:defrule identifier (not-qsp-keyword-p identifier-raw))
 
 ;;; Strings
 
 (p:defrule qsp-string (or normal-string brace-string))
 
 (p:defrule brace-string (and #\{ before-statement block-body #\})
   (:lambda (list)
     (list* 'lib:qspblock (third list))))
 
 (p:defrule normal-string (or sstring dstring)
   (:lambda (str)
     (list* 'lib:str (or str (list "")))))
 
 (p:defrule sstring (and #\' (* (or sstring-interpol
                                    sstring-exec
                                    sstring-char))
                         #\')
   (:lambda (list)
     (maybe-text (second list))))
 
 (p:defrule dstring (and #\" (* (or dstring-interpol
                                    dstring-exec
                                    dstring-char))
                         #\")
   (:lambda (list)
     (maybe-text (second list))))
 
 (defun parse-interpol (list)
   (p:parse 'expression (p:text (mapcar 'second (second list)))))
 
 (defun parse-exec (list)
-  (list* 'lib:exec (p:parse 'exec-body (p:text (second list)))))
+  (list* 'lib:exec (p:parse 'exec-body (p:text (mapcar #'second (second list))))))
 
 (p:defrule sstring-interpol (and "<<" (+ (and (p:! ">>")
                                               sstring-char))
                                  ">>")
   (:function parse-interpol))
 
 (p:defrule dstring-interpol (and "<<" (+ (and (p:! ">>")
                                               dstring-char))
                                  ">>")
   (:function parse-interpol))
 
 (p:defrule sstring-exec (or (and (p:~ "\"exec:")
                                  (+ (and (p:& (not-doublequote character)) sstring-char))
                                  #\")
                             (and (p:~ "''exec:")
                                  (+ (not-quote character))
                                  "''"))
   (:function parse-exec))
 
 (p:defrule dstring-exec (or (and (p:~ "'exec:")
                                  (+ (and (p:& (not-quote character)) dstring-char))
                                  #\')
                             (and (p:~ "\"\"exec")
                                  (+ (not-doublequote character))
                                  "\"\""))
   (:function parse-exec))
 
 ;;; Location
 
 (p:defrule txt2web-grammar (and (* (or spaces #\newline))
                                   (* location))
   (:lambda (list)
     `(lib:game ,@(second list))))
 
 (p:defrule location (and location-header block-body location-end)
   (:destructure (header body end)
     (declare (ignore end))
     `(lib: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 'lib:main-pl string)))
 
 (p:defrule expression-output expression
   (:lambda (list)
     (list 'lib: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* 'lib:local (third list)
            (when (fourth list)
              (list (fourth (fourth list)))))))
 
 ;;; Blocks
 
 (p:defrule block (or block-act block-if block-loop))
 
 (p:defrule block-if (and block-if-head block-if-body)
   (:destructure (head body)
     `(lib: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-ml block-sl))
   (:lambda (list)
     (apply #'append 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) '(lib:str ""))))))
 
 (p:defrule block-act-head-img (and #\, spaces? qsp-string spaces?)
   (:lambda (list)
     (or (third list) "")))
 
 (p:defrule block-loop (and block-loop-head (or block-ml block-sl))
   (:lambda (list)
     (apply #'append list)))
 
 (p:defrule block-loop-head (and (p:~ "loop") spaces
                                 (p:? (and block-loop-head-init spaces?))
                                 block-loop-head-while spaces?
                                 (p:? (and block-loop-head-step spaces?))
                                 colon spaces?)
   (:lambda (list)
     (break "~S" list)
     (list 'lib:qsploop
           (elt list 2)
           (elt list 6)
           (elt list 9)
           (elt list 10))))
 
 (p:defrule block-loop-head-init (or local plain-assignment))
 
 (p:defrule block-loop-head-while (and (p:~ "while") eq-expr)
   (:function second))
 
 (p:defrule block-loop-head-step (and (p:~ "step") (or plain-assignment op-assignment))
   (:function second))
 
 (p:defrule block-sl line-body)
 
 (p:defrule block-ml (and newline-block-body block-end)
   (:lambda (list)
     (apply #'list* (butlast list))))
 
 (p:defrule block-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 &rest names)
   (declare (ignore returning))
   (unless max-arity
     (setf max-arity *max-args*))
   (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* ',(intern (string sym) "TXT2WEB.LIB") arguments))))
 
 (defintrinsics (intrinsic returning-intrinsic non-returning-intrinsic)
   ;; Transitions
   (goto%    nil 0 nil "gt" "goto")
   (xgoto%   nil 0 nil "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 nil "max")
   (qspmin   t   1 nil "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)
   (qspreplace t 2 3 "replace")
   (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 nil "gosub" "gs")
   (func     t   1 nil)
   (exit     nil 0 0)
   ;; Jump
   (jump     nil 1 1)
   ;; Dynamic
   (dynamic  nil 1 nil)
   (dyneval  t   1 nil)
   ;; Sound
   (play     nil 1 2)
   (isplay   t   1 1)
   (close    nil 1 1)
   (closeall nil 0 0 "close all")
   ;; 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)
   (selact   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)
   (selobj   t   0 0)
   (unsel    nil 0 0 "unsel" "unselect")
   ;; Menu
   (menu     nil 1 1)
   ;; Images
   (refint   nil 0 0)
   (view     nil 0 1)
   (img      nil 1)
   (*img     nil 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 "<=" ">=" "=<" "=>" "<>"
-                                                     "=" "<" ">")
+(p:defrule eq-expr (and sum-expr (* (and spaces? comp-op
                                          spaces? sum-expr)))
   (:function do-binop))
 
+(p:defrule comp-op (or "<=" ">=" "=<" "=>" "<>" "=" "<" ">")
+  (:lambda (op)
+    (cond ((string= op "=>") ">=")
+          ((string= op "=<") "<=")
+          (t op))))
+
 (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-raw)
     (let ((idx (case idx-raw
                  ((nil) 0)
                  (:last nil)
                  (t idx-raw))))
       (list 'lib:qspvar id idx))))
 
 (p:defrule array-index (and #\[ spaces? (p:? expression) spaces? #\])
   (:lambda (list)
     (or (third list) :last)))
 
 (p:defrule assignment (or kw-assignment plain-assignment op-assignment)
   (:destructure (qspvar eq expr)
     (declare (ignore eq))
     (list 'lib:set qspvar 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 (qspvar ws1 op eq ws2 expr)
                 (declare (ignore ws1 ws2))
                 (list qspvar eq (intern-first (list op qspvar 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,391 +1,397 b''
 
 (in-package txt2web.lib)
 
 ;;;; Parenscript macros which make the parser's intermediate
 ;;;; representation directly compilable by Parenscript
 ;;;; Some utility macros for other .ps sources too.
 
 ;;;; Block type | Has own locals | Has labels | async
 ;;;  Location   | TRUE           | TRUE       | TRUE
 ;;;  Act        | TRUE           | TRUE       | TRUE
 ;;;  {}         | TRUE           | TRUE       | TRUE
 ;;;  IF         | FALSE          | TRUE       | TRUE
 ;;;  FOR        | FALSE          | TRUE       | TRUE
 ;;;  
 ;;; IF and FOR are actually not blocks at all. They're implemented as Javascript's if and for loops.
 ;;; Jumps back are also optimized to Javascript's while loops.
 
 ;;; Utils
 
 ;;; Common
 
 (defpsmacro label-block (() &body body)
   (let ((has-labels (some #'keywordp body)))
     `(block nil
        ,@(when has-labels
            '((var _labels (list))))
        (tagbody
           ,@body
           (void)))))
 
 (defpsmacro str (&rest forms)
   (cond ((zerop (length forms))
          "")
         ((and (= 1 (length forms))
               (stringp (first forms)))
          (first forms))
         (t
          `(& ,@forms))))
 
 (defpsmacro locals-block (&body body)
   "Includes labels too (through qsp-lambda)"
   (let ((*locals* nil))
     (walker:walk 'locals body)
     `(qsp-lambda
       (create-locals ,*locals*)
       ,@(walker:walk 'apply-vars body))))
 
 ;;; 1loc
 
 (defparameter *special-variables*
   '((usehtml 0)
+    (args 0)
+    ($args 0)
     (result 0)
     ($result 0)
     ($ongload 0)
     ($ongsave 0)
     ($onobjadd 0)
     ($onobjdel 0)
     ($onobjsel 0)
     ($onnewloc 0)
     ($onactsel 0)
     ($counter 0)
     ($usercom 0)))
 
 (defpsmacro game ((name) &body body)
   (setf body (walker:walk 'for-transform body))
   (setf *globals* *special-variables*)
   (walker:walk 'globals body)
   `(progn
      ;; Game object
      (setf (@ *games ,name)
            (create))
      ;; Global variables from this game
-     (create-globals ,*globals*)
+     (setf (@ *default-globals ,name)
+           (create-globals ,*globals*))
      ;; Locations
      ,@(loop :for location :in body
           :collect `(setf (@ *games ,name ,(caadr location))
                           ,location))))
 
 (defpsmacro location ((name) &body body)
   (declare (ignore name))
   "Name is used by the game macro above"
   `(locals-block ,@body))
 
 (defpsmacro goto% (target &rest args)
   `(progn
-     (goto ,target ,args)
+     (goto ,target ,@args)
      (exit)))
 
 (defpsmacro xgoto% (target &rest args)
   `(progn
-     (xgoto ,target ,args)
+     (xgoto ,target ,@args)
      (exit)))
 
 ;;; 2var
 
 (defvar *globals* nil)
 (defvar *locals* nil)
 
 (defpsmacro create-globals (globals)
   (flet ((indexes (name)
            (remove nil
                    (remove-if #'listp
                               (mapcar #'second
                                       (remove name globals
                                               :key #'first
                                               :test-not #'eq))))))
     (let ((names (remove-duplicates (mapcar #'first globals))))
-      `(chain *object
-              (assign *globals
-                      (create
-                       ,@(loop :for sym :in names
-                            :for indexes := (indexes sym)
-                            :for name := (string-upcase sym)
-                            :append `(,name
-                                      (api-call new-var ,name ,@indexes)))))))))
+      `(create
+        ,@(loop :for sym :in names
+             :for indexes := (indexes sym)
+             :for name := (string-upcase sym)
+             :append `(,name
+                       (api-call new-var ,name ,@indexes)))))))
 
 (walker:deftransform globals qspvar (&rest var)
   (pushnew var *globals* :test #'equal)
   (walker:walk-continue))
 
 (walker:deftransform globals local (var &rest expr)
   (declare (ignore var))
   (walker:walk 'globals expr))
 
 (defpsmacro create-locals (locals)
   (when locals
     `(progn
        (var locals (create
                     ,@(loop :for (sym index) :in locals
                          :for name := (string-upcase sym)
                          :append `(,name (api-call new-var ,name))))))))
 
 ;; locations, blocks, and acts all have their own locals namespace
 (walker:deftransform-stop locals qspblock)
 (walker:deftransform-stop locals act)
 
 (walker:deftransform locals local (var &optional expr)
   (declare (ignore expr))
   (pushnew (rest var) *locals* :test #'equal)
   nil)
 
 ;; index types:
 ;; literal number
 ;; literal string
 ;; variable number
 ;; variable string
 ;; expression (may be possible to determine if it's a string or a number)
 
 (defun $-var-p (sym)
   (char= #\$ (elt (string-upcase (symbol-name sym)) 0)))
 
 (defun literal-string-p (form)
   (and (listp form)
        (= 2 (length form))
        (eq 'str (first form))
        (stringp (second form))))
 
 (defun variable-number-p (form)
   (and (listp form)
        (eq 'qspvar (first form))
        (not ($-var-p (second form)))))
 
 (defun variable-string-p (form)
   (and (listp form)
        (eq 'qspvar (first form))
        ($-var-p (second form))))
 
 (walker:deftransform apply-vars set (var expr)
   (destructuring-bind (qspvar name index)
       var
     (declare (ignore qspvar))
     (setf name (string-upcase name))
     (let ((slot `(getprop
                   ,(if (member name *locals* :key #'first)
                        'locals '*globals)
                   ,name))
           (index (walker:walk 'apply-vars index))
           (value (walker:walk 'apply-vars expr)))
       (cond
         ((member name api:*serv-vars* :test #'equalp)
          `(api:set-serv-var ,name ,index ,value))
         ((null index)
          `(chain (elt ,slot) (push ,value)))
         ((or (numberp index)
              (variable-number-p index))
          `(setf (elt ,slot ,index) ,value))
         ((or (literal-string-p index)
              (variable-string-p index))
          `(api:set-str-element ,slot ,index ,value))
         (t
          `(api:set-any-element ,slot ,index ,value))))))
 
 (walker:deftransform apply-vars local (var &optional expr)
                      ;; TODO: var can't be a service variable
   (when expr
     (walker:walk 'apply-vars (list 'set var expr))))
 
 (walker:deftransform apply-vars qspvar (name index)
   (let ((slot `(getprop
                 ,(if (member name *locals* :key #'first) 'locals '*globals)
                 ,(string-upcase name))))
     (cond
       ((null index)
        `(elt ,slot (1- (length ,slot))))
       ((or (numberp index)
            (variable-number-p index))
        `(elt ,slot ,(walker:walk-continue index)))
       ((or (literal-string-p index)
            (variable-string-p index))
        `(elt ,slot (@ ,slot :indexes ,(walker:walk-continue index))))
       (t
        `(get-element ,slot ,(walker:walk-continue index))))))
 
 (walker:deftransform apply-vars qspblock (&rest block)
   (declare (ignore block))
   (walker:whole))
 (walker:deftransform apply-vars act (&rest block)
   (declare (ignore block))
   (walker:whole))
 (walker:deftransform apply-vars qspfor (var from to step body)
   (list* 'qspfor var (mapcar #'walker:walk-continue (list from to step body))))
 
+(defpsmacro get-slot (name)
+  `(getprop
+    (if (chain locals (includes name)) locals *globals)
+    (string-upcase name)))
+
 ;;; 3expr
 
 (defpsmacro <> (op1 op2)
   `(not (equal ,op1 ,op2)))
 
 (defpsmacro qspmod (&rest ops)
   (case (length ops)
     (1 (first ops))
     (2 `(mod ,@ops))
     (t `(mod ,(first ops) (qspmod ,@(rest ops))))))
 
 ;;; 4code
 
 (defpsmacro exec (&body body)
   (format nil "javascript: ~{~A~^~%~}" (mapcar #'ps* body)))
 
 ;;; 5arrays
 
 ;;; 6str
 
 (defpsmacro & (&rest args)
   `(chain "" (concat ,@args)))
 
 ;;; 7if
 
 (defpsmacro qspcond (&rest clauses)
   `(cond ,@(loop :for clause :in clauses
               :for f := (if (eq 'txt2web::else (first clause))
                             't
                             (first clause))
               :collect (list f
                              `(tagbody
                                  ,@(rest clause))))))
 
 ;;; 8sub
 
 ;;; 9jump
 ;;; Yep, that's a huge kludge since Javascript doesn't support arbitrary labels
 
 (defpsmacro jump (target)
   `(return-from label-body ,(string-upcase (second target))))
 
 (defpsmacro tagbody (&body body)
   (let ((create-locals (if (eq (caar body) 'create-locals)
                            (list (car body))))
         (void (if (equal (car (last body)) '(void))
                   '((void)))))
     (when create-locals
       (setf body (cdr body)))
     (when void
       (setf body (butlast body)))
     (let ((funcs (list nil "_nil")))
       (dolist (form body)
         (cond ((keywordp form)
                (setf (first funcs) (reverse (first funcs)))
                (push (string-upcase form) funcs)
                (push nil funcs))
               (t
                (push form (first funcs)))))
       (setf (first funcs) (reverse (first funcs)))
       (setf funcs (reverse funcs))
       `(progn
          ,@create-locals
          ,(if (= 2 (length funcs))
               `(progn
                  ,@body)
               `(progn
                  (tagbody-blocks ,funcs)
                  (loop
                     :for _nextblock
                       := :_nil
                     :then (await (funcall (getprop _labels _nextblock)))
                     :while _nextblock)))
          ,@void))))
 
 (defvar *current-label*)
 (defvar *has-jump-back*)
 (walker:deftransform optimize-jump jump (target)
   (cond ((string= (string-upcase (second target)) *current-label*)
          (setf *has-jump-back* t)
          '(continue))
         (t
          (walker:walk-continue))))
 
 (defpsmacro tagbody-blocks (funcs)
   `(setf ,@(loop :for (label code . rest-labels) :on funcs :by #'cddr
               :append `((@ _labels ,label)
                         (async-lambda ()
                           (block label-body
                             (tagbody-block-body ,label ,code
                                                 ,(first rest-labels))))))))
 
 (defpsmacro tagbody-block-body (label code next-label)
   (let ((*current-label* label)
         (*has-jump-back* nil))
     (let ((code (walker:walk 'optimize-jump code)))
       (if *has-jump-back*
           `(progn
              (loop :do (progn
                          ,@code
                          (break)))
              ,@(if next-label
                    (list next-label)
                    nil))
           `(progn
              ,@code
              ,@(if next-label
                    (list next-label)
                    nil))))))
 
 (defpsmacro exit ()
   '(return-from nil (values)))
 
 ;;; 10dynamic
 
 (defpsmacro qspblock (&body body)
   `(locals-block
     ,@body))
 
 (defpsmacro qsp-lambda (&body body)
   `(async-lambda (args)
      (label-block ()
        ,@body)))
 
 ;;; 11main
 
 (defpsmacro act (name img &body body)
   `(api-call add-act ,name ,img
              (locals-block
                ,@body)))
 
 ;;; 12aux
 
 ;;; 13diag
 
 ;;; 14act
 
 ;;; 15objs
 
 ;;; 16menu
 
 ;;; 17sound
 
 ;;; 18img
 
 ;;; 19input
 
 ;;; 20time
 
 ;;; 21local
 
 ;;; 22loop
 
 (defpsmacro qsploop (init cond step &body body)
   `(progn
      ,init
      (loop :while ,cond
            :do (progn
                  ,@body
                  ,step))))
 
 ;; Transform because it creates a (set ...) hence it has to be processed
 ;; before the apply-vars transform. And macros are processed after all
 ;; the transforms
 (walker:deftransform for-transform qspfor (var from to step &rest body)
   `(loop :for i :from ,from :to ,to :by ,step
       :do (set ,var i)
       :do (block nil
             ,@(walker:walk-continue body))))