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