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 (defun references? (exp place)
  67   (cond ((not exp) nil)
  68         ((atom exp) (equal exp place))
  69         (t (or (equal exp place)
  70                (references? (car exp) place)
  71                (references? (cdr exp) place)))))
  72
  73 (defmacro inc-dec (op op1 op2)
  74   `(let ((delta (ps-macroexpand delta)))
  75      (cond ((eql delta 1)
  76             (list ',op1 (compile-expression x)))
  77            ((references? delta x)
  78             (ps-compile
  79              (let ((var (ps-gensym "_PS_INCR_PLACE")))
  80                `(let ((,var ,delta))
  81                   (,',op ,x ,var)))))
  82            (t
  83             (list ',op2 (compile-expression x)
  84                   (compile-expression delta))))))
  85
  86 (define-expression-operator incf (x &optional (delta 1))
  87   (inc-dec incf ps-js:++ ps-js:+=))
  88
  89 (define-expression-operator decf (x &optional (delta 1))
  90   (inc-dec decf ps-js:-- ps-js:-=))
  91
  92 (let ((inverses (mapcan (lambda (x)
  93                           (list x (reverse x)))
  94                         '((ps-js:=== ps-js:!==)
  95                           (ps-js:== ps-js:!=)
  96                           (ps-js:< ps-js:>=)
  97                           (ps-js:> ps-js:<=)))))
  98   (define-expression-operator not (x)
  99     (let ((form (compile-expression x)))
 100       (acond ((and (listp form) (eq (car form) 'ps-js:!))
 101               (second form))
 102              ((and (listp form) (cadr (assoc (car form) inverses)))
 103               `(,it ,@(cdr form)))
 104              (t `(ps-js:! ,form))))))
 105
 106 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 107 ;;; blocks and control flow
 108
 109 (defun flatten-blocks (body)
 110   (when body
 111     (if (and (listp (car body)) (eq 'ps-js:block (caar body)))
 112         (append (cdr (car body)) (flatten-blocks (cdr body)))
 113         (cons (car body) (flatten-blocks (cdr body))))))
 114
 115 (defun compile-progn (body)
 116   (let ((block (flatten-blocks (mapcar #'ps-compile body))))
 117     (append (remove-if #'constantp (butlast block))
 118             (unless (and (or (eq *compilation-level* :toplevel)
 119                              (not compile-expression?))
 120                          (not (car (last block))))
 121               (last block)))))
 122
 123 (define-expression-operator progn (&rest body)
 124   (if (cdr body)
 125       `(ps-js:|,| ,@(compile-progn body))
 126       (compile-expression (car body))))
 127
 128 (define-statement-operator progn (&rest body)
 129   `(ps-js:block ,@(compile-progn body)))
 130
 131 (defun wrap-for-dynamic-return (handled-tags body)
 132   (aif (loop for (tag . thrown?) in *dynamic-return-tags*
 133              when (and thrown? (member tag handled-tags))
 134              collect tag)
 135       `(ps-js:block
 136          (ps-js:try
 137           ,body
 138           :catch
 139           (err
 140            ,(compile-statement
 141              `(progn
 142                 (cond
 143                   ,@(loop for tag in it collect
 144                          `((and err (eql ',tag (getprop err :ps-block-tag)))
 145                            ;; FIXME make this a multiple-value return
 146                            (when (and (@ arguments :callee :caller)
 147                                       (defined (@ arguments :callee :caller :mv)))
 148                              (setf (@ arguments :callee :caller :mv)
 149                                    (getprop err :ps-return-mv-rest)))
 150                            (return-from ,tag (getprop err :ps-return-value))))
 151                  (t (throw err))))))
 152           :finally nil))
 153       body))
 154
 155 (define-statement-operator block (name &rest body)
 156   (if in-function-scope?
 157       (let* ((name (or name 'nilBlock))
 158              (in-loop-scope? (if name in-loop-scope? nil))
 159              (*dynamic-return-tags* (cons (cons name nil) *dynamic-return-tags*))
 160              (*current-block-tag* name)
 161              (compiled-body (compile-statement `(progn ,@body))))
 162         `(ps-js:label ,name
 163                       ,(wrap-for-dynamic-return
 164                         (list name) compiled-body)))
 165       (ps-compile (with-lambda-scope `(block ,name ,@body)))))
 166
 167 (defun return-exp (tag &optional (value nil value?) rest-values)
 168   (symbol-macrolet
 169       ((cvalue (when value? (list (compile-expression value))))
 170        (crest  (mapcar #'compile-expression rest-values)))
 171     (acond ((or (eql '%function tag)
 172                 (member tag *function-block-names*))
 173             (if rest-values
 174                 (with-ps-gensyms (val1 valrest)
 175                   (compile-statement
 176                    `(let ((,val1 ,value)
 177                           (,valrest (list ,@rest-values)))
 178                       (when (defined (@ arguments :callee :caller :mv))
 179                         (setf (@ arguments :callee :caller :mv) ,valrest))
 180                       (return-from ,tag ,val1))))
 181                 `(ps-js:return ,@cvalue)))
 182            ((eql tag *current-block-tag*) ;; fixme: multiple values
 183             (if value?
 184                 `(ps-js:block ,@cvalue ,@crest (ps-js:break ,tag))
 185                 `(ps-js:break ,tag)))
 186            ((assoc tag *dynamic-return-tags*)
 187             (setf (cdr it) t)
 188             (ps-compile `(throw (create
 189                                  :ps-block-tag      ',tag
 190                                  :ps-return-value   ,value
 191                                  ,@(when rest-values
 192                                     `(:ps-return-mv-rest (list ,@rest-values)))))))
 193            (t
 194             (warn "Returning from unknown block ~A" tag)
 195             `(ps-js:return ,@cvalue))))) ;; for backwards-compatibility
 196
 197 (defun try-expressionizing-if? (exp &optional (score 0)) ;; poor man's codewalker
 198   (cond ((< 1 score) nil)
 199         ((and (listp exp) (eq (car exp) 'quote))
 200          t)
 201         ((listp exp)
 202          (loop for x in (cdr exp) always
 203               (try-expressionizing-if?
 204                (or (ignore-errors (ps-macroexpand x)) x) ;; fail
 205                (+ score (case (car exp)
 206                           ((if cond let) 1)
 207                           ((progn) (1- (length (cdr exp))))
 208                           (otherwise 0))))))
 209         (t t)))
 210
 211 (defun expressionize-result (tag form)
 212   (ps-compile
 213    (case (car form)
 214      ((continue break throw) ;; non-local exit
 215       form)
 216      ((with label let flet labels macrolet symbol-macrolet) ;; implicit progn forms
 217       `(,(first form) ,(second form)
 218          ,@(butlast (cddr form))
 219          (return-from ,tag ,(car (last (cddr form))))))
 220      (progn
 221        `(progn ,@(butlast (cdr form))
 222                (return-from ,tag ,(car (last (cdr form))))))
 223      (switch
 224       `(switch
 225         ,(second form)
 226         ,@(loop for (cvalue . cbody) in (cddr form)
 227              for remaining on (cddr form) collect
 228                (aif (cond ((or (eq 'default cvalue) (not (cdr remaining)))
 229                            1)
 230                           ((eq 'break (car (last cbody)))
 231                            2))
 232                     (let ((result-form (ps-macroexpand (car (last cbody it)))))
 233                       `(,cvalue
 234                         ,@(butlast cbody it)
 235                         (return-from ,tag
 236                           ,(if (eq result-form 'break) nil result-form))))
 237                     (cons cvalue cbody)))))
 238      (try
 239       `(try (return-from ,tag ,(second form))
 240             ,@(let ((catch (cdr (assoc :catch (cdr form))))
 241                     (finally (assoc :finally (cdr form))))
 242                    (list (when catch
 243                            `(:catch ,(car catch)
 244                               ,@(butlast (cdr catch))
 245                               (return-from ,tag ,(car (last (cdr catch))))))
 246                          finally))))
 247      (cond
 248        `(cond
 249           ,@(loop for clause in (cdr form) collect
 250                  `(,@(butlast clause) (return-from ,tag ,(car (last clause)))))
 251           ,@(when in-case? `((t (return-from ,tag nil))))))
 252      (if
 253       (if (and (try-expressionizing-if? form)
 254                (let ((used-up-names *used-up-names*)
 255                      (*lambda-wrappable-statements* ()))
 256                  (handler-case (compile-expression form)
 257                    (compile-expression-error ()
 258                      (setf *used-up-names* used-up-names)
 259                      nil))))
 260            (return-from expressionize-result (return-exp tag form))
 261            `(if ,(second form)
 262                 (return-from ,tag ,(third form))
 263                 ,@(when (or in-case? (fourth form))
 264                    `((return-from ,tag ,(fourth form)))))))
 265      (return-from ;; this will go away someday
 266       (unless tag
 267         (warn 'simple-style-warning
 268               :format-control "Trying to RETURN a RETURN without a block tag specified. Perhaps you're still returning values from functions by hand?
 269 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."))
 270        form)
 271      (otherwise
 272       (return-from expressionize-result
 273         (cond ((not (gethash (car form) *special-statement-operators*))
 274                (return-exp tag form))
 275               (in-case?
 276                `(ps-js:block ,(compile-statement form) ,(return-exp tag)))
 277               (t (compile-statement form))))))))
 278
 279 (define-statement-operator return-from (tag &optional result)
 280   (cond (tag
 281          (let ((form (ps-macroexpand result)))
 282            (cond ((atom form)             (return-exp tag form))
 283                  ((eq 'values (car form)) (return-exp tag (cadr form) (cddr form)))
 284                  (t                       (expressionize-result tag form)))))
 285         (in-loop-scope?
 286          (setf loop-returns?     t
 287                *loop-return-var* (or *loop-return-var*
 288                                      (ps-gensym "loop-result-var")))
 289          (compile-statement `(progn (setf ,*loop-return-var* ,result)
 290                                     (break))))
 291         (t
 292          (ps-compile `(return-from nilBlock ,result)))))
 293
 294
 295 (define-expression-operator values (&optional main &rest additional)
 296   (when main
 297     (ps-compile (if additional
 298                     `(prog1 ,main ,@additional)
 299                     main))))
 300
 301 (define-statement-operator throw (&rest args)
 302   `(ps-js:throw ,@(mapcar #'compile-expression args)))
 303
 304 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 305 ;;; conditionals
 306
 307 (define-expression-operator if (test then &optional else)
 308    `(ps-js:? ,(compile-expression test)
 309              ,(compile-expression then)
 310              ,(compile-expression else)))
 311
 312 (define-statement-operator if (test then &optional else)
 313   `(ps-js:if ,(compile-expression test)
 314              ,(compile-statement `(progn ,then))
 315              ,@(when else
 316                      `(:else ,(compile-statement `(progn ,else))))))
 317
 318 (define-expression-operator cond (&rest clauses)
 319   (compile-expression
 320    (when clauses
 321      (destructuring-bind (test &rest body) (car clauses)
 322        (if (eq t test)
 323            `(progn ,@body)
 324            `(if ,test
 325                 (progn ,@body)
 326                 (cond ,@(cdr clauses))))))))
 327
 328 (define-statement-operator cond (&rest clauses)
 329   `(ps-js:if ,(compile-expression (caar clauses))
 330              ,(compile-statement `(progn ,@(cdar clauses)))
 331              ,@(loop for (test . body) in (cdr clauses) appending
 332                     (if (eq t test)
 333                         `(:else ,(compile-statement `(progn ,@body)))
 334                         `(:else-if ,(compile-expression test)
 335                                    ,(compile-statement `(progn ,@body)))))))
 336
 337 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 338 ;;; macros
 339
 340 (defmacro with-local-macro-environment ((var env) &body body)
 341   `(let* ((,var (make-macro-dictionary))
 342           (,env (cons ,var ,env)))
 343      ,@body))
 344
 345 (define-expression-operator macrolet (macros &body body)
 346   (with-local-macro-environment (local-macro-dict *macro-env*)
 347     (dolist (macro macros)
 348       (destructuring-bind (name arglist &body body)
 349           macro
 350         (setf (gethash name local-macro-dict)
 351               (eval (make-ps-macro-function arglist body)))))
 352     (ps-compile `(progn ,@body))))
 353
 354 (define-expression-operator symbol-macrolet (symbol-macros &body body)
 355   (with-local-macro-environment (local-macro-dict *symbol-macro-env*)
 356     (let (local-var-bindings)
 357       (dolist (macro symbol-macros)
 358         (destructuring-bind (name expansion) macro
 359           (setf (gethash name local-macro-dict) (lambda (x) (declare (ignore x)) expansion))
 360           (push name local-var-bindings)))
 361       (let ((*enclosing-lexicals* (append local-var-bindings *enclosing-lexicals*)))
 362         (ps-compile `(progn ,@body))))))
 363
 364 (define-expression-operator defmacro (name args &body body)
 365   (eval `(defpsmacro ,name ,args ,@body))
 366   nil)
 367
 368 (define-expression-operator define-symbol-macro (name expansion)
 369   (eval `(define-ps-symbol-macro ,name ,expansion))
 370   nil)
 371
 372 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 373 ;;; assignment
 374
 375 (defun assignment-op (op)
 376   (getf '(ps-js:+   ps-js:+=
 377           ps-js:~   ps-js:~=
 378           ps-js:&   ps-js:&=
 379           ps-js:\|  ps-js:\|=
 380           ps-js:-   ps-js:-=
 381           ps-js:*   ps-js:*=
 382           ps-js:%   ps-js:%=
 383           ps-js:>>  ps-js:>>=
 384           ps-js:^   ps-js:^=
 385           ps-js:<<  ps-js:<<=
 386           ps-js:>>> ps-js:>>>=
 387           ps-js:/   ps-js:/=)
 388         op))
 389
 390 (define-expression-operator ps-assign (lhs rhs)
 391   (let ((rhs (ps-macroexpand rhs)))
 392     (if (and (listp rhs) (eq (car rhs) 'progn))
 393         (ps-compile `(progn ,@(butlast (cdr rhs))
 394                             (ps-assign ,lhs ,(car (last (cdr rhs))))))
 395         (let ((lhs (compile-expression lhs))
 396               (rhs (compile-expression rhs)))
 397           (aif (and (listp rhs)
 398                     (= 3 (length rhs))
 399                     (equal lhs (second rhs))
 400                     (assignment-op (first rhs)))
 401                (list it lhs (if (fourth rhs)
 402                                 (cons (first rhs) (cddr rhs))
 403                                 (third rhs)))
 404                (list 'ps-js:= lhs rhs))))))
 405
 406 (define-statement-operator defvar (name &optional
 407                                         (value (values) value-provided?)
 408                                         documentation)
 409   ;; this must be used as a top-level form, otherwise the resulting
 410   ;; behavior will be undefined.
 411   (declare (ignore documentation))
 412   (pushnew name *special-variables*)
 413   (ps-compile `(var ,name ,@(when value-provided? (list value)))))
 414
 415 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 416 ;;; binding
 417
 418 (defmacro with-declaration-effects ((var block) &body body)
 419   (let ((declarations (gensym)))
 420    `(let* ((,var ,block)
 421            (,declarations (and (listp (car ,var))
 422                                (eq (caar ,var) 'declare)
 423                                (cdar ,var)))
 424            (,var (if ,declarations
 425                      (cdr ,var)
 426                      ,var))
 427            (*special-variables* (append (cdr (find 'special ,declarations :key #'car)) *special-variables*)))
 428       ,@body)))
 429
 430 (defun maybe-rename-lexical-var (x symbols-in-bindings)
 431   (when (or (member x *enclosing-lexicals*)
 432             (member x *enclosing-function-arguments*)
 433             (when (boundp '*used-up-names*)
 434               (member x *used-up-names*))
 435             (lookup-macro-def x *symbol-macro-env*)
 436             (member x symbols-in-bindings))
 437     (ps-gensym (symbol-name x))))
 438
 439 (defun with-lambda-scope (body)
 440  (prog1 `((lambda () ,body))
 441    (setf *vars-needing-to-be-declared* ())))
 442
 443 (define-expression-operator let (bindings &body body)
 444   (with-declaration-effects (body body)
 445     (flet ((rename (x) (first x))
 446            (var (x) (second x))
 447            (val (x) (third x)))
 448       (let* ((new-lexicals ())
 449              (normalized-bindings
 450               (mapcar (lambda (x)
 451                         (if (symbolp x)
 452                             (list x nil)
 453                             (list (car x) (ps-macroexpand (cadr x)))))
 454                       bindings))
 455              (symbols-in-bindings
 456               (mapcan (lambda (x) (flatten (cadr x)))
 457                       normalized-bindings))
 458              (lexical-bindings
 459               (loop for x in normalized-bindings
 460                     unless (special-variable? (car x)) collect
 461                     (cons (aif (maybe-rename-lexical-var (car x)
 462                                                          symbols-in-bindings)
 463                                it
 464                                (progn
 465                                  (push (car x) new-lexicals)
 466                                  (when (boundp '*used-up-names*)
 467                                    (push (car x) *used-up-names*))
 468                                  nil))
 469                           x)))
 470              (dynamic-bindings
 471               (loop for x in normalized-bindings
 472                     when (special-variable? (car x)) collect
 473                     (cons (ps-gensym (format nil "~A_~A" (car x) 'tmp-stack))
 474                           x)))
 475              (renamed-body
 476               `(symbol-macrolet ,(loop for x in lexical-bindings
 477                                        when (rename x) collect
 478                                        `(,(var x) ,(rename x)))
 479                  ,@body))
 480              (*enclosing-lexicals*
 481               (append new-lexicals *enclosing-lexicals*))
 482              (*loop-scope-lexicals*
 483               (when in-loop-scope?
 484                 (append new-lexicals *loop-scope-lexicals*)))
 485              (let-body
 486               `(progn
 487                  ,@(mapcar (lambda (x)
 488                              `(var ,(or (rename x) (var x)) ,(val x)))
 489                            lexical-bindings)
 490                  ,(if dynamic-bindings
 491                       `(progn
 492                          ,@(mapcar (lambda (x) `(var ,(rename x)))
 493                                    dynamic-bindings)
 494                          (try
 495                           (progn
 496                             (setf ,@(loop for x in dynamic-bindings append
 497                                          `(,(rename x) ,(var x)
 498                                             ,(var x) ,(val x))))
 499                             ,renamed-body)
 500                           (:finally
 501                            (setf ,@(mapcan (lambda (x) `(,(var x) ,(rename x)))
 502                                            dynamic-bindings)))))
 503                       renamed-body))))
 504         (ps-compile (cond (in-function-scope? let-body)
 505                           ;; HACK
 506                           ((find-if (lambda (x)
 507                                       (member x '(defun% defvar)))
 508                                     (flatten
 509                                      (loop for x in body collecting
 510                                           (or (ignore-errors (ps-macroexpand x))
 511                                               x))))
 512                            let-body)
 513                           (t (with-lambda-scope let-body))))))))
 514
 515 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 516 ;;; iteration
 517
 518 (defun make-for-vars/inits (init-forms)
 519   (mapcar (lambda (x)
 520             (cons (ps-macroexpand (if (atom x) x (first x)))
 521                   (compile-expression (if (atom x) nil (second x)))))
 522           init-forms))
 523
 524 (defun compile-loop-body (loop-vars body)
 525   (let* ((in-loop-scope? t)
 526          (in-function-scope? t) ;; not really, but we provide lexical
 527                                 ;; bindings for all free variables
 528                                 ;; using WITH
 529          (*loop-scope-lexicals* loop-vars)
 530          (*loop-scope-lexicals-captured* ())
 531          (*ps-gensym-counter* *ps-gensym-counter*)
 532          (compiled-body (compile-statement `(progn ,@body))))
 533     ;; the sort is there to make order for output-tests consistent across implementations
 534     (aif (sort (remove-duplicates *loop-scope-lexicals-captured*)
 535                #'string< :key #'symbol-name)
 536          `(ps-js:block
 537               (ps-js:with
 538                   ,(compile-expression
 539                     `(create
 540                       ,@(loop for x in it
 541                               collect x
 542                               collect (when (member x loop-vars) x))))
 543                 ,compiled-body))
 544          compiled-body)))
 545
 546 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 547 ;;; evalutation
 548
 549 (define-expression-operator quote (x)
 550   (flet ((quote% (expr) (when expr `',expr)))
 551     (compile-expression
 552      (typecase x
 553        (cons `(array ,@(mapcar #'quote% x)))
 554        (null '(array))
 555        (keyword x)
 556        (symbol (symbol-to-js-string x))
 557        (number x)
 558        (string x)
 559        (vector `(array ,@(loop for el across x collect (quote% el))))))))
 560
 561 (define-expression-operator eval-when (situation-list &body body)
 562   "The body is evaluated only during the given situations. The
 563 accepted situations are :load-toplevel, :compile-toplevel,
 564 and :execute. The code in BODY is assumed to be Common Lisp code
 565 in :compile-toplevel and :load-toplevel sitations, and Parenscript
 566 code in :execute."
 567   (when (and (member :compile-toplevel situation-list)
 568              (member *compilation-level* '(:toplevel :inside-toplevel-form)))
 569     (eval `(progn ,@body)))
 570   (if (member :execute situation-list)
 571       (ps-compile `(progn ,@body))
 572       (ps-compile `(progn))))