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