ps-macros.lisp
163 lines
| 3.5 KiB
| text/x-common-lisp
|
CommonLispLexer
/ src / ps-macros.lisp
r1 | ||||
r25 | (in-package sugar-qsp.lib) | |||
r1 | ||||
;;;; Parenscript macros which make the parser's intermediate | ||||
;;;; representation directly compilable by Parenscript | ||||
;;;; Some utility macros for other .ps sources too. | ||||
;;; Utils | ||||
;;; Common | ||||
r27 | (defpsmacro label-block (() &body body) | |||
r14 | (let ((has-labels (some #'keywordp body))) | |||
`(block nil | ||||
,@(when has-labels | ||||
r28 | '((defvar _labels))) | |||
r27 | (tagbody | |||
,@body | ||||
(void))))) | ||||
r1 | ||||
r25 | (defpsmacro str (&rest forms) | |||
r1 | (cond ((zerop (length forms)) | |||
"") | ||||
((and (= 1 (length forms)) | ||||
(stringp (first forms))) | ||||
(first forms)) | ||||
(t | ||||
`(& ,@forms)))) | ||||
;;; 1loc | ||||
r25 | (defpsmacro location ((name) &body body) | |||
r11 | `(setf (root locs ,name) | |||
r25 | (async-lambda (args) | |||
(label-block () | ||||
,@body)))) | ||||
r1 | ||||
r25 | (defpsmacro goto% (target &rest args) | |||
r1 | `(progn | |||
r25 | (goto ,target ,args) | |||
r1 | (exit))) | |||
r25 | (defpsmacro xgoto% (target &rest args) | |||
r1 | `(progn | |||
r25 | (xgoto ,target ,args) | |||
r1 | (exit))) | |||
;;; 2var | ||||
r25 | (defpsmacro qspvar (name index slot) | |||
r16 | `(api-call get-var ,(string name) ,index ,slot)) | |||
r1 | ||||
r25 | (defpsmacro set ((var vname vindex vslot) value) | |||
(assert (eq var 'qspvar)) | ||||
r16 | `(api-call set-var ,(string vname) ,vindex ,vslot ,value)) | |||
r1 | ||||
;;; 3expr | ||||
r25 | (defpsmacro <> (op1 op2) | |||
r1 | `(not (equal ,op1 ,op2))) | |||
r25 | (defpsmacro ! (op1 op2) | |||
r1 | `(not (equal ,op1 ,op2))) | |||
;;; 4code | ||||
r25 | (defpsmacro exec (&body body) | |||
(format nil "javascript: ~{~A~^~%~}" (mapcar #'ps* body))) | ||||
r1 | ||||
;;; 5arrays | ||||
;;; 6str | ||||
r25 | (defpsmacro & (&rest args) | |||
`(chain "" (concat ,@args))) | ||||
r1 | ||||
;;; 7if | ||||
r25 | (defpsmacro qspcond (&rest clauses) | |||
r1 | `(cond ,@(loop :for clause :in clauses | |||
:collect (list (first clause) | ||||
r16 | `(tagbody | |||
,@(rest clause)))))) | ||||
r1 | ||||
;;; 8sub | ||||
;;; 9loops | ||||
;;; Yep, that's a huge kludge since Javascript doesn't support arbitrary labels | ||||
r25 | (defpsmacro jump (target) | |||
r28 | `(return-from label-body | |||
(funcall (getprop _labels ,(string-upcase (second target)))))) | ||||
r1 | ||||
r25 | (defpsmacro tagbody (&body body) | |||
r28 | (let ((funcs (list nil "_nil"))) | |||
r1 | (dolist (form body) | |||
(cond ((keywordp form) | ||||
(setf (first funcs) (reverse (first funcs))) | ||||
r28 | (push (string-upcase form) funcs) | |||
r1 | (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 | ||||
r28 | (setf ,@(loop :for (label code . rest-labels) :on funcs :by #'cddr | |||
:append `((@ _labels ,label) | ||||
(block label-body | ||||
(block ,(intern label) | ||||
,@code | ||||
,@(when rest-labels | ||||
`((funcall | ||||
(getprop _labels ,(first rest-labels)))))))))) | ||||
(funcall (getprop _labels "_nil")))))) | ||||
r1 | ||||
;;; 10dynamic | ||||
r25 | (defpsmacro qspblock (&body body) | |||
`(async-lambda (args) | ||||
r16 | (label-block () | |||
r25 | ,@body))) | |||
r1 | ||||
;;; 11main | ||||
r25 | (defpsmacro act (name img &body body) | |||
r6 | `(api-call add-act ,name ,img | |||
r25 | (async-lambda () | |||
r16 | (label-block () | |||
r27 | ,@body)))) | |||
r1 | ||||
;;; 12aux | ||||
;;; 13diag | ||||
;;; 14act | ||||
;;; 15objs | ||||
;;; 16menu | ||||
;;; 17sound | ||||
;;; 18img | ||||
;;; 19input | ||||
;;; 20time | ||||
r14 | ||||
;;; 21local | ||||
r17 | ||||
;;; 22for | ||||
r25 | (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)))) | ||||