src/non-cl.lisp

   1 (in-package #:parenscript)
   2
   3 ;;; PS operators and macros that aren't present in the Common Lisp
   4 ;;; standard but exported by Parenscript, and their Common Lisp
   5 ;;; equivalent definitions
   6
   7 (define-trivial-special-ops
   8   array      js:array
   9   instanceof js:instanceof
  10   typeof     js:typeof
  11   new        js:new
  12   delete     js:delete
  13   in         js:in ;; maybe rename to slot-boundp?
  14   break      js:break
  15   )
  16
  17 (defun array (&rest initial-contents)
  18   (make-array (length initial-contents) :initial-contents initial-contents))
  19
  20 (define-statement-operator continue (&optional label)
  21   `(js:continue ,label))
  22
  23 (define-statement-operator switch (test-expr &rest clauses)
  24   `(js:switch ,(compile-expression test-expr)
  25      ,@(loop for (val . body) in clauses collect
  26             (cons (if (eq val 'default)
  27                       'js:default
  28                       (compile-expression val))
  29                   (mapcan (lambda (x)
  30                             (let ((exp (compile-statement x)))
  31                               (if (and (listp exp) (eq 'js:block (car exp)))
  32                                   (cdr exp)
  33                                   (list exp))))
  34                           body)))))
  35
  36 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  37 ;;; objects
  38
  39 (define-expression-operator create (&rest arrows)
  40   `(js:object
  41     ,@(loop for (key val-expr) on arrows by #'cddr collecting
  42            (progn
  43              (assert (or (stringp key) (numberp key) (symbolp key))
  44                      ()
  45                      "Slot key ~s is not one of symbol, string or number."
  46                      key)
  47              (cons (aif (and (symbolp key) (reserved-symbol? key)) it key)
  48                    (compile-expression val-expr))))))
  49
  50 (define-expression-operator %js-getprop (obj slot)
  51   (let ((expanded-slot (ps-macroexpand slot))
  52         (obj (compile-expression obj)))
  53     (if (and (listp expanded-slot)
  54              (eq 'quote (car expanded-slot)))
  55         (aif (or (reserved-symbol? (second expanded-slot))
  56                  (and (keywordp (second expanded-slot)) (second expanded-slot)))
  57              `(js:aref ,obj ,it)
  58              `(js:getprop ,obj ,(second expanded-slot)))
  59         `(js:aref ,obj ,(compile-expression slot)))))
  60
  61 (defpsmacro getprop (obj &rest slots)
  62   (if (null (rest slots))
  63       `(%js-getprop ,obj ,(first slots))
  64       `(getprop (getprop ,obj ,(first slots)) ,@(rest slots))))
  65
  66 (defpsmacro @ (obj &rest props)
  67   "Handy getprop/aref composition macro."
  68   (if props
  69       `(@ (getprop ,obj ,(if (symbolp (car props))
  70                              `',(car props)
  71                              (car props)))
  72           ,@(cdr props))
  73       obj))
  74
  75 (defpsmacro chain (&rest method-calls)
  76   (labels ((do-chain (method-calls)
  77              (if (cdr method-calls)
  78                  (if (listp (car method-calls))
  79                      `((@ ,(do-chain (cdr method-calls)) ,(caar method-calls)) ,@(cdar method-calls))
  80                      `(@ ,(do-chain (cdr method-calls)) ,(car method-calls)))
  81                  (car method-calls))))
  82     (do-chain (reverse method-calls))))
  83
  84 ;;; var
  85
  86 (define-expression-operator var (name &optional (value (values) value?) docstr)
  87   (declare (ignore docstr))
  88   (push name *enclosing-lexical-block-declarations*)
  89   (when value? (compile-expression `(setf ,name ,value))))
  90
  91 (define-statement-operator var (name &optional (value (values) value?) docstr)
  92   `(js:var ,(ps-macroexpand name) ,@(when value? (list (compile-expression value) docstr))))
  93
  94 (defmacro var (name &optional value docstr)
  95   `(defparameter ,name ,@(when value (list value)) ,@(when docstr (list docstr))))
  96
  97 ;;; iteration
  98
  99 (define-statement-operator for (init-forms cond-forms step-forms &body body)
 100   (let ((init-forms (make-for-vars/inits init-forms)))
 101    `(js:for ,init-forms
 102             ,(mapcar #'compile-expression cond-forms)
 103             ,(mapcar #'compile-expression step-forms)
 104             ,(compile-loop-body (mapcar #'car init-forms) body))))
 105
 106 (define-statement-operator for-in ((var object) &rest body)
 107   `(js:for-in ,(compile-expression var)
 108               ,(compile-expression object)
 109               ,(compile-loop-body (list var) body)))
 110
 111 (define-statement-operator while (test &rest body)
 112   `(js:while ,(compile-expression test)
 113      ,(compile-loop-body () body)))
 114
 115 (defmacro while (test &body body)
 116   `(loop while ,test do (progn ,@body)))
 117
 118 ;;; misc
 119
 120 (define-statement-operator try (form &rest clauses)
 121   (let ((catch (cdr (assoc :catch clauses)))
 122         (finally (cdr (assoc :finally clauses))))
 123     (assert (not (cdar catch)) () "Sorry, currently only simple catch forms are supported.")
 124     (assert (or catch finally) () "Try form should have either a catch or a finally clause or both.")
 125     `(js:try ,(compile-statement `(progn ,form))
 126              :catch ,(when catch (list (caar catch) (compile-statement `(progn ,@(cdr catch)))))
 127              :finally ,(when finally (compile-statement `(progn ,@finally))))))
 128
 129 (define-expression-operator regex (regex)
 130   `(js:regex ,(string regex)))
 131
 132 (define-expression-operator lisp (lisp-form)
 133   ;; (ps (foo (lisp bar))) is like (ps* `(foo ,bar))
 134   ;; When called from inside of ps*, lisp-form has access to the
 135   ;; dynamic environment only, analogous to eval.
 136   `(js:escape
 137     (with-output-to-string (*psw-stream*)
 138       (let ((compile-expression? ,compile-expression?))
 139         (parenscript-print (ps-compile ,lisp-form) t)))))
 140
 141 (defun lisp (x) x)
 142
 143 (defpsmacro undefined (x)
 144   `(eql undefined ,x))
 145
 146 (defpsmacro defined (x)
 147   `(not (undefined ,x)))
 148
 149 (defpsmacro objectp (x)
 150   `(string= (typeof ,x) "object"))
 151
 152 (define-ps-symbol-macro {} (create))
 153
 154 (defpsmacro [] (&rest args)
 155   `(array ,@(mapcar (lambda (arg)
 156                       (if (and (consp arg) (not (equal '[] (car arg))))
 157                           (cons '[] arg)
 158                           arg))
 159                     args)))
 160
 161 (defpsmacro stringify (&rest things)
 162   (if (and (= (length things) 1) (stringp (car things)))
 163       (car things)
 164       `((@ (list ,@things) :join) "")))
 165 (defun stringify (&rest things)
 166   "Like concatenate but prints all of its arguments."
 167   (format nil "~{~A~}" things))
 168
 169 (define-ps-symbol-macro f js:f)
 170 (defvar f nil)
 171
 172 (define-ps-symbol-macro false js:f)
 173 (defvar false nil)