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