src/non-cl.lisp

   1 ;;; Copyright 2005 Manuel Odendahl
   2 ;;; Copyright 2005-2006 Edward Marco Baringer
   3 ;;; Copyright 2006 Luca Capello
   4 ;;; Copyright 2010-2012 Vladimir Sedach
   5 ;;; Copyright 2012, 2014, 2015 Boris Smilga
   6
   7 ;;; SPDX-License-Identifier: BSD-3-Clause
   8
   9 ;;; Redistribution and use in source and binary forms, with or
  10 ;;; without modification, are permitted provided that the following
  11 ;;; conditions are met:
  12
  13 ;;; 1. Redistributions of source code must retain the above copyright
  14 ;;; notice, this list of conditions and the following disclaimer.
  15
  16 ;;; 2. Redistributions in binary form must reproduce the above
  17 ;;; copyright notice, this list of conditions and the following
  18 ;;; disclaimer in the documentation and/or other materials provided
  19 ;;; with the distribution.
  20
  21 ;;; 3. Neither the name of the copyright holder nor the names of its
  22 ;;; contributors may be used to endorse or promote products derived
  23 ;;; from this software without specific prior written permission.
  24
  25 ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND
  26 ;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
  27 ;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
  28 ;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
  29 ;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS
  30 ;;; BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
  31 ;;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
  32 ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
  33 ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
  34 ;;; ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
  35 ;;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
  36 ;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
  37 ;;; POSSIBILITY OF SUCH DAMAGE.
  38
  39 (in-package #:parenscript)
  40 (in-readtable :parenscript)
  41
  42 ;;; PS operators and macros that aren't present in the Common Lisp
  43 ;;; standard but exported by Parenscript, and their Common Lisp
  44 ;;; equivalent definitions
  45
  46 (defmacro define-trivial-special-ops (&rest mappings)
  47   `(progn ,@(loop for (form-name js-primitive) on mappings by #'cddr collect
  48                  `(define-expression-operator ,form-name (&rest args)
  49                     (cons ',js-primitive (mapcar #'compile-expression args))))))
  50
  51 (define-trivial-special-ops
  52   array      ps-js:array
  53   instanceof ps-js:instanceof
  54   typeof     ps-js:typeof
  55   new        ps-js:new
  56   delete     ps-js:delete
  57   in         ps-js:in ;; maybe rename to slot-boundp?
  58   break      ps-js:break
  59   <<         ps-js:<<
  60   >>         ps-js:>>
  61   )
  62
  63 (define-statement-operator continue (&optional label)
  64   `(ps-js:continue ,label))
  65
  66 (define-statement-operator switch (test-expr &rest clauses)
  67   `(ps-js:switch ,(compile-expression test-expr)
  68      ,@(loop for (val . body) in clauses collect
  69             (cons (if (eq val 'default)
  70                       'ps-js:default
  71                       (let ((in-case? t))
  72                         (compile-expression val)))
  73                   (mapcan (lambda (x)
  74                             (let* ((in-case? t)
  75                                    (exp      (compile-statement x)))
  76                               (if (and (listp exp) (eq 'ps-js:block (car exp)))
  77                                   (cdr exp)
  78                                   (list exp))))
  79                           body)))))
  80
  81 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  82 ;;; objects
  83
  84 (define-expression-operator create (&rest arrows)
  85   `(ps-js:object
  86     ,@(loop with allow-accessors = (vstring>= *js-target-version* "1.8.5")
  87             for (key val-expr) on arrows by #'cddr
  88             for (accessor . accessor-args) =
  89               (when (and allow-accessors
  90                          (consp key)
  91                          (symbolp (first  key))
  92                          (symbolp (second key)))
  93                 (case (first key)
  94                   (get (and (null (third key))
  95                             `((ps-js:get ,(second key)))))
  96                   (set (and (symbolp (third key)) (null (fourth key))
  97                             `((ps-js:set ,(second key)) ,(third key))))))
  98             collecting
  99               (if accessor
 100                   (list accessor accessor-args
 101                         (let ((*function-block-names* ()))
 102                           (compile-function-body (third accessor)
 103                                                  (list val-expr))))
 104                   (cons (cond ((and (symbolp key) (reserved-symbol-p key))
 105                                (reserved-symbol-p key))
 106                               ((or (stringp key) (numberp key) (symbolp key))
 107                                key)
 108                               ((and (consp key)
 109                                     (eq 'quote (first  key))
 110                                     (symbolp   (second key))
 111                                     (null      (third  key)))
 112                                (symbol-to-js-string (second key)))
 113                               (t
 114                                (error "Slot key ~s is not one of ~
 115                                        ~{~a~#[~;, or ~:;, ~]~}."
 116                                       key
 117                                       `("symbol" "string" "number"
 118                                         ,@(when allow-accessors
 119                                             '("accessor spec"))))))
 120                         (compile-expression val-expr))))))
 121
 122 (define-expression-operator %js-getprop (obj slot)
 123   (let ((expanded-slot (ps-macroexpand slot))
 124         (obj (compile-expression obj)))
 125     (if (and (listp expanded-slot)
 126              (eq 'quote (car expanded-slot)))
 127         (aif (or (reserved-symbol-p (second expanded-slot))
 128                  (and (keywordp (second expanded-slot)) (second expanded-slot)))
 129              `(ps-js:aref ,obj ,it)
 130              `(ps-js:getprop ,obj ,(second expanded-slot)))
 131         `(ps-js:aref ,obj ,(compile-expression slot)))))
 132
 133 (defpsmacro getprop (obj &rest slots)
 134   (if (null (rest slots))
 135       `(%js-getprop ,obj ,(first slots))
 136       `(getprop (getprop ,obj ,(first slots)) ,@(rest slots))))
 137
 138 (defpsmacro @ (obj &rest props)
 139   "Handy getprop/aref composition macro."
 140   (if props
 141       `(@ (getprop ,obj ,(if (symbolp (car props))
 142                              `',(car props)
 143                              (car props)))
 144           ,@(cdr props))
 145       obj))
 146
 147 (defpsmacro chain (&rest method-calls)
 148   (labels ((do-chain (method-calls)
 149              (if (cdr method-calls)
 150                  (if (listp (car method-calls))
 151                      `((@ ,(do-chain (cdr method-calls)) ,(caar method-calls)) ,@(cdar method-calls))
 152                      `(@ ,(do-chain (cdr method-calls)) ,(car method-calls)))
 153                  (car method-calls))))
 154     (do-chain (reverse method-calls))))
 155
 156 ;;; var
 157
 158 (define-expression-operator var (name &optional (value (values) value?) docstr)
 159   (declare (ignore docstr))
 160   (push name *vars-needing-to-be-declared*)
 161   (when value? (compile-expression `(setf ,name ,value))))
 162
 163 (define-statement-operator var (name &optional (value (values) value?) docstr)
 164   (let ((value (ps-macroexpand value)))
 165     (if (and (listp value) (eq 'progn (car value)))
 166         (ps-compile `(progn ,@(butlast (cdr value))
 167                             (var ,name ,(car (last value)))))
 168         `(ps-js:var ,(ps-macroexpand name)
 169                     ,@(when value? (list (compile-expression value) docstr))))))
 170
 171 (defmacro var (name &optional value docstr)
 172   `(defparameter ,name ,value ,@(when docstr (list docstr))))
 173
 174 ;;; iteration
 175
 176 (define-statement-operator for (init-forms cond-forms step-forms &body body)
 177   (let ((init-forms (make-for-vars/inits init-forms)))
 178     `(ps-js:for ,init-forms
 179                 ,(mapcar #'compile-expression cond-forms)
 180                 ,(mapcar #'compile-expression step-forms)
 181                 ,(compile-loop-body (mapcar #'car init-forms) body))))
 182
 183 (define-statement-operator for-in ((var object) &rest body)
 184   `(ps-js:for-in ,(compile-expression var)
 185                  ,(compile-expression object)
 186                  ,(compile-loop-body (list var) body)))
 187
 188 (define-statement-operator while (test &rest body)
 189   `(ps-js:while ,(compile-expression test)
 190      ,(compile-loop-body () body)))
 191
 192 (defmacro while (test &body body)
 193   `(loop while ,test do (progn ,@body)))
 194
 195 ;;; misc
 196
 197 (define-statement-operator try (form &rest clauses)
 198   (let ((catch   (cdr (assoc :catch clauses)))
 199         (finally (cdr (assoc :finally clauses))))
 200     (assert (not (cdar catch)) ()
 201             "Sorry, currently only simple catch forms are supported.")
 202     (assert (or catch finally) ()
 203             "Try form should have either a catch or a finally clause or both.")
 204     `(ps-js:try
 205       ,(compile-statement `(progn ,form))
 206       :catch ,(when catch
 207                     (list (caar catch)
 208                           (compile-statement `(progn ,@(cdr catch)))))
 209       :finally ,(when finally
 210                       (compile-statement `(progn ,@finally))))))
 211
 212 (define-expression-operator regex (regex)
 213   `(ps-js:regex ,(string regex)))
 214
 215 (define-expression-operator lisp (lisp-form)
 216   ;; (ps (foo (lisp bar))) is like (ps* `(foo ,bar))
 217   ;; When called from inside of ps*, lisp-form has access to the
 218   ;; dynamic environment only, analogous to eval.
 219   `(ps-js:escape
 220     (with-output-to-string (*psw-stream*)
 221       (let ((compile-expression? ,compile-expression?)
 222             (*js-string-delimiter* ,*js-string-delimiter*))
 223         (parenscript-print (ps-compile ,lisp-form) t)))))
 224
 225 (defun lisp (x) x)
 226
 227 (defpsmacro undefined (x)
 228   `(eql "undefined" (typeof ,x)))
 229
 230 (defpsmacro defined (x)
 231   `(not (undefined ,x)))
 232
 233 (defpsmacro objectp (x)
 234   `(string= (typeof ,x) "object"))
 235
 236 (define-ps-symbol-macro {} (create))
 237
 238 (defpsmacro [] (&rest args)
 239   `(array ,@(mapcar (lambda (arg)
 240                       (if (and (consp arg) (not (equal '[] (car arg))))
 241                           (cons '[] arg)
 242                           arg))
 243                     args)))
 244
 245 (defpsmacro stringify (&rest things)
 246   (if (and (= (length things) 1) (stringp (car things)))
 247       (car things)
 248       `((@ (list ,@things) join) "")))
 249 (defun stringify (&rest things)
 250   "Like concatenate but prints all of its arguments."
 251   (format nil "~{~A~}" things))
 252
 253 (define-ps-symbol-macro false ps-js:false)
 254 (defvar false nil)