src/special-operators.lisp

   1 (in-package #:parenscript)
   2 (in-readtable :parenscript)
   3
   4 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   5 ;;; arithmetic and logic
   6
   7 (define-trivial-special-ops
   8   +          ps-js:+
   9   -          ps-js:-
  10   *          ps-js:*
  11   rem        ps-js:%
  12   and        ps-js:&&
  13   or         ps-js:\|\|
  14
  15   logand     ps-js:&
  16   logior     ps-js:\|
  17   logxor     ps-js:^
  18   lognot     ps-js:~
  19
  20   aref       ps-js:aref
  21
  22   funcall    ps-js:funcall
  23   )
  24
  25 (define-expression-operator / (&rest args)
  26   `(ps-js:/ ,@(unless (cdr args) (list 1)) ,@(mapcar #'compile-expression args)))
  27
  28 (define-expression-operator - (&rest args)
  29   (let ((args (mapcar #'compile-expression args)))
  30     (cons (if (cdr args) 'ps-js:- 'ps-js:negate) args)))
  31
  32 (defun fix-nary-comparison (operator objects)
  33   (let* ((tmp-var-forms (butlast (cdr objects)))
  34          (tmp-vars (loop repeat (length tmp-var-forms)
  35                          collect (ps-gensym "_CMP")))
  36          (all-comparisons (append (list (car objects))
  37                                   tmp-vars
  38                                   (last objects))))
  39     `(let ,(mapcar #'list tmp-vars tmp-var-forms)
  40        (and ,@(loop for x1 in all-comparisons
  41                     for x2 in (cdr all-comparisons)
  42                     collect (list operator x1 x2))))))
  43
  44 (macrolet ((define-nary-comparison-forms (&rest mappings)
  45              `(progn
  46                 ,@(loop for (form js-primitive) on mappings by #'cddr collect
  47                        `(define-expression-operator ,form (&rest objects)
  48                           (if (cddr objects)
  49                               (ps-compile
  50                                (fix-nary-comparison ',form objects))
  51                               (cons ',js-primitive
  52                                     (mapcar #'compile-expression objects))))))))
  53   (define-nary-comparison-forms
  54     <     ps-js:<
  55     >     ps-js:>
  56     <=    ps-js:<=
  57     >=    ps-js:>=
  58     eql   ps-js:===
  59     equal ps-js:==))
  60
  61 (define-expression-operator /= (a b)
  62   ;; for n>2, /= is finding duplicates in an array of numbers (ie -
  63   ;; nontrivial runtime algorithm), so we restrict it to binary in PS
  64   `(ps-js:!== ,(compile-expression a) ,(compile-expression b)))
  65
  66 (define-expression-operator incf (x &optional (delta 1))
  67   (let ((delta (ps-macroexpand delta)))
  68     (if (eql delta 1)
  69         `(ps-js:++ ,(compile-expression x))
  70         `(ps-js:+= ,(compile-expression x) ,(compile-expression delta)))))
  71
  72 (define-expression-operator decf (x &optional (delta 1))
  73   (let ((delta (ps-macroexpand delta)))
  74     (if (eql delta 1)
  75         `(ps-js:-- ,(compile-expression x))
  76         `(ps-js:-= ,(compile-expression x) ,(compile-expression delta)))))
  77
  78 (let ((inverses (mapcan (lambda (x)
  79                           (list x (reverse x)))
  80                         '((ps-js:=== ps-js:!==)
  81                           (ps-js:== ps-js:!=)
  82                           (ps-js:< ps-js:>=)
  83                           (ps-js:> ps-js:<=)))))
  84   (define-expression-operator not (x)
  85     (let ((form (compile-expression x)))
  86       (acond ((and (listp form) (eq (car form) 'ps-js:!))
  87               (second form))
  88              ((and (listp form) (cadr (assoc (car form) inverses)))
  89               `(,it ,@(cdr form)))
  90              (t `(ps-js:! ,form))))))
  91
  92 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  93 ;;; blocks and control flow
  94
  95 (defun flatten-blocks (body)
  96   (when body
  97     (if (and (listp (car body)) (eq 'ps-js:block (caar body)))
  98         (append (cdr (car body)) (flatten-blocks (cdr body)))
  99         (cons (car body) (flatten-blocks (cdr body))))))
 100
 101 (defun compile-progn (body)
 102   (let ((block (flatten-blocks (mapcar #'ps-compile body))))
 103     (append (remove-if #'constantp (butlast block))
 104             (unless (and (or (eq *compilation-level* :toplevel)
 105                              (not compile-expression?))
 106                          (not (car (last block))))
 107               (last block)))))
 108
 109 (define-expression-operator progn (&rest body)
 110   (if (cdr body)
 111       `(ps-js:|,| ,@(compile-progn body))
 112       (compile-expression (car body))))
 113
 114 (define-statement-operator progn (&rest body)
 115   `(ps-js:block ,@(compile-progn body)))
 116
 117 (defun wrap-block-for-dynamic-return (tag body)
 118   (if (member tag *tags-that-return-throws-to*)
 119       `(ps-js:block
 120          (ps-js:try ,body
 121                     :catch (err ,(compile-statement `(progn (if (and err (eql ',tag (getprop err :ps-block-tag)))
 122                                                                 ;; FIXME make this a multiple-value return
 123                                                                 (getprop err :ps-return-value)
 124                                                                 (throw err)))))
 125                    :finally nil))
 126       body))
 127
 128 (define-statement-operator block (name &rest body)
 129   (let* ((name (or name 'nilBlock))
 130          (*lexical-extent-return-tags* (cons name *lexical-extent-return-tags*))
 131          (*tags-that-return-throws-to* ()))
 132     `(ps-js:label ,name ,(wrap-block-for-dynamic-return name (compile-statement `(progn ,@body))))))
 133
 134 (defun try-expressionize-if? (form)
 135   (< (count #\Newline (with-output-to-string (*psw-stream*)
 136                         (let ((*ps-print-pretty* t))
 137                           (parenscript-print (compile-statement form) t))))
 138      (if (= (length form) 4) 5 4)))
 139
 140 (define-statement-operator return-from (tag &optional result)
 141   (if (not tag)
 142       (if in-loop-scope?
 143           (progn
 144             (when result
 145               (warn "Trying to (RETURN ~A) from inside a loop with an implicit nil block (DO, DOLIST, DOTIMES, etc.). Parenscript doesn't support returning values this way from inside a loop yet!" result))
 146             '(ps-js:break))
 147           (ps-compile `(return-from nilBlock ,result)))
 148       (let ((form (ps-macroexpand result)))
 149         (flet ((return-exp (value) ;; this stuff needs to be fixed to handle multiple-value returns, too
 150                  (let ((value (compile-expression value)))
 151                   (cond ((member tag *lexical-extent-return-tags*)
 152                          (when result
 153                            (warn "Trying to (RETURN-FROM ~A ~A) a value from a block. Parenscript doesn't support returning values this way from blocks yet!" tag result))
 154                          `(ps-js:break ,tag))
 155                         ((or (eql '%function-body tag) (member tag *function-block-names*))
 156                          `(ps-js:return ,value))
 157                         ((member tag *dynamic-extent-return-tags*)
 158                          (push tag *tags-that-return-throws-to*)
 159                          (ps-compile `(throw (create :ps-block-tag ',tag :ps-return-value ,value))))
 160                         (t (warn "Returning from unknown block ~A" tag)
 161                            `(ps-js:return ,value)))))) ;; for backwards-compatibility
 162           (if (listp form)
 163               (block expressionize
 164                 (ps-compile
 165                  (case (car form)
 166                    (progn
 167                      `(progn ,@(butlast (cdr form)) (return-from ,tag ,(car (last (cdr form))))))
 168                    (switch
 169                        `(switch ,(second form)
 170                           ,@(loop for (cvalue . cbody) in (cddr form)
 171                                for remaining on (cddr form) collect
 172                                  (let ((last-n (cond ((or (eq 'default cvalue) (not (cdr remaining)))
 173                                                       1)
 174                                                      ((eq 'break (car (last cbody)))
 175                                                       2))))
 176                                    (if last-n
 177                                        (let ((result-form (ps-macroexpand (car (last cbody last-n)))))
 178                                          `(,cvalue
 179                                            ,@(butlast cbody last-n)
 180                                            (return-from ,tag ,result-form)
 181                                            ,@(when (and (= last-n 2)
 182                                                         (find-if (lambda (x) (or (eq x 'if) (eq x 'cond)))
 183                                                                  (flatten result-form)))
 184                                               '(break))))
 185                                        (cons cvalue cbody))))))
 186                    (try
 187                     `(try (return-from ,tag ,(second form))
 188                           ,@(let ((catch (cdr (assoc :catch (cdr form))))
 189                                   (finally (assoc :finally (cdr form))))
 190                                  (list (when catch
 191                                          `(:catch ,(car catch)
 192                                             ,@(butlast (cdr catch))
 193                                             (return-from ,tag ,(car (last (cdr catch))))))
 194                                        finally))))
 195                    (cond
 196                      `(cond ,@(loop for clause in (cdr form) collect
 197                                    `(,@(butlast clause) (return-from ,tag ,(car (last clause)))))))
 198                    ((with label let flet labels macrolet symbol-macrolet) ;; implicit progn forms
 199                     `(,(first form) ,(second form)
 200                        ,@(butlast (cddr form))
 201                        (return-from ,tag ,(car (last (cddr form))))))
 202                    ((continue break throw) ;; non-local exit
 203                     form)
 204                    (return-from ;; this will go away someday
 205                     (unless tag
 206                       (warn 'simple-style-warning
 207                             :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."))
 208                      form)
 209                    (if
 210                     (aif (and (try-expressionize-if? form)
 211                               (handler-case (compile-expression form)
 212                                 (compile-expression-error () nil)))
 213                          (return-from expressionize `(ps-js:return ,it))
 214                          `(if ,(second form)
 215                               (return-from ,tag ,(third form))
 216                               ,@(when (fourth form) `((return-from ,tag ,(fourth form)))))))
 217                    (otherwise
 218                     (if (gethash (car form) *special-statement-operators*)
 219                         form ;; by now only special forms that return nil should be left, so this is ok for implicit return
 220                         (return-from expressionize (return-exp form)))))))
 221               (return-exp form))))))
 222
 223 (define-statement-operator throw (&rest args)
 224   `(ps-js:throw ,@(mapcar #'compile-expression args)))
 225
 226 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 227 ;;; conditionals
 228
 229 (define-expression-operator if (test then &optional else)
 230    `(ps-js:? ,(compile-expression test) ,(compile-expression then) ,(compile-expression else)))
 231
 232 (define-statement-operator if (test then &optional else)
 233   `(ps-js:if ,(compile-expression test)
 234      ,(compile-statement `(progn ,then))
 235      ,@(when else `(:else ,(compile-statement `(progn ,else))))))
 236
 237 (define-expression-operator cond (&rest clauses)
 238   (compile-expression
 239    (when clauses
 240      (destructuring-bind (test &rest body) (car clauses)
 241        (if (eq t test)
 242            `(progn ,@body)
 243            `(if ,test
 244                 (progn ,@body)
 245                 (cond ,@(cdr clauses))))))))
 246
 247 (define-statement-operator cond (&rest clauses)
 248   `(ps-js:if ,(compile-expression (caar clauses))
 249      ,(compile-statement `(progn ,@(cdar clauses)))
 250      ,@(loop for (test . body) in (cdr clauses) appending
 251             (if (eq t test)
 252                 `(:else ,(compile-statement `(progn ,@body)))
 253                 `(:else-if ,(compile-expression test)
 254                            ,(compile-statement `(progn ,@body)))))))
 255
 256 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 257 ;;; macros
 258
 259 (defmacro with-local-macro-environment ((var env) &body body)
 260   `(let* ((,var (make-macro-dictionary))
 261           (,env (cons ,var ,env)))
 262      ,@body))
 263
 264 (define-expression-operator macrolet (macros &body body)
 265   (with-local-macro-environment (local-macro-dict *macro-env*)
 266     (dolist (macro macros)
 267       (destructuring-bind (name arglist &body body)
 268           macro
 269         (setf (gethash name local-macro-dict)
 270               (eval (make-ps-macro-function arglist body)))))
 271     (ps-compile `(progn ,@body))))
 272
 273 (define-expression-operator symbol-macrolet (symbol-macros &body body)
 274   (with-local-macro-environment (local-macro-dict *symbol-macro-env*)
 275     (let (local-var-bindings)
 276       (dolist (macro symbol-macros)
 277         (destructuring-bind (name expansion) macro
 278           (setf (gethash name local-macro-dict) (lambda (x) (declare (ignore x)) expansion))
 279           (push name local-var-bindings)))
 280       (let ((*enclosing-lexicals* (append local-var-bindings *enclosing-lexicals*)))
 281         (ps-compile `(progn ,@body))))))
 282
 283 (define-expression-operator defmacro (name args &body body)
 284   (eval `(defpsmacro ,name ,args ,@body))
 285   nil)
 286
 287 (define-expression-operator define-symbol-macro (name expansion)
 288   (eval `(define-ps-symbol-macro ,name ,expansion))
 289   nil)
 290
 291 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 292 ;;; assignment
 293
 294 (defun assignment-op (op)
 295   (getf '(ps-js:+   ps-js:+=
 296           ps-js:~   ps-js:~=
 297           ps-js:&   ps-js:&=
 298           ps-js:\|  ps-js:\|=
 299           ps-js:-   ps-js:-=
 300           ps-js:*   ps-js:*=
 301           ps-js:%   ps-js:%=
 302           ps-js:>>  ps-js:>>=
 303           ps-js:^   ps-js:^=
 304           ps-js:<<  ps-js:<<=
 305           ps-js:>>> ps-js:>>>=
 306           ps-js:/   ps-js:/=)
 307         op))
 308
 309 (define-expression-operator ps-assign (lhs rhs)
 310   (let ((rhs (ps-macroexpand rhs)))
 311     (if (and (listp rhs) (eq (car rhs) 'progn))
 312         (ps-compile `(progn ,@(butlast (cdr rhs)) (ps-assign ,lhs ,(car (last (cdr rhs))))))
 313         (let ((lhs (compile-expression lhs))
 314               (rhs (compile-expression rhs)))
 315           (aif (and (listp rhs)
 316                     (= 3 (length rhs))
 317                     (equal lhs (second rhs))
 318                     (assignment-op (first rhs)))
 319                (list it lhs (if (fourth rhs)
 320                                 (cons (first rhs) (cddr rhs))
 321                                 (third rhs)))
 322                (list 'ps-js:= lhs rhs))))))
 323
 324 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 325 ;;; binding
 326
 327 (defmacro with-declaration-effects ((var block) &body body)
 328   (let ((declarations (gensym)))
 329    `(let* ((,var ,block)
 330            (,declarations (and (listp (car ,var))
 331                                (eq (caar ,var) 'declare)
 332                                (cdar ,var)))
 333            (,var (if ,declarations
 334                      (cdr ,var)
 335                      ,var))
 336            (*special-variables* (append (cdr (find 'special ,declarations :key #'car)) *special-variables*)))
 337       ,@body)))
 338
 339 (define-expression-operator let (bindings &body body)
 340   (with-declaration-effects (body body)
 341     (let* ((lexical-bindings-introduced-here             ())
 342            (normalized-bindings                          (mapcar (lambda (x)
 343                                                                    (if (symbolp x)
 344                                                                        (list x nil)
 345                                                                        (list (car x) (ps-macroexpand (cadr x)))))
 346                                                                  bindings))
 347            (free-variables-in-binding-value-expressions  (mapcan (lambda (x) (flatten (cadr x)))
 348                                                                  normalized-bindings)))
 349       (flet ((maybe-rename-lexical-var (x)
 350                (if (or (member x *enclosing-lexicals*)
 351                        (member x *enclosing-function-arguments*)
 352                        (lookup-macro-def x *symbol-macro-env*)
 353                        (member x free-variables-in-binding-value-expressions))
 354                    (ps-gensym (string x))
 355                    (progn (push x lexical-bindings-introduced-here) nil)))
 356              (rename (x) (first x))
 357              (var (x) (second x))
 358              (val (x) (third x)))
 359         (let* ((lexical-bindings      (loop for x in normalized-bindings
 360                                             unless (special-variable? (car x))
 361                                             collect (cons (maybe-rename-lexical-var (car x)) x)))
 362                (dynamic-bindings      (loop for x in normalized-bindings
 363                                             when (special-variable? (car x))
 364                                             collect (cons (ps-gensym (format nil "~A_~A" (car x) 'tmp-stack)) x)))
 365                (renamed-body          `(symbol-macrolet ,(loop for x in lexical-bindings
 366                                                                when (rename x) collect
 367                                                                `(,(var x) ,(rename x)))
 368                                           ,@body))
 369                (*enclosing-lexicals*  (append lexical-bindings-introduced-here *enclosing-lexicals*))
 370                (*loop-scope-lexicals* (when in-loop-scope? (append lexical-bindings-introduced-here *loop-scope-lexicals*))))
 371           (ps-compile
 372            `(progn
 373               ,@(mapcar (lambda (x) `(var ,(or (rename x) (var x)) ,(val x)))
 374                         lexical-bindings)
 375               ,(if dynamic-bindings
 376                    `(progn ,@(mapcar (lambda (x) `(var ,(rename x)))
 377                                      dynamic-bindings)
 378                            (try (progn
 379                                   (setf ,@(loop for x in dynamic-bindings append
 380                                                `(,(rename x) ,(var x)
 381                                                   ,(var x) ,(val x))))
 382                                   ,renamed-body)
 383                                 (:finally
 384                                  (setf ,@(mapcan (lambda (x) `(,(var x) ,(rename x)))
 385                                                  dynamic-bindings)))))
 386                    renamed-body))))))))
 387
 388 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 389 ;;; iteration
 390
 391 (defun make-for-vars/inits (init-forms)
 392   (mapcar (lambda (x)
 393             (cons (ps-macroexpand (if (atom x) x (first x)))
 394                   (compile-expression (if (atom x) nil (second x)))))
 395           init-forms))
 396
 397 (defun compile-loop-body (loop-vars body)
 398   (let* ((in-loop-scope? t)
 399          (*loop-scope-lexicals* loop-vars)
 400          (*loop-scope-lexicals-captured* ())
 401          (*ps-gensym-counter* *ps-gensym-counter*)
 402          (compiled-body (compile-statement `(progn ,@body))))
 403     ;; the sort is there to make order for output-tests consistent across implementations
 404     (aif (sort (remove-duplicates *loop-scope-lexicals-captured*) #'string< :key #'symbol-name)
 405          `(ps-js:block
 406               (ps-js:with ,(compile-expression
 407                          `(create ,@(loop for x in it
 408                                           collect x
 409                                           collect (when (member x loop-vars) x))))
 410                 ,compiled-body))
 411          compiled-body)))
 412
 413 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 414 ;;; evalutation
 415
 416 (define-expression-operator quote (x)
 417   (flet ((quote% (expr) (when expr `',expr)))
 418     (compile-expression
 419      (typecase x
 420        (cons `(array ,@(mapcar #'quote% x)))
 421        (null '(array))
 422        (keyword x)
 423        (symbol (symbol-to-js-string x))
 424        (number x)
 425        (string x)
 426        (vector `(array ,@(loop for el across x collect (quote% el))))))))
 427
 428 (define-expression-operator eval-when (situation-list &body body)
 429   "The body is evaluated only during the given situations. The
 430 accepted situations are :load-toplevel, :compile-toplevel,
 431 and :execute. The code in BODY is assumed to be Common Lisp code
 432 in :compile-toplevel and :load-toplevel sitations, and Parenscript
 433 code in :execute."
 434   (when (and (member :compile-toplevel situation-list)
 435              (member *compilation-level* '(:toplevel :inside-toplevel-form)))
 436     (eval `(progn ,@body)))
 437   (if (member :execute situation-list)
 438       (ps-compile `(progn ,@body))
 439       (ps-compile `(progn))))