special-operators.lisp 27.4 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 2007-2012 Vladimir Sedach
;;; Copyright 2011-2013 Daniel Gackle
;;; Copyright 2014 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
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; arithmetic and logic
44

45
(define-trivial-special-ops
46
47
48
49
50
51
52
53
54
55
56
  +          ps-js:+
  -          ps-js:-
  *          ps-js:*
  rem        ps-js:%
  and        ps-js:&&
  or         ps-js:\|\|

  logand     ps-js:&
  logior     ps-js:\|
  logxor     ps-js:^
  lognot     ps-js:~
57

58
  aref       ps-js:aref
59

60
  funcall    ps-js:funcall
61
  )
Vladimir Sedach's avatar
Vladimir Sedach committed
62

63
(define-expression-operator / (&rest args)
64
  `(ps-js:/ ,@(unless (cdr args) (list 1)) ,@(mapcar #'compile-expression args)))
65

66
67
68
69
(define-expression-operator + (&rest args)
  (let ((args (mapcar #'compile-expression args)))
    (cons (if (cdr args) 'ps-js:+ 'ps-js:unary-plus) args)))

70
(define-expression-operator - (&rest args)
Vladimir Sedach's avatar
Vladimir Sedach committed
71
  (let ((args (mapcar #'compile-expression args)))
72
    (cons (if (cdr args) 'ps-js:- 'ps-js:negate) args)))
Vladimir Sedach's avatar
Vladimir Sedach committed
73
74
75
76

(defun fix-nary-comparison (operator objects)
  (let* ((tmp-var-forms (butlast (cdr objects)))
         (tmp-vars (loop repeat (length tmp-var-forms)
77
                         collect (ps-gensym '_cmp)))
Vladimir Sedach's avatar
Vladimir Sedach committed
78
79
80
81
82
83
84
85
86
         (all-comparisons (append (list (car objects))
                                  tmp-vars
                                  (last objects))))
    `(let ,(mapcar #'list tmp-vars tmp-var-forms)
       (and ,@(loop for x1 in all-comparisons
                    for x2 in (cdr all-comparisons)
                    collect (list operator x1 x2))))))

