non-cl.lisp 9.81 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
;;; Copyright 2005 Manuel Odendahl
;;; Copyright 2005-2006 Edward Marco Baringer
;;; Copyright 2006 Luca Capello
;;; Copyright 2010-2012 Vladimir Sedach
;;; Copyright 2012, 2014, 2015 Boris Smilga

;;; SPDX-License-Identifier: BSD-3-Clause

;;; Redistribution and use in source and binary forms, with or
;;; without modification, are permitted provided that the following
;;; conditions are met:

;;; 1. Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.

;;; 2. Redistributions in binary form must reproduce the above
;;; copyright notice, this list of conditions and the following
;;; disclaimer in the documentation and/or other materials provided
;;; with the distribution.

;;; 3. Neither the name of the copyright holder nor the names of its
;;; contributors may be used to endorse or promote products derived
;;; from this software without specific prior written permission.

;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND
;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS
;;; BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
;;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
;;; ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
;;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
;;; POSSIBILITY OF SUCH DAMAGE.
38

39
(in-package #:parenscript)
40
(in-readtable :parenscript)
41
42
43
44
45

;;; PS operators and macros that aren't present in the Common Lisp
;;; standard but exported by Parenscript, and their Common Lisp
;;; equivalent definitions

46
47
48
49
50
(defmacro define-trivial-special-ops (&rest mappings)
  `(progn ,@(loop for (form-name js-primitive) on mappings by #'cddr collect
                 `(define-expression-operator ,form-name (&rest args)
                    (cons ',js-primitive (mapcar #'compile-expression args))))))

