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
 122                     (err
 123                      ,(compile-statement
 124                        `(progn (if (and err (eql ',tag (getprop err :ps-block-tag)))
 125                                    ;; FIXME make this a multiple-value return
 126                                    (getprop err :ps-return-value)
 127                                    (throw err)))))
 128                     :finally nil))
 129       body))
 130
 131 (define-statement-operator block (name &rest body)
 132   (let* ((name (or name 'nilBlock))
 133          (*lexical-extent-return-tags* (cons name *lexical-extent-return-tags*))
 134          (*tags-that-return-throws-to* ()))
 135     `(ps-js:label ,name ,(wrap-block-for-dynamic-return name (compile-statement `(progn ,@body))))))
 136
 137 (defun try-expressionize-if? (form)
 138   (< (count #\Newline (with-output-to-string (*psw-stream*)
 139                         (let ((*ps-print-pretty* t))
 140                           (parenscript-print (compile-statement form) t))))
 141      (if (= (length form) 4) 5 4)))
 142
 143 (define-statement-operator return-from (tag &optional result)
 144   (if (not tag)
 145       (if in-loop-scope?
 146           (progn
 147             (when result
 148               (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))
 149             '(ps-js:break))
 150           (ps-compile `(return-from nilBlock ,result)))
 151       (let ((form (ps-macroexpand result)))
 152         (flet ((return-exp (value) ;; this stuff needs to be fixed to handle multiple-value returns, too
 153                  (let ((value (compile-expression value)))
 154                   (cond ((member tag *lexical-extent-return-tags*)
 155                          (when result
 156                            (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))
 157                          `(ps-js:break ,tag))
 158                         ((or (eql '%function-body tag) (member tag *function-block-names*))
 159                          `(ps-js:return ,value))
 160                         ((member tag *dynamic-extent-return-tags*)
 161                          (push tag *tags-that-return-throws-to*)
 162                          (ps-compile `(throw (create :ps-block-tag ',tag :ps-return-value ,value))))
 163                         (t (warn "Returning from unknown block ~A" tag)
 164                            `(ps-js:return ,value)))))) ;; for backwards-compatibility
 165           (if (listp form)
 166               (block expressionize
 167                 (ps-compile
 168                  (case (car form)
 169                    (progn
 170                      `(progn ,@(butlast (cdr form)) (return-from ,tag ,(car (last (cdr form))))))
 171                    (switch
 172                        `(switch ,(second form)
 173                           ,@(loop for (cvalue . cbody) in (cddr form)
 174                                for remaining on (cddr form) collect
 175                                  (let ((last-n (cond ((or (eq 'default cvalue) (not (cdr remaining)))
 176                                                       1)
 177                                                      ((eq 'break (car (last cbody)))
 178                                                       2))))
 179                                    (if last-n
 180                                        (let ((result-form (ps-macroexpand (car (last cbody last-n)))))
 181                                          `(,cvalue
 182                                            ,@(butlast cbody last-n)
 183                                            (return-from ,tag ,(if (eq result-form 'break) nil result-form))
 184                                            ,@(when (and (= last-n 2)
 185                                                         (find-if (lambda (x) (or (eq x 'if) (eq x 'cond)))
 186                                                                  (flatten result-form)))
 187                                               '(break))))
 188                                        (cons cvalue cbody))))))
 189                    (try
 190                     `(try (return-from ,tag ,(second form))
 191                           ,@(let ((catch (cdr (assoc :catch (cdr form))))
 192                                   (finally (assoc :finally (cdr form))))
 193                                  (list (when catch
 194                                          `(:catch ,(car catch)
 195                                             ,@(butlast (cdr catch))
 196                                             (return-from ,tag ,(car (last (cdr catch))))))
 197                                        finally))))
 198                    (cond
 199                      `(cond ,@(loop for clause in (cdr form) collect
 200                                    `(,@(butlast clause) (return-from ,tag ,(car (last clause)))))))
 201                    ((with label let flet labels macrolet symbol-macrolet) ;; implicit progn forms
 202                     `(,(first form) ,(second form)
 203                        ,@(butlast (cddr form))
 204                        (return-from ,tag ,(car (last (cddr form))))))
 205                    ((continue break throw) ;; non-local exit
 206                     form)
 207                    (return-from ;; this will go away someday
 208                     (unless tag
 209                       (warn 'simple-style-warning
 210                             :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."))
 211                      form)
 212                    (if
 213                     (aif (and (try-expressionize-if? form)
 214                               (handler-case (compile-expression form)
 215                                 (compile-expression-error () nil)))
 216                          (return-from expressionize `(ps-js:return ,it))
 217                          `(if ,(second form)
 218                               (return-from ,tag ,(third form))
 219                               ,@(when (fourth form) `((return-from ,tag ,(fourth form)))))))
 220                    (otherwise
 221                     (if (gethash (car form) *special-statement-operators*)
 222                         form ;; by now only special forms that return nil should be left, so this is ok for implicit return
 223                         (return-from expressionize (return-exp form)))))))
 224               (return-exp form))))))
 225
 226 (define-statement-operator throw (&rest args)
 227   `(ps-js:throw ,@(mapcar #'compile-expression args)))
 228
 229 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 230 ;;; conditionals
 231
 232 (define-expression-operator if (test then &optional else)
 233    `(ps-js:? ,(compile-expression test) ,(compile-expression then) ,(compile-expression else)))
 234
 235 (define-statement-operator if (test then &optional else)
 236   `(ps-js:if ,(compile-expression test)
 237      ,(compile-statement `(progn ,then))
 238      ,@(when else `(:else ,(compile-statement `(progn ,else))))))
 239
 240 (define-expression-operator cond (&rest clauses)
 241   (compile-expression
 242    (when clauses
 243      (destructuring-bind (test &rest body) (car clauses)
 244        (if (eq t test)
 245            `(progn ,@body)
 246            `(if ,test
 247                 (progn ,@body)
 248                 (cond ,@(cdr clauses))))))))
 249
 250 (define-statement-operator cond (&rest clauses)
 251   `(ps-js:if ,(compile-expression (caar clauses))
 252      ,(compile-statement `(progn ,@(cdar clauses)))
 253      ,@(loop for (test . body) in (cdr clauses) appending
 254             (if (eq t test)
 255                 `(:else ,(compile-statement `(progn ,@body)))
 256                 `(:else-if ,(compile-expression test)
 257                            ,(compile-statement `(progn ,@body)))))))
 258
 259 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 260 ;;; macros
 261
 262 (defmacro with-local-macro-environment ((var env) &body body)
 263   `(let* ((,var (make-macro-dictionary))
 264           (,env (cons ,var ,env)))
 265      ,@body))
 266
 267 (define-expression-operator macrolet (macros &body body)
 268   (with-local-macro-environment (local-macro-dict *macro-env*)
 269     (dolist (macro macros)
 270       (destructuring-bind (name arglist &body body)
 271           macro
 272         (setf (gethash name local-macro-dict)
 273               (eval (make-ps-macro-function arglist body)))))
 274     (ps-compile `(progn ,@body))))
 275
 276 (define-expression-operator symbol-macrolet (symbol-macros &body body)
 277   (with-local-macro-environment (local-macro-dict *symbol-macro-env*)
 278     (let (local-var-bindings)
 279       (dolist (macro symbol-macros)
 280         (destructuring-bind (name expansion) macro
 281           (setf (gethash name local-macro-dict) (lambda (x) (declare (ignore x)) expansion))
 282           (push name local-var-bindings)))
 283       (let ((*enclosing-lexicals* (append local-var-bindings *enclosing-lexicals*)))
 284         (ps-compile `(progn ,@body))))))
 285
 286 (define-expression-operator defmacro (name args &body body)
 287   (eval `(defpsmacro ,name ,args ,@body))
 288   nil)
 289
 290 (define-expression-operator define-symbol-macro (name expansion)
 291   (eval `(define-ps-symbol-macro ,name ,expansion))
 292   nil)
 293
 294 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 295 ;;; assignment
 296
 297 (defun assignment-op (op)
 298   (getf '(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           ps-js:<<  ps-js:<<=
 308           ps-js:>>> ps-js:>>>=
 309           ps-js:/   ps-js:/=)
 310         op))
 311
 312 (define-expression-operator ps-assign (lhs rhs)
 313   (let ((rhs (ps-macroexpand rhs)))
 314     (if (and (listp rhs) (eq (car rhs) 'progn))
 315         (ps-compile `(progn ,@(butlast (cdr rhs)) (ps-assign ,lhs ,(car (last (cdr rhs))))))
 316         (let ((lhs (compile-expression lhs))
 317               (rhs (compile-expression rhs)))
 318           (aif (and (listp rhs)
 319                     (= 3 (length rhs))
 320                     (equal lhs (second rhs))
 321                     (assignment-op (first rhs)))
 322                (list it lhs (if (fourth rhs)
 323                                 (cons (first rhs) (cddr rhs))
 324                                 (third rhs)))
 325                (list 'ps-js:= lhs rhs))))))
 326
 327 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 328 ;;; binding
 329
 330 (defmacro with-declaration-effects ((var block) &body body)
 331   (let ((declarations (gensym)))
 332    `(let* ((,var ,block)
 333            (,declarations (and (listp (car ,var))
 334                                (eq (caar ,var) 'declare)
 335                                (cdar ,var)))
 336            (,var (if ,declarations
 337                      (cdr ,var)
 338                      ,var))
 339            (*special-variables* (append (cdr (find 'special ,declarations :key #'car)) *special-variables*)))
 340       ,@body)))
 341
 342 (define-expression-operator let (bindings &body body)
 343   (with-declaration-effects (body body)
 344     (let* ((lexical-bindings-introduced-here             ())
 345            (normalized-bindings                          (mapcar (lambda (x)
 346                                                                    (if (symbolp x)
 347                                                                        (list x nil)
 348                                                                        (list (car x) (ps-macroexpand (cadr x)))))
 349                                                                  bindings))
 350            (free-variables-in-binding-value-expressions  (mapcan (lambda (x) (flatten (cadr x)))
 351                                                                  normalized-bindings)))
 352       (flet ((maybe-rename-lexical-var (x)
 353                (if (or (member x *enclosing-lexicals*)
 354                        (member x *enclosing-function-arguments*)
 355                        (lookup-macro-def x *symbol-macro-env*)
 356                        (member x free-variables-in-binding-value-expressions))
 357                    (ps-gensym (string x))
 358                    (progn (push x lexical-bindings-introduced-here) nil)))
 359              (rename (x) (first x))
 360              (var (x) (second x))
 361              (val (x) (third x)))
 362         (let* ((lexical-bindings      (loop for x in normalized-bindings
 363                                             unless (special-variable? (car x))
 364                                             collect (cons (maybe-rename-lexical-var (car x)) x)))
 365                (dynamic-bindings      (loop for x in normalized-bindings
 366                                             when (special-variable? (car x))
 367                                             collect (cons (ps-gensym (format nil "~A_~A" (car x) 'tmp-stack)) x)))
 368                (renamed-body          `(symbol-macrolet ,(loop for x in lexical-bindings
 369                                                                when (rename x) collect
 370                                                                `(,(var x) ,(rename x)))
 371                                           ,@body))
 372                (*enclosing-lexicals*  (append lexical-bindings-introduced-here *enclosing-lexicals*))
 373                (*loop-scope-lexicals* (when in-loop-scope? (append lexical-bindings-introduced-here *loop-scope-lexicals*))))
 374           (ps-compile
 375            `(progn
 376               ,@(mapcar (lambda (x) `(var ,(or (rename x) (var x)) ,(val x)))
 377                         lexical-bindings)
 378               ,(if dynamic-bindings
 379                    `(progn ,@(mapcar (lambda (x) `(var ,(rename x)))
 380                                      dynamic-bindings)
 381                            (try (progn
 382                                   (setf ,@(loop for x in dynamic-bindings append
 383                                                `(,(rename x) ,(var x)
 384                                                   ,(var x) ,(val x))))
 385                                   ,renamed-body)
 386                                 (:finally
 387                                  (setf ,@(mapcan (lambda (x) `(,(var x) ,(rename x)))
 388                                                  dynamic-bindings)))))
 389                    renamed-body))))))))
 390
 391 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 392 ;;; iteration
 393
 394 (defun make-for-vars/inits (init-forms)
 395   (mapcar (lambda (x)
 396             (cons (ps-macroexpand (if (atom x) x (first x)))
 397                   (compile-expression (if (atom x) nil (second x)))))
 398           init-forms))
 399
 400 (defun compile-loop-body (loop-vars body)
 401   (let* ((in-loop-scope? t)
 402          (*loop-scope-lexicals* loop-vars)
 403          (*loop-scope-lexicals-captured* ())
 404          (*ps-gensym-counter* *ps-gensym-counter*)
 405          (compiled-body (compile-statement `(progn ,@body))))
 406     ;; the sort is there to make order for output-tests consistent across implementations
 407     (aif (sort (remove-duplicates *loop-scope-lexicals-captured*) #'string< :key #'symbol-name)
 408          `(ps-js:block
 409               (ps-js:with ,(compile-expression
 410                          `(create ,@(loop for x in it
 411                                           collect x
 412                                           collect (when (member x loop-vars) x))))
 413                 ,compiled-body))
 414          compiled-body)))
 415
 416 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 417 ;;; evalutation
 418
 419 (define-expression-operator quote (x)
 420   (flet ((quote% (expr) (when expr `',expr)))
 421     (compile-expression
 422      (typecase x
 423        (cons `(array ,@(mapcar #'quote% x)))
 424        (null '(array))
 425        (keyword x)
 426        (symbol (symbol-to-js-string x))
 427        (number x)
 428        (string x)
 429        (vector `(array ,@(loop for el across x collect (quote% el))))))))
 430
 431 (define-expression-operator eval-when (situation-list &body body)
 432   "The body is evaluated only during the given situations. The
 433 accepted situations are :load-toplevel, :compile-toplevel,
 434 and :execute. The code in BODY is assumed to be Common Lisp code
 435 in :compile-toplevel and :load-toplevel sitations, and Parenscript
 436 code in :execute."
 437   (when (and (member :compile-toplevel situation-list)
 438              (member *compilation-level* '(:toplevel :inside-toplevel-form)))
 439     (eval `(progn ,@body)))
 440   (if (member :execute situation-list)
 441       (ps-compile `(progn ,@body))
 442       (ps-compile `(progn))))