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