src/ps-macros.lisp

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

(ps:defpsmacro in (key obj)
  `(ps:chain ,obj (has-own-property ,key)))

(ps:defpsmacro get-id-contents (id)
  `(if (var "USEHTML" 0)
       (ps:chain (document.get-element-by-id ,id) inner-h-t-m-l)
       (ps:chain (document.get-element-by-id ,id) inner-text)))

(ps:defpsmacro set-id-contents (id contents)
  `(if (var "USEHTML" 0)
       (setf (ps:chain (document.get-element-by-id ,id) inner-h-t-m-l) ,contents)
       (setf (ps:chain (document.get-element-by-id ,id) inner-text) ,contents)))

(ps:defpsmacro append-id-contents (id contents)
  `(set-id-contents ,id (+ (get-id-contents ,id) ,contents)))

(ps:defpsmacro conserving-vars (vars &body body)
  "Calls body with safely stored away VARS, and restores their values after that returning what BODY returns."
  `(let ((__conserved (list ,@(loop :for var :in vars
                                 :collect `(var ,var 0)))))
     ,@(loop :for var :in vars
          :collect `(set (var ,var 0) ,(if (char= #\$ (elt (string var) 0))
                                           "" 0)))
     (unwind-protect
          (progn ,@body)
       (progn
         ,@(loop :for var :in vars
                :for i from 0
              :collect `(set (var ,var 0) (ps:@ __conserved ,i)))))))

;;; Common

(defmacro defpsintrinsic (name)
  `(ps:defpsmacro ,name (&rest args)
     `(funcall (root lib ,',name)
               ,@args)))

(defmacro defpsintrinsics (() &rest names)
  `(progn ,@(loop :for name :in names
                 :collect `(defpsintrinsic ,name))))

(defpsintrinsics ()
    killvar obj loc no qspver curloc rand rnd qspmax qspmin killall copyarr arrsize arrpos arrcomp len mid ucase lcase trim replace instr isnum val qspstr strcomp strfind strpos iif gosub func dynamic dyneval main-p main-pl main-nl maintxt main-clear showstat stat-p stat-pl stat-nl stattxt stat-clear cls msg showacts delact curacts cla showobjs addobj delobj killobj countobj getobj menu play isplay close closeall refint view rgb showinput usertxt cmdclear input openqst addqst killqst opengame savegame wait msecscount settimer)

(ps:defpsmacro api-call (func &rest args)
  `(funcall (root api ,func) ,@args))

(ps:defpsmacro label-block (&body body)
  `(block nil
     ,@(when (some #'keywordp body)
         '((defvar __labels)))
     (tagbody
        ,@body)
     (values)))

(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)
  `(setf (root locations ,name)
         (lambda ()
           (label-block
            ,@body
            (api-call update-acts)))))

(ps:defpsmacro goto (target &rest args)
  `(progn
     (funcall (root lib goto) ,target ,@args)
     (exit)))

(ps:defpsmacro xgoto (target &rest args)
  `(progn
     (funcall (root lib xgoto) ,target ,@args)
     (exit)))

(ps:defpsmacro desc (target)
  (declare (ignore target))
  (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"))))))

(ps:defpsmacro exit ()
  `(return-from nil (values)))

;;; 10dynamic

(ps:defpsmacro qspblock (&body body)
  `(lambda ()
     (label-block
      ,@body)))

;;; 11main

(ps:defpsmacro act (name img &body body)
  `(api-call add-act ,name ,img
             (lambda ()
               (label-block
                ,@body))))

;;; 12aux

;;; 13diag

;;; 14act

;;; 15objs

;;; 16menu

;;; 17sound

;;; 18img

;;; 19input

;;; 20time