diff --git a/src/api-macros.lisp b/src/api-macros.lisp new file mode 100644 --- /dev/null +++ b/src/api-macros.lisp @@ -0,0 +1,15 @@ + +(in-package sugar-qsp.api) + +(defpsmacro with-call-args (args &body body) + `(progn + (init-args ,args) + ,@body + (get-result))) + +(defpsmacro with-frame (&body body) + `(progn + (push-local-frame) + (unwind-protect + ,@body + (pop-local-frame)))) diff --git a/src/api.ps b/src/api.ps --- a/src/api.ps +++ b/src/api.ps @@ -1,107 +1,106 @@ -(in-package sugar-qsp) +(in-package sugar-qsp.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 -(setf (root api) (ps:create)) - ;;; Utils -(defm (root api make-act-html) (title img) - (+ "" +(defun make-act-html (title img) + (+ "" title "")) -(defm (root api make-menu-item-html) (num title img loc) - (+ "" +(defun make-menu-item-html (num title img loc) + (+ "" "" title "")) -(defm (root api report-error) (text) +(defun report-error (text) (alert text)) -(defm (root api sleep) (msec) - (ps:new (*promise (ps:=> resolve (set-timeout resolve msec))))) +(defun sleep (msec) + (new (*promise (=> resolve (set-timeout resolve msec))))) -(defm (root api init-dom) () +(defun 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) "#")) + (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 (ps:@ (document.get-element-by-id "qsp-image-container") onclick) - (this.show-image nil)) + (setf (@ (by-id "qsp-image-container") onclick) + (show-image nil)) ;; Close the dropdown on any click - (setf window.onclick + (setf (@ window onclick) (lambda (event) - (setf (ps:@ (api-call get-frame :dropdown) style display) "none")))) + (setf (@ (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))) +(defun call-serv-loc (var-name &rest args) + (let ((loc-name (get-var var-name 0 :str))) (when loc-name - (let ((loc (ps:getprop (root locs) loc-name))) + (let ((loc (getprop (root locs) loc-name))) (when loc (funcall loc args)))))) ;;; Misc -(defm (root api newline) (key) - (this.append-id (this.key-to-id key) "
" t)) +(defun newline (key) + (append-id (key-to-id key) "
" t)) -(defm (root api clear-id) (id) - (setf (ps:inner-html (document.get-element-by-id id)) "")) +(defun clear-id (id) + (setf (inner-html (by-id id)) "")) -(setf (root api text-escaper) (document.create-element :textarea)) +(defvar text-escaper (chain document (create-element :textarea))) -(defm (root api prepare-contents) (s &optional force-html) - (if (or force-html (var "USEHTML" 0 :num)) +(defun prepare-contents (s &optional force-html) + (if (or force-html (get-var "USEHTML" 0 :num)) s (progn - (setf (ps:@ (root api text-escaper) text-content) s) - (ps:inner-html (root api text-escaper))))) + (setf (@ text-escaper text-content) s) + (inner-html text-escaper)))) -(defm (root api get-id) (id &optional force-html) - (ps:inner-html (document.get-element-by-id id))) +(defun get-id (id &optional force-html) + (inner-html (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))) +(defun set-id (id contents &optional force-html) + (setf (inner-html (by-id id)) (prepare-contents contents force-html))) -(defm (root api append-id) (id contents &optional force-html) +(defun 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)))) + (incf (inner-html (by-id id)) (prepare-contents contents force-html)))) ;;; Function calls -(defm (root api init-args) (args) +(defun 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))))) + (set-var args i :num arg) + (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))) +(defun get-result () + (if (not (equal "" (get-var result 0 :str))) + (get-var result 0 :str) + (get-var result 0 :num))) -(defm (root api call-loc) (name args) +(defun call-loc (name args) (with-frame - (funcall (ps:getprop (root locs) name) args))) + (with-call-args args + (funcall (getprop (root locs) name) args)))) -(defm (root api call-act) (title) +(defun call-act (title) (with-frame - (funcall (ps:getprop (root acts) title)))) + (funcall (getprop (root acts) title 'act)))) ;;; Text windows -(defm (root api key-to-id) (key) +(defun key-to-id (key) (case key (:main "qsp-main") (:stat "qsp-stat") @@ -109,288 +108,298 @@ (:acts "qsp-acts") (:input "qsp-input") (:dropdown "qsp-dropdown") - (t (this.report-error "Internal error!")))) + (t (report-error "Internal error!")))) -(defm (root api get-frame) (key) - (document.get-element-by-id (this.key-to-id key))) +(defun get-frame (key) + (by-id (key-to-id key))) -(defm (root api add-text) (key text) - (this.append-id (this.key-to-id key) text)) +(defun add-text (key text) + (append-id (key-to-id key) text)) -(defm (root api get-text) (key) - (this.get-id (this.key-to-id key))) +(defun get-text (key) + (get-id (key-to-id key))) -(defm (root api clear-text) (key) - (this.clear-id (this.key-to-id key))) +(defun clear-text (key) + (clear-id (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")) +(defun enable-frame (key enable) + (let ((obj (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)) +(defun add-act (title img act) + (setf (getprop (root acts) title) + (create img img act act)) + (update-acts)) -(defm (root api del-act) (title) - (delete (ps:getprop (root acts) title)) - (this.update-acts)) +(defun del-act (title) + (delete (getprop (root acts) title)) + (update-acts)) -(defm (root api clear-act) () - (setf (root acts) (ps:create)) - (this.clear-id "qsp-acts")) +(defun clear-act () + (setf (root acts) (create)) + (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))))))) - +(defun update-acts () + (clear-id "qsp-acts") + (let ((elt (by-id "qsp-acts"))) + (for-in (title (root acts)) + (let ((obj (getprop (root acts) title))) + (incf (inner-html elt) (make-act-html title (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))))) +(defun qspfor (name index from to step body) + (for ((i from)) + ((< i to)) + ((incf i step)) + (set-var name index :num i) + (unless (funcall body) + (return-from qspfor)))) ;;; Variable class -(defm (root api *var) (name) +(defun *var (name) ;; From strings to numbers - (setf this.indexes (ps:create)) + (setf (@ this indexes) (create)) ;; From numbers to {num: 0, str: ""} objects - (setf this.values (list)) + (setf (@ this values) (list)) (values)) -(defm (root api *var prototype new-value) () - (ps:create :num 0 :str "")) +(defun new-value () + (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)) +(setf (@ *var prototype index-num) + (lambda (index) + (let ((num-index + (if (stringp index) + (if (in index (@ this indexes)) + (getprop (@ this indexes) index) + (let ((n (length (@ this values)))) + (setf (getprop (@ this indexes) index) n) + n)) + index))) + (unless (in num-index (@ this values)) + (setf (elt (@ this values) num-index) (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)) +(setf (@ *var prototype get) + (lambda (index slot) + (unless (or index (= 0 index)) + (setf index (1- (length (@ this values))))) + (getprop (@ this values) (chain 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)) +(setf (@ *var prototype set) + (lambda (index slot value) + (unless (or index (= 0 index)) + (setf index (length (@ this values)))) + (case slot + (:num (setf value (chain *number (parse-int value)))) + (:str (setf value (chain value (to-string))))) + (setf (getprop (@ this values) + (chain 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))) +(setf (@ *var prototype kill) + (lambda (index) + (setf (elt (@ this values) (chain this (index-num index))) + (new-value)) + (delete (getprop 'this 'indexes index)))) ;;; Variables -(defm (root api var-real-name) (name) - (if (= (ps:@ name 0) #\$) - (values (ps:chain name (substr 1)) :str) +(defun var-real-name (name) + (if (= (@ name 0) #\$) + (values (chain name (substr 1)) :str) (values name :num))) -(defm (root api ensure-var) (name) - (let ((store (this.var-ref name))) +(defun ensure-var (name) + (let ((store (var-ref name))) (unless store - (setf store (ps:new (this.-var name))) - (setf (ps:getprop (root vars) name) store)) + (setf store (new (-var name))) + (setf (getprop (root vars) name) store)) store)) -(defm (root api var-ref) (name) - (let ((local-store (this.current-local-frame))) +(defun var-ref (name) + (let ((local-store (current-local-frame))) (cond ((and local-store (in name local-store)) - (ps:getprop local-store name)) + (getprop local-store name)) ((in name (root vars)) - (ps:getprop (root vars) name)) + (getprop (root vars) name)) (t nil)))) -(defm (root api get-var) (name index slot) - (ps:chain (this.ensure-var name) (get index slot))) +(defun get-var (name index slot) + (chain (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)) +(defun set-var (name index slot value) + (chain (ensure-var name) (set index slot value)) (values)) -(defm (root api get-array) (name) - (this.var-ref name)) +(defun get-array (name) + (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))) +(defun set-array (name value) + (let ((store (var-ref name))) + (setf (@ store values) (@ value values)) + (setf (@ store indexes) (@ value indexes))) (values)) -(defm (root api kill-var) (name &optional index) +(defun 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))) + (chain (getprop (root vars) name) (kill index)) + (delete (getprop (root vars) name))) (values)) -(defm (root api array-size) (name) - (ps:getprop (this.var-ref name) 'length)) +(defun array-size (name) + (getprop (var-ref name) 'length)) ;;; Locals -(defm (root api push-local-frame) () - (ps:chain (root locals) (push (ps:create))) +(defun push-local-frame () + (chain (root locals) (push (create))) (values)) -(defm (root api pop-local-frame) () - (ps:chain (root locals) (pop)) +(defun pop-local-frame () + (chain (root locals) (pop)) (values)) -(defm (root api current-local-frame) () +(defun current-local-frame () (elt (root locals) (1- (length (root locals))))) -(defm (root api new-local) (name) - (let ((frame (this.current-local-frame))) +(defun new-local (name) + (let ((frame (current-local-frame))) (unless (in name frame) - (setf (ps:getprop frame name) (ps:create))) + (setf (getprop frame name) (create))) (values))) ;;; Objects -(defm (root api update-objs) () - (let ((elt (document.get-element-by-id "qsp-objs"))) - (setf (ps:inner-html elt) ""))) ;;; Menu -(defm (root api menu) (menu-data) - (let ((elt (document.get-element-by-id "qsp-dropdown")) +(defun menu (menu-data) + (let ((elt (by-id "qsp-dropdown")) (i 0)) - (setf (ps:inner-html elt) "") + (setf (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"))) + :do (incf (inner-html elt) (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))))) +(defun clean-audio () + (loop :for k :in (chain *object (keys (root playing))) + :for v := (getprop (root playing) k) + :do (when (@ v ended) + (delete (@ (root playing) k))))) -(defm (root api show-image) (path) - (let ((img (document.get-element-by-id "qsp-image"))) +(defun show-image (path) + (let ((img (by-id "qsp-image"))) (cond (path - (setf img.src path) - (setf img.style.display "flex")) + (setf (@ img src) path) + (setf (@ img style display) "flex")) (t - (setf img.src "") - (setf img.style.display "hidden"))))) + (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 +(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 (elt event.target.files 0)) - (reader (ps:new (*file-reader)))) - (setf reader.onload + (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)) - (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))) + (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)))) -(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))) +(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)))) -(defm (root api stash-state) (args) - (api-call call-serv-loc "ONGSAVE") +(defun stash-state (args) + (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)))) + (chain *j-s-o-n (stringify + (create vars (root vars) + objs (root objs) + loc-args args + msecs (- (chain *date (now)) (root started-at)) + main-html (inner-html + (by-id :qsp-main)) + stat-html (inner-html + (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)) +(defun unstash-state () + (let ((data (chain *j-s-o-n (parse (root state-stash))))) + (clear-act) + (setf (root vars) (@ data vars)) + (loop :for k :in (chain *object (keys (root vars))) + :do (chain *object (set-prototype-of (getprop (root vars) k) + (@ *var prototype)))) + (setf (root started-at) (- (chain *date (now)) (@ data msecs))) + (setf (root objs) (@ data objs)) + (setf (root current-location) (@ data next-location)) + (setf (inner-html (by-id :qsp-main)) + (@ data main-html)) + (setf (inner-html (by-id :qsp-stat)) + (@ data stat-html)) + (update-objs) + (call-serv-loc "ONGLOAD") + (call-loc (root current-location) (@ data loc-args)) (values))) -(defm (root api state-to-base64) () +(defun state-to-base64 () (btoa (encode-u-r-i-component (root state-stash)))) -(defm (root api base64-to-state) (data) +(defun base64-to-state (data) (setf (root state-stash) (decode-u-r-i-component (atob data)))) ;;; Timers -(defm (root api set-timer) (interval) +(defun 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")) + (call-serv-loc "COUNTER")) interval))) diff --git a/src/class.lisp b/src/class.lisp --- a/src/class.lisp +++ b/src/class.lisp @@ -8,21 +8,25 @@ (asdf:system-source-directory :sugar-qsp))) (defun read-code-from-string (string) (with-input-from-string (in string) - `(progn - ,@(loop :for form := (read in nil :eof) - :until (eq form :eof) - :collect form)))) + (let ((*package* *package*)) + `(progn + ,@(loop :for form := (read in nil :eof) + :until (eq form :eof) + :when (eq (first form) 'cl:in-package) + :do (setf *package* (find-package (second form))) + :else + :collect form))))) (defun load-src (filename) (alexandria:read-file-into-string (src-file filename)))) (defclass compiler () ((body :accessor body :initform #.(load-src "extras/body.html")) (css :accessor css :initform (list #.(load-src "extras/default.css"))) - (js :accessor js :initform '#.(mapcar #'read-code-from-string - (mapcar #'load-src - (list "src/intrinsics.ps" - "src/api.ps" - "src/main.ps")))) + (js :accessor js :initform (reverse + (list + '#.(read-code-from-string (load-src "src/main.ps")) + '#.(read-code-from-string (load-src "src/api.ps")) + '#.(read-code-from-string (load-src "src/intrinsics.ps"))))) (compile :accessor compile-only :initarg :compile) (target :accessor target :initarg :target) (beautify :accessor beautify :initarg :beautify))) diff --git a/src/intrinsic-macros.lisp b/src/intrinsic-macros.lisp --- a/src/intrinsic-macros.lisp +++ b/src/intrinsic-macros.lisp @@ -1,5 +1,5 @@ -(in-package sugar-qsp) +(in-package sugar-qsp.lib) ;;;; Macros implementing some intrinsics where it makes sense ;;;; E.g. an equivalent JS function exists, or it's a direct API call @@ -8,74 +8,74 @@ ;;; 2var -(ps:defpsmacro killvar (varname &optional index) - `(api-call kill-var ,varname ,index)) +(defpsmacro killvar (varname &optional index) + `(kill-var ,varname ,index)) -(ps:defpsmacro killall () +(defpsmacro killall () `(api-call kill-all)) ;;; 3expr -(ps:defpsmacro obj (name) +(defpsmacro obj (name) `(funcall (root objs includes) ,name)) -(ps:defpsmacro loc (name) +(defpsmacro loc (name) `(funcall (root locs includes) ,name)) -(ps:defpsmacro no (arg) +(defpsmacro no (arg) `(- -1 ,arg)) ;;; 4code -(ps:defpsmacro qspver () +(defpsmacro qspver () "0.0.1") -(ps:defpsmacro curloc () +(defpsmacro curloc () `(root current-location)) -(ps:defpsmacro rnd () - `(funcall (root lib rand) 1 1000)) +(defpsmacro rnd () + `(funcall rand 1 1000)) -(ps:defpsmacro qspmax (&rest args) +(defpsmacro qspmax (&rest args) (if (= 1 (length args)) `(*math.max.apply nil ,@args) `(*math.max ,@args))) -(ps:defpsmacro qspmin (&rest args) +(defpsmacro qspmin (&rest args) (if (= 1 (length args)) `(*math.min.apply nil ,@args) `(*math.min ,@args))) ;;; 5arrays -(ps:defpsmacro arrsize (name) +(defpsmacro arrsize (name) `(api-call array-size ,name)) ;;; 6str -(ps:defpsmacro len (s) +(defpsmacro len (s) `(length ,s)) -(ps:defpsmacro mid (s from &optional count) - `(ps:chain ,s (substring ,from ,count))) +(defpsmacro mid (s from &optional count) + `(chain ,s (substring ,from ,count))) -(ps:defpsmacro ucase (s) - `(ps:chain ,s (to-upper-case))) +(defpsmacro ucase (s) + `(chain ,s (to-upper-case))) -(ps:defpsmacro lcase (s) - `(ps:chain ,s (to-lower-case))) +(defpsmacro lcase (s) + `(chain ,s (to-lower-case))) -(ps:defpsmacro trim (s) - `(ps:chain ,s (trim))) +(defpsmacro trim (s) + `(chain ,s (trim))) -(ps:defpsmacro replace (s from to) - `(ps:chain ,s (replace ,from ,to))) +(defpsmacro replace (s from to) + `(chain ,s (replace ,from ,to))) -(ps:defpsmacro val (s) +(defpsmacro val (s) `(parse-int ,s 10)) -(ps:defpsmacro qspstr (n) - `(ps:chain ,n (to-string))) +(defpsmacro qspstr (n) + `(chain ,n (to-string))) ;;; 7if @@ -85,77 +85,77 @@ ;; JUMP is in ps-macros.lisp (because it's a part of a huge kludge) -(ps:defpsmacro exit () +(defpsmacro exit () `(return-from nil (values))) ;;; 10dynamic ;;; 11main -(ps:defpsmacro desc (s) +(defpsmacro desc (s) (declare (ignore s)) "") ;;; 12stat -(ps:defpsmacro showstat (enable) +(defpsmacro showstat (enable) `(api-call enable-frame :stat ,enable)) ;;; 13diag -(ps:defpsmacro msg (text) +(defpsmacro msg (text) `(alert ,text)) ;;; 14act -(ps:defpsmacro showacts (enable) +(defpsmacro showacts (enable) `(api-call enable-frame :acts ,enable)) -(ps:defpsmacro delact (name) +(defpsmacro delact (name) `(api-call del-act ,name)) -(ps:defpsmacro cla () +(defpsmacro cla () `(api-call clear-act)) ;;; 15objs -(ps:defpsmacro showobjs (enable) +(defpsmacro showobjs (enable) `(api-call enable-frame :objs ,enable)) -(ps:defpsmacro countobj () +(defpsmacro countobj () `(length (root objs))) -(ps:defpsmacro getobj (index) +(defpsmacro getobj (index) `(or (elt (root objs) ,index) "")) ;;; 16menu ;;; 17sound -(ps:defpsmacro isplay (filename) +(defpsmacro isplay (filename) `(funcall (root playing includes) ,filename)) ;;; 18img -(ps:defpsmacro view (&optional path) +(defpsmacro view (&optional path) `(api-call show-image ,path)) ;;; 19input -(ps:defpsmacro showinput (enable) +(defpsmacro showinput (enable) `(api-call enable-frame :input ,enable)) ;;; 20time -(ps:defpsmacro wait (msec) +(defpsmacro wait (msec) `(await (api-call sleep ,msec))) -(ps:defpsmacro settimer (interval) +(defpsmacro settimer (interval) `(api-call set-timer ,interval)) ;;; 21local -(ps:defpsmacro local (var &optional expr) +(defpsmacro local (var &optional expr) `(progn (api-call new-local ,(string (second var))) ,@(when expr @@ -165,10 +165,10 @@ ;;; misc -(ps:defpsmacro opengame (&optional filename) +(defpsmacro opengame (&optional filename) (declare (ignore filename)) `(api-call opengame)) -(ps:defpsmacro savegame (&optional filename) +(defpsmacro savegame (&optional filename) (declare (ignore filename)) `(api-call savegame)) diff --git a/src/intrinsics.ps b/src/intrinsics.ps --- a/src/intrinsics.ps +++ b/src/intrinsics.ps @@ -1,24 +1,22 @@ -(in-package sugar-qsp) +(in-package sugar-qsp.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. -(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))) +(defun goto (target args) + (api:clear-text :main) + (funcall 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)) +(defun xgoto (target args) + (api:clear-act) + (setf (root current-location) (chain target (to-upper-case))) + (api:stash-state args) + (funcall (getprop (root locs) (root current-location)) (or args (list))) (values)) @@ -28,164 +26,166 @@ ;;; 4code -(defm (root lib rand) (a &optional (b 1)) +(defun rand (a &optional (b 1)) (let ((min (min a b)) (max (max a b))) - (+ min (ps:chain *math (random (- max min)))))) + (+ min (chain *math (random (- max min)))))) ;;; 5arrays -(defm (root lib copyarr) (to from start count) +(defun copyarr (to from start count) (multiple-value-bind (to-name to-slot) - (api-call var-real-name to) + (api: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)))))) + (api:var-real-name from) + (for ((i start)) + ((< i (min (api:array-size from-name) + (+ start count)))) + ((incf i)) + (api:set-var to-name (+ start i) to-slot + (api:get-var from-name (+ start i) from-slot)))))) -(defm (root lib arrpos) (name value &optional (start 0)) +(defun 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)))) + (api:var-real-name name) + (for ((i start)) ((< i (api:array-size name))) ((incf i)) + (when (eq (api:get-var real-name i slot) value) + (return-from arrpos i)))) -1) -(defm (root lib arrcomp) (name pattern &optional (start 0)) +(defun 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)))) + (api:var-real-name name) + (for ((i start)) ((< i (api:array-size name))) ((incf i)) + (when (funcall (getprop (api:get-var real-name i slot) 'match) pattern) + (return-from arrcomp i)))) -1) ;;; 6str -(defm (root lib instr) (s subs &optional (start 1)) - (+ start (ps:chain s (substring (- start 1)) (search subs)))) +(defun instr (s subs &optional (start 1)) + (+ start (chain s (substring (- start 1)) (search subs)))) -(defm (root lib isnum) (s) +(defun isnum (s) (if (is-na-n s) 0 -1)) -(defm (root lib strcomp) (s pattern) - (if (s.match pattern) +(defun strcomp (s pattern) + (if (chain 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))) +(defun strfind (s pattern group) + (let* ((re (new (*reg-exp pattern))) + (match (chain re (exec s)))) + (chain 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))) +(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 - (s.search found) + (chain 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) +(defun 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) +(defun gosub (target &rest args) + (funcall (getprop (root locs) target) args) (values)) -(defm (root lib func) (target &rest args) - (funcall (ps:getprop (root locs) target) args)) +(defun func (target &rest args) + (funcall (getprop (root locs) target) args)) ;;; 9loops ;;; 10dynamic -(defm (root lib dynamic) (block &rest args) +(defun 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) + (api:report-error "DYNAMIC can't evaluate arbitrary strings.\nUse {braces} to create blocks for DYNAMIC.")) + (api:with-call-args args + (funcall block args)) (values)) -(defm (root lib dyneval) (block &rest args) +(defun 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)) + (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 -(defm (root lib main-p) (s) - (api-call add-text :main s) +(defun main-p (s) + (api:add-text :main s) (values)) -(defm (root lib main-pl) (s) - (api-call add-text :main s) - (api-call newline :main) +(defun main-pl (s) + (api:add-text :main s) + (api:newline :main) (values)) -(defm (root lib main-nl) (s) - (api-call newline :main) - (api-call add-text :main s) +(defun main-nl (s) + (api:newline :main) + (api:add-text :main s) (values)) -(defm (root lib maintxt) (s) - (api-call get-text :main) +(defun maintxt (s) + (api:get-text :main) (values)) ;; For clarity (it leaves a lib.desc() call in JS) -(defm (root lib desc) (s) +(defun desc (s) "") -(defm (root lib main-clear) () - (api-call clear-text :main) +(defun main-clear () + (api:clear-text :main) (values)) ;;; 12stat -(defm (root lib stat-p) (s) - (api-call add-text :stat s) +(defun stat-p (s) + (api:add-text :stat s) (values)) -(defm (root lib stat-pl) (s) - (api-call add-text :stat s) - (api-call newline :stat) +(defun stat-pl (s) + (api:add-text :stat s) + (api:newline :stat) (values)) -(defm (root lib stat-nl) (s) - (api-call newline :stat) - (api-call add-text :stat s) +(defun stat-nl (s) + (api:newline :stat) + (api:add-text :stat s) (values)) -(defm (root lib stattxt) (s) - (api-call get-text :stat) +(defun stattxt (s) + (api:get-text :stat) (values)) -(defm (root lib stat-clear) () - (api-call clear-text :stat) +(defun stat-clear () + (api: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)) +(defun cls () + (stat-clear) + (main-clear) + (cla) + (cmdclear) (values)) ;;; 13diag ;;; 14act -(defm (root lib curacts) () +(defun curacts () (let ((acts (root acts))) (lambda () (setf (root acts) acts) @@ -193,89 +193,89 @@ ;;; 15objs -(defm (root lib addobj) (name) - (ps:chain (root objs) (push name)) - (api-call update-objs) +(defun addobj (name) + (chain (root objs) (push name)) + (api:update-objs) (values)) -(defm (root lib delobj) (name) - (let ((index (ps:chain (root objs) (index-of name)))) +(defun delobj (name) + (let ((index (chain (root objs) (index-of name)))) (when (> index -1) - (funcall (root lib killobj) (1+ index)))) + (killobj (1+ index)))) (values)) -(defm (root lib killobj) (&optional (num nil)) +(defun killobj (&optional (num nil)) (if (eq nil num) (setf (root objs) (list)) - (ps:chain (root objs) (splice (1- num) 1))) - (api-call update-objs) + (chain (root objs) (splice (1- num) 1))) + (api:update-objs) (values)) ;;; 16menu -(defm (root lib menu) (menu-name) +(defun menu (menu-name) (let ((menu-data (list))) - (loop :for item :in (api-call get-array (api-call var-real-name menu-name)) + (loop :for item :in (api:get-array (api:var-real-name menu-name)) :do (cond ((string= item "") (break)) ((string= item "-:-") - (ps:chain menu-data (push :delimiter))) + (chain menu-data (push :delimiter))) (t - (let* ((tokens (ps:chain item (split ":")))) + (let* ((tokens (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) + (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) (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)))) +(defun play (filename &optional (volume 100)) + (let ((audio (new (*audio filename)))) + (setf (getprop (root playing) filename) audio) + (setf (@ audio volume) (* volume 0.01)) + (chain audio (play)))) -(defm (root lib close) (filename) +(defun close (filename) (funcall (root playing filename) stop) - (ps:delete (root playing filename))) + (delete (root playing filename))) -(defm (root lib closeall) () - (loop :for k :in (*object.keys (root playing)) - :for v := (ps:getprop (root playing) k) +(defun closeall () + (loop :for k :in (chain *object (keys (root playing))) + :for v := (getprop (root playing) k) :do (funcall v stop)) - (setf (root playing) (ps:create))) + (setf (root playing) (create))) ;;; 18img -(defm (root lib refint) () +(defun refint () ;; "Force interface update" Uh... what exactly do we do here? - (api-call report-error "REFINT is not supported") + (api:report-error "REFINT is not supported") ) ;;; 19input -(defm (root lib usertxt) () - (let ((input (document.get-element-by-id "qsp-input"))) - (ps:@ input value))) +(defun usertxt () + (let ((input (by-id "qsp-input"))) + (@ input value))) -(defm (root lib cmdclear) () - (let ((input (document.get-element-by-id "qsp-input"))) - (setf (ps:@ input value) ""))) +(defun cmdclear () + (let ((input (by-id "qsp-input"))) + (setf (@ input value) ""))) -(defm (root lib input) (text) - (window.prompt text)) +(defun input (text) + (chain window (prompt text))) ;;; 20time -(defm (root lib msecscount) () - (- (*date.now) (root started-at))) +(defun msecscount () + (- (chain *date (now)) (root started-at))) ;;; 21local @@ -283,19 +283,19 @@ ;;; misc -(defm (root lib rgb) (red green blue) +(defun rgb (red green blue) (flet ((rgb-to-hex (comp) - (let ((hex (ps:chain (*number comp) (to-string 16)))) + (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 red)))) -(defm (root lib openqst) () - (api-call report-error "OPENQST is not supported.")) +(defun openqst () + (api: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.")) +(defun addqst () + (api: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.")) +(defun killqst () + (api:report-error "KILLQST is not supported.")) diff --git a/src/js-syms.lisp b/src/js-syms.lisp new file mode 100644 --- /dev/null +++ b/src/js-syms.lisp @@ -0,0 +1,37 @@ + +(in-package sugar-qsp.js) + +;;; Contains symbols from standard JS library to avoid obfuscating +;;; and/or namespacing them + +(cl:defmacro syms (cl:&rest syms) + `(cl:progn + ,@(cl:loop :for sym :in syms + :collect `(cl:export ',sym)))) + +(syms + ;; main + window + *object + now + onload + keys includes + has-own-property + ;; api + document get-element-by-id + onclick onchange + atob btoa + alert prompt + set-timeout set-interval clear-interval + *promise *j-s-o-n + href parse + set-prototype-of + body append-child remove-child + create-element set-attribute + *file-reader read-as-text + style display src + ;; lib + *number parse-int + to-upper-case concat + click target current-target files index-of + ) diff --git a/src/main-macros.lisp b/src/main-macros.lisp new file mode 100644 --- /dev/null +++ b/src/main-macros.lisp @@ -0,0 +1,15 @@ + +(in-package sugar-qsp.main) + + +(defpsmacro by-id (id) + `(chain document (get-element-by-id ,id))) + +(defmacro+ps api-call (name &rest args) + `(,(intern (string-upcase name) "API") ,@args)) + +(defpsmacro root (&rest path) + `(@ data ,@path)) + +(defpsmacro in (key obj) + `(chain ,obj (has-own-property ,key))) diff --git a/src/main.lisp b/src/main.lisp --- a/src/main.lisp +++ b/src/main.lisp @@ -59,8 +59,22 @@ ;;; JS +(defun minify-package (package-designator minify prefix) + (setf (ps:ps-package-prefix package-designator) prefix) + (if minify + (ps:obfuscate-package package-designator) + (ps:unobfuscate-package package-designator))) + (defmethod js-sources ((compiler compiler)) (let ((ps:*ps-print-pretty* (beautify compiler))) + (cond ((beautify compiler) + (minify-package "SUGAR-QSP.MAIN" nil "qsp_") + (minify-package "SUGAR-QSP.API" nil "qsp_api_") + (minify-package "SUGAR-QSP.LIB" nil "qsp_lib_")) + (t + (minify-package "SUGAR-QSP.MAIN" t "_") + (minify-package "SUGAR-QSP.API" t "a_") + (minify-package "SUGAR-QSP.LIB" t "l_"))) (format nil "~{~A~^~%~%~}" (mapcar #'ps:ps* (reverse (js compiler)))))) ;;; CSS diff --git a/src/main.ps b/src/main.ps --- a/src/main.ps +++ b/src/main.ps @@ -1,41 +1,43 @@ -(in-package sugar-qsp) +(in-package sugar-qsp.main) (setf (root) - (ps:create + (create ;;; Game session state ;; Variables - vars (ps:create) + vars (create) ;; Inventory (objects) objs (list) + current-location nil ;; Game time - started-at (*date.now) + started-at (chain *date (now)) ;; Timers timer-interval 500 timer-obj nil ;;; Transient state ;; Savegame data - state-stash (ps:create) + state-stash (create) ;; List of audio files being played - playing (ps:create) + playing (create) ;; Local variables stack (starts with an empty frame) locals (list) ;;; Game data ;; ACTions - acts (ps:create) + acts (create) ;; Locations - locs (ps:create))) + locs (create))) ;; Launch the game from the first location -(setf window.onload +(setf (@ window onload) (lambda () - (api-call init-dom) + (#.(intern "INIT-DOM" "SUGAR-QSP.API")) ;; For MSECCOUNT - (setf (root started-at) (*date.now)) + (setf (root started-at) (chain *date (now))) ;; For $COUNTER and SETTIMER - (api-call set-timer (root timer-interval)) - (funcall (ps:getprop (root locs) - (ps:chain *object (keys (root locs)) 0)) + (#.(intern "SET-TIMER" "SUGAR-QSP.API") + (root timer-interval)) + (funcall (getprop (root locs) + (chain *object (keys (root locs)) 0)) (list)) (values))) diff --git a/src/package.lisp b/src/package.lisp --- a/src/package.lisp +++ b/src/package.lisp @@ -1,7 +1,93 @@ (in-package cl-user) +(defpackage :sugar-qsp.js) + +(defpackage :sugar-qsp.main + (:use :cl :ps :sugar-qsp.js) + (:export #:api-call #:by-id + #:root #:in + #:vars #:objs #:current-location + #:started-at #:timer-interval #:timer-obj + #:state-stash #:playing #:locals + #:acts #:locs)) + +;;; API functions +(defpackage :sugar-qsp.api + (:use :cl :ps :sugar-qsp.main :sugar-qsp.js) + (:export #:with-frame #:with-call-args + #:stash-state + + #:report-error #:sleep #:init-dom #:call-serv-loc + #:newline #:clear-id #:prepare-contents #:get-id #:set-id #:append-id + #:init-args #:get-result #:call-loc #:call-act + #:get-frame #:add-text #:get-text #:clear-text #:enable-frame + #:add-act #:del-act #:clear-act #:update-acts + #:qspfor + #:*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 + )) + +;;; QSP library functions and macros +(defpackage :sugar-qsp.lib + (:use :cl :ps :sugar-qsp.main :sugar-qsp.js) + (:local-nicknames (#:api :sugar-qsp.api)) + (:export #:str #:exec #:qspblock #:qspfor #:location + #:qspcond #:qspvar #:set #:local + + #: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 + )) + +;;; The compiler (defpackage :sugar-qsp (:use :cl) - (:local-nicknames (#:p #:esrap)) + (:local-nicknames (#:p #:esrap) + (#:lib :sugar-qsp.lib) + (#:api :sugar-qsp.api) + (#:main :sugar-qsp.main)) (:export #:parse-file #:entry-point)) + +(setf (ps:ps-package-prefix "SUGAR-QSP.MAIN") "qsp_") +(setf (ps:ps-package-prefix "SUGAR-QSP.API") "qsp_api_") +(setf (ps:ps-package-prefix "SUGAR-QSP.LIB") "qsp_lib_") diff --git a/src/parser.lisp b/src/parser.lisp --- a/src/parser.lisp +++ b/src/parser.lisp @@ -33,7 +33,7 @@ (not (find char " !:&=<>+-*/,'\"()[]{}")))) (defun intern-first (list) - (list* (intern (string-upcase (first list))) + (list* (intern (string-upcase (first list)) :lib) (rest list))) (eval-when (:compile-toplevel :load-toplevel :execute) @@ -44,7 +44,7 @@ (destructuring-bind (ws1 operator ws2 operand2) list (declare (ignore ws1 ws2)) - (list (intern (string-upcase operator)) operand2))) + (list (intern (string-upcase operator) :lib) operand2))) (defun do-binop% (left-op other-ops) (if (null other-ops) @@ -127,7 +127,7 @@ (digit-char-p character))) (p:defrule identifier-raw (and id-first (* id-next)) (:lambda (list) - (intern (string-upcase (p:text list))))) + (intern (string-upcase (p:text list)) :lib))) (p:defrule identifier (not-qsp-keyword-p identifier-raw)) @@ -137,7 +137,7 @@ (p:defrule normal-string (or sstring dstring) (:lambda (str) - (list* 'str (or str (list ""))))) + (list* 'lib:str (or str (list ""))))) (p:defrule sstring (and #\' (* (or string-interpol sstring-exec @@ -162,15 +162,15 @@ (p:defrule sstring-exec (and (p:~ "\"exec:") sstring-exec-body #\") (:lambda (list) - (list* 'exec (p:parse 'exec-body (second list))))) + (list* 'lib:exec (p:parse 'exec-body (second list))))) (p:defrule dstring-exec (and (p:~ "'exec:") dstring-exec-body #\') (:lambda (list) - (list* 'exec (p:parse 'exec-body (second list))))) + (list* 'lib:exec (p:parse 'exec-body (second list))))) (p:defrule brace-string (and #\{ before-statement block-body #\}) (:lambda (list) - (list* 'qspblock (third list)))) + (list* 'lib:qspblock (third list)))) ;;; Location @@ -181,7 +181,7 @@ (p:defrule location (and location-header block-body location-end) (:destructure (header body end) (declare (ignore end)) - `(location (,header) ,@body))) + `(lib:location (,header) ,@body))) (p:defrule location-header (and #\# (+ not-newline) @@ -246,11 +246,11 @@ (p:defrule string-output qsp-string (:lambda (string) - (list 'main-pl string))) + (list 'lib:main-pl string))) (p:defrule expression-output expression (:lambda (list) - (list 'main-pl list))) + (list 'lib:main-pl list))) (p:defrule label (and colon identifier) (:lambda (list) @@ -264,7 +264,7 @@ (p:defrule local (and (p:~ "local") spaces variable (p:? (and spaces? #\= spaces? expression))) (:lambda (list) - (list* 'local (third list) + (list* 'lib:local (third list) (when (fourth list) (list (fourth (fourth list))))))) @@ -274,8 +274,8 @@ (p:defrule block-if (and block-if-head block-if-body) (:destructure (head body) - `(qspcond (,@head ,@(first body)) - ,@(rest body)))) + `(lib:qspcond (,@head ,@(first body)) + ,@(rest body)))) (p:defrule block-if-head (and (p:~ "if") spaces expression spaces? colon spaces?) (:function remove-nil) @@ -335,7 +335,7 @@ (:lambda (list) (intern-first (list (first list) (third list) - (or (fifth list) '(str "")))))) + (or (fifth list) '(lib:str "")))))) (p:defrule block-act-head-img (and #\, spaces? qsp-string spaces?) (:lambda (list) @@ -352,7 +352,7 @@ (:lambda (list) (unless (eq (fourth (third list)) :num) (error "For counter variable must be numeric.")) - (list 'qspfor + (list 'lib:qspfor (elt list 2) (elt list 6) (elt list 9) @@ -428,12 +428,12 @@ (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* ',sym arguments)))) + (list* ',(intern (string sym) :lib) arguments)))) (defintrinsics (intrinsic returning-intrinsic non-returning-intrinsic) ;; Transitions - (goto nil 0 10 "gt" "goto") - (xgoto nil 0 10 "xgt" "xgoto") + (goto% nil 0 10 "gt" "goto") + (xgoto% nil 0 10 "xgt" "xgoto") ;; Variables (killvar nil 0 2) ;; Expressions @@ -583,24 +583,24 @@ (p:defrule variable (and identifier (p:? array-index)) (:destructure (id idx) (if (char= #\$ (elt (string id) 0)) - (list 'var (intern (subseq (string-upcase id) 1)) (or idx 0) :str) - (list 'var id (or idx 0) :num)))) + (list 'lib:qspvar (intern (subseq (string-upcase id) 1) :lib) (or idx 0) :str) + (list 'lib:qspvar id (or idx 0) :num)))) (p:defrule array-index (and #\[ spaces? (p:? expression) spaces? #\]) (:function third)) (p:defrule assignment (or kw-assignment plain-assignment op-assignment) - (:destructure (var eq expr) + (:destructure (qspvar eq expr) (declare (ignore eq)) - (list 'set var expr))) + (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 (var ws1 op eq ws2 expr) + (:destructure (qspvar ws1 op eq ws2 expr) (declare (ignore ws1 ws2)) - (list var eq (intern-first (list op var expr))))) + (list qspvar eq (intern-first (list op qspvar expr))))) (p:defrule plain-assignment (and variable spaces? #\= spaces? expression) (:function remove-nil)) diff --git a/src/ps-macros.lisp b/src/ps-macros.lisp --- a/src/ps-macros.lisp +++ b/src/ps-macros.lisp @@ -1,5 +1,5 @@ -(in-package sugar-qsp) +(in-package sugar-qsp.lib) ;;;; Parenscript macros which make the parser's intermediate ;;;; representation directly compilable by Parenscript @@ -7,40 +7,9 @@ ;;; 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) +(defpsmacro label-block ((&key (locals t)) &body body) (let ((has-labels (some #'keywordp body))) `(block nil ,@(when has-labels @@ -51,7 +20,7 @@ `((tagbody ,@body)))))) -(ps:defpsmacro str (&rest forms) +(defpsmacro str (&rest forms) (cond ((zerop (length forms)) "") ((and (= 1 (length forms)) @@ -62,60 +31,54 @@ ;;; 1loc -(ps:defpsmacro location ((name) &body body) +(defpsmacro location ((name) &body body) `(setf (root locs ,name) - (ps:async-lambda (args) - (label-block () - (api-call init-args args) - ,@body - (api-call get-result))))) + (async-lambda (args) + (label-block () + ,@body)))) -(ps:defpsmacro goto (target &rest args) +(defpsmacro goto% (target &rest args) `(progn - (funcall (root lib goto) ,target ,args) + (goto ,target ,args) (exit))) -(ps:defpsmacro xgoto (target &rest args) +(defpsmacro xgoto% (target &rest args) `(progn - (funcall (root lib xgoto) ,target ,args) + (xgoto ,target ,args) (exit))) -(ps:defpsmacro desc (target) - (declare (ignore target)) - (report-error "DESC is not supported")) - ;;; 2var -(ps:defpsmacro var (name index slot) +(defpsmacro qspvar (name index slot) `(api-call get-var ,(string name) ,index ,slot)) -(ps:defpsmacro set ((var vname vindex vslot) value) - (assert (eq var 'var)) +(defpsmacro set ((var vname vindex vslot) value) + (assert (eq var 'qspvar)) `(api-call set-var ,(string vname) ,vindex ,vslot ,value)) ;;; 3expr -(ps:defpsmacro <> (op1 op2) +(defpsmacro <> (op1 op2) `(not (equal ,op1 ,op2))) -(ps:defpsmacro ! (op1 op2) +(defpsmacro ! (op1 op2) `(not (equal ,op1 ,op2))) ;;; 4code -(ps:defpsmacro exec (&body body) - (format nil "javascript: ~{~A~^~%~}" (mapcar #'ps:ps* body))) +(defpsmacro exec (&body body) + (format nil "javascript: ~{~A~^~%~}" (mapcar #'ps* body))) ;;; 5arrays ;;; 6str -(ps:defpsmacro & (&rest args) - `(ps:chain "" (concat ,@args))) +(defpsmacro & (&rest args) + `(chain "" (concat ,@args))) ;;; 7if -(ps:defpsmacro qspcond (&rest clauses) +(defpsmacro qspcond (&rest clauses) `(cond ,@(loop :for clause :in clauses :collect (list (first clause) `(tagbody @@ -126,11 +89,11 @@ ;;; 9loops ;;; Yep, that's a huge kludge since Javascript doesn't support arbitrary labels -(ps:defpsmacro jump (target) +(defpsmacro jump (target) `(return-from ,(intern (string-upcase (second target))) - (funcall (ps:getprop __labels ,target)))) + (funcall (getprop __labels ,target)))) -(ps:defpsmacro tagbody (&body body) +(defpsmacro tagbody (&body body) (let ((funcs (list nil :__nil))) (dolist (form body) (cond ((keywordp form) @@ -146,30 +109,28 @@ ,@body) `(progn (setf ,@(loop :for f :on funcs :by #'cddr - :append `((ps:@ __labels ,(first f)) + :append `((@ __labels ,(first f)) (block ,(intern (string-upcase (string (first f)))) ,@(second f) ,@(when (third f) `((funcall - (ps:getprop __labels ,(third f))))))))) + (getprop __labels ,(third f))))))))) (jump (str "__nil")))))) ;;; 10dynamic -(ps:defpsmacro qspblock (&body body) - `(lambda (args) +(defpsmacro qspblock (&body body) + `(async-lambda (args) (label-block () - (api-call init-args args) - ,@body - (api-call get-result)))) + ,@body))) ;;; 11main -(ps:defpsmacro act (name img &body body) +(defpsmacro act (name img &body body) `(api-call add-act ,name ,img - (lambda () + (async-lambda () (label-block () - ,@body)))) + ,@body)))) ;;; 12aux @@ -193,11 +154,11 @@ ;;; 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)))) +(defpsmacro qspfor (var from to step &body body) + `((intern "QSPFOR" "API") + ,(string (second var)) ,(third var) ;; name and index + ,from ,to ,step + (lambda () + (block nil + ,@body + t)))) diff --git a/sugar-qsp.asd b/sugar-qsp.asd --- a/sugar-qsp.asd +++ b/sugar-qsp.asd @@ -9,7 +9,10 @@ :serial t :components ((:file "package") (:file "patches") + (:file "js-syms") + (:file "main-macros") (:file "ps-macros") + (:file "api-macros") (:file "intrinsic-macros") (:file "class") (:file "main")