|
|
|
|
|
(in-package sugar-qsp.lib)
|
|
|
|
|
|
;;;; Parenscript macros which make the parser's intermediate
|
|
|
;;;; representation directly compilable by Parenscript
|
|
|
;;;; Some utility macros for other .ps sources too.
|
|
|
|
|
|
;;; Utils
|
|
|
|
|
|
;;; Common
|
|
|
|
|
|
(defpsmacro label-block ((&key (locals t)) &body body)
|
|
|
(let ((has-labels (some #'keywordp body)))
|
|
|
`(block nil
|
|
|
,@(when has-labels
|
|
|
'((defvar __labels)))
|
|
|
,@(if locals
|
|
|
`((tagbody
|
|
|
,@body))
|
|
|
`((tagbody
|
|
|
,@body))))))
|
|
|
|
|
|
(defpsmacro str (&rest forms)
|
|
|
(cond ((zerop (length forms))
|
|
|
"")
|
|
|
((and (= 1 (length forms))
|
|
|
(stringp (first forms)))
|
|
|
(first forms))
|
|
|
(t
|
|
|
`(& ,@forms))))
|
|
|
|
|
|
;;; 1loc
|
|
|
|
|
|
(defpsmacro location ((name) &body body)
|
|
|
`(setf (root locs ,name)
|
|
|
(async-lambda (args)
|
|
|
(label-block ()
|
|
|
,@body))))
|
|
|
|
|
|
(defpsmacro goto% (target &rest args)
|
|
|
`(progn
|
|
|
(goto ,target ,args)
|
|
|
(exit)))
|
|
|
|
|
|
(defpsmacro xgoto% (target &rest args)
|
|
|
`(progn
|
|
|
(xgoto ,target ,args)
|
|
|
(exit)))
|
|
|
|
|
|
;;; 2var
|
|
|
|
|
|
(defpsmacro qspvar (name index slot)
|
|
|
`(api-call get-var ,(string name) ,index ,slot))
|
|
|
|
|
|
(defpsmacro set ((var vname vindex vslot) value)
|
|
|
(assert (eq var 'qspvar))
|
|
|
`(api-call set-var ,(string vname) ,vindex ,vslot ,value))
|
|
|
|
|
|
;;; 3expr
|
|
|
|
|
|
(defpsmacro <> (op1 op2)
|
|
|
`(not (equal ,op1 ,op2)))
|
|
|
|
|
|
(defpsmacro ! (op1 op2)
|
|
|
`(not (equal ,op1 ,op2)))
|
|
|
|
|
|
;;; 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
|
|
|
:collect (list (first clause)
|
|
|
`(tagbody
|
|
|
,@(rest clause))))))
|
|
|
|
|
|
;;; 8sub
|
|
|
|
|
|
;;; 9loops
|
|
|
;;; Yep, that's a huge kludge since Javascript doesn't support arbitrary labels
|
|
|
|
|
|
(defpsmacro jump (target)
|
|
|
`(return-from ,(intern (string-upcase (second target)))
|
|
|
(funcall (getprop __labels ,target))))
|
|
|
|
|
|
(defpsmacro tagbody (&body body)
|
|
|
(let ((funcs (list nil :__nil)))
|
|
|
(dolist (form body)
|
|
|
(cond ((keywordp form)
|
|
|
(setf (first funcs) (reverse (first funcs)))
|
|
|
(push form funcs)
|
|
|
(push nil funcs))
|
|
|
(t
|
|
|
(push form (first funcs)))))
|
|
|
(setf (first funcs) (reverse (first funcs)))
|
|
|
(setf funcs (reverse funcs))
|
|
|
(if (= 2 (length funcs))
|
|
|
`(progn
|
|
|
,@body)
|
|
|
`(progn
|
|
|
(setf ,@(loop :for f :on funcs :by #'cddr
|
|
|
:append `((@ __labels ,(first f))
|
|
|
(block ,(intern (string-upcase (string (first f))))
|
|
|
,@(second f)
|
|
|
,@(when (third f)
|
|
|
`((funcall
|
|
|
(getprop __labels ,(third f)))))))))
|
|
|
(jump (str "__nil"))))))
|
|
|
|
|
|
;;; 10dynamic
|
|
|
|
|
|
(defpsmacro qspblock (&body body)
|
|
|
`(async-lambda (args)
|
|
|
(label-block ()
|
|
|
,@body)))
|
|
|
|
|
|
;;; 11main
|
|
|
|
|
|
(defpsmacro act (name img &body body)
|
|
|
`(api-call add-act ,name ,img
|
|
|
(async-lambda ()
|
|
|
(label-block ()
|
|
|
,@body))))
|
|
|
|
|
|
;;; 12aux
|
|
|
|
|
|
;;; 13diag
|
|
|
|
|
|
;;; 14act
|
|
|
|
|
|
;;; 15objs
|
|
|
|
|
|
;;; 16menu
|
|
|
|
|
|
;;; 17sound
|
|
|
|
|
|
;;; 18img
|
|
|
|
|
|
;;; 19input
|
|
|
|
|
|
;;; 20time
|
|
|
|
|
|
;;; 21local
|
|
|
|
|
|
;;; 22for
|
|
|
|
|
|
(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))))
|
|
|
|