(macrolet ((define-nary-comparison-forms (&rest mappings)
87
             `(progn
Vladimir Sedach's avatar
Vladimir Sedach committed
88
                ,@(loop for (form js-primitive) on mappings by #'cddr collect
89
                       `(define-expression-operator ,form (&rest objects)
Vladimir Sedach's avatar
Vladimir Sedach committed
90
91
92
93
94
95
                          (if (cddr objects)
                              (ps-compile
                               (fix-nary-comparison ',form objects))
                              (cons ',js-primitive
                                    (mapcar #'compile-expression objects))))))))
  (define-nary-comparison-forms
96
97
98
99
100
101
    <     ps-js:<
    >     ps-js:>
    <=    ps-js:<=
    >=    ps-js:>=
    eql   ps-js:===
    equal ps-js:==))
102

103
(define-expression-operator /= (a b)
Vladimir Sedach's avatar
Vladimir Sedach committed
104
105
  ;; for n>2, /= is finding duplicates in an array of numbers (ie -
  ;; nontrivial runtime algorithm), so we restrict it to binary in PS
106
  `(ps-js:!== ,(compile-expression a) ,(compile-expression b)))
Vladimir Sedach's avatar
Vladimir Sedach committed
107

108
109
110
111
112
113
114
115
116
117
118
119
120
(defun references? (exp place)
  (cond ((not exp) nil)
        ((atom exp) (equal exp place))
        (t (or (equal exp place)
               (references? (car exp) place)
               (references? (cdr exp) place)))))

(defmacro inc-dec (op op1 op2)
  `(let ((delta (ps-macroexpand delta)))
     (cond ((eql delta 1)
            (list ',op1 (compile-expression x)))
           ((references? delta x)
            (ps-compile
121
             (let ((var (ps-gensym '_ps_incr_place)))
122
123
124
125
126
127
               `(let ((,var ,delta))
                  (,',op ,x ,var)))))
           (t
            (list ',op2 (compile-expression x)
                  (compile-expression delta))))))

128
(define-expression-operator incf (x &optional (delta 1))
129
  (inc-dec incf ps-js:++ ps-js:+=))
130

131
(define-expression-operator decf (x &optional (delta 1))
132
  (inc-dec decf ps-js:-- ps-js:-=))
Vladimir Sedach's avatar
Vladimir Sedach committed
133
134
135

(let ((inverses (mapcan (lambda (x)
                          (list x (reverse x)))
136
137
138
139
                        '((ps-js:=== ps-js:!==)
                          (ps-js:== ps-js:!=)
                          (ps-js:< ps-js:>=)
                          (ps-js:> ps-js:<=)))))
140
  (define-expression-operator not (x)
Vladimir Sedach's avatar
Vladimir Sedach committed
141
    (let ((form (compile-expression x)))
Daniel Gackle's avatar
Daniel Gackle committed
142
      (acond ((and (listp form) (eq (car form) 'ps-js:!)) ;; not not → identity
Vladimir Sedach's avatar
Vladimir Sedach committed
143
              (second form))
Daniel Gackle's avatar
Daniel Gackle committed
144
             ((and (listp form) (cadr (assoc (car form) inverses))) ;; not equal → !=
Vladimir Sedach's avatar
Vladimir Sedach committed
145
              `(,it ,@(cdr form)))
146
             (t `(ps-js:! ,form))))))
147

148
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
149
;;; blocks and control flow
150
151

(defun compile-progn (body)
152
153
154
155
156
157
  (let ((block (flatten-blocks (mapcar #'ps-compile body))))
    (append (remove-if #'constantp (butlast block))
            (unless (and (or (eq *compilation-level* :toplevel)
                             (not compile-expression?))
                         (not (car (last block))))
              (last block)))))
158
159
160

(define-expression-operator progn (&rest body)
  (if (cdr body)
161
      `(ps-js:|,| ,@(compile-progn body))
162
163
164
      (compile-expression (car body))))

(define-statement-operator progn (&rest body)
165
  `(ps-js:block ,@(compile-progn body)))
166

167
(defvar returning-values? nil)
168

169
170
171
172
(defun wrap-for-dynamic-return (handled-tags body)
  (aif (loop for (tag . thrown?) in *dynamic-return-tags*
             when (and thrown? (member tag handled-tags))
             collect tag)
173
       (with-ps-gensyms (_ps_err)
174
         (flet ((make-catch-clause (tag)
175
176
177
                  `((and ,_ps_err (eql ',tag
                                       (getprop ,_ps_err :__ps_block_tag)))
                    (return-from ,tag
178
179
                      (getprop ,_ps_err :__ps_value)
                      t))))
180
181
182
           `(ps-js:block
               (ps-js:try
                ,body
183
184
185
186
187
                :catch (,_ps_err
                        ,(compile-statement
                          `(progn (cond
                                    ,@(mapcar #'make-catch-clause it)
                                    (t (throw ,_ps_err))))))
188
189
                :finally nil))))
       body))
190

191
(define-statement-operator block (name &rest body)
192
  (if in-function-scope?
193
194
      (let* ((name                  (or name 'nilBlock))
             (in-loop-scope?        (if name in-loop-scope? nil))
195
196
             (*dynamic-return-tags* (cons (cons name nil)
                                          *dynamic-return-tags*))
197
198
199
             (*current-block-tag*   name)
             (compiled-body         (wrap-for-dynamic-return
                                     (list name)
200
                                     (ps-compile `(progn ,@body)))))
201
        ;; this probably does not nest correctly
202
        (if (tree-find `(ps-js:break ,name) compiled-body)
203
204
            `(ps-js:label ,name ,compiled-body)
            compiled-body))
205
      (ps-compile (with-lambda-scope `(block ,name ,@body)))))
206

207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
(define-expression-operator values (&rest forms)
  (ps-compile
   (with-ps-gensyms (val)
     `(let ((,val ,(car forms)))
        (setf __PS_MV_REG (list ,@(cdr forms)))
        ,val))))

(define-expression-operator values-list (list)
  (ps-compile
   (with-ps-gensyms (values-list firstval)
     `(let ((,values-list (funcall (getprop ,list 'slice))))
        (setf ,firstval   (funcall (getprop ,values-list 'shift))
              __PS_MV_REG ,values-list)
        ,firstval))))

222
223
224
(define-statement-operator %simple-lexical-return (&rest value)
  `(ps-js:return ,@value))

225
(defun return-exp (tag &optional (value nil value?))
226
227
  (flet ((lexical-return ()
           (let ((X (when value? (list (compile-expression value)))))
228
229
230
             (ps-compile
              (if (and (not returning-values?) clear-multiple-values?)
                  `(progn
231
                     (setf __PS_MV_REG '())
232
233
                     (%simple-lexical-return ,@X))
                  `(%simple-lexical-return ,@X))))))
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
    (acond
      ((eql tag *current-block-tag*)
       (compile-statement
        `(progn
           ,@(when (and (not returning-values?) clear-multiple-values?)
               '((setf __PS_MV_REG '())))
           ,@(when value? (list value))
           (break ,tag))))

      ((or (eql '%function tag)
           (member tag *function-block-names*))
       (lexical-return))

      ((assoc tag *dynamic-return-tags*)
       (setf (cdr it) t)
       (ps-compile
        `(progn
251
           ,@(unless returning-values?
252
253
254
255
256
257
258
259
               '((setf __PS_MV_REG '())))
           (throw (create
                   :__ps_block_tag ',tag
                   :__ps_value     ,value)))))

      (t
       (warn "Returning from unknown block ~A" tag)
       (lexical-return)))))
260

261
(defun try-expressionizing-if? (exp &optional (score 0)) ;; poor man's codewalker
262
  "Heuristic that tries not to expressionize deeply nested if expressions."
263
  (cond ((< 1 score) nil)
264
265
        ((and (listp exp) (eq (car exp) 'quote))
         t)
266
267
268
        ((listp exp)
         (loop for x in (cdr exp) always
              (try-expressionizing-if?
269
               (or (ignore-errors (ps-macroexpand x))
270
                   x) ;; fail
271
               (+ score (case (car exp)
272
273
                          ((if cond) 1)
                          (let (if (second exp) 1 0)) ;; ignore empty binding list
274
275
276
277
                          ((progn) (1- (length (cdr exp))))
                          (otherwise 0))))))
        (t t)))

278
(defun return-result-of (tag form)
279
280
  (ps-compile
   (case (car form)
281
282
     ((continue break throw) ;; non-local exit
      form)
283
     ;; implicit progn forms
284
     ((with) ;; deprecated and will be removed
285
286
287
      `(,(first form) ,(second form)
         ,@(butlast (cddr form))
         (return-from ,tag ,(car (last (cddr form))))))
288
289
290
291
292
293
294
295
     ;; implicit body (declaration + progn) forms
     ((let flet labels macrolet symbol-macrolet)
      (multiple-value-bind (body declarations)
          (parse-body (cddr form))
        `(,(first form) ,(second form)
           ,@declarations
           ,@(butlast body)
           (return-from ,tag ,(car (last body))))))
296
     ((progn locally)
297
298
299
300
301
302
       `(progn ,@(butlast (cdr form))
               (return-from ,tag ,(car (last (cdr form))))))
     (switch
      `(switch
        ,(second form)
        ,@(loop for (cvalue . cbody) in (cddr form)
Daniel Gackle's avatar
Daniel Gackle committed
303
304
305
306
307
                for remaining on (cddr form) collect
                (aif (cond ((or (eq 'default cvalue) (not (cdr remaining)))
                            1)
                           ((eq 'break (car (last cbody)))
                            2))
308
309
                     (let ((result-form (ps-macroexpand
                                         (car (last cbody it)))))
Daniel Gackle's avatar
Daniel Gackle committed
310
311
312
313
314
                       `(,cvalue
                         ,@(butlast cbody it)
                         (return-from ,tag
                           ,(if (eq result-form 'break) nil result-form))))
                     (cons cvalue cbody)))))
315
316
317
318
319
320
321
     (try
      `(try (return-from ,tag ,(second form))
            ,@(let ((catch (cdr (assoc :catch (cdr form))))
                    (finally (assoc :finally (cdr form))))
                   (list (when catch
                           `(:catch ,(car catch)
                              ,@(butlast (cdr catch))
322
323
                              (return-from ,tag
                                ,(car (last (cdr catch))))))
324
325
326
327
                         finally))))
     (cond
       `(cond
          ,@(loop for clause in (cdr form) collect
Daniel Gackle's avatar
Daniel Gackle committed
328
                  `(,@(butlast clause) (return-from ,tag ,(car (last clause)))))
329
          ,@(when in-case? `((t (return-from ,tag nil))))))
330
     (if
331
      (if (and (try-expressionizing-if? form)
332
               (not (tree-find 'values form))
333
334
               (let ((used-up-names                   *used-up-names*)
                     (*lambda-wrappable-statements*                ()))
335
336
337
338
                 (handler-case (compile-expression form)
                   (compile-expression-error ()
                     (setf *used-up-names* used-up-names)
                     nil))))
339
          (return-from return-result-of (return-exp tag form))
Daniel Gackle's avatar
Daniel Gackle committed
340
341
342
          `(if ,(second form)
               (return-from ,tag ,(third form))
               ,@(when (or in-case? (fourth form))
343
                   `((return-from ,tag ,(fourth form)))))))
344
     (block
345
346
347
      (let* ((tag                   (or (cadr form) 'nilBlock))
             (*function-block-names* (cons tag *function-block-names*))
             (*dynamic-return-tags*  (cons (cons tag nil)
348
                                           *dynamic-return-tags*)))
349
        (return-from return-result-of
350
          (wrap-for-dynamic-return
351
           (list tag)
352
           (ps-compile `(return-from ,tag (progn ,@(cddr form))))))))
353
     (values
354
355
356
357
358
359
      (if (cddr form)
          (with-ps-gensyms (val)
            `(let ((,val ,(cadr form)))
               (setf __PS_MV_REG (list ,@(cddr form)))
               (return-from ,tag ,val t)))
          `(return-from ,tag ,@(cdr form))))
360
361
362
363
364
365
     (values-list
      (with-ps-gensyms (values-list firstval)
        `(let ((,values-list (funcall (getprop ,(cadr form) 'slice))))
           (setf ,firstval   (funcall (getprop ,values-list 'shift))
                 __PS_MV_REG ,values-list)
           (return-from ,tag ,firstval t))))
366
367
368
369
370
371
     (return-from ;; this will go away someday
      (unless tag
        (warn 'simple-style-warning
              :format-control "Trying to RETURN a RETURN without a block tag specified. Perhaps you're still returning values from functions by hand?
Parenscript now implements implicit return, update your code! Things like (lambda () (return x)) are not valid Common Lisp and may not be supported in future versions of Parenscript."))
       form)
372
     (otherwise
373
      (return-from return-result-of
374
375
376
377
378
        (cond ((not (gethash (car form) *special-statement-operators*))
               (return-exp tag form))
              (in-case?
               `(ps-js:block ,(compile-statement form) ,(return-exp tag)))
              (t (compile-statement form))))))))
379

380
(define-statement-operator return-from (tag &optional
381
382
                                            (result nil result?)
                                            returning-values?)
383
  (setq tag (or tag 'nilBlock))
384
385
386
387
388
389
  (if result?
      (let ((form (ps-macroexpand result)))
        (if (atom form)
            (return-exp tag form)
            (return-result-of tag form)))
      (return-exp tag)))
390

391
392
393
(define-statement-operator throw (&rest args)
  `(ps-js:throw ,@(mapcar #'compile-expression args)))

Vladimir Sedach's avatar
Vladimir Sedach committed
394
395
396
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; conditionals

397
(define-expression-operator if (test then &optional else)
Daniel Gackle's avatar
Daniel Gackle committed
398
399
400
  `(ps-js:? ,(compile-expression test)
            ,(compile-expression then)
            ,(compile-expression else)))
401
402

(define-statement-operator if (test then &optional else)
403
  `(ps-js:if ,(compile-expression test)
404
405
406
             ,(compile-statement `(progn ,then))
             ,@(when else
                     `(:else ,(compile-statement `(progn ,else))))))
407
408
409
410
411
412

(define-expression-operator cond (&rest clauses)
  (compile-expression
   (when clauses
     (destructuring-bind (test &rest body) (car clauses)
       (if (eq t test)
413
414
415
416
417
418
419
420
421
422
           (if (null body) t `(progn ,@body))
           (flet ((conditional (test body)
                    `(if ,test
                         (progn ,@body)
                         (cond ,@(cdr clauses)))))
             (if (null body)
                 (with-ps-gensyms (test-result)
                   `(let ((,test-result ,test))
                      ,(conditional test-result (list test-result))))
                 (conditional test body))))))))
423
424

(define-statement-operator cond (&rest clauses)
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
  (let* ((test-result nil)
         (clauses*
           (loop for clause in clauses for (test . body) = clause
                 if body
                   collect clause
                 else
                   do (unless test-result (setq test-result (ps-gensym)))
                   and collect
                     (if (and (consp test) (eq (first test) 'return-from))
                         (cons `(setq ,test-result ,(third test))
                               `((return-from ,(second test) ,test-result)))
                         (cons `(setq ,test-result ,test)
                               `(,test-result)))))
         (if-form
           `(ps-js:if
              ,(compile-expression (caar clauses*))
              ,(compile-statement `(progn ,@(cdar clauses*)))
              ,@(loop for (test . body) in (cdr clauses*) appending
                  (if (eq t test)
                      `(:else ,(compile-statement `(progn ,@body)))
                      `(:else-if ,(compile-expression test)
                                 ,(compile-statement `(progn ,@body))))))))
    (if test-result
        `(ps-js:block (ps-js:var ,test-result) ,if-form)
        if-form)))
450

451
452
453
454
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; binding

(defmacro with-declaration-effects ((var block) &body body)
455
  (with-ps-gensyms (decls)
456
    `(multiple-value-bind (,var ,decls) (parse-body ,block)
457
       (let ((*special-variables*
458
459
460
461
462
463
              (nconc
               (loop for decl in ,decls nconc
                    (loop for (decl-type . decl-args) in (cdr decl)
                          if (eq decl-type 'special)
                          append decl-args))
               *special-variables*)))
464
         ,@body))))
465

Vladimir Sedach's avatar
Vladimir Sedach committed
466
467
468
(defun maybe-rename-lexical-var (x symbols-in-bindings)
  (when (or (member x *enclosing-lexicals*)
            (member x *enclosing-function-arguments*)
469
470
            (when (boundp '*used-up-names*)
              (member x *used-up-names*))
Vladimir Sedach's avatar
Vladimir Sedach committed
471
472
473
474
            (lookup-macro-def x *symbol-macro-env*)
            (member x symbols-in-bindings))
    (ps-gensym (symbol-name x))))

475
476
477
478
479
480
481
(defun with-lambda-scope (form)
  (prog1 (if (tree-find 'this
                        (let ((*ps-gensym-counter* *ps-gensym-counter*))
                          (ps-compile `(lambda () ,form))))
             `(funcall (getprop (lambda () ,form) 'call) this)
             `((lambda () ,form)))
    (setf *vars-needing-to-be-declared* ())))
482

483
(define-expression-operator let (bindings &body body)
484
  (with-declaration-effects (body body)
Vladimir Sedach's avatar
Vladimir Sedach committed
485
    (flet ((rename (x) (first x))
486
487
           (var    (x) (second x))
           (val    (x) (third x)))
Vladimir Sedach's avatar
Vladimir Sedach committed
488
      (let* ((new-lexicals ())
489
             (loop-scoped-lexicals ())
Vladimir Sedach's avatar
Vladimir Sedach committed
490
491
492
493
494
495
496
497
498
499
             (normalized-bindings
              (mapcar (lambda (x)
                        (if (symbolp x)
                            (list x nil)
                            (list (car x) (ps-macroexpand (cadr x)))))
                      bindings))
             (symbols-in-bindings
              (mapcan (lambda (x) (flatten (cadr x)))
                      normalized-bindings))
             (lexical-bindings
500
501
502
503
504
505
506
507
508
509
510
511
512
513
              (mapcan
               (lambda (x)
                 (unless (special-variable? (car x))
                   (let ((renamed (maybe-rename-lexical-var
                                   (car x) symbols-in-bindings)))
                     (if renamed
                         (when in-loop-scope?
                           (push renamed loop-scoped-lexicals))
                         (progn
                           (push (car x) new-lexicals)
                           (when (boundp '*used-up-names*)
                             (push (car x) *used-up-names*))))
                     (list (cons renamed x)))))
               normalized-bindings))
Vladimir Sedach's avatar
Vladimir Sedach committed
514
515
516
517
518
519
520
521
522
523
524
525
526
527
             (dynamic-bindings
              (loop for x in normalized-bindings
                    when (special-variable? (car x)) collect
                    (cons (ps-gensym (format nil "~A_~A" (car x) 'tmp-stack))
                          x)))
             (renamed-body
              `(symbol-macrolet ,(loop for x in lexical-bindings
                                       when (rename x) collect
                                       `(,(var x) ,(rename x)))
                 ,@body))
             (*enclosing-lexicals*
              (append new-lexicals *enclosing-lexicals*))
             (*loop-scope-lexicals*
              (when in-loop-scope?
528
529
                (append new-lexicals loop-scoped-lexicals
                        *loop-scope-lexicals*)))
530
531
532
533
534
535
536
537
             (let-body
              `(progn
                 ,@(mapcar (lambda (x)
                             `(var ,(or (rename x) (var x)) ,(val x)))
                           lexical-bindings)
                 ,(if dynamic-bindings
                      `(progn
                         ,@(mapcar (lambda (x) `(var ,(rename x)))
Vladimir Sedach's avatar
Vladimir Sedach committed
538
                                   dynamic-bindings)
539
540
541
542
543
544
545
546
547
548
                         (try
                          (progn
                            (setf ,@(loop for x in dynamic-bindings append
                                         `(,(rename x) ,(var x)
                                            ,(var x) ,(val x))))
                            ,renamed-body)
                          (:finally
                           (setf ,@(mapcan (lambda (x) `(,(var x) ,(rename x)))
                                           dynamic-bindings)))))
                      renamed-body))))
549
          (ps-compile
550
           (cond ((or in-function-scope? (null bindings))
551
552
553
554
555
556
557
558
559
560
                  let-body)
                 ;; HACK
                 ((find-if
                   (lambda (x) (member x '(defun% defvar)))
                   (flatten
                    (loop for x in body collecting
                         (or (ignore-errors (ps-macroexpand x)) x))))
                  let-body)
                 (t
                  (with-lambda-scope let-body))))))))
Travis Cross's avatar
Travis Cross committed
561

562
563
564
565
(define-expression-operator locally (&rest body)
  (with-declaration-effects (body body)
    (ps-compile `(progn ,@body))))

566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; macros

(defmacro with-local-macro-environment ((var env) &body body)
  `(let* ((,var (make-macro-dictionary))
          (,env (cons ,var ,env)))
     ,@body))

(define-expression-operator macrolet (macros &body body)
  (with-local-macro-environment (local-macro-dict *macro-env*)
    (dolist (macro macros)
      (destructuring-bind (name arglist &body body)
          macro
        (setf (gethash name local-macro-dict)
              (eval (make-ps-macro-function arglist body)))))
    (ps-compile `(locally ,@body))))

(define-expression-operator symbol-macrolet (symbol-macros &body body)
  (with-local-macro-environment (local-macro-dict *symbol-macro-env*)
    (with-declaration-effects (body body)
      (let (local-var-bindings)
        (dolist (macro symbol-macros)
          (destructuring-bind (name expansion) macro
            (setf (gethash name local-macro-dict) (lambda (x) (declare (ignore x)) expansion))
            (push name local-var-bindings)))
        (let ((*enclosing-lexicals* (append local-var-bindings *enclosing-lexicals*)))
          (ps-compile `(progn ,@body)))))))

(define-expression-operator defmacro (name args &body body)
  (eval `(defpsmacro ,name ,args ,@body))
  nil)

(define-expression-operator define-symbol-macro (name expansion)
  (eval `(define-ps-symbol-macro ,name ,expansion))
  nil)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; assignment

(defun assignment-op (op)
  (getf '(ps-js:+   ps-js:+=
          ps-js:~   ps-js:~=
          ps-js:&   ps-js:&=
          ps-js:-   ps-js:-=
          ps-js:*   ps-js:*=
          ps-js:%   ps-js:%=
          ps-js:>>  ps-js:>>=
          ps-js:^   ps-js:^=
          ps-js:<<  ps-js:<<=
          ps-js:>>> ps-js:>>>=
          ps-js:/   ps-js:/=)
        op))

(define-expression-operator ps-assign (lhs rhs)
  (let ((rhs (ps-macroexpand rhs)))
    (if (and (listp rhs) (eq (car rhs) 'progn))
        (ps-compile `(progn ,@(butlast (cdr rhs))
                            (ps-assign ,lhs ,(car (last (cdr rhs))))))
        (let ((lhs (compile-expression lhs))
              (rhs (compile-expression rhs)))
          (aif (and (listp rhs)
                    (= 3 (length rhs))
                    (equal lhs (second rhs))
                    (assignment-op (first rhs)))
               (list it lhs (if (fourth rhs)
                                (cons (first rhs) (cddr rhs))
                                (third rhs)))
               (list 'ps-js:= lhs rhs))))))

(define-statement-operator defvar (name &optional
                                        (value (values) value-provided?)
                                        documentation)
  ;; this must be used as a top-level form, otherwise the resulting
  ;; behavior will be undefined.
640
641
642
643
644
645
646
647
648
649
650
651
  (declare (ignore documentation)) ; TODO: print docstring
  (pushnew name *special-variables*)

  (ps-compile (if value-provided?
                  `(when (undefined ,name) (var ,name ,value))
                  (list 'var name))))

(define-statement-operator defparameter
    (name &optional (value (values) value-provided?) documentation)
  ;; this must be used as a top-level form, otherwise the resulting
  ;; behavior will be undefined.
  (declare (ignore documentation)) ; TODO: print docstring
652
653
654
  (pushnew name *special-variables*)
  (ps-compile `(var ,name ,@(when value-provided? (list value)))))

655
656
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; iteration
Vladimir Sedach's avatar
Vladimir Sedach committed
657

658
659
(defun make-for-vars/inits (init-forms)
  (mapcar (lambda (x)
Vladimir Sedach's avatar
Vladimir Sedach committed
660
661
            (cons (ps-macroexpand (if (atom x) x (first x)))
                  (compile-expression (if (atom x) nil (second x)))))
662
          init-forms))
663

664
(defun compile-loop-body (loop-vars body)
665
666
667
668
669
670
671
672
673
674
  (let (compiled-body loop-closures?)
    (let* ((in-loop-scope?                 t)
           (*loop-scope-lexicals*          ())
           (*loop-scope-lexicals-captured* ())
           (*ps-gensym-counter*            *ps-gensym-counter*))
      (setf compiled-body  (compile-statement `(progn ,@body))
            loop-closures? *loop-scope-lexicals-captured*))
    (if loop-closures?
        (compile-statement `(progn ((lambda () ,@body))))
        compiled-body)))
675

Vladimir Sedach's avatar
Vladimir Sedach committed
676
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Daniel Gackle's avatar
Daniel Gackle committed
677
;;; evaluation
Vladimir Sedach's avatar
Vladimir Sedach committed
678

679
680
681
682
683
(define-expression-operator quote (x)
  (flet ((quote% (expr) (when expr `',expr)))
    (compile-expression
     (typecase x
       (cons `(array ,@(mapcar #'quote% x)))
684
       ((or null (eql [])) '(array))
685
686
687
688
689
690
691
       (keyword x)
       (symbol (symbol-to-js-string x))
       (number x)
       (string x)
       (vector `(array ,@(loop for el across x collect (quote% el))))))))

(define-expression-operator eval-when (situation-list &body body)
692
693
  "The body is evaluated only during the given situations. The
accepted situations are :load-toplevel, :compile-toplevel,
694
and :execute. The code in BODY is assumed to be Common Lisp code
695
696
in :compile-toplevel and :load-toplevel sitations, and Parenscript
code in :execute."
697
  (when (and (member :compile-toplevel situation-list)
698
             (member *compilation-level* '(:toplevel :inside-toplevel-form)))
699
700
    (eval `(progn ,@body)))
  (if (member :execute situation-list)
701
702
      (ps-compile `(progn ,@body))
      (ps-compile `(progn))))