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