[clinton/parenscript.git] / src / js-macrology.lisp

(in-package :parenscript)

;;;; The macrology of the basic Javascript-in-SEXPs language.  Special forms and macros.

;;; literals
(defmacro defpsliteral (name string)
  `(define-ps-special-form ,name (expecting) (list 'js-literal ,string)))

(defpsliteral this      "this")
(defpsliteral t         "true")
(defpsliteral true      "true")
(defpsliteral false     "false")
(defpsliteral f         "false")
(defpsliteral nil       "null")
(defpsliteral undefined "undefined")

(defmacro defpskeyword (name string)
  `(define-ps-special-form ,name (expecting) (list 'js-keyword ,string)))

(defpskeyword break    "break")
(defpskeyword continue "continue")

(define-ps-special-form array (expecting &rest values)
  (cons 'array-literal (mapcar (lambda (form) (compile-parenscript-form form :expecting :expression))
                               values)))

(define-ps-special-form aref (expecting array &rest coords)
  (list 'js-aref (compile-parenscript-form array :expecting :expression)
        (mapcar (lambda (form)
                  (compile-parenscript-form form :expecting :expression))
                coords)))

(define-ps-special-form {} (expecting &rest arrows)
  (cons 'object-literal (loop for (key value) on arrows by #'cddr
                              collect (cons key (compile-parenscript-form value :expecting :expression)))))

;;; operators
(define-ps-special-form incf (expecting x &optional (delta 1))
  (if (equal delta 1)
      (list 'unary-operator "++" (compile-parenscript-form x :expecting :expression) :prefix t)
      (list 'operator '+= (list (compile-parenscript-form x :expecting :expression)
                                (compile-parenscript-form delta :expecting :expression)))))

(define-ps-special-form decf (expecting x &optional (delta 1))
  (if (equal delta 1)
      (list 'unary-operator "--" (compile-parenscript-form x :expecting :expression) :prefix t)
      (list 'operator '-= (list (compile-parenscript-form x :expecting :expression)
                                (compile-parenscript-form delta :expecting :expression)))))

(define-ps-special-form - (expecting first &rest rest)
  (if (null rest)
      (list 'unary-operator "-" (compile-parenscript-form first :expecting :expression) :prefix t)
      (list 'operator '- (mapcar (lambda (val) (compile-parenscript-form val :expecting :expression))
                                 (cons first rest)))))

(define-ps-special-form not (expecting x)
  (let ((form (compile-parenscript-form x :expecting :expression))
        (not-op nil))
    (if (and (eql (first form) 'operator)
	     (= (length (third form)) 2)
             (setf not-op (case (second form)
                            (== '!=)
                            (< '>=)
                            (> '<=)
                            (<= '>)
                            (>= '<)
                            (!= '==)
                            (=== '!==)
                            (!== '===)
                            (t nil))))
        (list 'operator not-op (third form))
        (list 'unary-operator "!" form :prefix t))))

(define-ps-special-form ~ (expecting x)
  (list 'unary-operator "~" (compile-parenscript-form x :expecting :expressin) :prefix t))

(defun flatten-blocks (body)
  (when body
    (if (and (listp (car body))
             (eql 'js-block (caar body)))
        (append (third (car body)) (flatten-blocks (cdr body)))
        (cons (car body) (flatten-blocks (cdr body))))))

(define-ps-special-form progn (expecting &rest body)
  (if (and (eql expecting :expression) (= 1 (length body)))
      (compile-parenscript-form (car body) :expecting :expression)
      (list 'js-block
            (if (eql expecting :statement) t nil)
            (let* ((block (mapcar (lambda (form)
                                    (compile-parenscript-form form :expecting :statement))
                                  body))
                   (clean-block (remove nil block))
                   (flat-block (flatten-blocks clean-block))
                   (reachable-block (append (remove-if #'constant-literal-form-p (butlast flat-block))
                                            (last flat-block))))
              reachable-block))))

;;; function definition
(define-ps-special-form %js-lambda (expecting args &rest body)
  (list 'js-lambda (mapcar (lambda (arg)
                             (compile-parenscript-form arg :expecting :symbol))
                           args)
        (compile-parenscript-form `(progn ,@body))))

(define-ps-special-form %js-defun (expecting name args &rest body)
  (list 'js-defun name
        (mapcar (lambda (val) (compile-parenscript-form val :expecting :symbol)) args)
	(compile-parenscript-form `(progn ,@body))))

;;; object creation
(define-ps-special-form create (expecting &rest args)
  (list 'js-object (loop for (name val) on args by #'cddr collecting
                         (let ((name-expr (compile-parenscript-form name :expecting :expression)))
                           (assert (or (stringp name-expr)
                                       (numberp name-expr)
                                       (and (listp name-expr)
                                            (or (eql 'js-variable (car name-expr))
                                                (eql 'script-quote (car name-expr)))))
                                   ()
                                   "Slot ~s is not one of js-variable, keyword, string or number." name-expr)
                           (list name-expr (compile-parenscript-form val :expecting :expression))))))

(define-ps-special-form %js-slot-value (expecting obj slot)
  (if (ps::ps-macroexpand slot)
      (list 'js-slot-value (compile-parenscript-form obj :expecting :expression) (compile-parenscript-form slot))
      (compile-parenscript-form obj :expecting :expression)))

(define-ps-special-form cond (expecting &rest clauses)
  (ecase expecting
    (:statement (list 'js-cond-statement
                      (mapcar (lambda (clause)
                                (destructuring-bind (test &rest body)
                                    clause
                                  (list (compile-parenscript-form test :expecting :expression)
                                        (compile-parenscript-form `(progn ,@body)))))
                              clauses)))
    (:expression (make-cond-clauses-into-nested-ifs clauses))))

(defun make-cond-clauses-into-nested-ifs (clauses)
  (if clauses
      (destructuring-bind (test &rest body)
          (car clauses)
        (if (eq t test)
            (compile-parenscript-form `(progn ,@body) :expecting :expression)
            (list 'js-expression-if (compile-parenscript-form test :expecting :expression)
                  (compile-parenscript-form `(progn ,@body) :expecting :expression)
                  (make-cond-clauses-into-nested-ifs (cdr clauses)))))
      (compile-parenscript-form nil :expecting :expression)))

(define-ps-special-form if (expecting test then &optional else)
  (ecase expecting
    (:statement (list 'js-statement-if (compile-parenscript-form test :expecting :expression)
                      (compile-parenscript-form `(progn ,then))
                      (when else (compile-parenscript-form `(progn ,else)))))
    (:expression (list 'js-expression-if (compile-parenscript-form test :expecting :expression)
                       (compile-parenscript-form then :expecting :expression)
                       (compile-parenscript-form else :expecting :expression)))))

(define-ps-special-form switch (expecting test-expr &rest clauses)
  (let ((clauses (mapcar (lambda (clause)
			     (let ((val (car clause))
				   (body (cdr clause)))
			       (list (if (eql val 'default)
					 'default
					 (compile-parenscript-form val :expecting :expression))
                                     (compile-parenscript-form `(progn ,@body)))))
			 clauses))
	(expr (compile-parenscript-form test-expr :expecting :expression)))
    (list 'js-switch expr clauses)))

;;; assignment
(defun assignment-op (op)
  (case op
    (+ '+=)
    (~ '~=)
    (\& '\&=)
    (\| '\|=)
    (- '-=)
    (* '*=)
    (% '%=)
    (>> '>>=)
    (^  '^=)
    (<< '<<=)
    (>>> '>>>=)
    (/   '/=)
    (t   nil)))

(defun smart-setf (lhs rhs)
  (if (and (listp rhs)
           (eql 'operator (car rhs))
	   (member lhs (third rhs) :test #'equalp))
      (let ((args-without (remove lhs (third rhs) :count 1 :test #'equalp))
	    (args-without-first (remove lhs (third rhs) :count 1 :end 1 :test #'equalp)))
	(cond ((and (equal (car args-without) 1) (eql (second rhs) '+))
	       (list 'unary-operator "++" lhs :prefix nil))
	      ((and (equal (second args-without-first) 1) (eql (second rhs) '-))
	       (list 'unary-operator "--" lhs :prefix nil))
	      ((and (assignment-op (second rhs))
		    (member (second rhs) '(+ *))
                    (equalp lhs (first (third rhs))))
	       (list 'operator (assignment-op (second rhs))
                     (list lhs (list 'operator (second rhs) args-without-first))))
	      ((and (assignment-op (second rhs)) (equalp (first (third rhs)) lhs))
	       (list 'operator (assignment-op (second rhs))
                     (list lhs (list 'operator (second rhs) (cdr (third rhs))))))
	      (t (list 'js-assign lhs rhs))))
      (list 'js-assign lhs rhs)))

(define-ps-special-form setf1% (expecting lhs rhs)
  (smart-setf (compile-parenscript-form lhs :expecting :expression) (compile-parenscript-form rhs :expecting :expression)))

(define-ps-special-form defvar (expecting name &rest value)
  (append (list 'js-defvar name)
          (when value
            (assert (= (length value) 1) () "Wrong number of arguments to defvar: ~s" `(defvar ,name ,@value))
           (list (compile-parenscript-form (car value) :expecting :expression)))))

;;; iteration
(defun make-for-vars (decls)
  (loop for decl in decls
	for var = (if (atom decl) decl (first decl))
	for init-value = (if (atom decl) nil (second decl))
	collect (cons (compile-parenscript-form var :expecting :symbol) (compile-parenscript-form init-value))))

(defun make-for-steps (decls)
  (loop for decl in decls
	when (= (length decl) 3)
	collect (compile-parenscript-form (third decl) :expecting :expression)))

(define-ps-special-form do (expecting decls termination-test &rest body)
  (let ((vars (make-for-vars decls))
	(steps (make-for-steps decls))
	(test (compile-parenscript-form `(not ,(first termination-test)) :expecting :expression))
	(body (compile-parenscript-form `(progn ,@body))))
    (list 'js-for vars steps test body)))

(define-ps-special-form doeach (expecting decl &rest body)
  (list 'js-for-each
        (first decl)
        (compile-parenscript-form (second decl) :expecting :expression)
	(compile-parenscript-form `(progn ,@body))))

(define-ps-special-form while (expecting test &rest body)
  (list 'js-while (compile-parenscript-form test :expecting :expression)
                  (compile-parenscript-form `(progn ,@body))))

(define-ps-special-form with (expecting expression &rest body)
  (list 'js-with (compile-parenscript-form expression :expecting :expression)
		 (compile-parenscript-form `(progn ,@body))))

(define-ps-special-form try (expecting form &rest clauses)
  (let ((catch (cdr (assoc :catch clauses)))
        (finally (cdr (assoc :finally clauses))))
    (assert (not (cdar catch)) nil "Sorry, currently only simple catch forms are supported.")
    (assert (or catch finally) ()
            "Try form should have either a catch or a finally clause or both.")
    (list 'js-try (compile-parenscript-form `(progn ,form))
          :catch (when catch (list (compile-parenscript-form (caar catch) :expecting :symbol)
                                   (compile-parenscript-form `(progn ,@(cdr catch)))))
          :finally (when finally (compile-parenscript-form `(progn ,@finally))))))

(define-ps-special-form regex (expecting regex)
  (list 'js-regex (string regex)))

;;; TODO instanceof
(define-ps-special-form instanceof (expecting value type)
  (list 'js-instanceof (compile-parenscript-form value :expecting :expression)
        (compile-parenscript-form type :expecting :expression)))

;;; single operations
(mapcar (lambda (op) (eval `(define-ps-special-form ,op (expecting value)
                             (list 'js-named-operator ',op (compile-parenscript-form value)))))
        '(throw delete void typeof new))

(define-ps-special-form return (expecting &optional value)
  (list 'js-return (compile-parenscript-form value :expecting :expression)))

;;; conditional compilation
(define-ps-special-form cc-if (expecting test &rest body)
  (list 'cc-if test (mapcar #'compile-parenscript-form body)))

;;; standard macros
(defpsmacro when (test &rest body)
  `(if ,test (progn ,@body)))

(defpsmacro unless (test &rest body)
  `(if (not ,test) (progn ,@body)))

(defpsmacro 1- (form)
  `(- ,form 1))

(defpsmacro 1+ (form)
  `(+ ,form 1))
Commit	Line	Data
4a987e2b	1	(in-package :parenscript)
5aa10005 RD	2
	3	;;;; The macrology of the basic Javascript-in-SEXPs language. Special forms and macros.
	4
	5	;;; literals
4a987e2b VS	6	(defmacro defpsliteral (name string)
	7	`(define-ps-special-form ,name (expecting) (list 'js-literal ,string)))
	8
	9	(defpsliteral this "this")
	10	(defpsliteral t "true")
	11	(defpsliteral true "true")
	12	(defpsliteral false "false")
	13	(defpsliteral f "false")
	14	(defpsliteral nil "null")
	15	(defpsliteral undefined "undefined")
	16
	17	(defmacro defpskeyword (name string)
	18	`(define-ps-special-form ,name (expecting) (list 'js-keyword ,string)))
	19
	20	(defpskeyword break "break")
	21	(defpskeyword continue "continue")
	22
	23	(define-ps-special-form array (expecting &rest values)
	24	(cons 'array-literal (mapcar (lambda (form) (compile-parenscript-form form :expecting :expression))
	25	values)))
	26
	27	(define-ps-special-form aref (expecting array &rest coords)
	28	(list 'js-aref (compile-parenscript-form array :expecting :expression)
	29	(mapcar (lambda (form)
	30	(compile-parenscript-form form :expecting :expression))
	31	coords)))
	32
	33	(define-ps-special-form {} (expecting &rest arrows)
	34	(cons 'object-literal (loop for (key value) on arrows by #'cddr
	35	collect (cons key (compile-parenscript-form value :expecting :expression)))))
5aa10005 RD	36
5aa10005 RD	37	;;; operators
4a987e2b VS	38	(define-ps-special-form incf (expecting x &optional (delta 1))
	39	(if (equal delta 1)
	40	(list 'unary-operator "++" (compile-parenscript-form x :expecting :expression) :prefix t)
	41	(list 'operator '+= (list (compile-parenscript-form x :expecting :expression)
	42	(compile-parenscript-form delta :expecting :expression)))))
	43
	44	(define-ps-special-form decf (expecting x &optional (delta 1))
	45	(if (equal delta 1)
	46	(list 'unary-operator "--" (compile-parenscript-form x :expecting :expression) :prefix t)
	47	(list 'operator '-= (list (compile-parenscript-form x :expecting :expression)
	48	(compile-parenscript-form delta :expecting :expression)))))
	49
	50	(define-ps-special-form - (expecting first &rest rest)
5aa10005	51	(if (null rest)
4a987e2b VS	52	(list 'unary-operator "-" (compile-parenscript-form first :expecting :expression) :prefix t)
	53	(list 'operator '- (mapcar (lambda (val) (compile-parenscript-form val :expecting :expression))
	54	(cons first rest)))))
	55
	56	(define-ps-special-form not (expecting x)
	57	(let ((form (compile-parenscript-form x :expecting :expression))
	58	(not-op nil))
	59	(if (and (eql (first form) 'operator)
	60	(= (length (third form)) 2)
	61	(setf not-op (case (second form)
	62	(== '!=)
	63	(< '>=)
	64	(> '<=)
	65	(<= '>)
	66	(>= '<)
	67	(!= '==)
	68	(=== '!==)
	69	(!== '===)
	70	(t nil))))
	71	(list 'operator not-op (third form))
	72	(list 'unary-operator "!" form :prefix t))))
	73
	74	(define-ps-special-form ~ (expecting x)
	75	(list 'unary-operator "~" (compile-parenscript-form x :expecting :expressin) :prefix t))
	76
839600e9 VS	77	(defun flatten-blocks (body)
839600e9 VS	78	(when body
4a987e2b	79	(if (and (listp (car body))
839600e9 VS	80	(eql 'js-block (caar body)))
	81	(append (third (car body)) (flatten-blocks (cdr body)))
	82	(cons (car body) (flatten-blocks (cdr body))))))
4a987e2b VS	83
4a987e2b VS	84	(define-ps-special-form progn (expecting &rest body)
b1017218 VS	85	(if (and (eql expecting :expression) (= 1 (length body)))
	86	(compile-parenscript-form (car body) :expecting :expression)
	87	(list 'js-block
	88	(if (eql expecting :statement) t nil)
13b8268e VS	89	(let* ((block (mapcar (lambda (form)
	90	(compile-parenscript-form form :expecting :statement))
	91	body))
	92	(clean-block (remove nil block))
	93	(flat-block (flatten-blocks clean-block))
	94	(reachable-block (append (remove-if #'constant-literal-form-p (butlast flat-block))
	95	(last flat-block))))
	96	reachable-block))))
5aa10005 RD	97
5aa10005 RD	98	;;; function definition
4a987e2b VS	99	(define-ps-special-form %js-lambda (expecting args &rest body)
	100	(list 'js-lambda (mapcar (lambda (arg)
	101	(compile-parenscript-form arg :expecting :symbol))
	102	args)
	103	(compile-parenscript-form `(progn ,@body))))
	104
	105	(define-ps-special-form %js-defun (expecting name args &rest body)
f26808d8	106	(list 'js-defun name
4a987e2b VS	107	(mapcar (lambda (val) (compile-parenscript-form val :expecting :symbol)) args)
4a987e2b VS	108	(compile-parenscript-form `(progn ,@body))))
5aa10005 RD	109
5aa10005 RD	110	;;; object creation
4a987e2b VS	111	(define-ps-special-form create (expecting &rest args)
	112	(list 'js-object (loop for (name val) on args by #'cddr collecting
	113	(let ((name-expr (compile-parenscript-form name :expecting :expression)))
	114	(assert (or (stringp name-expr)
	115	(numberp name-expr)
	116	(and (listp name-expr)
	117	(or (eql 'js-variable (car name-expr))
	118	(eql 'script-quote (car name-expr)))))
	119	()
	120	"Slot ~s is not one of js-variable, keyword, string or number." name-expr)
	121	(list name-expr (compile-parenscript-form val :expecting :expression))))))
	122
	123	(define-ps-special-form %js-slot-value (expecting obj slot)
	124	(if (ps::ps-macroexpand slot)
	125	(list 'js-slot-value (compile-parenscript-form obj :expecting :expression) (compile-parenscript-form slot))
	126	(compile-parenscript-form obj :expecting :expression)))
	127
	128	(define-ps-special-form cond (expecting &rest clauses)
0949f072 VS	129	(ecase expecting
	130	(:statement (list 'js-cond-statement
	131	(mapcar (lambda (clause)
	132	(destructuring-bind (test &rest body)
	133	clause
	134	(list (compile-parenscript-form test :expecting :expression)
	135	(compile-parenscript-form `(progn ,@body)))))
	136	clauses)))
	137	(:expression (make-cond-clauses-into-nested-ifs clauses))))
	138
	139	(defun make-cond-clauses-into-nested-ifs (clauses)
	140	(if clauses
	141	(destructuring-bind (test &rest body)
	142	(car clauses)
	143	(if (eq t test)
	144	(compile-parenscript-form `(progn ,@body) :expecting :expression)
	145	(list 'js-expression-if (compile-parenscript-form test :expecting :expression)
	146	(compile-parenscript-form `(progn ,@body) :expecting :expression)
	147	(make-cond-clauses-into-nested-ifs (cdr clauses)))))
	148	(compile-parenscript-form nil :expecting :expression)))
4a987e2b VS	149
	150	(define-ps-special-form if (expecting test then &optional else)
	151	(ecase expecting
	152	(:statement (list 'js-statement-if (compile-parenscript-form test :expecting :expression)
	153	(compile-parenscript-form `(progn ,then))
	154	(when else (compile-parenscript-form `(progn ,else)))))
	155	(:expression (list 'js-expression-if (compile-parenscript-form test :expecting :expression)
	156	(compile-parenscript-form then :expecting :expression)
5705b542	157	(compile-parenscript-form else :expecting :expression)))))
4a987e2b VS	158
	159	(define-ps-special-form switch (expecting test-expr &rest clauses)
	160	(let ((clauses (mapcar (lambda (clause)
	161	(let ((val (car clause))
5aa10005 RD	162	(body (cdr clause)))
	163	(list (if (eql val 'default)
	164	'default
4a987e2b VS	165	(compile-parenscript-form val :expecting :expression))
4a987e2b VS	166	(compile-parenscript-form `(progn ,@body)))))
5aa10005	167	clauses))
4a987e2b VS	168	(expr (compile-parenscript-form test-expr :expecting :expression)))
4a987e2b VS	169	(list 'js-switch expr clauses)))
5aa10005 RD	170
	171	;;; assignment
	172	(defun assignment-op (op)
	173	(case op
	174	(+ '+=)
	175	(~ '~=)
	176	(\& '\&=)
	177	(\\| '\\|=)
	178	(- '-=)
	179	(* '*=)
	180	(% '%=)
	181	(>> '>>=)
	182	(^ '^=)
	183	(<< '<<=)
	184	(>>> '>>>=)
	185	(/ '/=)
	186	(t nil)))
	187
4a987e2b VS	188	(defun smart-setf (lhs rhs)
	189	(if (and (listp rhs)
	190	(eql 'operator (car rhs))
	191	(member lhs (third rhs) :test #'equalp))
	192	(let ((args-without (remove lhs (third rhs) :count 1 :test #'equalp))
	193	(args-without-first (remove lhs (third rhs) :count 1 :end 1 :test #'equalp)))
	194	(cond ((and (equal (car args-without) 1) (eql (second rhs) '+))
	195	(list 'unary-operator "++" lhs :prefix nil))
	196	((and (equal (second args-without-first) 1) (eql (second rhs) '-))
	197	(list 'unary-operator "--" lhs :prefix nil))
	198	((and (assignment-op (second rhs))
	199	(member (second rhs) '(+ *))
	200	(equalp lhs (first (third rhs))))
	201	(list 'operator (assignment-op (second rhs))
	202	(list lhs (list 'operator (second rhs) args-without-first))))
	203	((and (assignment-op (second rhs)) (equalp (first (third rhs)) lhs))
	204	(list 'operator (assignment-op (second rhs))
	205	(list lhs (list 'operator (second rhs) (cdr (third rhs))))))
	206	(t (list 'js-assign lhs rhs))))
	207	(list 'js-assign lhs rhs)))
	208
	209	(define-ps-special-form setf1% (expecting lhs rhs)
	210	(smart-setf (compile-parenscript-form lhs :expecting :expression) (compile-parenscript-form rhs :expecting :expression)))
	211
	212	(define-ps-special-form defvar (expecting name &rest value)
f26808d8	213	(append (list 'js-defvar name)
4a987e2b VS	214	(when value
	215	(assert (= (length value) 1) () "Wrong number of arguments to defvar: ~s" `(defvar ,name ,@value))
	216	(list (compile-parenscript-form (car value) :expecting :expression)))))
5aa10005 RD	217
	218	;;; iteration
	219	(defun make-for-vars (decls)
	220	(loop for decl in decls
	221	for var = (if (atom decl) decl (first decl))
4a987e2b VS	222	for init-value = (if (atom decl) nil (second decl))
4a987e2b VS	223	collect (cons (compile-parenscript-form var :expecting :symbol) (compile-parenscript-form init-value))))
5aa10005 RD	224
	225	(defun make-for-steps (decls)
	226	(loop for decl in decls
	227	when (= (length decl) 3)
4a987e2b	228	collect (compile-parenscript-form (third decl) :expecting :expression)))
5aa10005	229
4a987e2b	230	(define-ps-special-form do (expecting decls termination-test &rest body)
5aa10005 RD	231	(let ((vars (make-for-vars decls))
5aa10005 RD	232	(steps (make-for-steps decls))
4a987e2b VS	233	(test (compile-parenscript-form `(not ,(first termination-test)) :expecting :expression))
	234	(body (compile-parenscript-form `(progn ,@body))))
	235	(list 'js-for vars steps test body)))
	236
	237	(define-ps-special-form doeach (expecting decl &rest body)
	238	(list 'js-for-each
f26808d8	239	(first decl)
4a987e2b VS	240	(compile-parenscript-form (second decl) :expecting :expression)
	241	(compile-parenscript-form `(progn ,@body))))
	242
	243	(define-ps-special-form while (expecting test &rest body)
	244	(list 'js-while (compile-parenscript-form test :expecting :expression)
	245	(compile-parenscript-form `(progn ,@body))))
	246
	247	(define-ps-special-form with (expecting expression &rest body)
	248	(list 'js-with (compile-parenscript-form expression :expecting :expression)
	249	(compile-parenscript-form `(progn ,@body))))
	250
	251	(define-ps-special-form try (expecting form &rest clauses)
	252	(let ((catch (cdr (assoc :catch clauses)))
	253	(finally (cdr (assoc :finally clauses))))
5aa10005	254	(assert (not (cdar catch)) nil "Sorry, currently only simple catch forms are supported.")
839600e9 VS	255	(assert (or catch finally) ()
839600e9 VS	256	"Try form should have either a catch or a finally clause or both.")
4a987e2b VS	257	(list 'js-try (compile-parenscript-form `(progn ,form))
	258	:catch (when catch (list (compile-parenscript-form (caar catch) :expecting :symbol)
	259	(compile-parenscript-form `(progn ,@(cdr catch)))))
	260	:finally (when finally (compile-parenscript-form `(progn ,@finally))))))
	261
	262	(define-ps-special-form regex (expecting regex)
	263	(list 'js-regex (string regex)))
5aa10005 RD	264
5aa10005 RD	265	;;; TODO instanceof
4a987e2b VS	266	(define-ps-special-form instanceof (expecting value type)
	267	(list 'js-instanceof (compile-parenscript-form value :expecting :expression)
	268	(compile-parenscript-form type :expecting :expression)))
5aa10005 RD	269
5aa10005 RD	270	;;; single operations
4a987e2b VS	271	(mapcar (lambda (op) (eval `(define-ps-special-form ,op (expecting value)
	272	(list 'js-named-operator ',op (compile-parenscript-form value)))))
	273	'(throw delete void typeof new))
5aa10005	274
4a987e2b VS	275	(define-ps-special-form return (expecting &optional value)
4a987e2b VS	276	(list 'js-return (compile-parenscript-form value :expecting :expression)))
a2434734	277
5aa10005	278	;;; conditional compilation
4a987e2b VS	279	(define-ps-special-form cc-if (expecting test &rest body)
4a987e2b VS	280	(list 'cc-if test (mapcar #'compile-parenscript-form body)))
5aa10005 RD	281
5aa10005 RD	282	;;; standard macros
4a987e2b	283	(defpsmacro when (test &rest body)
5aa10005 RD	284	`(if ,test (progn ,@body)))
5aa10005 RD	285
4a987e2b	286	(defpsmacro unless (test &rest body)
5aa10005 RD	287	`(if (not ,test) (progn ,@body)))
5aa10005 RD	288
4a987e2b	289	(defpsmacro 1- (form)
5aa10005 RD	290	`(- ,form 1))
5aa10005 RD	291
4a987e2b	292	(defpsmacro 1+ (form)
5aa10005	293	`(+ ,form 1))