src/non-cl.lisp

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