src/non-cl.lisp

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