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              (in-loop-scope? (if name in-loop-scope? nil))
 141              (*dynamic-return-tags* (cons (cons name nil) *dynamic-return-tags*))
 142              (*current-block-tag* name)
 143              (compiled-body (compile-statement `(progn ,@body))))
 144         `(ps-js:label ,name
 145                       ,(wrap-for-dynamic-return
 146                         (list name) compiled-body)))
 147       (ps-compile (with-lambda-scope `(block ,name ,@body)))))
 148
 149 ;; fixme to handle multiple values
 150 (defun return-exp (tag &optional (value nil value?))
 151   (let ((cvalue (when value? (list (compile-expression value)))))
 152     (acond ((or (eql '%function tag) (member tag *function-block-names*))
 153             `(ps-js:return ,@cvalue))
 154            ((eql tag *current-block-tag*)
 155             (if value?
 156                 `(ps-js:block ,@cvalue (ps-js:break ,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 ,@cvalue))))) ;; for backwards-compatibility
 164
 165 (defun try-expressionizing-if? (exp &optional (score 0)) ;; poor man's codewalker
 166   (cond ((< 1 score) nil)
 167         ((listp exp)
 168          (loop for x in (cdr exp) always
 169               (try-expressionizing-if?
 170                (or (ignore-errors (ps-macroexpand x)) x) ;; fail
 171                (+ score (case (car exp)
 172                           ((if cond let) 1)
 173                           ((progn) (1- (length (cdr exp))))
 174                           (otherwise 0))))))
 175         (t t)))
 176
 177 (defun expressionize-result (tag form)
 178   (ps-compile
 179    (case (car form)
 180      (progn
 181        `(progn ,@(butlast (cdr form))
 182                (return-from ,tag ,(car (last (cdr form))))))
 183      (switch
 184       `(switch
 185         ,(second form)
 186         ,@(loop for (cvalue . cbody) in (cddr form)
 187              for remaining on (cddr form) collect
 188                (aif (cond ((or (eq 'default cvalue) (not (cdr remaining)))
 189                            1)
 190                           ((eq 'break (car (last cbody)))
 191                            2))
 192                     (let ((result-form (ps-macroexpand (car (last cbody it)))))
 193                       `(,cvalue
 194                         ,@(butlast cbody it)
 195                         (return-from ,tag
 196                           ,(if (eq result-form 'break) nil result-form))))
 197                     (cons cvalue cbody)))))
 198      (try
 199       `(try (return-from ,tag ,(second form))
 200             ,@(let ((catch (cdr (assoc :catch (cdr form))))
 201                     (finally (assoc :finally (cdr form))))
 202                    (list (when catch
 203                            `(:catch ,(car catch)
 204                               ,@(butlast (cdr catch))
 205                               (return-from ,tag ,(car (last (cdr catch))))))
 206                          finally))))
 207      (cond
 208        `(cond
 209           ,@(loop for clause in (cdr form) collect
 210                  `(,@(butlast clause) (return-from ,tag ,(car (last clause)))))
 211           ,@(when in-case? `((t (return-from ,tag nil))))))
 212      ((with label let flet labels macrolet symbol-macrolet) ;; implicit progn forms
 213       `(,(first form) ,(second form)
 214          ,@(butlast (cddr form))
 215          (return-from ,tag ,(car (last (cddr form))))))
 216      ((continue break throw) ;; non-local exit
 217       form)
 218      (return-from ;; this will go away someday
 219       (unless tag
 220         (warn 'simple-style-warning
 221               :format-control "Trying to RETURN a RETURN without a block tag specified. Perhaps you're still returning values from functions by hand?
 222 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."))
 223        form)
 224      (if
 225       (if (and (try-expressionizing-if? form)
 226                (let ((used-up-names *used-up-names*)
 227                      (*lambda-wrappable-statements* ()))
 228                  (handler-case (compile-expression form)
 229                    (compile-expression-error ()
 230                      (setf *used-up-names* used-up-names)
 231                      nil))))
 232            (return-from expressionize-result (return-exp tag form))
 233            `(if ,(second form)
 234                 (return-from ,tag ,(third form))
 235                 ,@(when (or in-case? (fourth form))
 236                     `((return-from ,tag ,(fourth form)))))))
 237      (otherwise
 238       (return-from expressionize-result
 239         (cond ((not (gethash (car form) *special-statement-operators*))
 240                (return-exp tag form))
 241               (in-case?
 242                `(ps-js:block ,(compile-statement form) ,(return-exp tag)))
 243               (t (compile-statement form))))))))
 244
 245 (define-statement-operator return-from (tag &optional result)
 246   (cond (tag
 247          (let ((form (ps-macroexpand result)))
 248            (if (listp form)
 249                (expressionize-result tag form)
 250                (return-exp tag form))))
 251         (in-loop-scope?
 252          (setf loop-returns? t
 253                *loop-return-var* (or *loop-return-var*
 254                                      (ps-gensym "loop-result-var")))
 255          (compile-statement `(progn (setf ,*loop-return-var* ,result)
 256                                     (break))))
 257         (t (ps-compile `(return-from nilBlock ,result)))))
 258
 259 (define-statement-operator throw (&rest args)
 260   `(ps-js:throw ,@(mapcar #'compile-expression args)))
 261
 262 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 263 ;;; conditionals
 264
 265 (define-expression-operator if (test then &optional else)
 266    `(ps-js:? ,(compile-expression test)
 267              ,(compile-expression then)
 268              ,(compile-expression else)))
 269
 270 (define-statement-operator if (test then &optional else)
 271   `(ps-js:if ,(compile-expression test)
 272              ,(compile-statement `(progn ,then))
 273              ,@(when else
 274                      `(: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))
 352                             (ps-assign ,lhs ,(car (last (cdr rhs))))))
 353         (let ((lhs (compile-expression lhs))
 354               (rhs (compile-expression rhs)))
 355           (aif (and (listp rhs)
 356                     (= 3 (length rhs))
 357                     (equal lhs (second rhs))
 358                     (assignment-op (first rhs)))
 359                (list it lhs (if (fourth rhs)
 360                                 (cons (first rhs) (cddr rhs))
 361                                 (third rhs)))
 362                (list 'ps-js:= lhs rhs))))))
 363
 364 (define-statement-operator defvar (name &optional
 365                                         (value (values) value-provided?)
 366                                         documentation)
 367   ;; this must be used as a top-level form, otherwise the resulting
 368   ;; behavior will be undefined.
 369   (declare (ignore documentation))
 370   (pushnew name *special-variables*)
 371   (ps-compile `(var ,name ,@(when value-provided? (list value)))))
 372
 373 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 374 ;;; binding
 375
 376 (defmacro with-declaration-effects ((var block) &body body)
 377   (let ((declarations (gensym)))
 378    `(let* ((,var ,block)
 379            (,declarations (and (listp (car ,var))
 380                                (eq (caar ,var) 'declare)
 381                                (cdar ,var)))
 382            (,var (if ,declarations
 383                      (cdr ,var)
 384                      ,var))
 385            (*special-variables* (append (cdr (find 'special ,declarations :key #'car)) *special-variables*)))
 386       ,@body)))
 387
 388 (defun maybe-rename-lexical-var (x symbols-in-bindings)
 389   (when (or (member x *enclosing-lexicals*)
 390             (member x *enclosing-function-arguments*)
 391             (when (boundp '*used-up-names*)
 392               (member x *used-up-names*))
 393             (lookup-macro-def x *symbol-macro-env*)
 394             (member x symbols-in-bindings))
 395     (ps-gensym (symbol-name x))))
 396
 397 (defun with-lambda-scope (body)
 398  (prog1 `((lambda () ,body))
 399    (setf *vars-needing-to-be-declared* ())))
 400
 401 (define-expression-operator let (bindings &body body)
 402   (with-declaration-effects (body body)
 403     (flet ((rename (x) (first x))
 404            (var (x) (second x))
 405            (val (x) (third x)))
 406       (let* ((new-lexicals ())
 407              (normalized-bindings
 408               (mapcar (lambda (x)
 409                         (if (symbolp x)
 410                             (list x nil)
 411                             (list (car x) (ps-macroexpand (cadr x)))))
 412                       bindings))
 413              (symbols-in-bindings
 414               (mapcan (lambda (x) (flatten (cadr x)))
 415                       normalized-bindings))
 416              (lexical-bindings
 417               (loop for x in normalized-bindings
 418                     unless (special-variable? (car x)) collect
 419                     (cons (aif (maybe-rename-lexical-var (car x)
 420                                                          symbols-in-bindings)
 421                                it
 422                                (progn
 423                                  (push (car x) new-lexicals)
 424                                  (when (boundp '*used-up-names*)
 425                                    (push (car x) *used-up-names*))
 426                                  nil))
 427                           x)))
 428              (dynamic-bindings
 429               (loop for x in normalized-bindings
 430                     when (special-variable? (car x)) collect
 431                     (cons (ps-gensym (format nil "~A_~A" (car x) 'tmp-stack))
 432                           x)))
 433              (renamed-body
 434               `(symbol-macrolet ,(loop for x in lexical-bindings
 435                                        when (rename x) collect
 436                                        `(,(var x) ,(rename x)))
 437                  ,@body))
 438              (*enclosing-lexicals*
 439               (append new-lexicals *enclosing-lexicals*))
 440              (*loop-scope-lexicals*
 441               (when in-loop-scope?
 442                 (append new-lexicals *loop-scope-lexicals*)))
 443              (let-body
 444               `(progn
 445                  ,@(mapcar (lambda (x)
 446                              `(var ,(or (rename x) (var x)) ,(val x)))
 447                            lexical-bindings)
 448                  ,(if dynamic-bindings
 449                       `(progn
 450                          ,@(mapcar (lambda (x) `(var ,(rename x)))
 451                                    dynamic-bindings)
 452                          (try
 453                           (progn
 454                             (setf ,@(loop for x in dynamic-bindings append
 455                                          `(,(rename x) ,(var x)
 456                                             ,(var x) ,(val x))))
 457                             ,renamed-body)
 458                           (:finally
 459                            (setf ,@(mapcan (lambda (x) `(,(var x) ,(rename x)))
 460                                            dynamic-bindings)))))
 461                       renamed-body))))
 462         (ps-compile (cond (in-function-scope? let-body)
 463                           ;; HACK
 464                           ((find-if (lambda (x)
 465                                       (member x '(defun% defvar)))
 466                                     (flatten
 467                                      (loop for x in body collecting
 468                                           (or (ignore-errors (ps-macroexpand x))
 469                                               x))))
 470                            let-body)
 471                           (t (with-lambda-scope let-body))))))))
 472
 473 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 474 ;;; iteration
 475
 476 (defun make-for-vars/inits (init-forms)
 477   (mapcar (lambda (x)
 478             (cons (ps-macroexpand (if (atom x) x (first x)))
 479                   (compile-expression (if (atom x) nil (second x)))))
 480           init-forms))
 481
 482 (defun compile-loop-body (loop-vars body)
 483   (let* ((in-loop-scope? t)
 484          (in-function-scope? t) ;; not really, but we provide lexical
 485                                 ;; bindings for all free variables
 486                                 ;; using WITH
 487          (*loop-scope-lexicals* loop-vars)
 488          (*loop-scope-lexicals-captured* ())
 489          (*ps-gensym-counter* *ps-gensym-counter*)
 490          (compiled-body (compile-statement `(progn ,@body))))
 491     ;; the sort is there to make order for output-tests consistent across implementations
 492     (aif (sort (remove-duplicates *loop-scope-lexicals-captured*)
 493                #'string< :key #'symbol-name)
 494          `(ps-js:block
 495               (ps-js:with
 496                   ,(compile-expression
 497                     `(create
 498                       ,@(loop for x in it
 499                               collect x
 500                               collect (when (member x loop-vars) x))))
 501                 ,compiled-body))
 502          compiled-body)))
 503
 504 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 505 ;;; evalutation
 506
 507 (define-expression-operator quote (x)
 508   (flet ((quote% (expr) (when expr `',expr)))
 509     (compile-expression
 510      (typecase x
 511        (cons `(array ,@(mapcar #'quote% x)))
 512        (null '(array))
 513        (keyword x)
 514        (symbol (symbol-to-js-string x))
 515        (number x)
 516        (string x)
 517        (vector `(array ,@(loop for el across x collect (quote% el))))))))
 518
 519 (define-expression-operator eval-when (situation-list &body body)
 520   "The body is evaluated only during the given situations. The
 521 accepted situations are :load-toplevel, :compile-toplevel,
 522 and :execute. The code in BODY is assumed to be Common Lisp code
 523 in :compile-toplevel and :load-toplevel sitations, and Parenscript
 524 code in :execute."
 525   (when (and (member :compile-toplevel situation-list)
 526              (member *compilation-level* '(:toplevel :inside-toplevel-form)))
 527     (eval `(progn ,@body)))
 528   (if (member :execute situation-list)
 529       (ps-compile `(progn ,@body))
 530       (ps-compile `(progn))))