[Drop unused js2.lisp
Marco Baringer <mb@bese.it>**20060716170749] {
hunk ./src/js2.lisp 1
-(in-package :js)
-
-;;; javascript name conversion
-
-(defvar *special-chars*
-  '((#\! . "Bang")
-    (#\? . "What")
-    (#\# . "Hash")
-    (#\@ . "At")
-    (#\% . "Percent")
-    (#\+ . "Plus")))
-
-(defun string-chars (string)
-  (coerce string 'list))
-
-(defun constant-string-p (string)
-  (let ((len (length string))
-        (constant-chars '(#\+ #\*)))
-    (and (> len 2)
-         (member (char string 0) constant-chars)
-         (member (char string (1- len)) constant-chars))))
-
-(defun first-uppercase-p (string)
-  (and (> (length string) 1)
-       (member (char string 0) '(#\+ #\*))))
-
-(defun symbol-to-js (symbol)
-  (when (symbolp symbol)
-    (setf symbol (symbol-name symbol)))
-  (let (res
-        (lowercase t)
-        (all-uppercase nil))
-    (cond ((constant-string-p symbol)
-           (setf all-uppercase t
-                 symbol (subseq symbol 1 (1- (length symbol)))))
-          ((first-uppercase-p symbol)
-           (setf lowercase nil
-                 symbol (subseq symbol 1))))
-    (flet ((reschar (c)
-             (push (if (and lowercase (not all-uppercase))
-                       (char-downcase c)
-                       (char-upcase c)) res)
-             (setf lowercase t)))
-      (dotimes (i (length symbol))
-        (let ((c (char symbol i)))
-          (cond
-            ((eql c #\-)
-             (setf lowercase (not lowercase)))
-            ((assoc c *special-chars*)
-             (dolist (i (coerce (cdr (assoc c *special-chars*)) 'list))
-               (reschar i)))
-            (t (reschar c))))))
-    (coerce (nreverse res) 'string)))
-
-;;; Tokens
-
-;;; break
-;;; continue
-;;; delete
-;;; else
-;;; if
-;;; in
-;;; new
-;;; return
-;;; this
-;;; var
-;;; instanceof
-;;; typeof
-;;; void
-;;; function
-;;; case
-;;; default
-;;; do
-;;; for
-;;; switch
-;;; while
-;;; with
-;;; throw
-;;;
-;;; TODO:
-;;; catch
-;;; finally
-;;; try
-
-;;; Punctuators
-
-;;; {   }    (   )   [   ]
-;;; .   ;    ,   <   >   <=
-;;; >=  ==   !=  === !==
-;;; +   -    *   %   ++  --
-;;; <<  >>   >>> &   |   ^
-;;; !   ~    &&  ||  ?   :
-;;; =   +=   -=  *=  %=  <<=
-;;; >>= >>>= &=  |=  ^=
-;;; / /=
-
-;;; Literals
-
-;;; null true false
-
-;;; js language types
-
-(defclass statement ()
-  ((value :initarg :value :accessor value)))
-
-(defclass expression (statement)
-  ())
-
-;;; indenter
-
-(defun special-append-to-last (form elt)
-  (flet ((special-append (form elt)
-	   (let ((len (length form)))
-	     (if (and (> len 0)
-		      (member (char form (1- len))
-			      '(#\; #\, #\})))
-		 form
-		 (concatenate 'string form elt)))))
-    (cond ((stringp form)
-	   (special-append form elt))
-	  ((consp form)
-	   (let ((last (last form)))
-	     (if (stringp (car last))
-		 (rplaca last (special-append (car last) elt))
-		 (append-to-last (car last) elt))
-	   form))
-	  (t (error "unsupported form ~S" form)))))
-
-(defun dwim-join (value-string-lists max-length
-		  &key start end
-		       join-before join-after
-		  white-space (separator " ")
-		  (append-to-last #'append-to-last)
-		  (collect t))
-    #+nil
-    (format t "value-string-lists: ~S~%" value-string-lists)
-
-    (unless start
-      (setf start ""))
-
-    (unless join-before
-      (setf join-before ""))
-
-    ;;; collect single value-string-lists until line full
-
-    (do* ((string-lists value-string-lists (cdr string-lists))
-	  (string-list (car string-lists) (car string-lists))
-	  (cur-elt start)
-	  (cur-empty t)
-	  (white-space (or white-space (make-string (length start) :initial-element #\Space)))
-	  (res nil))
-	 ((null string-lists)
-	  (unless cur-empty
-	    (push cur-elt res))
-	  (when end
-	    (setf (first res)
-		  (funcall append-to-last (first res) end)))
-	  (nreverse res))
-
-      #+nil
-      (format t "string-list: ~S~%" string-list)
-
-      (when join-after
-	(unless (null (cdr string-lists))
-	  (funcall append-to-last string-list join-after)))
-
-      (if (and collect (= (length string-list) 1))
-	  (progn
-	    #+nil
-	    (format t "cur-elt: ~S line-length ~D, max-length ~D, string: ~S~%"
-		    cur-elt
-		    (+ (length (first string-list))
-		       (length cur-elt))
-		    max-length
-		    (first string-list))
-	    (if (or cur-empty
-		    (< (+ (length (first string-list))
-			  (length cur-elt)) max-length))
-		(setf cur-elt
-		      (concatenate 'string cur-elt
-				   (if cur-empty "" (concatenate 'string separator join-before))
-				   (first string-list))
-		      cur-empty nil)
-		(progn
-		  (push cur-elt res)
-		  (setf cur-elt (concatenate 'string white-space
-					     join-before (first string-list))
-			cur-empty nil))))
-
-	  (progn
-	    (unless cur-empty
-	      (push cur-elt res)
-	      (setf cur-elt white-space
-		    cur-empty t))
-	    (setf res (nconc (nreverse
-			      (cons (concatenate 'string
-						 cur-elt (if (null res)
-							     "" join-before)
-						 (first string-list))
-				    (mapcar #'(lambda (x) (concatenate 'string white-space x))
-					    (cdr string-list)))) res))
-	    (setf cur-elt white-space cur-empty t)))))
-
-(defmethod js-to-strings ((expression expression) start-pos)
-  (list (princ-to-string (value expression))))
-
-(defmethod js-to-statement-strings ((expression expression) start-pos)
-  (js-to-strings expression start-pos))
-
-(defmethod js-to-statement-strings ((statement statement) start-pos)
-  (list (princ-to-string (value statement))))
-
-;;; compiler macros
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (defvar *js-compiler-macros* (make-hash-table)
-    "*JS-COMPILER-MACROS* is a hash-table containing the functions corresponding
-to javascript special forms, indexed by their name. Javascript special
-forms are compiler macros for JS expressions."))
-
-(defmacro define-js-compiler-macro (name lambda-list &rest body)
-  "Define a javascript compiler macro NAME. Arguments are destructured
-according to LAMBDA-LIST. The resulting JS language types are appended
-to the ongoing javascript compilation."
-  (let ((js-name (intern (concatenate 'string "JS-" (symbol-name name)))))
-    `(progn (defun ,js-name ,lambda-list ,@body)
-            (setf (gethash ',name *js-compiler-macros*) #',js-name))))
-
-(defun js-compiler-macro-form-p (form)
-  (when (gethash (car form) *js-compiler-macros*)
-    t))
-
-(defun js-get-compiler-macro (name)
-  (gethash name *js-compiler-macros*))
-
-;;; macro expansion
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (defvar *js-macro-toplevel* (make-hash-table)
-    "Toplevel of macro expansion, holds all the toplevel javascript macros.")
-  (defvar *js-macro-env* (list *js-macro-toplevel*)
-    "Current macro environment."))
-
-(defun lookup-macro (name)
-  "Lookup the macro NAME in the current macro expansion
-environment. Returns the macro and the parent macro environment of
-this macro."
-  (do ((env *js-macro-env* (cdr env)))
-      ((null env) nil)
-    (let ((val (gethash name (car env))))
-      (when val
-	(return-from lookup-macro
-	  (values val (or (cdr env)
-			  (list *js-macro-toplevel*))))))))
-
-(defmacro defjsmacro (name args &rest body)
-  "Define a javascript macro, and store it in the toplevel macro environment."
-  (when (gethash name *js-compiler-macros*)
-    (warn "Redefining compiler macro ~S" name)
-    (remhash name *js-compiler-macros*))
-  (let ((lambda-list (gensym)))
-    `(setf (gethash ',name *js-macro-toplevel*)
-      #'(lambda (&rest ,lambda-list)
-	  (destructuring-bind ,args ,lambda-list ,@body)))))
-
-(defun js-expand-form (expr)
-  "Expand a javascript form."
-  (cond ((atom expr)
-	 (multiple-value-bind (js-macro macro-env)
-	     (lookup-macro expr)
-	   (if js-macro
-	       (js-expand-form (let ((*js-macro-env* macro-env))
-				 (funcall js-macro)))
-	       expr)))
-
-	((js-compiler-macro-form-p expr) expr)
-
-	((equal (first expr) 'quote) expr)
-
-	(t (let ((js-macro (lookup-macro (car expr))))
-	     (if js-macro
-		 (js-expand-form (apply js-macro (cdr expr)))
-		 expr)))))
-
-;;; literals
-
-(defmacro defjsliteral (name string)
-  "Define a Javascript literal that will expand to STRING."
-  `(define-js-compiler-macro ,name () (make-instance 'expression :value ,string)))
-
-(defjsliteral this      "this")
-(defjsliteral t         "true")
-(defjsliteral nil       "null")
-(defjsliteral false     "false")
-(defjsliteral undefined "undefined")
-
-(defmacro defjskeyword (name string)
-  "Define a Javascript keyword that will expand to STRING."
-  `(define-js-compiler-macro ,name () (make-instance 'statement :value ,string)))
-
-(defjskeyword break    "break")
-(defjskeyword continue "continue")
-
-;;; array literals
-
-(defclass array-literal (expression)
-  ((values :initarg :values :accessor array-values)))
-
-(define-js-compiler-macro array (&rest values)
-  (make-instance 'array-literal
-		 :values (mapcar #'js-compile-to-expression values)))
-
-(defjsmacro list (&rest values)
-  `(array ,@values))
-
-(defmethod js-to-strings ((array array-literal) start-pos)
-  (let ((value-string-lists
-	 (mapcar #'(lambda (x) (js-to-strings x (+ start-pos 2)))
-		 (array-values array)))
-	(max-length (- 80 start-pos 2)))
-    (dwim-join value-string-lists max-length
-	       :start "[ " :end " ]"
-	       :join-after ",")))
-
-(defclass js-aref (expression)
-  ((array :initarg :array
-	  :accessor aref-array)
-   (index :initarg :index
-	  :accessor aref-index)))
-
-(define-js-compiler-macro aref (array &rest coords)
-  (make-instance 'js-aref
-		 :array (js-compile-to-expression array)
-		 :index (mapcar #'js-compile-to-expression coords)))
-
-(defmethod js-to-strings ((aref js-aref) start-pos)
-  (dwim-join (cons (js-to-strings (aref-array aref) start-pos)
-		   (mapcar #'(lambda (x) (dwim-join (list (js-to-strings x (+ start-pos 2)))
-						    (- 80 start-pos 2)
-						    :start "[" :end "]"))
-			   (aref-index aref)))
-	     (- 80 start-pos 2) :separator ""
-	     :white-space "  "))
-
-;;; string literals
-
-(defclass string-literal (expression)
-  ())
-
-(defmethod js-to-strings ((string string-literal) start-pos)
-  (declare (ignore start-pos))
-  (list (prin1-to-string (value string))))
-
-;;; number literals
-
-(defclass number-literal (expression)
-  ())
-
-;;; variables
-
-(defclass js-variable (expression)
-  ())
-
-(defmethod js-to-strings ((v js-variable) start-form)
-  (list (symbol-to-js (value v))))
-
-;;; arithmetic operators
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
-
-  (defparameter *op-precedence-hash* (make-hash-table))
-
-  (defparameter *op-precedences*
-    '((aref)
-      (slot-value)
-      (! not ~)
-      (* / %)
-      (+ -)
-      (<< >>)
-      (>>>)
-      (< > <= >=)
-      (in if)
-      (eql == != = )
-      (=== !==)
-      (&)
-      (^)
-      (\|)
-      (\&\& and)
-      (\|\| or)
-      (setf)
-      (comma)))
-
-  ;;; generate the operator precedences from *OP-PRECEDENCES*
-  (let ((precedence 1))
-    (dolist (ops *op-precedences*)
-      (dolist (op ops)
-        (setf (gethash op *op-precedence-hash*) precedence))
-      (incf precedence))))
-
-(defun js-convert-op-name (op)
-  (case op
-    (and '\&\&)
-    (or '\|\|)
-    (not '!)
-    (eql '\=\=)
-    (=   '\=\=)
-    (t op)))
-
-(defclass op-form (expression)
-  ((operator :initarg :operator :accessor operator)
-   (args :initarg :args :accessor op-args)))
-
-(defun op-form-p (form)
-  (and (listp form)
-       (not (js-compiler-macro-form-p form))
-       (not (null (gethash (first form) *op-precedence-hash*)))))
-
-(defun klammer (string-list)
-  (prepend-to-first string-list "(")
-  (append-to-last string-list ")")
-  string-list)
-
-(defmethod expression-precedence ((expression expression))
-  0)
-
-(defmethod expression-precedence ((form op-form))
-  (gethash (operator form) *op-precedence-hash*))
-
-(defmethod js-to-strings ((form op-form) start-pos)
-  (let* ((precedence (expression-precedence form))
-	 (value-string-lists
-	  (mapcar #'(lambda (x)
-		      (let ((string-list (js-to-strings x (+ start-pos 2))))
-			(if (>= (expression-precedence x) precedence)
-			    (klammer string-list)
-			    string-list)))
-		  (op-args form)))
-	 (max-length (- 80 start-pos 2))
-	 (op-string (format nil "~A " (operator form))))
-    (dwim-join value-string-lists max-length :join-before op-string)))
-
-(defjsmacro 1- (form)
-  `(- ,form 1))
-
-(defjsmacro 1+ (form)
-  `(+ ,form 1))
-
-(defclass one-op (expression)
-  ((pre-p :initarg :pre-p
-	  :initform nil
-	  :accessor one-op-pre-p)
-   (op :initarg :op
-       :accessor one-op)))
-
-(defmethod js-to-strings ((one-op one-op) start-pos)
-  (let* ((value (value one-op))
-	 (value-strings (js-to-strings value start-pos)))
-    (when (typep value 'op-form)
-      (setf value-strings (klammer value-strings)))
-    (if (one-op-pre-p one-op)
-      (prepend-to-first value-strings
-			(one-op one-op))
-      (append-to-last value-strings
-		      (one-op one-op)))))
-
-(define-js-compiler-macro incf (x)
-  (make-instance 'one-op :pre-p t :op "++"
-		 :value (js-compile-to-expression x)))
-(define-js-compiler-macro ++ (x)
-  (make-instance 'one-op :pre-p nil :op "++"
-		 :value (js-compile-to-expression x)))
-(define-js-compiler-macro decf (x)
-  (make-instance 'one-op :pre-p t :op "--"
-		 :value (js-compile-to-expression x)))
-(define-js-compiler-macro -- (x)
-  (make-instance 'one-op :pre-p nil :op "--"
-		 :value (js-compile-to-expression x)))
-
-
-(define-js-compiler-macro not (x)
-  (let ((value (js-compile-to-expression x)))
-    (if (typep value 'op-form)
-	(let ((new-op (case (operator value)
-			(== '!=)
-			(< '>=)
-			(> '<=)
-			(<= '>)
-			(>= '<)
-			(!= '==)
-			(=== '!==)
-			(!== '===)
-			(t nil))))
-	  (if new-op
-	      (make-instance 'op-form :operator new-op
-			     :args (op-args value))
-	      (make-instance 'one-op :pre-p t :op "!"
-			    :value value)))
-	(make-instance 'one-op :pre-p t :op "!"
-		       :value value))))
-
-;;; function calls
-
-(defclass function-call (expression)
-  ((function :initarg :function :accessor f-function)
-   (args :initarg :args :accessor f-args)))
-
-(defun funcall-form-p (form)
-  (and (listp form)
-       (not (op-form-p form))
-       (not (js-compiler-macro-form-p form))))
-
-(defmethod js-to-strings ((form function-call) start-pos)
-  (let ((value-string-lists
-	 (mapcar #'(lambda (x) (js-to-strings x (+ start-pos 2)))
-		 (f-args form)))
-	(max-length (- 80 start-pos 2)))
-    (dwim-join value-string-lists max-length
-	       :start (format nil "~A(" (symbol-to-js (f-function form)))
-	       :end ")"
-	       :join-after ",")))
-
-(defclass method-call (expression)
-  ((method :initarg :method :accessor m-method)
-   (args :initarg :args :accessor m-args)))
-
-(defun method-call-p (form)
-  (and (funcall-form-p form)
-       (eql (char (symbol-name (first form)) 0) #\.)))
-
-;;; body forms
-
-(defclass js-body (expression)
-  ((stmts :initarg :stmts :accessor b-stmts)
-   (indent :initarg :indent :initform "" :accessor b-indent)))
-
-(define-js-compiler-macro progn (&rest body)
-  (make-instance 'js-body
-		 :stmts (mapcar #'js-compile-to-statement body)))
-
-(defmethod js-to-statement-strings ((body js-body) start-pos)
-  (dwim-join (mapcar #'(lambda (x) (js-to-statement-strings x (+ start-pos 2)))
-		     (b-stmts body))
-	     (- 80 start-pos 2)
-	     :join-after ";"
-	     :append-to-last #'special-append-to-last
-	     :start (b-indent body) :collect nil
-	     :end ";"))
-
-(defmethod js-to-strings ((body js-body) start-pos)
-  (dwim-join (mapcar #'(lambda (x) (js-to-strings x (+ start-pos 2)))
-		     (b-stmts body))
-	     (- 80 start-pos 2)
-	     :append-to-last #'special-append-to-last
-	     :join-after ","
-	     :start (b-indent body)))
-
-(defclass js-sub-body (js-body)
-  ())
-
-(defmethod js-to-statement-strings ((body js-sub-body) start-pos)
-  (nconc (list "{") (call-next-method) (list "}")))
-#+nil
-  (dwim-join (mapcar #'(lambda (x) (js-to-statement-strings x (+ start-pos 2)))
-		     (b-stmts body))
-	     (- 80 start-pos 2)
-	     :start (format nil "{~%  ")
-	     :end (format nil "~%}")
-	     :white-space "  " :collect nil)
-
-(defmethod expression-precedence ((body js-body))
-  (if (= (length (b-stmts body)) 1)
-      (expression-precedence (first (b-stmts body)))
-      (gethash 'comma *op-precedence-hash*)))
-
-;;; function definition
-
-(defclass js-defun (expression)
-  ((name :initarg :name :accessor d-name)
-   (args :initarg :args :accessor d-args)
-   (body :initarg :body :accessor d-body)))
-
-(define-js-compiler-macro defun (name args &rest body)
-  (make-instance 'js-defun
-		 :name (js-compile-to-symbol name)
-		 :args (mapcar #'js-compile-to-symbol args)
-		 :body (make-instance 'js-body
-				      :indent "  "
-				      :stmts (mapcar #'js-compile-to-statement body))))
-
-(defmethod js-to-strings ((defun js-defun) start-pos)
-  (let ((fun-header (dwim-join (mapcar #'(lambda (x) (list (symbol-to-js x)))
-				       (d-args defun))
-			       (- 80 start-pos 2)
-			       :start (format nil "function ~A("
-					      (symbol-to-js (d-name defun)))
-			       :end ") {" :join-after ","))
-	(fun-body (js-to-statement-strings (d-body defun) (+ start-pos 2))))
-    (nconc fun-header fun-body (list "}"))))
-
-(defmethod js-to-statement-strings ((defun js-defun) start-pos)
-  (js-to-strings defun start-pos))
-
-(defjsmacro lambda (args &rest body)
-  `(defun :|| ,args ,@body))
-
-;;; object creation
-
-(defclass js-object (expression)
-  ((slots :initarg :slots
-	  :accessor o-slots)))
-
-(define-js-compiler-macro create (&rest args)
-  (make-instance 'js-object
-		 :slots (loop for (name val) on args by #'cddr
-			      collect (list (js-compile-to-symbol name)
-					    (js-compile-to-expression val)))))
-
-;;; XXX so ist das noch nicht korrekt
-(defmethod js-to-strings ((object js-object) start-pos)
-  (let ((value-string-lists
-	 (mapcar #'(lambda (slot)
-		     (dwim-join (list (js-to-strings (second slot) (+ start-pos 4)))
-				(- 80 start-pos 2)
-				:start (concatenate 'string (symbol-to-js (first slot)) " : ")
-				:white-space "    ")) (o-slots object)))
-	(max-length (- 80 start-pos 2)))
-    (dwim-join value-string-lists max-length
-	       :start (format nil "{~%  ")
-	       :end (format nil "~%} ")
-	       :join-after ", "
-	       :white-space "  "
-	       :collect nil)))
-
-(defclass js-slot-value (expression)
-  ((object :initarg :object
-	   :accessor sv-object)
-   (slot :initarg :slot
-	 :accessor sv-slot)))
-
-(define-js-compiler-macro slot-value (obj slot)
-  (make-instance 'js-slot-value :object (js-compile-to-expression obj)
-		 :slot (js-compile-to-symbol slot)))
-
-(defmethod js-to-strings ((sv js-slot-value) start-pos)
-  (append-to-last (js-to-strings (sv-object sv) start-pos)
-		  (format nil ".~A" (symbol-to-js (sv-slot sv)))))
-
-(defjsmacro with-slots (slots object &rest body)
-  `(symbol-macrolet ,(mapcar #'(lambda (slot)
-				 `(,slot '(slot-value ,object ',slot)))
-			     slots)
-    ,@body))
-
-;;; macros
-
-(define-js-compiler-macro macrolet (macros &rest body)
-  (let* ((macro-env (make-hash-table))
-	 (*js-macro-env* (cons macro-env *js-macro-env*)))
-    (dolist (macro macros)
-      (destructuring-bind (name arglist &rest body) macro
-	(setf (gethash name macro-env)
-	      (compile nil `(lambda ,arglist ,@body)))))
-    (js-compile `(progn ,@body))))
-
-(defjsmacro symbol-macrolet (macros &rest body)
-  `(macrolet ,(mapcar #'(lambda (macro)
-			  `(,(first macro) () ,@(rest macro))) macros)
-    ,@body))
-
-;;; lisp eval
-
-(defjsmacro lisp (&rest forms)
-  (eval (cons 'progn forms)))
-
-;;; if
-
-(defclass js-if (expression)
-  ((test :initarg :test
-	 :accessor if-test)
-   (then :initarg :then
-	 :accessor if-then)
-   (else :initarg :else
-	 :accessor if-else)))
-
-(define-js-compiler-macro if (test then &optional else)
-  (make-instance 'js-if :test (js-compile-to-expression test)
-		 :then (js-compile-to-body then :indent "  ")
-		 :else (when else
-			 (js-compile-to-body else :indent "  "))))
-
-(defmethod js-to-statement-strings ((if js-if) start-pos)
-  (let ((if-strings (dwim-join (list (js-to-strings (if-test if) 0))
-			       (- 80 start-pos 2)
-			       :start "if ("
-			       :end ") {"))
-	(then-strings (js-to-statement-strings (if-then if) (+ start-pos 2)))
-	(else-strings (when (if-else if)
-			(js-to-statement-strings (if-else if)
-						 (+ start-pos 2)))))
-    (nconc if-strings then-strings (if else-strings
-				       (nconc (list "} else {") else-strings (list "}"))
-				       (list "}")))))
-
-(defmethod expression-precedence ((if js-if))
-  (gethash 'if *op-precedence-hash*))
-
-(defmethod js-to-strings ((if js-if) start-pos)
-  (assert (typep (if-then if) 'expression))
-  (when (if-else if)
-    (assert (typep (if-else if) 'expression)))
-  (dwim-join (list (append-to-last (js-to-strings (if-test if) start-pos) " ?")
-		   (let* ((new-then (make-instance 'js-body
-						   :stmts (b-stmts (if-then if))
-						   :indent ""))
-			  (res (js-to-strings new-then start-pos)))
-		     (if (>= (expression-precedence (if-then if))
-			     (expression-precedence if))
-			     (klammer res)
-			     res))
-		   (list ":")
-		   (if (if-else if)
-		       (let* ((new-else (make-instance 'js-body
-						       :stmts (b-stmts (if-else if))
-						       :indent ""))
-			      (res (js-to-strings new-else start-pos)))
-			 (if (>= (expression-precedence (if-else if))
-				 (expression-precedence if))
-			     (klammer res)
-			     res))
-		       (list "undefined")))
-	     (- 80 start-pos 2)
-	     :white-space "  "))
-
-(defjsmacro when (test &rest body)
-  `(if ,test (progn ,@body)))
-
-(defjsmacro unless (test &rest body)
-  `(if (not ,test) (progn ,@body)))
-
-;;; single keyword expressions and statements
-
-(defmacro define-js-single-op (name &optional (superclass 'expression))
-  (let ((js-name (intern (concatenate 'string "JS-" (symbol-name name)) #.*package*)))
-  `(progn
-    (defclass ,js-name (,superclass)
-      ())
-    (define-js-compiler-macro ,name (value)
-      (make-instance ',js-name :value (js-compile-to-expression value)))
-    (defmethod js-to-strings ((,name ,js-name) start-pos)
-      (dwim-join (list (js-to-strings (value ,name) (+ start-pos 2)))
-		 (- 80 start-pos 2)
-		 :start ,(concatenate 'string (string-downcase (symbol-name name)) " ")
-		 :white-space "  ")))))
-
-
-(define-js-single-op return statement)
-(define-js-single-op throw statement)
-(define-js-single-op delete)
-(define-js-single-op void)
-(define-js-single-op typeof)
-(define-js-single-op instanceof)
-(define-js-single-op new)
-
-;;; assignment
-
-(defclass js-setf (expression)
-  ((lhs :initarg :lhs :accessor setf-lhs)
-   (rhsides :initarg :rhsides :accessor setf-rhsides)))
-
-(define-js-compiler-macro setf (&rest args)
-  (let ((assignments (loop for (lhs rhs) on args by #'cddr
-			   for rexpr = (js-compile-to-expression rhs)
-			   for lexpr = (js-compile-to-expression lhs)
-			   collect (make-instance 'js-setf :lhs lexpr
-						  :rhsides (list rexpr)))))
-    (if (= (length assignments) 1)
-	(first assignments)
-	(make-instance 'js-body :indent "" :stmts assignments))))
-
-(defmethod js-to-strings ((setf js-setf) start-pos)
-  (dwim-join (cons (js-to-strings (setf-lhs setf) start-pos)
-		   (mapcar #'(lambda (x) (js-to-strings x start-pos)) (setf-rhsides setf)))
-	     (- 80 start-pos 2)
-	     :join-after " ="))
-
-(defmethod expression-precedence ((setf js-setf))
-  (gethash '= *op-precedence-hash*))
-
-;;; defvar
-
-(defclass js-defvar (statement)
-  ((names :initarg :names :accessor var-names)
-   (value :initarg :value :accessor var-value)))
-
-(define-js-compiler-macro defvar (name &optional value)
-  (make-instance 'js-defvar :names (list (js-compile-to-symbol name))
-		 :value (when value (js-compile-to-expression value))))
-
-(defmethod js-to-statement-strings ((defvar js-defvar) start-pos)
-  (dwim-join (nconc (mapcar #'(lambda (x) (list (symbol-to-js x))) (var-names defvar))
-		    (when (var-value defvar)
-		      (list (js-to-strings (var-value defvar) start-pos))))
-	     (- 80 start-pos 2)
-	     :join-after " ="
-	     :start "var " :end ";"))
-
-;;; let
-
-(define-js-compiler-macro let (decls &rest body)
-  (let ((single-defvar (make-instance 'js-defvar
-				      :names (mapcar #'js-compile-to-symbol
-						     (remove-if-not #'atom decls))
-				      :value nil))
-	(defvars (mapcar #'(lambda (decl)
-			     (let ((name (first decl))
-				   (value (second decl)))
-			     (make-instance 'js-defvar
-					    :names (list (js-compile-to-symbol name))
-					    :value (js-compile-to-expression value))))
-			 (remove-if #'atom decls))))
-    (make-instance 'js-sub-body
-		   :indent "  "
-		   :stmts (nconc (when (var-names single-defvar) (list single-defvar))
-				 defvars
-				 (mapcar #'js-compile-to-statement body)))))
-
-;;; iteration
-
-(defclass js-for (statement)
-  ((vars :initarg :vars :accessor for-vars)
-   (steps :initarg :steps :accessor for-steps)
-   (check :initarg :check :accessor for-check)
-   (body :initarg :body :accessor for-body)))
-
-(defun make-for-vars (decls)
-  (loop for decl in decls
-	for var = (if (atom decl) decl (first decl))
-	for init = (if (atom decl) nil (second decl))
-	collect (make-instance 'js-defvar :names (list (js-compile-to-symbol var))
-			       :value (js-compile-to-expression init))))
-
-(defun make-for-steps (decls)
-  (loop for decl in decls
-	when (= (length decl) 3)
-	collect (js-compile-to-expression (third decl))))
-
-(define-js-compiler-macro do (decls termination &rest body)
-  (let ((vars (make-for-vars decls))
-	(steps (make-for-steps decls))
-	(check (js-compile-to-expression (list 'not (first termination))))
-	(body (js-compile-to-body (cons 'progn body) :indent "  ")))
-    (make-instance 'js-for
-		   :vars vars
-		   :steps steps
-		   :check check
-		   :body body)))
-
-(defun strings-length (string-list)
-  (reduce #'max (mapcar #'length string-list) :initial-value most-negative-fixnum))
-
-(defmethod js-to-statement-strings ((for js-for) start-pos)
-  (let* ((init (dwim-join (mapcar #'(lambda (x)
-				      (dwim-join (list (list (symbol-to-js (first (var-names x))))
-						       (js-to-strings (var-value x)
-								      (+ start-pos 2)))
-						 (- 80 start-pos 2)
-						 :join-after " ="))
-				  (for-vars for))
-			  (- 80 start-pos 2)
-			  :start "var " :join-after ","))
-	 #+nil
-	 (init-len (strings-length init))
-	 (check (js-to-strings (for-check for) (+ start-pos 2)))
-	 #+nil
-	 (check-len (strings-length check))
-	 (steps (dwim-join (mapcar #'(lambda (x)
-				       (js-to-strings x (- start-pos 2)))
-				   (for-steps for))
-			   (- 80 start-pos 2)
-			   :join-after ","))
-	 (header (dwim-join (list init check steps)
-			    (- 80 start-pos 2)
-			    :start "for (" :end ") {"
-			    :join-after ";"))
-	 (body (js-to-statement-strings (for-body for) (+ start-pos 2))))
-    (nconc header body (list "}"))))
-
-  (let ((fun-header (dwim-join (mapcar #'(lambda (x) (list (symbol-to-js x)))
-				       (d-args defun))
-			       (- 80 start-pos 2)
-			       :start (format nil "function ~A("
-					      (symbol-to-js (d-name defun)))
-			       :end ") {" :join-after ","))
-	(fun-body (js-to-statement-strings (d-body defun) (+ start-pos 2))))
-    (nconc fun-header fun-body (list "}"))))
-
-(defclass for-each (statement)
-  ((name :initarg :name :accessor fe-name)
-   (value :initarg :value :accessor fe-value)
-   (body :initarg :value :accessor fe-body)))
-
-(define-js-compiler-macro do-each (decl &rest body)
-  (make-instance 'for-each :name (js-compile-to-symbol (first decl))
-		 :value (js-compile-to-expression (second decl))
-		 :body (js-compile-to-body (cons 'progn body) :indent "  ")))
-
-(defmethod js-to-statement-strings ((fe for-each) start-pos)
-  (let ((header (dwim-join (list (list (symbol-to-js (fe-name fe)) " in ")
-				 (js-to-strings (fe-value fe) (+ start-pos 2)))
-			   :start "for (var "
-			   :end ") {"))
-	(body (js-to-statement-strings (fe-body fe) (+ start-pos 2))))
-    (nconc header body (list "}"))))
-
-(defclass js-while (statement)
-  ((check :initarg :check :accessor while-check)
-   (body :initarg :body :accessor while-body)))
-
-(define-js-compiler-macro while (check &rest body)
-  (make-instance 'js-while
-		 :check (js-compile-to-expression check)
-		 :body (js-compile-to-body (cons 'progn body) :indent "  ")))
-
-(defmethod js-to-statement-strings ((while js-while) start-pos)
-  (let ((header (dwim-join (list (js-to-strings (while-check while) (+ start-pos 2)))
-			   (- 80 start-pos 2)
-			   :start "while ("
-			   :end ") {"))
-	(body (js-to-statement-strings (while-body while) (+ start-pos 2))))
-    (nconc header body (list "}"))))
-
-;;; with
-
-(defclass js-with (statement)
-  ((obj :initarg :obj :accessor with-obj)
-   (body :initarg :body :accessor with-body)))
-
-(define-js-compiler-macro with (statement &rest body)
-  (make-instance 'js-with
-		 :obj (js-compile-to-expression (first statement))
-		 :body (js-compile-to-body (cons 'progn body) :indent "  ")))
-
-(defmethod js-to-statement-strings ((with js-with) start-pos)
-  (nconc (dwim-join (list (js-to-strings (with-obj with) (+ start-pos 2)))
-		    (- 80 start-pos 2)
-		    :start "with (" :end ") {")
-	 (js-to-statement-strings (with-body with) (+ start-pos 2))
-	 (list "}")))
-
-;;; case
-
-(defclass js-case (statement)
-  ((value :initarg :value :accessor case-value)
-   (clauses :initarg :clauses :accessor case-clauses)))
-
-;;; XXX DEFAULT exporten
-(define-js-compiler-macro case (value &rest clauses)
-  (let ((clauses (mapcar #'(lambda (clause)
-			     (let ((val (first clause))
-				   (body (cdr clause)))
-			       (list (if (eql val 'default)
-					 'default
-					 (js-compile-to-expression val))
-				     (js-compile-to-body (cons 'progn body) :indent "  "))))
-			 clauses))
-	(check (js-compile-to-expression value)))
-    (make-instance 'js-case :value check
-		   :clauses clauses)))
-
-(defmethod js-to-statement-strings ((case js-case) start-pos)
-  (let ((body 	 (mapcan #'(lambda (clause)
-		     (let ((val (car clause))
-			   (body (second clause)))
-		       (dwim-join (list (if (eql val 'default)
-					    (list "")
-					    (js-to-strings val (+ start-pos 2)))
-					(js-to-statement-strings body (+ start-pos 2)))
-				  (- 80 start-pos 2)
-				  :start (if (eql val 'default) "  default" "  case ")
-				  :white-space "   "
-				  :join-after ":"))) (case-clauses case))))
-
-    (format t "body: ~S~%" body)
-    (nconc (dwim-join (list (js-to-strings (case-value case) (+ start-pos 2)))
-		    (- 80 start-pos 2)
-		    :start "switch (" :end ") {")
-	   body
-	   (list "}"))))
-
-;;; throw catch
-
-(defclass js-try (statement)
-  ((body :initarg :body :accessor try-body)
-   (catch :initarg :catch :accessor try-catch)
-   (finally :initarg :finally :accessor try-finally)))
-
-(define-js-compiler-macro try (body clauses)
-  (let ((body (js-compile-to-body body :indent "  "))
-	(catch (cdr (assoc :catch clauses)))
-	(finally (cdr (assoc :finally clauses))))
-    (make-instance 'js-try
-		   :body body
-		   :catch (when catch (list (js-compile-to-symbol (first catch))
-					    (js-compile-to-body (cons 'progn (cdr catch))
-								:indent "  ")))
-		   :finally (when finally (js-compile-to-body finally :indent "   ")))))
-
-(defmethod js-to-statement-strings ((try js-try) start-pos)
-  (let* ((catch (try-catch try))
-	 (finally (try-finally try))
-	 (catch-list (when catch
-		       (dwim-join (list (list (symbol-to-js (first catch)))
-					(js-to-strings (second catch) (+ start-pos 2)))
-				  (- 80 start-pos 2)
-				  :start "} catch ("
-				  :end ") {")))
-	 (finally-list (when finally
-			 (dwim-join (list (js-to-strings finally (+ start-pos 2)))
-				    (- 80 start-pos 2)
-				    :start "finally {"))))
-    (nconc (dwim-join (list (js-to-statement-strings (try-body try) (+ start-pos 2)))
-		      (- 80 start-pos 2)
-		      :start "try {")
-	   catch-list
-	   finally-list
-	   (list "}"))))
-
-;;; regex
-
-(defclass regex (expression)
-  ())
-
-(define-js-compiler-macro regex (regex)
-  (make-instance 'regex :value (string regex)))
-
-;;; conditional compilation
-
-(defclass cc-if ()
-  ((test :initarg :test :accessor cc-if-test)
-   (body :initarg :body :accessor cc-if-body)))
-
-(defmethod js-to-statement-strings ((cc cc-if) start-pos)
-  (nconc (list (format nil "/*@if ~A" (cc-if-test cc)))
-	 (mapcan #'(lambda (x) (js-to-strings x start-pos)) (cc-if-body cc))
-	 (list "@end @*/")))
-
-(define-js-compiler-macro cc-if (test &rest body)
-  (make-instance 'cc-if :test test
-		 :body (mapcar #'js-compile body)))
-
-;;; compiler
-
-(defun js-compile (form)
-  (setf form (js-expand-form form))
-  (cond ((stringp form)
-	 (make-instance 'string-literal :value form))
-	((numberp form)
-	 (make-instance 'number-literal :value form))
-	((symbolp form)
-	 (let ((c-macro (js-get-compiler-macro form)))
-	   (if c-macro
-	       (funcall c-macro)
-	       (make-instance 'js-variable :value form))))
-	((and (consp form)
-	      (eql (first form) 'quote))
-	 (second form))
-	((consp form)
-	 (js-compile-list form))
-	(t (error "Unknown atomar expression ~S" form))))
-
-(defun js-compile-list (form)
-  (let* ((name (car form))
-	 (args (cdr form))
-	 (js-form (js-get-compiler-macro name)))
-    (cond (js-form
-	   (apply js-form args))
-
-	  ((op-form-p form)
-	   (make-instance 'op-form
-			  :operator (js-convert-op-name (first form))
-			  :args (mapcar #'js-compile-to-expression (rest form))))
-
-	  ((method-call-p form)
-	   (make-instance 'method-call
-			  :method (first form)
-			  :args (mapcar #'js-compile-to-expression (rest form))))
-
-	  ((funcall-form-p form)
-	   (make-instance 'function-call
-			  :function (first form)
-			  :args (mapcar #'js-compile-to-expression (rest form))))
-
-	  (t (error "Unknown form ~S" form)))))
-
-(defun js-compile-to-expression (form)
-  (let ((res (js-compile form)))
-    (assert (typep res 'expression))
-    res))
-
-(defun js-compile-to-symbol (form)
-  (let ((res (js-compile form)))
-    (when (typep res 'js-variable )
-      (setf res (value res)))
-    (assert (symbolp res))
-    res))
-
-(defun js-compile-to-statement (form)
-  (let ((res (js-compile form)))
-    (assert (typep res 'statement))
-    res))
-
-(defun js-compile-to-body (form &key (indent ""))
-  (let ((res (js-compile-to-statement form)))
-    (if (typep res 'js-body)
-	(progn (setf (b-indent res) indent)
-	       res)
-	(make-instance 'js-body
-		       :indent indent
-		       :stmts (list res)))))
rmfile ./src/js2.lisp
}