non-cl.lisp 10.1 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
  `(ps-js:object
86
87
    ,@(loop with allow-accessors = (vstring>= *js-target-version* "1.8.5")
            for (key val-expr) on arrows by #'cddr
88
            for (accessor . accessor-args) =
89
90
              (when (and allow-accessors
                         (consp key)
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
                         (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
114
115
116
117
118
119
                               (error "Slot key ~s is not one of ~
                                       ~{~a~#[~;, or ~:;, ~]~}."
                                      key
                                      `("symbol" "string" "number"
                                        ,@(when allow-accessors
                                            '("accessor spec"))))))
120
                        (compile-expression val-expr))))))
121
122
123
124
125
126

(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)))
127
        (aif (or (reserved-symbol-p (second expanded-slot))
128
                 (and (keywordp (second expanded-slot)) (second expanded-slot)))
129
130
131
             `(ps-js:aref ,obj ,it)
             `(ps-js:getprop ,obj ,(second expanded-slot)))
        `(ps-js:aref ,obj ,(compile-expression slot)))))
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159

(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))

(defpsmacro chain (&rest method-calls)
  (labels ((do-chain (method-calls)
             (if (cdr method-calls)
                 (if (listp (car method-calls))
                     `((@ ,(do-chain (cdr method-calls)) ,(caar method-calls)) ,@(cdar method-calls))
                     `(@ ,(do-chain (cdr method-calls)) ,(car method-calls)))
                 (car method-calls))))
    (do-chain (reverse method-calls))))

;;; var

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

(define-statement-operator var (name &optional (value (values) value?) docstr)
164
165
166
167
168
169
  (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))))))
170
171

(defmacro var (name &optional value docstr)
172
  `(defparameter ,name ,value ,@(when docstr (list docstr))))
173
174
175
176
177

;;; iteration

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

(define-statement-operator for-in ((var object) &rest body)
184
185
186
  `(ps-js:for-in ,(compile-expression var)
                 ,(compile-expression object)
                 ,(compile-loop-body (list var) body)))
187
188

(define-statement-operator while (test &rest body)
189
190
  `(ps-js:while ,(compile-expression test)
     ,(compile-loop-body () body)))
191
192
193
194
195
196
197

(defmacro while (test &body body)
  `(loop while ,test do (progn ,@body)))

;;; misc

(define-statement-operator try (form &rest clauses)
198
  (let ((catch   (cdr (assoc :catch clauses)))
199
        (finally (cdr (assoc :finally clauses))))
200
201
202
203
204
205
206
207
208
209
210
    (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))))))
211
212

(define-expression-operator regex (regex)
213
  `(ps-js:regex ,(string regex)))
214
215
216
217
218

(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.
219
  `(ps-js:escape
220
    (with-output-to-string (*psw-stream*)
221
222
223
224
225
      (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))))))
226
227
228
229

(defun lisp (x) x)

(defpsmacro undefined (x)
230
  `(eql "undefined" (typeof ,x)))
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249

(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)
Daniel Gackle's avatar
Daniel Gackle committed
250
      `((@ (list ,@things) join) "")))
251
252
253
254
(defun stringify (&rest things)
  "Like concatenate but prints all of its arguments."
  (format nil "~{~A~}" things))

255
(define-ps-symbol-macro false ps-js:false)
256
(defvar false nil)