src/special-forms.lisp

   1 (in-package "PARENSCRIPT")
   2
   3 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   4 ;;; literals
   5 (defmacro defpsliteral (name string)
   6   `(progn
   7      (add-ps-literal ',name)
   8      (define-ps-special-form ,name ()
   9        (list 'js:literal ,string))))
  10
  11 (defpsliteral this      "this")
  12 (defpsliteral t         "true")
  13 (defpsliteral true      "true")
  14 (defpsliteral false     "false")
  15 (defpsliteral f         "false")
  16 (defpsliteral nil       "null")
  17 (defpsliteral undefined "undefined")
  18
  19 (macrolet ((def-for-literal (name printer)
  20              `(progn
  21                 (add-ps-literal ',name)
  22                 (define-ps-special-form ,name (&optional label)
  23                   (list ',printer label)))))
  24   (def-for-literal break js:break)
  25   (def-for-literal continue js:continue))
  26
  27 (defpsmacro quote (x)
  28   (typecase x
  29     (cons (cons 'array (mapcar (lambda (x) `',x) x)))
  30     (null '(array))
  31     (symbol (symbol-to-js-string x))
  32     (number x)
  33     (string x)))
  34
  35 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  36 ;;; unary operators
  37 (macrolet ((def-unary-ops (&rest ops)
  38              `(progn ,@(mapcar (lambda (op)
  39                                  (let ((op (if (listp op) (car op) op))
  40                                        (spacep (if (listp op) (second op) nil)))
  41                                    `(define-ps-special-form ,op (x)
  42                                       (list 'js:unary-operator ',op
  43                                             (compile-parenscript-form x :expecting :expression)
  44                                             :prefix t :space ,spacep))))
  45                                ops))))
  46   (def-unary-ops ~ ! (new t) (delete t) (void t) (typeof t)))
  47
  48 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  49 ;;; statements
  50 (define-ps-special-form return (&optional value)
  51   `(js:return ,(compile-parenscript-form value :expecting :expression)))
  52
  53 (define-ps-special-form throw (value)
  54   `(js:throw ,(compile-parenscript-form value :expecting :expression)))
  55
  56 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  57 ;;; arrays
  58 (define-ps-special-form array (&rest values)
  59   `(js:array ,@(mapcar (lambda (form) (compile-parenscript-form form :expecting :expression))
  60                                values)))
  61
  62 (define-ps-special-form aref (array &rest coords)
  63   `(js:aref ,(compile-parenscript-form array :expecting :expression)
  64             ,(mapcar (lambda (form)
  65                        (compile-parenscript-form form :expecting :expression))
  66                      coords)))
  67
  68 (defpsmacro list (&rest values)
  69   `(array ,@values))
  70
  71 (defpsmacro make-array (&rest initial-values)
  72   `(new (*array ,@initial-values)))
  73
  74 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  75 ;;; operators
  76 (define-ps-special-form incf (x &optional (delta 1))
  77   (if (eql delta 1)
  78       `(js:unary-operator js:++ ,(compile-parenscript-form x :expecting :expression) :prefix t)
  79       `(js:operator js:+= ,(compile-parenscript-form x :expecting :expression)
  80                     ,(compile-parenscript-form delta :expecting :expression))))
  81
  82 (define-ps-special-form decf (x &optional (delta 1))
  83   (if (eql delta 1)
  84       `(js:unary-operator js:-- ,(compile-parenscript-form x :expecting :expression) :prefix t)
  85       `(js:operator js:-= ,(compile-parenscript-form x :expecting :expression)
  86                     ,(compile-parenscript-form delta :expecting :expression))))
  87
  88 (define-ps-special-form - (first &rest rest)
  89   (if rest
  90       `(js:operator js:- ,@(mapcar (lambda (val) (compile-parenscript-form val :expecting :expression))
  91                                    (cons first rest)))
  92       `(js:unary-operator js:- ,(compile-parenscript-form first :expecting :expression) :prefix t)))
  93
  94 (define-ps-special-form not (x)
  95   (let ((form (compile-parenscript-form x :expecting :expression))
  96         inverse-op)
  97     (if (and (eq (car form) 'js:operator)
  98              (= (length (cddr form)) 2)
  99              (setf inverse-op (case (cadr form)
 100                                 (== '!=)
 101                                 (< '>=)
 102                                 (> '<=)
 103                                 (<= '>)
 104                                 (>= '<)
 105                                 (!= '==)
 106                                 (=== '!==)
 107                                 (!== '===))))
 108         `(js:operator ,inverse-op ,@(cddr form))
 109         `(js:unary-operator js:! ,form :prefix t))))
 110
 111 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 112 ;;; control structures
 113 (defun flatten-blocks (body)
 114   (when body
 115     (if (and (listp (car body))
 116              (eq 'js:block (caar body)))
 117         (append (third (car body)) (flatten-blocks (cdr body)))
 118         (cons (car body) (flatten-blocks (cdr body))))))
 119
 120 (defun constant-literal-form-p (form)
 121   (or (numberp form)
 122       (stringp form)
 123       (and (listp form)
 124            (eq 'js:literal (car form)))))
 125
 126 (define-ps-special-form progn (&rest body)
 127   (if (and (eq expecting :expression) (= 1 (length body)))
 128       (compile-parenscript-form (car body) :expecting :expression)
 129       `(js:block
 130            ,expecting
 131          ,(let* ((block (flatten-blocks (remove nil (mapcar (lambda (form)
 132                                                               (compile-parenscript-form form :expecting expecting))
 133                                                             body)))))
 134                  (append (remove-if #'constant-literal-form-p (butlast block)) (last block))))))
 135
 136 (define-ps-special-form cond (&rest clauses)
 137   (ecase expecting
 138     (:statement `(js:cond ,(mapcar (lambda (clause)
 139                                      (destructuring-bind (test &rest body)
 140                                          clause
 141                                        (list (compile-parenscript-form test :expecting :expression)
 142                                              (compile-parenscript-form `(progn ,@body) :expecting :statement))))
 143                                    clauses)))
 144     (:expression (make-cond-clauses-into-nested-ifs clauses))))
 145
 146 (defun make-cond-clauses-into-nested-ifs (clauses)
 147   (if clauses
 148       (destructuring-bind (test &rest body)
 149           (car clauses)
 150         (if (eq t test)
 151             (compile-parenscript-form `(progn ,@body) :expecting :expression)
 152             `(js:? ,(compile-parenscript-form test :expecting :expression)
 153                    ,(compile-parenscript-form `(progn ,@body) :expecting :expression)
 154                    ,(make-cond-clauses-into-nested-ifs (cdr clauses)))))
 155       (compile-parenscript-form nil :expecting :expression))) ;; js:null
 156
 157 (define-ps-special-form if (test then &optional else)
 158   (ecase expecting
 159     (:statement `(js:if ,(compile-parenscript-form test :expecting :expression)
 160                         ,(compile-parenscript-form `(progn ,then))
 161                         ,(when else (compile-parenscript-form `(progn ,else)))))
 162     (:expression `(js:? ,(compile-parenscript-form test :expecting :expression)
 163                         ,(compile-parenscript-form then :expecting :expression)
 164                         ,(compile-parenscript-form else :expecting :expression)))))
 165
 166 (define-ps-special-form switch (test-expr &rest clauses)
 167   `(js:switch ,(compile-parenscript-form test-expr :expecting :expression)
 168      ,(loop for (val . body) in clauses collect
 169            (cons (if (and (symbolp val) (eq (ensure-ps-symbol val) 'default))
 170                      'default
 171                      (compile-parenscript-form val :expecting :expression))
 172                  (mapcar (lambda (x) (compile-parenscript-form x :expecting :statement))
 173                          body)))))
 174
 175 (defpsmacro case (value &rest clauses)
 176   (labels ((make-clause (val body more)
 177              (cond ((and (listp val) (not (eq (car val) 'quote)))
 178                     (append (mapcar #'list (butlast val))
 179                             (make-clause (first (last val)) body more)))
 180                    ((member val '(t otherwise))
 181                     (make-clause 'default body more))
 182                    (more `((,val ,@body break)))
 183                    (t `((,val ,@body))))))
 184     `(switch ,value ,@(mapcon (lambda (clause)
 185                                 (make-clause (car (first clause))
 186                                              (cdr (first clause))
 187                                              (rest clause)))
 188                               clauses))))
 189
 190 (defpsmacro when (test &rest body)
 191   `(if ,test (progn ,@body)))
 192
 193 (defpsmacro unless (test &rest body)
 194   `(if (not ,test) (progn ,@body)))
 195
 196 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 197 ;;; function definition
 198 (defun compile-function-definition (args body)
 199   (list (mapcar (lambda (arg) (compile-parenscript-form arg :expecting :symbol)) args)
 200         (let ((*enclosing-lexical-block-declarations* ()))
 201           ;; the first compilation will produce a list of variables we need to declare in the function body
 202           (compile-parenscript-form `(progn ,@body) :expecting :statement)
 203           ;; now declare and compile
 204           (compile-parenscript-form `(progn
 205                                        ,@(mapcar (lambda (var) `(var ,var)) *enclosing-lexical-block-declarations*)
 206                                        ,@body)
 207                                     :expecting :statement))))
 208
 209 (define-ps-special-form %js-lambda (args &rest body)
 210   `(js:lambda ,@(compile-function-definition args body)))
 211
 212 (define-ps-special-form %js-defun (name args &rest body)
 213   `(js:defun ,name ,@(compile-function-definition args body)))
 214
 215 (defun parse-function-body (body)
 216   (let* ((docstring
 217           (when (stringp (first body))
 218             (first body)))
 219          (body-forms (if docstring (rest body) body)))
 220     (values body-forms docstring)))
 221
 222 (defun parse-key-spec (key-spec)
 223   "parses an &key parameter.  Returns 5 values:
 224 var, init-form,  keyword-name, supplied-p-var, init-form-supplied-p.
 225
 226 Syntax of key spec:
 227 [&key {var | ({var | (keyword-name var)} [init-form [supplied-p-parameter]])}*
 228 "
 229   (let* ((var (cond ((symbolp key-spec) key-spec)
 230                     ((and (listp key-spec) (symbolp (first key-spec))) (first key-spec))
 231                     ((and (listp key-spec) (listp (first key-spec)))   (second key-spec))))
 232          (keyword-name (if (and (listp key-spec) (listp (first key-spec)))
 233                            (first (first key-spec))
 234                            (intern (string var) :keyword)))
 235          (init-form (if (listp key-spec) (second key-spec) nil))
 236          (init-form-supplied-p (if (listp key-spec) t nil))
 237          (supplied-p-var (if (listp key-spec) (third key-spec) nil)))
 238     (values var init-form keyword-name supplied-p-var init-form-supplied-p)))
 239
 240 (defun parse-optional-spec (spec)
 241   "Parses an &optional parameter.  Returns 3 values: var, init-form, supplied-p-var.
 242 [&optional {var | (var [init-form [supplied-p-parameter]])}*] "
 243   (let* ((var (cond ((symbolp spec) spec)
 244                     ((and (listp spec) (first spec)))))
 245          (init-form (if (listp spec) (second spec)))
 246          (supplied-p-var (if (listp spec) (third spec))))
 247     (values var init-form supplied-p-var)))
 248
 249 (defun parse-aux-spec (spec)
 250   "Returns two values: variable and init-form"
 251   ;; [&aux {var | (var [init-form])}*])
 252   (values (if (symbolp spec) spec (first spec))
 253           (when (listp spec) (second spec))))
 254
 255 (defpsmacro defaultf (place value)
 256   `(when (=== ,place undefined)
 257      (setf ,place ,value)))
 258
 259 (defun parse-extended-function (lambda-list body &optional name)
 260   "Returns two values: the effective arguments and body for a function with
 261 the given lambda-list and body."
 262
 263   ;; The lambda list is transformed as follows, since a javascript lambda list is just a
 264   ;; list of variable names, and you have access to the arguments variable inside the function:
 265   ;; * standard variables are the mapped directly into the js-lambda list
 266   ;; * optional variables' variable names are mapped directly into the lambda list,
 267   ;;   and for each optional variable with name v and default value d, a form is produced
 268   ;;   (defaultf v d)
 269   ;; * keyword variables are not included in the js-lambda list, but instead are
 270   ;;   obtained from the magic js ARGUMENTS pseudo-array. Code assigning values to
 271   ;;   keyword vars is prepended to the body of the function.
 272   (declare (ignore name))
 273   (multiple-value-bind (requireds optionals rest? rest keys? keys allow? aux? aux
 274                                   more? more-context more-count key-object)
 275       (parse-lambda-list lambda-list)
 276     (declare (ignore allow? aux? aux more? more-context more-count key-object))
 277     (let* (;; optionals are of form (var default-value)
 278            (effective-args
 279             (remove-if
 280              #'null
 281              (append requireds
 282                      (mapcar #'parse-optional-spec optionals))))
 283            (opt-forms
 284             (mapcar #'(lambda (opt-spec)
 285                         (multiple-value-bind (var val) (parse-optional-spec opt-spec)
 286                           `(defaultf ,var ,val)))
 287                     optionals))
 288            (key-forms
 289             (when keys?
 290               (with-ps-gensyms (n)
 291                 (let ((decls nil) (assigns nil) (defaults nil))
 292                   (mapc (lambda (k)
 293                           (multiple-value-bind (var init-form keyword)
 294                               (parse-key-spec k)
 295                             (push (list 'var var) decls)
 296                             (push `(,keyword (setf ,var (aref arguments (1+ ,n)))) assigns)
 297                             (push (list 'defaultf var init-form) defaults)))
 298                         (reverse keys))
 299                   `(,@decls
 300                     (loop :for ,n :from ,(length requireds)
 301                       :below (length arguments) :by 2 :do
 302                       (case (aref arguments ,n) ,@assigns))
 303                     ,@defaults)))))
 304            (rest-form
 305             (if rest?
 306                 (with-ps-gensyms (i)
 307                   `(progn (var ,rest (array))
 308                     (dotimes (,i (- (slot-value arguments 'length) ,(length effective-args)))
 309                       (setf (aref ,rest ,i) (aref arguments (+ ,i ,(length effective-args)))))))
 310                 `(progn)))
 311            (body-paren-forms (parse-function-body body)) ; remove documentation
 312            (effective-body (append opt-forms key-forms (list rest-form) body-paren-forms)))
 313       (values effective-args effective-body))))
 314
 315 (defpsmacro defun (name lambda-list &body body)
 316   "An extended defun macro that allows cool things like keyword arguments.
 317 lambda-list::=
 318  (var*
 319   [&optional {var | (var [init-form [supplied-p-parameter]])}*]
 320   [&rest var]
 321   [&key {var | ({var | (keyword-name var)} [init-form [supplied-p-parameter]])}* [&allow-other-keys]]
 322   [&aux {var | (var [init-form])}*])"
 323   (if (symbolp name)
 324       `(defun-function ,name ,lambda-list ,@body)
 325       (progn (assert (and (= (length name) 2) (eq 'setf (ensure-ps-symbol (car name)))) ()
 326                      "(defun ~s ~s ...) needs to have a symbol or (setf symbol) for a name." name lambda-list)
 327              `(defun-setf ,name ,lambda-list ,@body))))
 328
 329 (defpsmacro defun-function (name lambda-list &body body)
 330   (multiple-value-bind (effective-args effective-body)
 331       (parse-extended-function lambda-list body name)
 332     `(%js-defun ,name ,effective-args
 333       ,@effective-body)))
 334
 335 (defvar *defun-setf-name-prefix* "__setf_")
 336
 337 (defpsmacro defun-setf (setf-name lambda-list &body body)
 338   (let ((mangled-function-name (intern (concatenate 'string *defun-setf-name-prefix* (symbol-name (second setf-name)))
 339                                        (symbol-package (second setf-name))))
 340         (function-args (cdr (ordered-set-difference lambda-list lambda-list-keywords))))
 341     `(progn (defsetf ,(second setf-name) ,(cdr lambda-list) (store-var)
 342               `(,',mangled-function-name ,store-var ,@(list ,@function-args)))
 343             (defun ,mangled-function-name ,lambda-list ,@body))))
 344
 345 (defpsmacro lambda (lambda-list &body body)
 346   "An extended defun macro that allows cool things like keyword arguments.
 347 lambda-list::=
 348  (var*
 349   [&optional {var | (var [init-form [supplied-p-parameter]])}*]
 350   [&rest var]
 351   [&key {var | ({var | (keyword-name var)} [init-form [supplied-p-parameter]])}* [&allow-other-keys]]
 352   [&aux {var | (var [init-form])}*])"
 353   (multiple-value-bind (effective-args effective-body)
 354       (parse-extended-function lambda-list body)
 355     `(%js-lambda ,effective-args
 356       ,@effective-body)))
 357
 358 (defpsmacro flet (fn-defs &rest body)
 359   (flet ((process-fn-def (def)
 360            `(var ,(car def) (lambda ,@(cdr def)))))
 361     `(progn ,@(mapcar #'process-fn-def fn-defs) ,@body)))
 362
 363 (defpsmacro labels (fn-defs &rest body)
 364   (flet ((process-fn-def (def)
 365            `(var ,(car def) (defun ,(car def) ,@(cdr def)))))
 366     `(progn ,@(mapcar #'process-fn-def fn-defs) ,@body)))
 367
 368 (defpsmacro defsetf-long (access-fn lambda-list (store-var) form)
 369   (setf (get-macro-spec access-fn *ps-setf-expanders*)
 370         (compile nil
 371                  (let ((var-bindings (ordered-set-difference lambda-list lambda-list-keywords)))
 372                    `(lambda (access-fn-args store-form)
 373                      (destructuring-bind ,lambda-list
 374                                access-fn-args
 375                        (let* ((,store-var (ps-gensym))
 376                               (gensymed-names (loop repeat ,(length var-bindings) collecting (ps-gensym)))
 377                               (gensymed-arg-bindings (mapcar #'list gensymed-names (list ,@var-bindings))))
 378                          (destructuring-bind ,var-bindings
 379                              gensymed-names
 380                            `(let* (,@gensymed-arg-bindings
 381                                    (,,store-var ,store-form))
 382                              ,,form))))))))
 383   nil)
 384
 385 (defpsmacro defsetf-short (access-fn update-fn &optional docstring)
 386   (declare (ignore docstring))
 387   (setf (get-macro-spec access-fn *ps-setf-expanders*)
 388         (lambda (access-fn-args store-form)
 389           `(,update-fn ,@access-fn-args ,store-form)))
 390   nil)
 391
 392 (defpsmacro defsetf (access-fn &rest args)
 393   `(,(if (= (length args) 3) 'defsetf-long 'defsetf-short) ,access-fn ,@args))
 394
 395 (defpsmacro funcall (&rest arg-form)
 396   arg-form)
 397
 398 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 399 ;;; macros
 400 (defmacro with-temp-macro-environment ((var) &body body)
 401   `(let* ((,var (make-macro-env-dictionary))
 402           (*ps-macro-env* (cons ,var *ps-macro-env*)))
 403     ,@body))
 404
 405 (define-ps-special-form macrolet (macros &body body)
 406   (with-temp-macro-environment (macro-env-dict)
 407     (dolist (macro macros)
 408       (destructuring-bind (name arglist &body body)
 409           macro
 410         (setf (get-macro-spec name macro-env-dict)
 411               (cons nil (eval (make-ps-macro-function arglist body))))))
 412     (compile-parenscript-form `(progn ,@body))))
 413
 414 (define-ps-special-form symbol-macrolet (symbol-macros &body body)
 415   (with-temp-macro-environment (macro-env-dict)
 416     (dolist (macro symbol-macros)
 417       (destructuring-bind (name expansion)
 418           macro
 419         (setf (get-macro-spec name macro-env-dict)
 420               (cons t (lambda (x) (declare (ignore x)) expansion)))))
 421     (compile-parenscript-form `(progn ,@body))))
 422
 423 (define-ps-special-form defmacro (name args &body body) ;; should this be a macro?
 424   (eval `(defpsmacro ,name ,args ,@body))
 425   nil)
 426
 427 (define-ps-special-form define-symbol-macro (name expansion) ;; should this be a macro?
 428   (eval `(define-ps-symbol-macro ,name ,expansion))
 429   nil)
 430
 431 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 432 ;;; objects
 433 (add-ps-literal '{})
 434 (define-ps-symbol-macro {} (create))
 435
 436 (define-ps-special-form create (&rest arrows)
 437   `(js:object ,@(loop for (key-expr val-expr) on arrows by #'cddr collecting
 438                      (let ((key (compile-parenscript-form key-expr :expecting :expression)))
 439                        (when (keywordp key)
 440                          (setf key `(js:variable ,key)))
 441                        (assert (or (stringp key)
 442                                    (numberp key)
 443                                    (and (listp key)
 444                                         (or (eq 'js:variable (car key))
 445                                             (eq 'quote (car key)))))
 446                                ()
 447                                "Slot key ~s is not one of js-variable, keyword, string or number." key)
 448                        (cons key (compile-parenscript-form val-expr :expecting :expression))))))
 449
 450 (define-ps-special-form %js-slot-value (obj slot)
 451   `(js:slot-value ,(compile-parenscript-form obj :expecting :expression)
 452                   ,(if (and (listp slot) (eq 'quote (car slot)))
 453                        (second slot) ;; assume we're quoting a symbol
 454                        (compile-parenscript-form slot))))
 455
 456 (define-ps-special-form instanceof (value type)
 457   `(js:instanceof ,(compile-parenscript-form value :expecting :expression)
 458                   ,(compile-parenscript-form type :expecting :expression)))
 459
 460 (defpsmacro slot-value (obj &rest slots)
 461   (if (null (rest slots))
 462       `(%js-slot-value ,obj ,(first slots))
 463       `(slot-value (slot-value ,obj ,(first slots)) ,@(rest slots))))
 464
 465 (defpsmacro with-slots (slots object &rest body)
 466   (flet ((slot-var (slot) (if (listp slot) (first slot) slot))
 467          (slot-symbol (slot) (if (listp slot) (second slot) slot)))
 468     `(symbol-macrolet ,(mapcar #'(lambda (slot)
 469                                    `(,(slot-var slot) (slot-value ,object ',(slot-symbol slot))))
 470                                slots)
 471       ,@body)))
 472
 473 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 474 ;;; assignment and binding
 475 (defun assignment-op (op)
 476   (case op
 477     (+ '+=)
 478     (~ '~=)
 479     (\& '\&=)
 480     (\| '\|=)
 481     (- '-=)
 482     (* '*=)
 483     (% '%=)
 484     (>> '>>=)
 485     (^  '^=)
 486     (<< '<<=)
 487     (>>> '>>>=)
 488     (/   '/=)
 489     (t   nil)))
 490
 491 (define-ps-special-form setf1% (lhs rhs)
 492   (let ((lhs (compile-parenscript-form lhs :expecting :expression))
 493         (rhs (compile-parenscript-form rhs :expecting :expression)))
 494     (if (and (listp rhs)
 495              (eq 'js:operator (car rhs))
 496              (member (cadr rhs) '(+ *))
 497              (equalp lhs (caddr rhs)))
 498         `(js:operator ,(assignment-op (cadr rhs)) ,lhs (js:operator ,(cadr rhs) ,@(cdddr rhs)))
 499         `(js:= ,lhs ,rhs))))
 500
 501 (defpsmacro setf (&rest args)
 502   (flet ((process-setf-clause (place value-form)
 503            (if (and (listp place) (get-macro-spec (car place) *ps-setf-expanders*))
 504                (funcall (get-macro-spec (car place) *ps-setf-expanders*) (cdr place) value-form)
 505                (let ((exp-place (ps-macroexpand place)))
 506                  (if (and (listp exp-place) (get-macro-spec (car exp-place) *ps-setf-expanders*))
 507                      (funcall (get-macro-spec (car exp-place) *ps-setf-expanders*) (cdr exp-place) value-form)
 508                      `(setf1% ,exp-place ,value-form))))))
 509     (assert (evenp (length args)) ()
 510             "~s does not have an even number of arguments." (cons 'setf args))
 511     `(progn ,@(loop for (place value) on args by #'cddr collect (process-setf-clause place value)))))
 512
 513 (defpsmacro psetf (&rest args)
 514   (let ((vars (loop for x in args by #'cddr collect x))
 515         (vals (loop for x in (cdr args) by #'cddr collect x)))
 516     (let ((gensyms (mapcar (lambda (x) (declare (ignore x)) (ps-gensym)) vars)))
 517       `(simple-let* ,(mapcar #'list gensyms vals)
 518          (setf ,@(mapcan #'list vars gensyms))))))
 519
 520 (defun check-setq-args (args)
 521   (let ((vars (loop for x in args by #'cddr collect x)))
 522     (let ((non-var (find-if (complement #'symbolp) vars)))
 523       (when non-var
 524         (error 'type-error :datum non-var :expected-type 'symbol)))))
 525
 526 (defpsmacro setq (&rest args)
 527   (check-setq-args args)
 528   `(setf ,@args))
 529
 530 (defpsmacro psetq (&rest args)
 531   (check-setq-args args)
 532   `(psetf ,@args))
 533
 534 (define-ps-special-form var (name &optional (value (values) value-provided?) documentation)
 535   (declare (ignore documentation))
 536   `(js:var ,name ,@(when value-provided?
 537                          (list (compile-parenscript-form value :expecting :expression)))))
 538
 539 (defpsmacro defvar (name &optional (value (values) value-provided?) documentation)
 540   "Note: this must be used as a top-level form, otherwise the result will be undefined behavior."
 541   (pushnew name *ps-special-variables*)
 542   `(var ,name ,@(when value-provided? (list value))))
 543
 544 (defun make-let-vars (bindings)
 545   (mapcar (lambda (x) (if (listp x) (car x) x)) bindings))
 546
 547 (defun make-let-vals (bindings)
 548   (mapcar (lambda (x) (if (or (atom x) (endp (cdr x))) nil (second x))) bindings))
 549
 550 (defpsmacro lexical-let* (bindings &body body)
 551   `((lambda ()
 552       (let* ,bindings
 553         ,@body))))
 554
 555 (defpsmacro lexical-let (bindings &body body)
 556   `((lambda ,(make-let-vars bindings)
 557       ,@body)
 558     ,@(make-let-vals bindings)))
 559
 560 (defpsmacro simple-let* (bindings &body body)
 561   (if bindings
 562       (let ((var (if (listp (car bindings)) (caar bindings) (car bindings))))
 563         `(,(if (member var *ps-special-variables*) 'let1-dynamic 'let1) ,(car bindings)
 564            (simple-let* ,(cdr bindings) ,@body)))
 565       `(progn ,@body)))
 566
 567 (defpsmacro simple-let (bindings &body body)
 568   (let ((vars (mapcar (lambda (x) (if (atom x) x (first x))) bindings))
 569         (vals (mapcar (lambda (x) (if (or (atom x) (endp (cdr x))) nil (second x))) bindings)))
 570     (let ((gensyms (mapcar (lambda (x) (ps-gensym (format nil "_js_~a" x))) vars)))
 571       `(simple-let* ,(mapcar #'list gensyms vals)
 572          (simple-let* ,(mapcar #'list vars gensyms)
 573            ,@(mapcar (lambda (x) `(delete ,x)) gensyms)
 574            ,@body)))))
 575
 576 (defpsmacro let* (bindings &body body)
 577   `(simple-let* ,bindings ,@body))
 578
 579 (defpsmacro let (bindings &body body)
 580   `(,(if (= 1 (length bindings)) 'simple-let* 'simple-let) ,bindings ,@body))
 581
 582 (define-ps-special-form let1 (binding &rest body)
 583   (ecase expecting
 584     (:statement
 585      (compile-parenscript-form `(progn ,(if (atom binding) `(var ,binding) `(var ,@binding)) ,@body) :expecting :statement))
 586     (:expression
 587      (let ((var (if (atom binding) binding (car binding)))
 588            (variable-assignment (when (listp binding) (cons 'setf binding))))
 589        (push var *enclosing-lexical-block-declarations*)
 590        (compile-parenscript-form `(progn ,variable-assignment ,@body) :expecting :expression)))))
 591
 592 (defpsmacro let1-dynamic ((var value) &rest body)
 593   (with-ps-gensyms (temp-stack-var)
 594     `(progn (var ,temp-stack-var)
 595       (try (progn (setf ,temp-stack-var ,var)
 596                   (setf ,var ,value)
 597                   ,@body)
 598        (:finally
 599         (setf ,var ,temp-stack-var)
 600         (delete ,temp-stack-var))))))
 601
 602 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 603 ;;; iteration
 604 (defun make-for-vars/inits (init-forms)
 605   (mapcar (lambda (x)
 606             (cons (compile-parenscript-form (if (atom x) x (first x)) :expecting :symbol)
 607                   (compile-parenscript-form (if (atom x) nil (second x)) :expecting :expression)))
 608           init-forms))
 609
 610 (define-ps-special-form labeled-for (label init-forms cond-forms step-forms &rest body)
 611   `(js:for ,label
 612            ,(make-for-vars/inits init-forms)
 613            ,(mapcar (lambda (x) (compile-parenscript-form x :expecting :expression)) cond-forms)
 614            ,(mapcar (lambda (x) (compile-parenscript-form x :expecting :expression)) step-forms)
 615            ,(compile-parenscript-form `(progn ,@body))))
 616
 617 (defpsmacro for (init-forms cond-forms step-forms &body body)
 618   `(labeled-for nil ,init-forms ,cond-forms ,step-forms ,@body))
 619
 620 (defun do-make-let-bindings (decls)
 621   (mapcar (lambda (x)
 622             (if (atom x) x
 623                 (if (endp (cdr x)) (list (car x))
 624                     (subseq x 0 2))))
 625           decls))
 626
 627 (defun do-make-init-vars (decls)
 628   (mapcar (lambda (x) (if (atom x) x (first x))) decls))
 629
 630 (defun do-make-init-vals (decls)
 631   (mapcar (lambda (x) (if (or (atom x) (endp (cdr x))) nil (second x))) decls))
 632
 633 (defun do-make-for-vars/init (decls)
 634   (mapcar (lambda (x)
 635             (if (atom x) x
 636                 (if (endp (cdr x)) x
 637                     (subseq x 0 2))))
 638           decls))
 639
 640 (defun do-make-for-steps (decls)
 641   (mapcar (lambda (x)
 642             `(setf ,(first x) ,(third x)))
 643           (remove-if (lambda (x) (or (atom x) (< (length x) 3))) decls)))
 644
 645 (defun do-make-iter-psteps (decls)
 646   `(psetq
 647     ,@(mapcan (lambda (x) (list (first x) (third x)))
 648               (remove-if (lambda (x) (or (atom x) (< (length x) 3))) decls))))
 649
 650 (defpsmacro do* (decls (termination &optional (result nil result?)) &body body)
 651   (if result?
 652       `((lambda ()
 653           (for ,(do-make-for-vars/init decls) ((not ,termination)) ,(do-make-for-steps decls)
 654                ,@body)
 655           (return ,result)))
 656       `(progn
 657          (for ,(do-make-for-vars/init decls) ((not ,termination)) ,(do-make-for-steps decls)
 658               ,@body))))
 659
 660 (defpsmacro do (decls (termination &optional (result nil result?)) &body body)
 661   (if result?
 662       `((lambda ,(do-make-init-vars decls)
 663           (for () ((not ,termination)) ()
 664                ,@body
 665                ,(do-make-iter-psteps decls))
 666           (return ,result))
 667         ,@(do-make-init-vals decls))
 668       `(let ,(do-make-let-bindings decls)
 669          (for () ((not ,termination)) ()
 670               ,@body
 671               ,(do-make-iter-psteps decls)))))
 672
 673 (define-ps-special-form for-in ((var object) &rest body)
 674   `(js:for-in ,(compile-parenscript-form `(var ,var) :expecting :expression)
 675               ,(compile-parenscript-form object :expecting :expression)
 676               ,(compile-parenscript-form `(progn ,@body))))
 677
 678 (define-ps-special-form while (test &rest body)
 679   `(js:while ,(compile-parenscript-form test :expecting :expression)
 680      ,(compile-parenscript-form `(progn ,@body))))
 681
 682 (defpsmacro dotimes ((var count &optional (result nil result?)) &rest body)
 683   `(do* ((,var 0 (1+ ,var)))
 684         ((>= ,var ,count) ,@(when result? (list result)))
 685      ,@body))
 686
 687 (defpsmacro dolist ((var array &optional (result nil result?)) &body body)
 688   (let ((idx (ps-gensym "_js_idx"))
 689         (arrvar (ps-gensym "_js_arrvar")))
 690     `(do* (,var
 691            (,arrvar ,array)
 692            (,idx 0 (1+ ,idx)))
 693           ((>= ,idx (slot-value ,arrvar 'length))
 694            ,@(when result? (list result)))
 695        (setq ,var (aref ,arrvar ,idx))
 696        ,@body)))
 697
 698 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 699 ;;; misc
 700 (define-ps-special-form with (expression &rest body)
 701   `(js:with ,(compile-parenscript-form expression :expecting :expression)
 702      ,(compile-parenscript-form `(progn ,@body))))
 703
 704 (define-ps-special-form try (form &rest clauses)
 705   (let ((catch (cdr (assoc :catch clauses)))
 706         (finally (cdr (assoc :finally clauses))))
 707     (assert (not (cdar catch)) nil "Sorry, currently only simple catch forms are supported.")
 708     (assert (or catch finally) ()
 709             "Try form should have either a catch or a finally clause or both.")
 710     `(js:try ,(compile-parenscript-form `(progn ,form))
 711           :catch ,(when catch (list (compile-parenscript-form (caar catch) :expecting :symbol)
 712                                    (compile-parenscript-form `(progn ,@(cdr catch)))))
 713           :finally ,(when finally (compile-parenscript-form `(progn ,@finally))))))
 714
 715 (define-ps-special-form cc-if (test &rest body)
 716   `(js:cc-if ,test ,@(mapcar #'compile-parenscript-form body)))
 717
 718 (define-ps-special-form regex (regex)
 719   `(js:regex ,(string regex)))
 720
 721 (define-ps-special-form lisp (lisp-form)
 722   ;; (ps (foo (lisp bar))) is in effect equivalent to (ps* `(foo ,bar))
 723   ;; when called from inside of ps*, lisp-form has access only to the dynamic environment (like for eval)
 724   `(js:escape ,(ps1* lisp-form)))