|
|
|
|
|
(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)
|
|
|
(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*)
|
|
|
;; 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)
|
|
|
(exit)))
|
|
|
|
|
|
(defpsmacro xgoto% (target &rest args)
|
|
|
`(progn
|
|
|
(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)))))))))
|
|
|
|
|
|
(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))))
|
|
|
|
|
|
;;; 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))))
|
|
|
|
