non-cl.lisp 8.28 KB
Newer Older
1
(in-package #:parenscript)
2
(in-readtable :parenscript)
3
4
5
6
7

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

8
9
10
11
12
(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))))))

13
(define-trivial-special-ops
14
15
16
17
18
19
20
  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
21
22
  <<         ps-js:<<
  >>         ps-js:>>
23
24
25
  )

(define-statement-operator continue (&optional label)
26
  `(ps-js:continue ,label))
27
28

(define-statement-operator switch (test-expr &rest clauses)
29
  `(ps-js:switch ,(compile-expression test-expr)
30
31
     ,@(loop for (val . body) in clauses collect
            (cons (if (eq val 'default)
32
                      'ps-js:default
33
34
                      (let ((in-case? t))
                        (compile-expression val)))
35
                  (mapcan (lambda (x)
36
                            (let* ((in-case? t)
37
                                   (exp      (compile-statement x)))
38
                              (if (and (listp exp) (eq 'ps-js:block (car exp)))
39
40
41
42
43
44
45
46
                                  (cdr exp)
                                  (list exp))))
                          body)))))

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

(define-expression-operator create (&rest arrows)
47
  `(ps-js:object
48
49
    ,@(loop with allow-accessors = (vstring>= *js-target-version* "1.8.5")
            for (key val-expr) on arrows by #'cddr
50
            for (accessor . accessor-args) =
51
52
              (when (and allow-accessors
                         (consp key)
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
                         (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
76
77
78
79
80
81
                               (error "Slot key ~s is not one of ~
                                       ~{~a~#[~;, or ~:;, ~]~}."
                                      key
                                      `("symbol" "string" "number"
                                        ,@(when allow-accessors
                                            '("accessor spec"))))))
82
                        (compile-expression val-expr))))))
83
84
85
86
87
88

(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)))
89
        (aif (or (reserved-symbol-p (second expanded-slot))
90
                 (and (keywordp (second expanded-slot)) (second expanded-slot)))
91
92
93
             `(ps-js:aref ,obj ,it)
             `(ps-js:getprop ,obj ,(second expanded-slot)))
        `(ps-js:aref ,obj ,(compile-expression slot)))))
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

(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))
122
  (push name *vars-needing-to-be-declared*)
123
124
125
  (when value? (compile-expression `(setf ,name ,value))))

(define-statement-operator var (name &optional (value (values) value?) docstr)
126
127
128
129
130
131
  (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))))))
132
133

(defmacro var (name &optional value docstr)
134
  `(defparameter ,name ,value ,@(when docstr (list docstr))))
135
136
137
138
139

;;; iteration

(define-statement-operator for (init-forms cond-forms step-forms &body body)
  (let ((init-forms (make-for-vars/inits init-forms)))
140
141
142
143
    `(ps-js:for ,init-forms
                ,(mapcar #'compile-expression cond-forms)
                ,(mapcar #'compile-expression step-forms)
                ,(compile-loop-body (mapcar #'car init-forms) body))))
144
145

(define-statement-operator for-in ((var object) &rest body)
146
147
148
  `(ps-js:for-in ,(compile-expression var)
                 ,(compile-expression object)
                 ,(compile-loop-body (list var) body)))
149
150

(define-statement-operator while (test &rest body)
151
152
  `(ps-js:while ,(compile-expression test)
     ,(compile-loop-body () body)))
153
154
155
156
157
158
159

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

;;; misc

(define-statement-operator try (form &rest clauses)
160
  (let ((catch   (cdr (assoc :catch clauses)))
161
        (finally (cdr (assoc :finally clauses))))
162
163
164
165
166
167
168
169
170
171
172
    (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))))))
173
174

(define-expression-operator regex (regex)
175
  `(ps-js:regex ,(string regex)))
176
177
178
179
180

(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.
181
  `(ps-js:escape
182
    (with-output-to-string (*psw-stream*)
183
184
      (let ((compile-expression? ,compile-expression?)
	    (*js-string-delimiter* ,*js-string-delimiter*))
185
186
187
188
189
        (parenscript-print (ps-compile ,lisp-form) t)))))

(defun lisp (x) x)

(defpsmacro undefined (x)
190
  `(eql "undefined" (typeof ,x)))
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209

(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
210
      `((@ (list ,@things) join) "")))
211
212
213
214
(defun stringify (&rest things)
  "Like concatenate but prints all of its arguments."
  (format nil "~{~A~}" things))

215
(define-ps-symbol-macro false ps-js:false)
216
(defvar false nil)