ps-macros.lisp
386 lines
| 10.6 KiB
| text/x-common-lisp
|
CommonLispLexer
/ src / ps-macros.lisp
r1 | ||||
r46 | (in-package txt2web.lib) | |||
r1 | ||||
;;;; Parenscript macros which make the parser's intermediate | ||||
;;;; representation directly compilable by Parenscript | ||||
;;;; Some utility macros for other .ps sources too. | ||||
r37 | ;;;; 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 | ||||
;;; | ||||
r40 | ;;; 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. | ||||
r37 | ||||
r1 | ;;; Utils | |||
;;; Common | ||||
r27 | (defpsmacro label-block (() &body body) | |||
r14 | (let ((has-labels (some #'keywordp body))) | |||
`(block nil | ||||
,@(when has-labels | ||||
r36 | '((var _labels (list)))) | |||
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)))) | ||||
r37 | (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)))) | ||||
r1 | ;;; 1loc | |||
r42 | (defparameter *special-variables* | |||
r37 | '((usehtml 0) | |||
(result 0) | ||||
r38 | ($result 0) | |||
($ongload 0) | ||||
($ongsave 0) | ||||
($onobjadd 0) | ||||
($onobjdel 0) | ||||
($onobjsel 0) | ||||
($onnewloc 0) | ||||
($onactsel 0) | ||||
($counter 0) | ||||
($usercom 0))) | ||||
r37 | ||||
r31 | (defpsmacro game ((name) &body body) | |||
r37 | (setf body (walker:walk 'for-transform body)) | |||
r42 | (setf *globals* *special-variables*) | |||
r37 | (walker:walk 'globals body) | |||
r31 | `(progn | |||
r37 | ;; Game object | |||
r39 | (setf (@ *games ,name) | |||
r31 | (create)) | |||
r37 | ;; Global variables from this game | |||
(create-globals ,*globals*) | ||||
;; Locations | ||||
r31 | ,@(loop :for location :in body | |||
r39 | :collect `(setf (@ *games ,name ,(caadr location)) | |||
r31 | ,location)))) | |||
r25 | (defpsmacro location ((name) &body body) | |||
r31 | (declare (ignore name)) | |||
"Name is used by the game macro above" | ||||
r37 | `(locals-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 | ||||
r37 | (defvar *globals* nil) | |||
(defvar *locals* nil) | ||||
(defpsmacro create-globals (globals) | ||||
r38 | (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 | ||||
r39 | (assign *globals | |||
r38 | (create | |||
,@(loop :for sym :in names | ||||
:for indexes := (indexes sym) | ||||
:for name := (string-upcase sym) | ||||
:append `(,name | ||||
(api-call new-var ,name ,@indexes))))))))) | ||||
r37 | ||||
(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 | ||||
r38 | ,@(loop :for (sym index) :in locals | |||
:for name := (string-upcase sym) | ||||
:append `(,name (api-call new-var ,name)))))))) | ||||
r37 | ||||
;; 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) | ||||
r38 | (= 2 (length form)) | |||
(eq 'str (first form)) | ||||
(stringp (second form)))) | ||||
r37 | ||||
(defun variable-number-p (form) | ||||
(and (listp form) | ||||
(eq 'qspvar (first form)) | ||||
(not ($-var-p (second form))))) | ||||
r1 | ||||
r37 | (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)) | ||||
r42 | (setf name (string-upcase name)) | |||
r37 | (let ((slot `(getprop | |||
,(if (member name *locals* :key #'first) | ||||
r39 | 'locals '*globals) | |||
r42 | ,name)) | |||
(index (walker:walk 'apply-vars index)) | ||||
(value (walker:walk 'apply-vars expr))) | ||||
r37 | (cond | |||
r42 | ((member name api:*serv-vars* :test #'equalp) | |||
`(api:set-serv-var ,name ,index ,value)) | ||||
r38 | ((null index) | |||
r42 | `(chain (elt ,slot) (push ,value))) | |||
r37 | ((or (numberp index) | |||
(variable-number-p index)) | ||||
r42 | `(setf (elt ,slot ,index) ,value)) | |||
r37 | ((or (literal-string-p index) | |||
(variable-string-p index)) | ||||
r42 | `(api:set-str-element ,slot ,index ,value)) | |||
r37 | (t | |||
r42 | `(api:set-any-element ,slot ,index ,value)))))) | |||
r37 | ||||
(walker:deftransform apply-vars local (var &optional expr) | ||||
r42 | ;; TODO: var can't be a service variable | |||
r37 | (when expr | |||
(walker:walk 'apply-vars (list 'set var expr)))) | ||||
(walker:deftransform apply-vars qspvar (name index) | ||||
(let ((slot `(getprop | ||||
r39 | ,(if (member name *locals* :key #'first) 'locals '*globals) | |||
r37 | ,(string-upcase name)))) | |||
(cond | ||||
r38 | ((null index) | |||
`(elt ,slot (1- (length ,slot)))) | ||||
r37 | ((or (numberp index) | |||
(variable-number-p index)) | ||||
r38 | `(elt ,slot ,(walker:walk-continue index))) | |||
r37 | ((or (literal-string-p index) | |||
(variable-string-p index)) | ||||
r38 | `(elt ,slot (@ ,slot :indexes ,(walker:walk-continue index)))) | |||
r37 | (t | |||
r38 | `(get-element ,slot ,(walker:walk-continue index)))))) | |||
r37 | ||||
(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)))) | ||||
r1 | ||||
;;; 3expr | ||||
r25 | (defpsmacro <> (op1 op2) | |||
r1 | `(not (equal ,op1 ,op2))) | |||
r25 | (defpsmacro ! (op1 op2) | |||
r1 | `(not (equal ,op1 ,op2))) | |||
r56 | (defpsmacro qspmod (&rest ops) | |||
(case (length ops) | ||||
(1 (first ops)) | ||||
(2 `(mod ,@ops)) | ||||
(t `(mod ,(first ops) (qspmod ,@(rest ops)))))) | ||||
r1 | ;;; 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 | |||
r56 | :for f := (if (eq 'txt2web::else (first clause)) | |||
't | ||||
(first clause)) | ||||
:collect (list f | ||||
r16 | `(tagbody | |||
,@(rest clause)))))) | ||||
r1 | ||||
;;; 8sub | ||||
;;; 9loops | ||||
;;; Yep, that's a huge kludge since Javascript doesn't support arbitrary labels | ||||
r25 | (defpsmacro jump (target) | |||
r36 | `(return-from label-body ,(string-upcase (second target)))) | |||
r1 | ||||
r25 | (defpsmacro tagbody (&body body) | |||
r37 | (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)))) | ||||
r36 | ||||
(defpsmacro tagbody-blocks (funcs) | ||||
`(setf ,@(loop :for (label code . rest-labels) :on funcs :by #'cddr | ||||
:append `((@ _labels ,label) | ||||
(async-lambda () | ||||
(block label-body | ||||
r37 | (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)))))) | ||||
r1 | ||||
r32 | (defpsmacro exit () | |||
'(return-from nil (values))) | ||||
r1 | ;;; 10dynamic | |||
r25 | (defpsmacro qspblock (&body body) | |||
r37 | `(locals-block | |||
,@body)) | ||||
(defpsmacro qsp-lambda (&body body) | ||||
r25 | `(async-lambda (args) | |||
r16 | (label-block () | |||
r25 | ,@body))) | |||
r1 | ||||
;;; 11main | ||||
r25 | (defpsmacro act (name img &body body) | |||
r6 | `(api-call add-act ,name ,img | |||
r37 | (locals-block | |||
,@body))) | ||||
r1 | ||||
;;; 12aux | ||||
;;; 13diag | ||||
;;; 14act | ||||
;;; 15objs | ||||
;;; 16menu | ||||
;;; 17sound | ||||
;;; 18img | ||||
;;; 19input | ||||
;;; 20time | ||||
r14 | ||||
;;; 21local | ||||
r17 | ||||
;;; 22for | ||||
r37 | ;; Transform because it creates a (set ...) hence it has to be processed | |||
r42 | ;; before the apply-vars transform. And macros are processed after all | |||
r37 | ;; 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)))) | ||||