src/non-cl.lisp

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