51
(define-trivial-special-ops
52
53
54
55
56
57
58
  array      ps-js:array
  instanceof ps-js:instanceof
  typeof     ps-js:typeof
  new        ps-js:new
  delete     ps-js:delete
  in         ps-js:in ;; maybe rename to slot-boundp?
  break      ps-js:break
59
60
  <<         ps-js:<<
  >>         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
69
     ,@(loop for (val . body) in clauses collect
            (cons (if (eq val 'default)
70
                      'ps-js:default
71
72
                      (let ((in-case? t))
                        (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
78
79
80
81
82
83
84
                                  (cdr exp)
                                  (list exp))))
                          body)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; objects

(define-expression-operator create (&rest arrows)
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
  (let ((allow-accessors (js-target-at-least "1.8.5")))
    (cons
     'ps-js:object
     (loop for (key val-expr) on arrows by #'cddr
           for (accessor . accessor-args) =
             (when (and allow-accessors
                        (consp key)
                        (symbolp (first  key))
                        (symbolp (second key)))
               (case (first key)
                 (get (and (null (third key))
                           `((ps-js:get ,(second key)))))
                 (set (and (symbolp (third key)) (null (fourth key))
                           `((ps-js:set ,(second key)) ,(third key))))))
           collecting
             (if accessor
                 (list accessor accessor-args
                       (let ((*function-block-names* ()))
                         (compile-function-body (third accessor)
                                                (list val-expr))))
                 (cons (cond ((and (symbolp key) (reserved-symbol-p key))
                              (reserved-symbol-p key))
                             ((or (stringp key) (numberp key) (symbolp key))
                              key)
                             ((and (consp key)
                                   (eq 'quote (first  key))
                                   (symbolp   (second key))
                                   (null      (third  key)))
                              (symbol-to-js-string (second key)))
                             (t
                              (error "Slot key ~s is not one of ~
                                      ~{~a~#[~;, or ~:;, ~]~}."
                                     key
                                     (list* "symbol" "string" "number"
                                            (when allow-accessors
                                              '("accessor spec"))))))
                       (compile-expression val-expr)))))))
122
123
124
125
126
127

(define-expression-operator %js-getprop (obj slot)
  (let ((expanded-slot (ps-macroexpand slot))
        (obj (compile-expression obj)))
    (if (and (listp expanded-slot)
             (eq 'quote (car expanded-slot)))
128
        (aif (or (reserved-symbol-p (second expanded-slot))
129
                 (and (keywordp (second expanded-slot)) (second expanded-slot)))
130
131
132
             `(ps-js:aref ,obj ,it)
             `(ps-js:getprop ,obj ,(second expanded-slot)))
        `(ps-js:aref ,obj ,(compile-expression slot)))))
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147

(defpsmacro getprop (obj &rest slots)
  (if (null (rest slots))
      `(%js-getprop ,obj ,(first slots))
      `(getprop (getprop ,obj ,(first slots)) ,@(rest slots))))

(defpsmacro @ (obj &rest props)
  "Handy getprop/aref composition macro."
  (if props
      `(@ (getprop ,obj ,(if (symbolp (car props))
                             `',(car props)
                             (car props)))
          ,@(cdr props))
      obj))

148
149
150
151
152
153
154
155
(defun chain (method-calls)
  (let ((chain (car method-calls)))
    (dolist (next (cdr method-calls))
      (setf chain (if (consp next)
                      `(funcall (@ ,chain ,(car next)) ,@(cdr next))
                      `(@ ,chain ,next))))
    chain))

156
(defpsmacro chain (&rest method-calls)
157
  (chain method-calls))
158
159
160
161
162

;;; var

(define-expression-operator var (name &optional (value (values) value?) docstr)
  (declare (ignore docstr))
163
  (push name *vars-needing-to-be-declared*)
164
165
166
  (when value? (compile-expression `(setf ,name ,value))))

(define-statement-operator var (name &optional (value (values) value?) docstr)
167
168
169
170
171
172
  (let ((value (ps-macroexpand value)))
    (if (and (listp value) (eq 'progn (car value)))
        (ps-compile `(progn ,@(butlast (cdr value))
                            (var ,name ,(car (last value)))))
        `(ps-js:var ,(ps-macroexpand name)
                    ,@(when value? (list (compile-expression value) docstr))))))
173
174

(defmacro var (name &optional value docstr)
175
  `(defparameter ,name ,value ,@(when docstr (list docstr))))
176
177
178
179
180

;;; iteration

(define-statement-operator for (init-forms cond-forms step-forms &body body)
  (let ((init-forms (make-for-vars/inits init-forms)))
181
182
183
184
    `(ps-js:for ,init-forms
                ,(mapcar #'compile-expression cond-forms)
                ,(mapcar #'compile-expression step-forms)
                ,(compile-loop-body (mapcar #'car init-forms) body))))
185
186

(define-statement-operator for-in ((var object) &rest body)
187
188
189
  `(ps-js:for-in ,(compile-expression var)
                 ,(compile-expression object)
                 ,(compile-loop-body (list var) body)))
190
191
192
193

;;; misc

(define-statement-operator try (form &rest clauses)
194
  (let ((catch   (cdr (assoc :catch clauses)))
195
        (finally (cdr (assoc :finally clauses))))
196
197
198
199
200
201
202
203
204
205
206
    (assert (not (cdar catch)) ()
            "Sorry, currently only simple catch forms are supported.")
    (assert (or catch finally) ()
            "Try form should have either a catch or a finally clause or both.")
    `(ps-js:try
      ,(compile-statement `(progn ,form))
      :catch ,(when catch
                    (list (caar catch)
                          (compile-statement `(progn ,@(cdr catch)))))
      :finally ,(when finally
                      (compile-statement `(progn ,@finally))))))
207
208

(define-expression-operator regex (regex)
209
  `(ps-js:regex ,(string regex)))
210
211
212
213
214

(define-expression-operator lisp (lisp-form)
  ;; (ps (foo (lisp bar))) is like (ps* `(foo ,bar))
  ;; When called from inside of ps*, lisp-form has access to the
  ;; dynamic environment only, analogous to eval.
215
  `(ps-js:escape
216
    (with-output-to-string (*psw-stream*)
217
218
219
220
221
      (let ((compile-expression?   ,compile-expression?)
	    (*js-string-delimiter* ,*js-string-delimiter*)
            (eval-results          (multiple-value-list ,lisp-form)))
        (when eval-results
          (parenscript-print (ps-compile (car eval-results)) t))))))
222
223
224
225

(defun lisp (x) x)

(defpsmacro undefined (x)
226
  `(eql "undefined" (typeof ,x)))
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245

(defpsmacro defined (x)
  `(not (undefined ,x)))

(defpsmacro objectp (x)
  `(string= (typeof ,x) "object"))

(define-ps-symbol-macro {} (create))

(defpsmacro [] (&rest args)
  `(array ,@(mapcar (lambda (arg)
                      (if (and (consp arg) (not (equal '[] (car arg))))
                          (cons '[] arg)
                          arg))
                    args)))

(defpsmacro stringify (&rest things)
  (if (and (= (length things) 1) (stringp (car things)))
      (car things)
246
      `(funcall (getprop (list ,@things) 'join) "")))
247
248
249
250
(defun stringify (&rest things)
  "Like concatenate but prints all of its arguments."
  (format nil "~{~A~}" things))

251
(define-ps-symbol-macro false ps-js:false)
252
(defvar false nil)