|
|
|
|
|
(in-package sugar-qsp)
|
|
|
|
|
|
;;;; Parenscript macros which make the parser's intermediate
|
|
|
;;;; representation directly compilable by Parenscript
|
|
|
;;;; Some utility macros for other .ps sources too.
|
|
|
|
|
|
;;; Utils
|
|
|
|
|
|
(ps:defpsmacro defm (path args &body body)
|
|
|
`(setf ,path (lambda ,args ,@body)))
|
|
|
|
|
|
(ps:defpsmacro root (&rest path)
|
|
|
`(ps:@ *sugar-q-s-p ,@path))
|
|
|
|
|
|
(ps:defpsmacro in (key obj)
|
|
|
`(ps:chain ,obj (has-own-property ,key)))
|
|
|
|
|
|
;;; 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 (&body body)
|
|
|
(let ((has-labels (some #'keywordp body)))
|
|
|
`(block nil
|
|
|
,@(when has-labels
|
|
|
'((defvar __labels)))
|
|
|
(api-call push-local-frame)
|
|
|
(unwind-protect
|
|
|
(tagbody
|
|
|
,@body)
|
|
|
(api-call pop-local-frame))
|
|
|
(values))))
|
|
|
|
|
|
(ps:defpsmacro str (&rest forms)
|
|
|
(cond ((zerop (length forms))
|
|
|
"")
|
|
|
((and (= 1 (length forms))
|
|
|
(stringp (first forms)))
|
|
|
(first forms))
|
|
|
(t
|
|
|
`(& ,@forms))))
|
|
|
|
|
|
;;; 1loc
|
|
|
|
|
|
(ps:defpsmacro location ((name) &body body)
|
|
|
`(setf (root locs ,name)
|
|
|
(lambda ()
|
|
|
(label-block
|
|
|
,@body))))
|
|
|
|
|
|
(ps:defpsmacro goto (target &rest args)
|
|
|
`(progn
|
|
|
(funcall (root lib goto) ,target ,@args)
|
|
|
(exit)))
|
|
|
|
|
|
(ps:defpsmacro xgoto (target &rest args)
|
|
|
`(progn
|
|
|
(funcall (root lib xgoto) ,target ,@args)
|
|
|
(exit)))
|
|
|
|
|
|
(ps:defpsmacro desc (target)
|
|
|
(declare (ignore target))
|
|
|
(report-error "DESC is not supported"))
|
|
|
|
|
|
;;; 2var
|
|
|
|
|
|
(ps:defpsmacro var (name index)
|
|
|
`(api-call get-var ,(string name) ,index))
|
|
|
|
|
|
(ps:defpsmacro set ((var vname vindex) value)
|
|
|
(assert (eq var 'var))
|
|
|
`(api-call set-var ,(string vname) ,vindex ,value))
|
|
|
|
|
|
;;; 3expr
|
|
|
|
|
|
(ps:defpsmacro <> (op1 op2)
|
|
|
`(not (equal ,op1 ,op2)))
|
|
|
|
|
|
(ps:defpsmacro ! (op1 op2)
|
|
|
`(not (equal ,op1 ,op2)))
|
|
|
|
|
|
;;; 4code
|
|
|
|
|
|
(ps:defpsmacro exec (&body body)
|
|
|
(format nil "javascript: ~{~A~^~%~}" (mapcar #'ps:ps* body)))
|
|
|
|
|
|
;;; 5arrays
|
|
|
|
|
|
;;; 6str
|
|
|
|
|
|
(ps:defpsmacro & (&rest args)
|
|
|
`(ps:chain "" (concat ,@args)))
|
|
|
|
|
|
;;; 7if
|
|
|
|
|
|
(ps:defpsmacro qspcond (&rest clauses)
|
|
|
`(cond ,@(loop :for clause :in clauses
|
|
|
:collect (list (first clause)
|
|
|
`(tagbody ,@(rest clause))))))
|
|
|
|
|
|
;;; 8sub
|
|
|
|
|
|
;;; 9loops
|
|
|
;;; Yep, that's a huge kludge since Javascript doesn't support arbitrary labels
|
|
|
|
|
|
(ps:defpsmacro jump (target)
|
|
|
`(return-from ,(intern (string-upcase (second target)))
|
|
|
(funcall (ps:getprop __labels ,target))))
|
|
|
|
|
|
(ps:defpsmacro tagbody (&body body)
|
|
|
(let ((funcs (list nil :__nil)))
|
|
|
(dolist (form body)
|
|
|
(cond ((keywordp form)
|
|
|
(setf (first funcs) (reverse (first funcs)))
|
|
|
(push form funcs)
|
|
|
(push nil funcs))
|
|
|
(t
|
|
|
(push form (first funcs)))))
|
|
|
(setf (first funcs) (reverse (first funcs)))
|
|
|
(setf funcs (reverse funcs))
|
|
|
(if (= 2 (length funcs))
|
|
|
`(progn
|
|
|
,@body)
|
|
|
`(progn
|
|
|
(setf ,@(loop :for f :on funcs :by #'cddr
|
|
|
:append (list `(ps:@ __labels ,(first f))
|
|
|
`(block ,(intern (string-upcase (string (first f))))
|
|
|
,@(second f)
|
|
|
,@(when (third f)
|
|
|
`((funcall
|
|
|
(ps:getprop __labels ,(third f)))))))))
|
|
|
(jump (str "__nil"))))))
|
|
|
|
|
|
;;; 10dynamic
|
|
|
|
|
|
(ps:defpsmacro qspblock (&body body)
|
|
|
`(lambda ()
|
|
|
(label-block
|
|
|
,@body)))
|
|
|
|
|
|
;;; 11main
|
|
|
|
|
|
(ps:defpsmacro act (name img &body body)
|
|
|
`(api-call add-act ,name ,img
|
|
|
(lambda ()
|
|
|
(label-block
|
|
|
,@body))))
|
|
|
|
|
|
;;; 12aux
|
|
|
|
|
|
;;; 13diag
|
|
|
|
|
|
;;; 14act
|
|
|
|
|
|
;;; 15objs
|
|
|
|
|
|
;;; 16menu
|
|
|
|
|
|
;;; 17sound
|
|
|
|
|
|
;;; 18img
|
|
|
|
|
|
;;; 19input
|
|
|
|
|
|
;;; 20time
|
|
|
|
|
|
;;; 21local
|
|
|
|