src/ps-macros.lisp

(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))))