ps-macros.lisp
181 lines
| 4.4 KiB
| text/x-common-lisp
|
CommonLispLexer
/ src / ps-macros.lisp
r1 | ||||
(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)) | ||||
r6 | (ps:defpsmacro in (key obj) | |||
`(ps:chain ,obj (has-own-property ,key))) | ||||
r1 | ;;; Common | |||
(defmacro defpsintrinsic (name) | ||||
`(ps:defpsmacro ,name (&rest args) | ||||
r6 | `(funcall (root lib ,',name) | |||
r1 | ,@args))) | |||
(defmacro defpsintrinsics (() &rest names) | ||||
`(progn ,@(loop :for name :in names | ||||
:collect `(defpsintrinsic ,name)))) | ||||
(defpsintrinsics () | ||||
r11 | 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) | |||
r1 | ||||
(ps:defpsmacro api-call (func &rest args) | ||||
`(funcall (root api ,func) ,@args)) | ||||
(ps:defpsmacro label-block (&body body) | ||||
r14 | (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)))) | ||||
r1 | ||||
(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) | ||||
r11 | `(setf (root locs ,name) | |||
r6 | (lambda () | |||
(label-block | ||||
r11 | ,@body)))) | |||
r1 | ||||
(ps:defpsmacro goto (target &rest args) | ||||
`(progn | ||||
r6 | (funcall (root lib goto) ,target ,@args) | |||
r1 | (exit))) | |||
(ps:defpsmacro xgoto (target &rest args) | ||||
`(progn | ||||
r6 | (funcall (root lib xgoto) ,target ,@args) | |||
r1 | (exit))) | |||
(ps:defpsmacro desc (target) | ||||
r6 | (declare (ignore target)) | |||
r1 | (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 () | ||||
r6 | (label-block | |||
,@body))) | ||||
r1 | ||||
;;; 11main | ||||
r6 | (ps:defpsmacro act (name img &body body) | |||
`(api-call add-act ,name ,img | ||||
(lambda () | ||||
(label-block | ||||
,@body)))) | ||||
r1 | ||||
;;; 12aux | ||||
;;; 13diag | ||||
;;; 14act | ||||
;;; 15objs | ||||
;;; 16menu | ||||
;;; 17sound | ||||
;;; 18img | ||||
;;; 19input | ||||
;;; 20time | ||||
r14 | ||||
;;; 21local | ||||