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 (() &body body)
  (let ((has-labels (some #'keywordp body)))
    `(block nil
       ,@(when has-labels
           '((defvar _labels)))
       (tagbody
          ,@body
          (void)))))

(defpsmacro str (&rest forms)
  (cond ((zerop (length forms))
         "")
        ((and (= 1 (length forms))
              (stringp (first forms)))
         (first forms))
        (t
         `(& ,@forms))))

;;; 1loc

(defpsmacro game ((name) &body body)
  `(progn
     (setf (root games ,name)
           (create))
     ,@(loop :for location :in body
          :collect `(setf (root games ,name ,(caadr location))
                          ,location))))

(defpsmacro location ((name) &body body)
  (declare (ignore name))
  "Name is used by the game macro above"
  `(async-lambda ()
     (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 label-body
     (funcall (getprop _labels ,(string-upcase (second target))))))

(defpsmacro tagbody (&body 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))
    (if (= 2 (length funcs))
        `(progn
           ,@body)
        `(progn
           (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"))))))

(defpsmacro exit ()
  '(return-from nil (values)))

;;; 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

(defpsmacro local (var &optional expr)
  `(progn
     (api-call new-local ,(string (second var)))
     ,@(when expr
         `((set ,var ,expr)))))

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