linj.lisp

;; -*- Mode: Common-Lisp; Syntax: Common-Lisp; Package: LINJ; Base: 10 -*-

;;; Copyright (C) Antonio Menezes Leitao Created on Fri Oct 13 09:30:05 2000
;;; Copyright (C) eValuator, Lda

;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

(in-package "LINJ")

;;This file requires the Linj readtable
(eval-when (:compile-toplevel :load-toplevel)
  (setq *readtable* *linj-readtable*))

;;14.8 Expression Statements
;; Certain kinds of expressions may be used as statements by following them with semicolons:

;; ExpressionStatement:
;; 	StatementExpression ;

;; StatementExpression:
;; 	Assignment
;; 	PreIncrementExpression
;; 	PreDecrementExpression
;; 	PostIncrementExpression
;; 	PostDecrementExpression
;; 	MethodInvocation
;; 	ClassInstanceCreationExpression

;;Let's define the statement-expression category as a subcategory of expression:
(def-category statement-expression (expression)
  ())

;;Now, the expression-statement as a subcategory of a statement:
(def-syntax expression-statement (statement)
  ;;  ?expression/statement-expression)
  ;;We don't use the above definition because we want to infer return
  ;;statements.  This forces us to accept any expression as
  ;;expression-statement and only latter we might check whether all
  ;;expression-statements-expressions are, in fact, statement-expressions.
  ?expression/expression)

(defmethod get-type ((e expression-statement))
  (get-type (expression-statement-expression e)))

(def-unparse expression-statement (e)
  (format t "~:/ppexp/;" (expression-statement-expression e)))

;;;;;;;;;;;;;;;;;;;;;;;;;;
;;Assignments and such:

(def-syntax setf-expression (statement-expression)
  (setf ?l-value/expression ?r-value/expression))

;;The type of an assignment is the type of the r-value in Common Lisp
;;and the type of the l-value in Java.  In the past, I decided to
;;treat it as void but now I prefer to approach the Common Lisp way.
;;Note that this requires the type inferencer to treat void as an
;;absorvent element in type-merges.

(defmethod get-type ((e setf-expression))
  (get-type (setf-expression-l-value e)))

(defparameter *check-assignments-to-closure-variables*  t)

(defun check-not-final-variable (var)
  (when (and *check-assignments-to-closure-variables* (reference-p var))
    (let ((decl (find-declaration var)))
      (when (and (variable-declaration-p decl)
		 (get-option :final decl))
	(linj-error "Can't assign a value to the variable ~A that is accessed in a closure" var)))))

(defmethod visit-current ((e setf-expression) (visitor cast-and-wrap))
  (check-not-final-variable (setf-expression-l-value e))
  (setf (setf-expression-r-value e)
	(convert-type-to-lvalue (setf-expression-l-value e) (setf-expression-r-value e))))

;; 5.2 Assignment Conversion
;; Assignment conversion occurs when the value of an expression is
;; assigned (§15.26) to a variable: the type of the expression must be
;; converted to the type of the variable. Assignment contexts allow
;; the use of an identity conversion (§5.1.1), a widening primitive
;; conversion (§5.1.2), or a widening reference conversion
;; (§5.1.4). In addition, a narrowing primitive conversion may be used
;; if all of the following conditions are satisfied:
;;     * The expression is a constant expression of type byte, short,
;;       char or int.
;;     * The type of the variable is byte, short, or char.
;;     * The value of the expression (which is known at compile time,
;;       because it is a constant expression) is representable in the
;;       type of the variable.

(defun assignment-convertion (value type error-fn)
  (let ((val-type (get-type value)))
    (if (literal-p value)
      (if (or (byte-type-p val-type)
	      (short-type-p val-type)
	      (char-type-p val-type)
	      (int-type-p val-type))
	(let ((rval (literal-value value)))
	  (flet ((bogus ()
		   (error "Trying to convert the literal value ~A to the type ~A that doesn't contain it" rval type)))
	    (cond ((byte-type-p type) (if (byte-value-p rval) value (bogus)))
		  ((short-type-p type) (if (short-value-p rval) value (bogus)))
		  ((char-type-p type) (if (char-value-p rval) value (bogus)))
		  (t (cast-and-wrap-if-needed type val-type value error-fn)))))
	(cast-and-wrap-if-needed type val-type value error-fn))
      (cast-and-wrap-if-needed type val-type value error-fn))))

(defun convert-type-to-lvalue (lvalue rvalue)
  (assignment-convertion
   rvalue
   (get-type lvalue)
   #'(lambda (expected current expr)
       (linj-error "Can't assign variable ~S of type ~S~%with value ~S of type ~S"
		   lvalue
		   expected
		   expr
		   current))))

(def-unparse setf-expression (e)
  (when *print-out-parenthesis*
    (format t "("))
  (format t "~/pp/ = ~:/ppexp/" 
	  (setf-expression-l-value e)
	  (setf-expression-r-value e))
  (when *print-out-parenthesis*
    (format t ")")))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(def-category in-form ()
  ((object :reader in-form-object)))

(defmethod visit :before ((e in-form) (visitor adjust-parents))
  ;;Correct context for the initializer to jump over the in-expression
  (setf (ast-node-parent (in-form-object e)) (ast-node-parent e)))

(defmethod find-declaration-in ((what t) (e in-form))
  (or (find-declaration-in what (get-type-declaration (get-type (in-form-object e))))
      (find-declaration-in what (ast-node-parent e))))

(def-syntax in-expression (in-form expression)
  (in ?object/expression ?expression/expression))

(def-syntax in-type-expression (in-expression)
  (in (the ?object/type-reference) ?expression/expression))

(defmethod get-type ((e in-expression))
  (get-type (in-expression-expression e)))

(def-unparse in-expression (e)
  (unparse-object (in-expression-expression e) *standard-output*))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(def-syntax in-statement (in-form statement)
  (in ?object/expression . ?body/statement-list))

(def-syntax in-type-statement (in-statement)
  (in (the ?object/type-reference) . ?body/statement-list))

(def-unparse in-statement (e)
  (format t "~{~/ppblk/~^~:@_~}"
	  (statement-list-elements (in-statement-body e))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun collect-upward-in-forms (node)
  (cond ((or (static-block-p node)
	     (method-declaration-p node)
	     (slot-declaration-p node))
	 (list))
	((in-expression-p node)
	 (cons (in-expression-object node)
	       (collect-upward-in-forms (ast-node-parent node))))
	((in-statement-p node)
	 (cons (in-statement-object node)
	       (collect-upward-in-forms (ast-node-parent node))))
	(t
	 (collect-upward-in-forms (ast-node-parent node)))))

;;if
(def-syntax if-statement (statement)
  (if ?test/expression ?then/statement ?else/statement)
  :strict-p t)

;;In fact, this will become a little more complicated because we want to
;;combine multiple ifs. The rule is that when the else statement is another
;;if-statement, then we print this as "else if ..." and not as "else { if ... }"

(defparameter *translate-reference-type-to-boolean* t)

(defun from-reference-type-to-boolean (expr)
  (if *translate-reference-type-to-boolean*
    (let ((type (get-type expr)))
      (cond ((boolean-type-p type)
	     expr)
	    ((cons-type-p type)
	     (with-parent ((ast-node-parent expr))
	       (parse `(not (endp ,expr)) 'expression)))
	    ((class-or-interface-type-reference-p type)
	     (with-parent ((ast-node-parent expr))
	       (parse `(not (eq ,expr null)) 'expression)))
	    (t
	     (error "Can't use expression ~A in a context where a boolean is expected" expr))))
    expr))

(def-unparse if-statement (e)
  (format t
	  (cond ((and (if-statement-p (ast-node-parent e))
		      (or (if-statement-p (if-statement-else e))
			  (cond-statement-p (if-statement-else e))))
		 "if (~:/ppexp/) ~/ppstm/ else ~/pp/")
		((and (if-statement-p (ast-node-parent e))
		      (eq (if-statement-else (ast-node-parent e)) e))
		 "if (~:/ppexp/) ~/ppstm/ else ~/ppstm/")
		((or (if-statement-p (if-statement-else e))
		     (cond-statement-p (if-statement-else e)))
		 "~@<if (~:/ppexp/) ~/ppstm/ else ~/pp/~:>")
		(t
		 "~@<if (~:/ppexp/) ~/ppstm/ else ~/ppstm/~:>"))
	  (from-reference-type-to-boolean (if-statement-test e))
	  (if-statement-then e)
	  (if-statement-else e)))

;;cond
(def-syntax clause (linj-node)
  (?test/expression . ?body/statement-list)
  :strict-p t)

(def-unparse clause (e)
  (cond ((true-literal-p (clause-test e))
 	 (format t "~/ppblk/" (clause-body e)))
 	(t
	 (format t "if (~:/ppexp/) ~/ppblk/"
		 (from-reference-type-to-boolean (clause-test e))
		 (clause-body e)))))

(def-list-syntax clause-list (linj-list-node) clause)

(def-unparse clause-list (e)
  (let ((up (ast-node-parent (ast-node-parent e))))
    (format t (if (or (and (if-statement-p up)
			   (eq (if-statement-else up) (ast-node-parent e)))
		      (cond-statement-p up))
		"~/pp/~{ else ~/pp/~}"
		"~@<~/pp/~{ else ~/pp/~}~:>")
	    (first (clause-list-elements e))
	    (rest (clause-list-elements e)))))

(def-syntax cond-statement (statement)
  (cond . ?clauses/clause-list)
  :strict-p t)

(def-unparse cond-statement (e)
  (unparse-object (cond-statement-clauses e) *standard-output*))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;conditional expression
(def-syntax conditional-expression (expression)
  (if ?test/expression ?then/expression ?else/expression))

;;; The type of a conditional expression is determined as follows:

;;;  If the second and third operands have the same type (which may be the
;;; null type), then that is the type of the conditional expression.

;;;  Otherwise, if the second and third operands have numeric type, then
;;; there are several cases:

;;;    If one of the operands is of type byte and the other is of type
;;; short, then the type of the conditional expression is short.

;;;    If one of the operands is of type T where T is byte, short, or char,
;;; and the other operand is a constant expression of type int whose value
;;; is representable in type T, then the type of the conditional expression
;;; is T.

;;;    Otherwise, binary numeric promotion (§5.6.2) is applied to the
;;; operand types, and the type of the conditional expression is the
;;; promoted type of the second and third operands. Note that binary
;;; numeric promotion performs value set conversion (§5.1.8).

;;;    If one of the second and third operands is of the null type and the
;;; type of the other is a reference type, then the type of the conditional
;;; expression is that reference type.

;;;    If the second and third operands are of different reference types,
;;; then it must be possible to convert one of the types to the other type
;;; (call this latter type T) by assignment conversion (§5.2); the type of
;;; the conditional expression is T. It is a compile-time error if neither
;;; type is assignment compatible with the other type.

(defmethod get-type ((e conditional-expression))
  (let ((then (conditional-expression-then e))
	(else (conditional-expression-else e)))
    (assert (not (and (null-literal-p then)
		      (null-literal-p else))))
    (let ((type-then (get-type then))
	  (type-else (get-type else)))
      (merge-types type-then type-else))))

;;I guess there's a problem here due to type promotions.  When both then
;;and else are char, the return type is char? It should, but...
(def-unparse conditional-expression (e)
  (format t (if *print-out-parenthesis*
	      "(~@<(~:/ppexp/) ? ~_~/pp/ : ~_~/pp/~:>)"
	      "~@<(~:/ppexp/) ? ~_~/pp/ : ~_~/pp/~:>")
	  (from-reference-type-to-boolean (conditional-expression-test e))
	  (conditional-expression-then e)
	  (conditional-expression-else e)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;We also have a 'cond' as an expression (this is beautifull) as long as we
;;convert it to an 'if'. 
;;Note that we cannot translate clauses with multiple consequents because
;;Java does not have the C/C++ comma operator.

(def-transform expression (cond (t ?expression))
  ?expression)

(def-transform expression (cond (?test ?expression) . ?rest-clauses)
  (if ?test
    ?expression
    (cond . ?rest-clauses)))

(def-transform expression (cond (t ?expression1 ?expression2 . ?more-expressions))
  (progn ?expression1 ?expression2 . ?more-expressions))

(def-transform expression (cond (?test ?expression1 ?expression2 . ?more-expressions) . ?rest-clauses)
  (if ?test
    (progn
      ?expression1 ?expression2 . ?more-expressions)
    (cond . ?rest-clauses)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;Let's continue.
;;when
(def-syntax when-statement (statement) 
  (when ?test/expression . ?body/statement-list)
  :strict-p t)

(def-unparse when-statement (e)
  (format t "~@<if (~:/ppexp/) ~/ppblk/~:>"
	  (from-reference-type-to-boolean (when-statement-test e))
	  (when-statement-body e)))

;;unless
(def-transform statement (unless ?test . ?body)
  (when (not ?test) . ?body))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass type-node ()
  ())

;;Some nodes have an explicit (or easily determinable type)
;;Let's create a class just for those nodes

(defclass explicit-type-node (type-node)
  ((type :accessor explicit-type-node-type :initarg :type)))

(defmethod get-type ((e explicit-type-node))
  (explicit-type-node-type e))


;;In other cases, the type might be inferred

(defclass inferred-type-node (type-node)
  ((type :accessor inferred-type-node-type :initform (unknown-type) :initarg :type)))

(defmethod get-type ((e inferred-type-node))
  (assert (not (null (inferred-type-node-type e)))) ;;I suspect this can't happen now
  (when (unknown-type-reference-p (inferred-type-node-type e))
    (setf (inferred-type-node-type e) (with-parent (e) (copy-type (infer-type e)))))
  (inferred-type-node-type e))

;;;;;Let's do this now so that the errors are presented before
;;;unparsing HACK!!!!!!  This __MUST__ be done now, otherwise terrible
;;;bugs show up.  This must be studied in detail to understand what's
;;;happening.  I'm really afraid there are some nasty bugs waiting to
;;;show up.
(defmethod visit :after ((e inferred-type-node) (v parse-tree-finish))
  (get-type e))
;;HACK: shouldn't be doing this on around methods belonging to interfaces because it might need type-inference over call-next-method and this isn't defined!

;;let-bindings and such:
(def-category variable-declaration (declaration-options inferred-type-node linj-node)
  ((name :accessor variable-declaration-name :initarg :name)
   (initializer :accessor variable-declaration-initializer :initform nil :initarg :initializer)))

(defun supplied-p (var)
  (get-option :supplied-p var))

(defun (setf supplied-p) (val var)
  (setf (get-option :supplied-p var) val))

(defmethod infer-type ((e variable-declaration))
  (get-type (variable-declaration-initializer e)))

(defun initialized-variable-declaration-p (param)
  (not (null (variable-declaration-initializer param))))

(defmethod visit-current ((e variable-declaration) (visitor cast-and-wrap))
  (when (variable-declaration-initializer e)
    (setf (variable-declaration-initializer e)
	  (with-parent (e) ;;initializer doesn't have auto-parent
	    (convert-to-type (variable-declaration-initializer e) (get-type e) :force-cast nil)))))

(def-unparse variable-declaration (e)
  (format t "~@<~:[~;final ~]~/pp/ ~/unlinj-name/~:[~; = ~4I~_~:/ppexp/~I~]~:>"
	  (get-option :final e)
	  (get-type e)
	  (variable-declaration-name e)
	  (and *print-out-initializer* 
	       (not (null (variable-declaration-initializer e))))
	  (variable-declaration-initializer e)))


;;The syntaxes for variable declarations (mainly parameters) are:
;; (defun xpto (a b/int (c 1) (d/long 1))
;;   ...)

;; The possibilities are:
;; linj-name                             - untyped, uninitialized variable
;; linj-name/type-reference              - typed, uninitialized variable
;; (linj-name expression)                - untyped, initialized variable
;; (linj-name/type-reference expression) - typed, initialized variable

;;I'm not sure about the last form.  It can be trivially implemented as
;; (linj-name (the type-reference expression))
;;thus reducing the number of cases to three.

;;However, there's a different decomposition which is more ortogonal, namely
;; var-or-var/type
;; (var-or-var/type expression)
;;where var-or-var/type is
;; linj-name
;; linj-name/type-reference

;;This suggests a more structured variable declaration.  Unfortunately, I'm afraid
;;it would break a lot of code so I'll stick with the first four possibilities

;;complete with type name and initializer
(def-syntax full-variable-declaration (variable-declaration)
  (?name/linj-name (the ?type/type-reference ?initializer/expression)))

;;lacking initializer
(def-syntax uninitialized-variable-declaration (variable-declaration)
  (?name/linj-name (the ?type/type-reference)))

;;lacking initializer but with special syntax for type declaration

(def-syntax short-uninitialized-variable-declaration (variable-declaration)
  (?is ?name name&type-p)
  :constructor make-short-uninitialized-variable-declaration)

(defun make-short-uninitialized-variable-declaration (category &key original-form name)
  (declare (ignore category))
  (multiple-value-bind (name type)
      (extract-name&type name)
    (make-instance 'uninitialized-variable-declaration
		   :original-form original-form
		   :name (parse name 'linj-name)
		   :type (parse type 'type-reference))))

;;lacking type
;;Types might be computed by our "type inferencer"
(def-syntax untyped-variable-declaration (variable-declaration)
  (?name/linj-name ?initializer/expression)
  :components (?type/type-reference))

(def-syntax short-untyped-variable-declaration (untyped-variable-declaration)
  ((?is ?name name&type-p) ?initializer/expression)
  :constructor make-short-untyped-variable-declaration
  :components (?type/type-reference))

(defun make-short-untyped-variable-declaration (category &key original-form name initializer)
  (declare (ignore category))
  (multiple-value-bind (name type)
      (extract-name&type name)
    (make-instance 'untyped-variable-declaration
		   :original-form original-form
		   :name (parse name 'linj-name)
		   :type (parse type 'type-reference)
		   :initializer (parse initializer 'expression))))


;;lacking type and initializer
(def-syntax untyped-uninitialized-variable-declaration (variable-declaration)
  ?name/linj-name
  :components (?type/type-reference))

(defmethod infer-type ((e untyped-uninitialized-variable-declaration))
  ;;There are several ways to infer the type of a function or method parameter:

  ;; - infer its type from the operations done with the parameter.  This
  ;;   might be problematic in the presence of polimorfic operators such as
  ;;   the + or = operators that can deal with int our double

  ;; - look to a method call and identify what type of objects are being
  ;;   passed as arguments to that parameter.
  ;; 
  ;;We can try both venues.  The idea is that a variable might have a set
  ;;of potential types that, at code generation time, must be resolved to a
  ;;singleton.
  ;;For the moment, I'll use just the first approach
;;  (object-type))
  (setf (inferred-type-node-type e) (object-type))
  (let ((meth (containing-method-declaration e)))
    (when meth
      (let ((meth-inferred-type (inferred-type-node-type meth)))
	(let ((type (get-type meth)))
	  (unless (or (cyclic-type-p type) (void-type-p type))
	    (force-type meth type))
	  ;;Now, check if all my uses have a lower common type in casts expressions
	  (setf (inferred-type-node-type e)
		(let ((casts (collect-all-type-info-for-references-to meth e)))
		  (cond ((endp casts) ;;No casts, (object-type) is OK
			 (object-type))
			((endp (rest casts)) ;;Just one. Use it
			 (first casts))
			(t
			 (block common-sub-type
			   (reduce #'(lambda (type1 type2)
				       (cond ((super-type-p type1 type2)
					      type2)
					     ((super-type-p type2 type1)
					      type1)
					     (t	;;No good common subtype
					      (return-from common-sub-type (object-type)))))
				   casts)))))))
	(setf (inferred-type-node-type meth) meth-inferred-type))))
  (inferred-type-node-type e))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;We will restrict bindings so that they only accept variable declarations
;;with initialization forms.  If you want a non-initialized reference,
;;write (the <???> null)

(def-list-syntax bindings (linj-list-node) untyped-variable-declaration)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;I use a nice trick to overcome the stupid java limitation regarding shadowing:
;;names have a trailing number that expresses its shadowing level.

(defun shadowing-level (name node &optional (level 0))
  (let ((ref (make-instance 'reference
			    :name name
			    :parent (ast-node-parent (ast-node-parent node)))))
    (labels ((shadow-level (e)
	       (let ((decl (find-declaration-in ref e)))
		 (cond ((null decl)
			0)
		       ((slot-declaration-p decl)
			level) ;;slots can be shadowed
		       ((and (parameter-list-p (ast-node-parent decl))
			     (method-declaration-p (ast-node-parent (ast-node-parent decl))))
			1) ;;parameters can't be shadowed but there's no need to look further up
		       (t ;;everything else (let, for, etc)
			(1+ (shadow-level (ast-node-parent (ast-node-parent (ast-node-parent decl))))))))))
      (shadow-level (ast-node-parent (ast-node-parent (ast-node-parent node)))))))

(defclass collect-references-to ()
  ((declaration :initarg :declaration :reader get-declaration)
   (references :initform (list) :accessor get-references)))

(defmethod visit :before ((ref reference) (visitor collect-references-to))
  (when (eq (find-declaration ref) (get-declaration visitor))
    (push ref (get-references visitor))))

(defun all-references-to (var-decl &optional (within (ast-node-parent (ast-node-parent var-decl))))
  (let ((visitor (make-instance 'collect-references-to :declaration var-decl)))
    (visit within visitor)
    (get-references visitor)))

;;HACK: this is operating too soon, preventing semantic macros that rebind variables to work properly.  Consider the example:
;;(for-each (e l)
;;  (for-each (e e)
;;    ..))
(defmethod visit :before ((e bindings) (visitor parse-tree-finish))
  (dolist (var (bindings-elements e))
    (let ((level (shadowing-level (variable-declaration-name var) var)))
      (when (> level 0)
	(let ((new-name (unshadowed-name (variable-declaration-name var) var)))
	  (dolist (ref (all-references-to var))
	    (setf (reference-name ref) new-name))
	  (setf (variable-declaration-name var) new-name))))))

(defun unshadowed-name (name node)
  (labels ((try (suf default-level)
	     (if (= (shadowing-level (conc-symbol name suf) node default-level) 0)
	       suf
	       (try (1+ suf) default-level))))
    (do* ((first-try (try 0 0) second-try)
	  (second-try (try first-try 1) (try first-try 1)))
	((eq first-try second-try) (conc-symbol name first-try)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(def-syntax let-statement (statement)
  (p-let ?bindings/bindings . ?body/statement-list)
  :strict-p t)

(def-macro-transform let-statement (let ?bindings . ?body)
  (multiple-value-bind (new-binds reordered-binds)
      (serialize-parallel ?bindings)
    (if new-binds
	`(p-let ,new-binds
	  (p-let ,reordered-binds 
	   (unlet-macro-transform ,(mapcar #'(lambda (bind)
					       `(expression ,(first bind)))
					   (append new-binds reordered-binds))
	    (p-let () ,@?body))))
	(if reordered-binds
	    `(p-let ,reordered-binds
	      (unlet-macro-transform ,(mapcar #'(lambda (bind)
						  `(expression ,(first bind)))
					      reordered-binds)
	       (p-let () ,@?body)))
	    `(p-let () ,@?body)))))

(defmethod visit :before ((e let-statement) (visitor adjust-parents))
  ;;Correct context for the initializers to jump over the let
  (dolist (bind (bindings-elements (let-statement-bindings e)))
    (setf (ast-node-parent (variable-declaration-initializer bind)) (ast-node-parent e))))

;;In Common Lisp, references inside bindings can't refer to the bindings
;;themselves and this suggests that the following method should be active:

; (defmethod find-declaration-in ((ref reference) (e bindings))
; (find-declaration-in ref (ast-node-parent (ast-node-parent e))))

;;This is necessary to deal with code like (let ((x (- x))) ...) without
;;infinite regression.

;;However, in Java, this rule isn't valid.  In fact, the specification says:

;; 14.4.2 Scope of Local Variable Declarations

;; The scope of a local variable declaration in a block (§14.4.2) is the
;; rest of the block in which the declaration appears, starting with its
;; own initializer (§14.4) and including any further declarators to the
;; right in the local variable declaration statement.

;; The name of a local variable v may not be redeclared as a local
;; variable of the directly enclosing method, constructor or initializer
;; block within the scope of v, or a compile-time error occurs. The name
;; of a local variable v may not be redeclared as an exception parameter
;; of a catch clause in a try statement of the directly enclosing method,
;; constructor or initializer block within the scope of v, or a
;; compile-time error occurs. However, a local variable of a method or
;; initializer block may be shadowed (§6.3.1) anywhere inside a class
;; declaration nested within the scope of the local variable.

;;All this implies that in order to translate the shadowing of let-bindings
;;or parameters, we need to rename the new bindings, that is, we should
;;translate (let ((x 1)) (let ((x (- x))) ...x...)) into something like 
;;(let ((x 1)) (let ((x1 (- x))) ...x1...)).  I'm not in the mood to
;;do this know.

(defmethod find-declaration-in ((ref reference) (e let-statement))
  (or (find (reference-name ref)
	    (bindings-elements (let-statement-bindings e))
	    :key #'variable-declaration-name)
      (call-next-method)))

;;Due to the fact that a statement-list is represented in Java using a
;;block and that blocks can introduce local variables (as long as they
;;don't shadow other variables - stupid language), we will define a special
;;(simplified) unparse for statement-lists composed by a unique let
;;statement.

;; (defclass references-p ()
;;   ((name :initarg :name :reader get-name)
;;    (exit :initarg :exit :reader get-exit)))

;; (defun unneded-braces-p (e)
;;   (let ((all-bindings (collect-all-bindings e)))
;;     (or (endp all-bindings)
;; 	(or (not (statement-list-p (ast-node-parent e)))
;; 	    (let ((next-statements (rest (member e (statement-list-elements (ast-node-parent e))))))
;; 	      (every #'(lambda (decl)
;; 			 (notany #'(lambda (statement)
;; 				     (references-p (variable-declaration-name decl) statement))
;; 				 next-statements))
;; 		     all-bindings))))))


(defun no-redeclarations-p (e out-bindings)
  (or (not (statement-list-p (ast-node-parent e)))
      (and (no-redeclarations-in-statement-list 
	    (rest (member e (statement-list-elements (ast-node-parent e)))) out-bindings)
	   (no-redeclarations-p (ast-node-parent (ast-node-parent e)) out-bindings))))

(defclass operate-bindings-visitor ()
  ((function :initarg :function :reader operate-binding-function)))

(defmethod visit :before ((bindings bindings) (visitor operate-bindings-visitor))
  (funcall (operate-binding-function visitor) (bindings-elements bindings)))

(defun no-redeclarations-in-statement-list (statements out-bindings)
  (visit statements
	 (make-instance
	  'operate-bindings-visitor
	  :function #'(lambda (bindings)
			(when (some #'(lambda (bind)
					(some #'(lambda (out-bind)
						  (eq (variable-declaration-name bind) (variable-declaration-name out-bind)))
					      out-bindings))
				    bindings)
			  (return-from no-redeclarations-in-statement-list nil)))))
  t)

(defun unneded-braces-p (e)
  (let ((out-bindings (bindings-elements (let-statement-bindings e))))
    (or (endp out-bindings)
	(no-redeclarations-p e out-bindings))))
	


;; (def-unparse let-statement (e)
;;   (let ((statements (statement-list-elements (let-statement-body e))))
;;     (if (not (endp statements)) ;;more than zero?
;;       (if (and *print-out-braces* (not (unneded-braces-p e)))
;; 	(format t "~@<{~4I~{~:@_~/pp/;~}~{~:@_~/ppblk/~}~:@_~:/ppblk/~I~:@_}~:>"
;; 		(bindings-elements (let-statement-bindings e))
;; 		(butlast statements)
;; 		(first (last statements)))
;; 	(format t "~@<~{~/pp/;~:@_~}~{~/ppblk/~:@_~}~:/ppblk/~:>"
;; 		(bindings-elements (let-statement-bindings e))
;; 		(butlast statements)
;; 		(first (last statements))))
;;       (if (and *print-out-braces* (not (unneded-braces-p e)))
;; 	(format t "~@<{~4I~{~:@_~/pp/;~}~I~:@_}~:>"
;; 		(bindings-elements (let-statement-bindings e)))
;; 	(format t "~@<~{~/pp/;~:@_~}~:>"
;; 		(bindings-elements (let-statement-bindings e)))))))

(def-unparse let-statement (e)
  (let ((statements (statement-list-elements (let-statement-body e))))
    (if (not (endp statements)) ;;more than zero?
      (if (and *print-out-braces* (not (unneded-braces-p e)))
	(format t "~@<{~4I~{~:@_~/pp/;~}~{~:@_~/ppblk/~}~:@_~/ppblk/~I~:@_}~:>"
		(bindings-elements (let-statement-bindings e))
		(butlast statements)
		(first (last statements)))
	(format t "~@<~{~/pp/;~:@_~}~{~/ppblk/~:@_~}~/ppblk/~:>"
		(bindings-elements (let-statement-bindings e))
		(butlast statements)
		(first (last statements))))
      (if (and *print-out-braces* (not (unneded-braces-p e)))
	(format t "~@<{~4I~{~:@_~/pp/;~}~I~:@_}~:>"
		(bindings-elements (let-statement-bindings e)))
	(format t "~@<~{~/pp/;~:@_~}~:>"
		(bindings-elements (let-statement-bindings e)))))))

;; (defmethod visit :before ((ref reference) (visitor references-p))
;;   (when (eq (reference-name ref) (get-name visitor))
;;     (funcall (get-exit visitor))))

;; ;;This is not strictly a reference but it is also a situation where the let-statement can't be inlined.
;; (defmethod visit :before ((var variable-declaration) (visitor references-p))
;;   (when (eq (variable-declaration-name var) (get-name visitor))
;;     (funcall (get-exit visitor))))

;; (defun references-p (name node)
;;   (let ((visitor (make-instance 'references-p
;; 				:name name
;; 				:exit #'(lambda () (return-from references-p t)))))
;;     (visit node visitor)
;;     nil))

;;;;;;;;;;;;;;;;;;;;;;

(defclass collect-bindings-visitor ()
  ((bindings :initform (list) :accessor get-bindings)))

(defmethod visit :before ((var variable-declaration) (visitor collect-bindings-visitor))
  (push var (get-bindings visitor)))

(defun collect-all-bindings (node)
  (let ((visitor (make-instance 'collect-bindings-visitor)))
    (visit node visitor)
    (get-bindings visitor)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(def-macro-transform let-statement (let* ?bindings . ?body)
  (if (endp ?bindings)
    `(let ,?bindings
       ,@?body)
    `(let (,(first ?bindings))
       (let* ,(rest ?bindings)
	 ,@?body))))

;;;;;;;;;;;;;;;;;;;;;

;;A very simple let-statement:
(def-transform let-statement (progn . ?body)
  (let () . ?body))

;;A very special case:
(def-transform expression (prog1 ?form (incf ?form))
  (post-incf ?form))


;;A not so simple let-statement:
(def-macro-transform let-statement (prog1 ?form . ?body)
  (with-new-names (results)
   `(let ((,results ,?form))
      ,@?body
      ,results)))

;;The equivalent form...
(def-transform let-statement (multiple-value-prog1 ?form . ?body)
  (prog1 ?form . ?body))

;;;prog2
(def-transform let-statement (prog2 ?form1 ?form2 . ?body)
  (progn ?form1 (prog1 ?form2 . ?body)))

;;;;;;;;;;;;;;;;;;;;;;;;

(def-list-syntax argument-list (linj-list-node) expression)

(defparameter *infer-principal-value* t)

(defun principal-value (arg)
  (if *infer-principal-value*
    (with-parent ((ast-node-parent arg))
      (cast-and-wrap-if-needed
       (get-principal-type arg)
       (get-type arg)
       arg
       #'(lambda (expected current expr)
	   (declare (ignore expected current expr))
	   (linj-error "Something weird happen with ~A" arg))))
    arg))

(def-unparse argument-list (e)
  (format t "(~@<~{~:/ppexp/~^, ~_~}~:>)"
	  (mapcar #'principal-value (argument-list-elements e))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;Another needed feature is generic iteration
;;We'll consider first a do-type form on top of which one can define
;;several other macros (including, presumably, the loop macro)

(def-syntax for-statement (statement)
  (for (?bindings/bindings ?test/expression ?updates/argument-list)
       . ?body/statement-list)
  :strict-p t)

(defmethod visit :before ((e for-statement) (visitor adjust-parents))
  ;;Correct context for the initializers to jump over the for
  (dolist (bind (bindings-elements (for-statement-bindings e)))
    (setf (ast-node-parent (variable-declaration-initializer bind)) (ast-node-parent e))))

(defmethod find-declaration-in ((ref reference) (e for-statement))
  (or (find (reference-name ref)
	    (bindings-elements (for-statement-bindings e))
	    :key #'variable-declaration-name)
      (call-next-method)))

(def-unparse for-statement (e)
  (if (and (null (bindings-elements (for-statement-bindings e)))
	   (null (argument-list-elements (for-statement-updates e))))
    (format t "~@<while (~:/ppexp/) ~/ppblk/~:>"
	    (from-reference-type-to-boolean (for-statement-test e))
	    (for-statement-body e))
    (format t "~@<for ~<(~{~/pp/~^, ~}; ~1I~_~:/ppexp/; ~_~{~:/ppexp/~^, ~_~})~:> ~/ppblk/~:>"
	    (list (bindings-elements (for-statement-bindings e))
		  (from-reference-type-to-boolean (for-statement-test e))
		  (argument-list-elements (for-statement-updates e)))
	    (for-statement-body e))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;An implementation for (block ?label . ?body)
;;An implementation for (return) (return ?expr) (return-from ?label) (return-from ?label ?expr)

;;;In Common Lisp
;;;do, do*, dolist, dotimes, simple loop, and complex loop
;;;establish implicit blocks (labeled nil)

;;;defun, defmethod, and the complex loop with the :named keyword
;;;establish implicit blocks (labelled the name of the definition)

;;;(block ?name . ?body) establishes an explicit block named ?name
;;;Moreover
;;;(return) = (return-from nil)
;;;(return ?expr) = (return-from nil ?expr)

(def-transform statement (return) (return-from nil))

(def-transform statement (return ?expr) (return-from nil ?expr))

;;;In Java
;;;A break statement with no label attempts to transfer
;;;control to the innermost enclosing switch, while, do, or for
;;;statement of the immediately enclosing method or initializer block;

;;;A break statement with label Identifier attempts to transfer
;;;control to the enclosing labeled statement that has the same
;;;Identifier as its label

;;There are special forms to break or 'continue' a block.  Common Lisp
;;doesn't contain them, but Linj does.  However, they can only be used
;;with a surrounding block.  Obviously, in the 'continue' case, just
;;like in Java, for it to take any effect, the block must contain just
;;one loop.

;;Note also that I don't expect that programmers will use the break
;;statement in Linj because the "equivalent" return-from statement is
;;available and it spares the return/break Java duality.

(def-transform statement (break) (break nil))

(def-syntax break-statement (statement)
  (break ?label/linj-name))

(def-unparse break-statement (e)
  (format t "break ~/unlinj-name/;" (break-statement-label e)))

(def-syntax empty-break-statement (break-statement)
  (break nil)
  :slots ((label :initform nil)))

(def-unparse empty-break-statement (e)
  (format t "break;"))

;;;;;;;;;;;;;;;;;;;;;;;;

(def-transform statement (continue) (continue nil))

(def-syntax continue-statement (statement)
  (continue ?label/linj-name))

(def-unparse continue-statement (e)
  (format t "continue ~/unlinj-name/;" (continue-statement-label e)))

(def-syntax empty-continue-statement (continue-statement)
  (continue nil)
  :slots ((label :initform nil)))

(def-unparse empty-continue-statement (e)
  (format t "continue;"))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;Now, let's deal with processing all this return/break/continue mess.

;;First, we, create a special statement that will be used to implement
;;the proper Java return statement.  Note that this statemtent (and
;;its subclasses) cannot be present in any Linj file and it is only
;;generated as the result of the compilation process
(def-category return-statement (statement)
  ((expression :accessor return-statement-expression :initform nil)))

(defmethod get-type ((e return-statement))
  (if (null (return-statement-expression e))
    (void-type)
    (get-type (return-statement-expression e))))

(def-unparse return-statement (e)
  (format t "return~@[ ~:/ppexp/~];"
	  (return-statement-expression e)))

;;Now, we create two varieties (the void and non-void return statement)
;;;HACK:: This must be changed
(def-syntax non-void-return-statement (return-statement)
  (cannot-parse-this-return ?expression/expression)
  :strict-p t)

(def-syntax void-return-statement (return-statement)
  (cannot-parse-this-return)
  :strict-p t)

;;Now, let's specify the Linj statements.  We can write (return),
;;(return ...), (return-from ...), and (return-from ... ...) and they
;;will all be parsed as just one type of return, namely the
;;return-from-statement.  Some of these 'returns' have the containing
;;method as target and these will be transformed into the above
;;return-statements.  The remaining ones should be transformed into
;;break statements.

(def-syntax return-from-statement (statement)
  (return-from ?label/linj-name &optional ?expression/expression))

;;The empty-label return-from statement
(def-syntax empty-return-from-statement (return-from-statement)
  (return-from nil &optional ?expression/expression)
  :slots ((label :initform nil)))

(defmethod return-from-method-p ((e return-from-statement))
  (let ((block (containing-block-named e (return-from-statement-label e))))
    (eq block (containing-method-declaration e))))

;;We will implement another pass to transform all return statements.

(defclass process-return-from-statements ()
  ())

(defmethod visit :before ((stat return-from-statement) (visitor process-return-from-statements))
  (if (return-from-method-p stat)
    (error "Something wrong happened during inference of method exit points for ~A" stat)
    (if (null (return-from-statement-expression stat))
      (change-class stat 'break-statement)
      (error "Can't return a value to an inner block from return ~A" stat))))

;;After this pass and after the exit point inference, there should not
;;be any more return-from statements.
(def-unparse return-from-statement (e)
  (error "The ~A return-from-statement must have been translated into
a return-statement or into a break statement" e))

(defmethod get-type ((e return-from-statement))
  (if (null (return-from-statement-expression e))
    (void-type)
    (get-type (return-from-statement-expression e))))

;;Linj contains something very similar to a Common Lisp block:

(def-syntax block-statement (statement)
  (block ?name/linj-name . ?body/statement-list))

;;And nil blocks (we need extra syntax as nil is never parsable as itself (and linj-names are symbols))
(def-syntax nil-block-statement (block-statement)
  (block nil . ?body/statement-list)
  :slots ((name :initform nil)))

;;We will remove the block when we are sure it isn't needed.  This is
;;necessary for further simplifications (such as let's)

;;First pass:

;;In several cases, we might have a block immediately followed by another block.  This might be the result of code like

;; (block outer (loop inner (return) (return-from outer)))

;; where the inner loop is expanded into something like

;; (block outer (block nil (while t inner (return-from nil) (return-from outer))))

;; In this case, it is preferable to "compress"  the blocks:

;; (block outer (while t inner (return-from outer) (return-from outer)))

;; the result is semantically equivalente but has other advantages. Consider:

;; (block outer (loop inner (return) (continue outer)))

;; Here, the intent is to continue a labeled loop but it can only work if we "compress" the blocks.

(defclass compress-blocks ()
  ())

(defmethod visit :before ((e block-statement) (visitor compress-blocks))
  (unless (not (block-statement-name e))
    (compress-blocks e)))

(defun compress-blocks (e)
  (let ((statements (statement-list-elements (block-statement-body e))))
    (when (endp (rest statements))
      (let ((statement (first statements)))
	(when (nil-block-statement-p statement)
	  (let ((label (ast-node-form (block-statement-name e))))
	    (multiple-value-bind (breaks continues returns)
		(collect-exits-for-block statement)
	      (loop for (e) in breaks
		    do (change-class e 'break-statement :label (parse label 'linj-name)))
	      (loop for (e) in continues
		    do (change-class e 'continue-statement :label (parse label 'linj-name)))
	      (loop for (e) in returns
		    do (change-class e 'return-from-statement :label (parse label 'linj-name)))))
	  (setf (block-statement-body e)
		(block-statement-body statement))
	  e)))))


(defun collect-exits-for-block (statement)
  (let ((collector (make-instance 'collect-return-from :block statement)))
    (visit statement collector)
    (values (breaks collector) (continues collector) (returns collector))))
  
(defclass remove-unneded-blocks ()
  ())

(defmethod visit :before ((e block-statement) (visitor remove-unneded-blocks))
  (remove-unneded-blocks e))

(defun remove-unneded-blocks (e)
  (multiple-value-bind (breaks continues returns)
      (collect-exits-for-block e)
    (when (every #'(lambda (elems)
		     (or ;;If there are no references to the block, we can remove it
		      (endp elems)
		      (and (not (block-statement-name e))
			   (endp (second (first elems))))))
		 (list breaks continues returns))
      (loop for (e) in breaks
	    do (change-class e 'empty-break-statement :label nil))
      (loop for (e) in continues
	    do (change-class e 'empty-continue-statement :label nil))
      (loop for (e) in returns
	    do (change-class e 'empty-return-from-statement :label nil))
      ;;HACK: this might be simpler:
      (change-class e 'let-statement :bindings (parse '() 'bindings))
;;       ;;But I'll use the older version for now.
;;       (cond ((statement-list-p (ast-node-parent e))
;; 	     (setf (statement-list-elements (ast-node-parent e))
;; 		   (mapcan #'(lambda (statement)
;; 			       (if (eq statement e)
;; 				 (statement-list-elements (block-statement-body e))
;; 				 (list statement)))
;; 			   (statement-list-elements (ast-node-parent e)))))
;; 	    ((endp (rest (statement-list-elements (block-statement-body e)))) ;;just one
;; 	     (with-parent ((ast-node-parent e))
;; 	      (become-instance e (first (statement-list-elements (block-statement-body e))))))
;; 	    (t
;; 	     (let ((node (with-parent ((ast-node-parent e))
;; 			   (parse `(progn ,@(statement-list-elements (block-statement-body e)))
;; 				  'statement))))
;; 	       (apply-visitors 'after-parse node)
;; 	       (become-instance e node))))
      e)))

(def-unparse block-statement (e)
  (if (avoid-labelled-statement-brackets-p (block-statement-body e))
    (format t "~/unlinj-name/: ~{~/ppblk/~^~:@_~}"
	    (block-statement-name e)
	    (statement-list-elements (block-statement-body e)))
    (format t "~@<~/unlinj-name/: ~/ppblk/~:>"
	    (block-statement-name e)
	    (block-statement-body e))))

(defun avoid-labelled-statement-brackets-p (statement-list)
  (and (endp (rest (statement-list-elements statement-list)))
       (let ((unique-statement (first (statement-list-elements statement-list))))
	 (or (not (let-statement-p unique-statement))
	     (and (endp (bindings-elements (let-statement-bindings unique-statement))) 
		  (avoid-labelled-statement-brackets-p (let-statement-body unique-statement)))))))


;;HACK: This should be done using lambdas so that it returns as soon as possible
(defclass collect-return-from ()
  ((block :reader collect-block :initarg :block)
   (returns :accessor returns :initform (list))
   (breaks :accessor breaks :initform (list))
   (continues :accessor continues :initform (list))))

(defmethod visit ((e return-from-statement) (visitor collect-return-from))
  (let ((block (containing-block-named e (return-from-statement-label e))))
    (when (eq block (collect-block visitor))
      (push (list e (jumped-over-blocks e (return-from-statement-label e)))
	    (returns visitor)))))

(defmethod visit ((e continue-statement) (visitor collect-return-from))
  (let ((block (containing-block-named e (continue-statement-label e))))
    (when (eq block (collect-block visitor))
      (push (list e (jumped-over-blocks e (continue-statement-label e)))
	    (continues visitor)))))

(defmethod visit ((e break-statement) (visitor collect-return-from))
  (let ((block (containing-block-named e (break-statement-label e))))
    (when (eq block (collect-block visitor))
      (push (list e (jumped-over-blocks e (break-statement-label e)))
	    (breaks visitor)))))

;;Let's define some iteration forms on top of this

;; (def-transform for-statement (loop . ?body) SEE FILE loop.lisp
;;   (block nil (for (() t ()) . ?body)))

(def-transform for-statement (while ?test . ?body)
  (block nil (for (() ?test ()) . ?body)))

(def-transform for-statement (do . ?rest)
  (do-iter nil . ?rest))

(def-transform for-statement (do* . ?rest)
  (do-iter t . ?rest))

;;;From a set of parallel bindings (or assignments) in the form
;;;((var1 . exprs1) (val2 . exprs2) ... (varn . exprsn))
;;;returns a reordering and extension of the bindings so that they can be
;;;done sequencially.  The bindings have that strange form because
;;;they can be used both for let and for do bindings. To avoid parsing the
;;;code, this is done conservatively by mixin all namespaces.

;;;The idea is that if one of the exprs references one of the other vars,
;;;the corresponding binding must be done before the binding of those vars
;;;((x 1) (y x)) -> ((y x) (x 1))
;;;((x 1) (y (1+ x)) (z (+ x y))) -> ((z (+ x y)) (y (1+ x)) (x 1))
;;;((x y) (y x)) -> ((x-old x) (x y) (y x-old))

(defun serialize-parallel (all-binds)
    ;;First, mutual dependencies
  (let ((mutual-depends
	 (mapcon #'(lambda (binds)
		     (let ((bind1 (first binds)))
		       (mapcan #'(lambda (bind2)
				   (if (and (depends-p bind1 bind2 all-binds)
					    (depends-p bind2 bind1 all-binds))
				     (list bind1)
				     (list)))
			       (rest binds))))
		 all-binds)))
    (if mutual-depends
	;;;add extra vars
      (let ((rebinds (mapcar #'(lambda (mutual)
				 (let ((var (first mutual)))
				   (cons var (gen-new-name var all-binds))))
			     (remove-duplicates mutual-depends :key #'second))))
	(let ((extras (mapcar #'(lambda (mutual rebind)
				  (let ((var (car rebind))
					(new-var (cdr rebind)))
				    (if (rest (rest mutual)) ;;do binds
				      `(,new-var ,(second mutual) ,var)
				      `(,new-var ,var))))
			      mutual-depends
			      rebinds)))
	  (values extras
		  (stable-sort (mapcar #'(lambda (bind)
					   (if (rest (rest bind)) ;;do binds
					     (let ((extra (assoc (first bind) rebinds)))
					       (if extra
						 `(,(first bind) ,(cdr extra) ,@(sublis rebinds (rest (rest bind))))
						 `(,(first bind) ,@(sublis rebinds (rest bind)))))
					     `(,(first bind) ,@(sublis rebinds (rest bind)))))
				       all-binds)
			       #'(lambda (b1 b2) (depends-p b1 b2 all-binds))))))
      (values (list)
	      (nreverse
	       (stable-sort (copy-list all-binds)
			    #'(lambda (b1 b2) (not (depends-p b1 b2 all-binds)))))))))

(defun depends-p (b1 b2 binds)
  (and (consp b1)
       (consp b2)
       (some #'(lambda (expr1)
		 (dependency-path-p expr1 (first b2) binds))
	     (rest b1))))

(defun dependency-path-p (expr var binds &optional (closed-binds (list)))
  (labels ((iterate (form)
	     (if (atom form)
	       (and (symbolp form)
		    (or (eq form var)
			(let ((bind (assoc form binds)))
			  (and bind
			       (not (member bind closed-binds)) 
			       (some #'(lambda (expr1)
					 (dependency-path-p expr1 var binds (cons bind closed-binds)))
				     (rest bind))))))
	       (or (iterate (car form))
		   (iterate (cdr form))))))
    (iterate expr)))

;;For the do and let binds
(defun serialize-parallel-bindings (binds)
  (multiple-value-bind (new-binds reordered-binds)
      (serialize-parallel binds)
    (append new-binds reordered-binds)))

(def-macro-transform for-statement (do-iter ?sequencial
				     ?bind-and-update-list 
				     (?end-test . ?result-forms)
				     . ?body)
  (multiple-value-bind (new-binds reordered-binds)
      (if ?sequencial
	(values (list) ?bind-and-update-list)
	(serialize-parallel ?bind-and-update-list))
      (setq ?bind-and-update-list (append new-binds reordered-binds))
      (flet ((build-for (pre)
			`(for (,pre
			       (not ,?end-test)
			       ,(mapcan #'(lambda (bind-and-update)
					    (when (rest (rest bind-and-update))
					      (list `(setf ,(first (last bind-and-update 3))
							   ,(first (last bind-and-update))))))
					?bind-and-update-list))
			      ,@?body))
	     (first-two (l) (list (first l) (second l))))
	(let ((?result-forms
	       (if (and ?result-forms
			(or (expression-references-p ?result-forms 'error)
			    (expression-references-p ?result-forms 'throw)
			    ;;(expression-references-p ?body 'return) ;;This is not safe but, until I have a better idea
			    (expression-references-p ?body 'return-from)))
		 `((when ,?end-test ,@?result-forms))
		 ?result-forms)))
	  `(block nil
	     ,(if (or (rest ?bind-and-update-list) ;;more than one => 'for' isn't enough
		      ?result-forms ;;more than zero => 'for' isn't enough
		      (and (not ?sequencial) ;;paralel => 'for' is sequential but
			   ;;this only makes sense if
			   (rest (rest ?bind-and-update-list)))) ;;more than one
		(let ((for-bind
		       (if ?sequencial
			 (let ((bind (first (last ?bind-and-update-list))))
			   (and (not (expression-references-p ?result-forms (first bind)))
				bind))
			 (find-if-not #'(lambda (var) (expression-references-p ?result-forms var))
				      reordered-binds
				      :key #'first
				      :from-end t))))
		  (if for-bind
		    `(let* ;;the binds are serialized ,(if ?sequencial 'let* 'let)
			 ,(mapcar #'first-two (remove for-bind ?bind-and-update-list :count 1))
		       ,(build-for (list (first-two for-bind)))
		       ,@?result-forms)
		    `(let* ;;the binds are serialized ,(if ?sequencial 'let* 'let)
			 ,(mapcar #'first-two ?bind-and-update-list)
		       ,(build-for '())	;;could put the initializations here but 'let'
		       ;;doesn't allow uninitialized bindings
		       ,@?result-forms)))
		(build-for (mapcar #'(lambda (bind-and-update)
				       (first-two bind-and-update))
				   ?bind-and-update-list))))))))

(defun expression-references-p (e var)
  "Poor's man approach."
  (if (atom e)
    (eq e var)
    (or (expression-references-p (car e) var)
	(expression-references-p (cdr e) var))))

;;Iteration
;;simple dotimes

(def-macro dotimes ((var end . result-forms) . body)
  (if (or (numberp end)
	  (and (atom end) (not (expression-references-p body end))))
    `(do ((,var 0 (1+ ,var)))
	 ((>= ,var ,end) . ,result-forms) . ,body)
    (with-new-names (limit)
      `(let ((,limit ,end))
	 (do ((,var 0 (1+ ,var)))
	     ((>= ,var ,limit) . ,result-forms) . ,body)))))

;;Now, for a dolist, which must use the (supposedly) defined first, rest
;;and endp

(def-macro dolist ((var expr . result-forms) . body)
  (with-new-names (list)
    `(do ((,list (real-the linj.cons ,expr) (rest ,list)))
	 ((endp ,list) . ,result-forms)
       (let ((,var (first ,list))) . ,body))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;Parallel assignment can be implemented with the help of serialize-parallel

(def-macro-transform setf-expression (psetq ?var ?val)
  (assert (symbolp ?var))
  `(setq ,?var ,?val))

(def-macro-transform statement (psetq ?var ?val)
  (assert (symbolp ?var))
  `(setq ,?var ,?val))

(def-macro-transform statement (psetq . ?vars-vals)
  (dolist-2 ((var val) ?vars-vals)
    (declare (ignore val))
    (assert (symbolp var)))
  `(psetf . ,?vars-vals))

(defparameter *parallel-assignment-can-reorder* t)

(def-macro-transform statement (psetf ?var1 ?val1 . (?is ?others consp))
  (expand-psetq-psetf `(,?var1 ,?val1 ,@?others)))

(defun expand-psetq-psetf (var-vals)
  (let ((binds (list)))
    (dolist-2 ((var val) var-vals)
      (push (list var val) binds))
    (expand-assignments (nreverse binds))))

(defun expand-assignments (binds)
  (if *parallel-assignment-can-reorder*
    (multiple-value-bind (new-binds reordered-binds)
	(serialize-parallel binds)
      (if new-binds
	`(let ,new-binds
	   (setf ,@(mapcan #'identity reordered-binds)))
	`(setf ,@(mapcan #'identity reordered-binds))))
    (let ((new-binds
	   (mapcar #'(lambda (bind)
		       `(,(gen-new-name (first bind) binds) ,(second bind)))
		   binds)))
      `(let ,new-binds
	 (setf ,@(mapcan #'(lambda (bind new-bind)
			     `(,(first bind) ,(first new-bind)))
			 binds new-binds))))))


(def-macro-transform statement (rotatef ?var1 ?var2)
  `(psetf ,?var1 ,?var2 ,?var2 ,?var1))


;;;We need to simplify some expressions before they can be unparsed.  One
;;;simple way is to partially evaluate them at macro expansion time.
;;Example:

(def-transform expression (not (not ?expr)) ?expr)
(def-transform expression (not t) nil)
(def-transform expression (not nil) t)
(def-transform expression (not (> ?x ?y)) (<= ?x ?y))
(def-transform expression (not (>= ?x ?y)) (< ?x ?y))
(def-transform expression (not (< ?x ?y)) (>= ?x ?y))
(def-transform expression (not (<= ?x ?y)) (> ?x ?y))
(def-transform expression (not (eq ?x ?y)) (neq ?x ?y))
(def-transform expression (not (= ?x ?y)) (/= ?x ?y))
(def-transform expression (not (/= ?x ?y)) (= ?x ?y))

(def-transform expression (or) nil)
(def-transform expression (and) t)
(def-transform expression (or ?expr) ?expr)
(def-transform expression (and ?expr) ?expr)

;;Maybe we are pushing this too far but they are useful for extended loop macro expansions
(def-macro-transform expression (not (or . ?exprs)) `(and ,@(mapcar #'(lambda (expr) `(not ,expr)) ?exprs)))
(def-macro-transform expression (not (and . ?exprs)) `(or ,@(mapcar #'(lambda (expr) `(not ,expr)) ?exprs)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;The case statement isn't simply a macro transformation on top of cond.
;;For <int>, <long> and <char> types, the translation to Java can expand to
;;a switch or to a cond.

;;First, transform atomic keys into a list with the key:

(def-macro-transform nil (case ?expr . ?clauses)
    (when (some #'(lambda (clause)
		    (and (atom (first clause))
			 (not (eq (first clause) 't))
			 (not (eq (first clause) 'otherwise))))
		?clauses)
      `(case ,?expr
	 ,@(mapcar #'(lambda (clause)
		       (if (and (atom (first clause))
				(not (eq (first clause) 't))
				(not (eq (first clause) 'otherwise)))
			 `((,(first clause)) ,@(rest clause))
			 clause))
		   ?clauses))))

;;Second, case expressions are a special case that needs special parsing

(def-macro-transform expression (case ?expr . ?clauses)
  (and (or (reference-p ?expr)
	   (symbolp ?expr))
       (from-case-to-cond ?expr ?clauses)))

;;Third, case statements must also save the cond version because the
;;unparse will depends on the type of the case expression

(def-macro-transform statement (case ?expr . ?clauses)
  `(yet-unknow-case-form
    ,?expr
    ,?clauses
    ,(if (or (reference-p ?expr)
	   (symbolp ?expr))
	 (from-case-to-cond ?expr ?clauses)
	 (with-new-names (case)
	   `(let ((,case ,?expr))
	     ,(from-case-to-cond case ?clauses))))))

(defun from-case-to-cond (?expr ?clauses)
  `(cond ,@(mapcar #'(lambda (clause)
		       `(,(cond ((listp (first clause))
				 `(or ,@(mapcar #'(lambda (elem)
						    `(eql ,?expr ',elem))
						(first clause))))
				((or (eq (first clause) 't) (eq (first clause) 'otherwise))
				 't)
				(t ;;this should never happen bc of the
				 ;;previous macro, but...
				 (error "Can't process case clause ~S" (first clause))))
			 ,@(rest clause)))
		   ?clauses)))

;;Now, the syntax.
;;HACK: This doesn't look pretty.
(def-syntax default-case-clause (linj-node)
  ((?is ?test (lambda (test) (or (eq test 't) (eq test 'otherwise)))) . ?body/statement-list))

(defun last-statement-terminates-p (statement-list)
  ;;empty statement lists do not last-statement-terminates-p
  (if (null (statement-list-elements statement-list))
    nil
    (progn
      (apply-to-exit-point statement-list
			   #'(lambda (statement)
			       (unless (or (return-statement-p statement)
					   (return-from-statement-p statement)
					   (throw-statement-p statement))
				 (return-from last-statement-terminates-p nil)))
			   (list 'normal-flow))
      t)))

(def-unparse default-case-clause (e)
  (format t "~@<default:~4I~{~:@_~/ppblk/~}~:[~:@_break;~;~]~I~:>"
	  (statement-list-elements (default-case-clause-body e))
	  (last-statement-terminates-p (default-case-clause-body e))))

(def-syntax case-clause (default-case-clause)
  (?keys/argument-list . ?body/statement-list))

(def-unparse case-clause (e)
  (if (some #'let-statement-p (statement-list-elements (case-clause-body e))) ;;This must go deeper.
    (format t "~@<~{case ~/pp/:~^~:@_~}~4I {~{~:@_~/ppblk/~}~:[~:@_break;~;~]~I~:@_}~:>"
	    (argument-list-elements (case-clause-keys e))
	    (statement-list-elements (case-clause-body e))
	    (last-statement-terminates-p (case-clause-body e)))
    (format t "~@<~{case ~/pp/:~^~:@_~}~4I~{~:@_~/ppblk/~}~:[~:@_break;~;~]~I~:>"
	    (argument-list-elements (case-clause-keys e))
	    (statement-list-elements (case-clause-body e))
	    (last-statement-terminates-p (case-clause-body e)))))

(def-list-syntax case-clause-list (linj-list-node) default-case-clause)

(def-syntax case-statement (statement)
  (yet-unknow-case-form ?expression/expression ?clauses/case-clause-list ?let-cond/statement))

;;The type of the Expression must be char, byte, short, or int, or a compile-time error occurs.

(defun switch-type-reference-p (type)
  (or (char-type-p type)
      (byte-type-p type)
      (short-type-p type)
      (int-type-p type)))

;; (defmethod visit :before ((e case-statement) (visitor parse-tree-finish))
;;   (unless (switch-type-reference-p (get-type (case-statement-expression e)))
;;     (let ((expr (ast-node-form (case-statement-expression e)))
;; 	  (clauses (ast-node-form (case-statement-clauses e))))
;;       (let ((statement
;; 	     (with-parent ((ast-node-parent e))
;; 	       (parse (if (reference-p (case-statement-expression e))
;; 			(from-case-to-cond expr clauses)
;; 			(with-new-names (case)
;; 			  `(let ((,case ,expr))
;; 			     ,(from-case-to-cond case clauses))))
;; 		      'statement))))
;; 	(apply-previous-visitors statement)
;; 	;;It is important to replace the case with the cond for several
;; 	;;reasons, including properly dealing with the let unparsing and
;; 	;;also to avoid repeated transformation between case and cond.
;; 	(setf (statement-list-elements (ast-node-parent e))
;; 	  (substitute statement e (statement-list-elements (ast-node-parent e))))))))

(def-unparse case-statement (e)
  (if (switch-type-reference-p (get-type (case-statement-expression e)))
    (format t "~@<switch (~:/ppexp/) {~{~:@_~/pp/~}~:@_}~:>"
	    (case-statement-expression e)
	    (case-clause-list-elements (case-statement-clauses e)))
    (unparse-object (case-statement-let-cond e) *standard-output*)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;Operator expressions

;;; 5.6.1 Unary Numeric Promotion

;;; Some operators apply unary numeric promotion to a single operand, which
;;; must produce a value of a numeric type:

;;; If the operand is of compile-time type byte, short, or char, unary
;;; numeric promotion promotes it to a value of type int by a widening
;;; conversion (§5.1.2).  Otherwise, a unary numeric operand remains as is
;;; and is not converted.

;;; Unary numeric promotion is performed on expressions in the following
;;; situations:

;;; Each dimension expression in an array creation expression (§15.10) 
;;; The index expression in an array access expression (§15.13) 
;;; The operand of a unary plus operator + (§15.15.3) 
;;; The operand of a unary minus operator - (§15.15.4) 
;;; The operand of a bitwise complement operator ~ (§15.15.5) 
;;; Each operand, separately, of a shift operator >>, >>>, or << (§15.19);
;;; therefore a long shift distance (right operand) does not promote the
;;; value being shifted (left operand) to long

(defparameter *unary-numeric-promotion-types*
    (list (byte-type) (short-type) (char-type)))

(defparameter *unary-numeric-acceptable-types*
    (list (int-type) (long-type) (float-type) (double-type)));; (big-integer-type) (big-decimal-type)))

(defun unary-numeric-promotion (type)
  (cond ((member type *unary-numeric-promotion-types* :test #'equal-type-p)
	 (int-type)) ;;promotion
	((member type *unary-numeric-acceptable-types* :test #'equal-type-p)
	 type)
	(t
	 (linj-error "Unnaceptable type ~S for unary numeric promotion" type))))

;;; 5.6.2 Binary Numeric Promotion

;;; When an operator applies binary numeric promotion to a pair of
;;; operands, each of which must denote a value of a numeric type, the
;;; following rules apply, in order, using widening conversion (§5.1.2) to
;;; convert operands as necessary:

;;; If either operand is of type double, the other is converted to double. 
;;; Otherwise, if either operand is of type float, the other is converted to float. 
;;; Otherwise, if either operand is of type long, the other is converted to long. 
;;; Otherwise, both operands are converted to type int. 

;;; Binary numeric promotion is performed on the operands of certain operators:

;;; The multiplicative operators *, / and % (§15.17) 
;;; The addition and subtraction operators for numeric types + and - (§15.18.2) 
;;; The numerical comparison operators <, <=, >, and >= (§15.20.1) 
;;; The numerical equality operators == and != (§15.21.1) 
;;; The integer bitwise operators &, ^, and | (§15.22.1) 
;;; In certain cases, the conditional operator ? : (§15.25)

(defmethod merge-types :around ((t1 type-reference) (t2 type-reference))
  (cond ((cyclic-type-p t1) t2)
	((cyclic-type-p t2) t1)
	(t (call-next-method))))

(defmethod merge-types ((t1 type-reference) (t2 type-reference))
  (cond ((or (void-type-p t1)
	     (void-type-p t2))
	 (void-type))
	((or (and (bignum-type-p t1)
		  (or (int-type-p t2) (long-type-p t2) (big-integer-type-p t2)))
	     (and (bignum-type-p t2)
		  (or (int-type-p t1) (long-type-p t1) (big-integer-type-p t1))))
	 (bignum-type))
	((or (and (big-integer-type-p t1)
		  (or (int-type-p t2) (long-type-p t2)))
	     (and (big-integer-type-p t2)
		  (or (int-type-p t1) (long-type-p t1))))
	 (big-integer-type))
	((or (and (long-wrapper-type-p t1)
		  (or (int-type-p t2) (long-type-p t2)))
	     (and (long-wrapper-type-p t2)
		  (or (int-type-p t1) (long-type-p t1))))
	 (long-wrapper-type))
	((or (and (double-wrapper-type-p t1)
		  (or (float-type-p t2) (double-type-p t2)))
	     (and (double-wrapper-type-p t2)
		  (or (float-type-p t1) (double-type-p t1))))
	 (double-wrapper-type))
	((and (boolean-type-p t1)
	      (class-or-interface-type-reference-p t2))
	 t1)
	((and (boolean-type-p t2)
	      (class-or-interface-type-reference-p t1))
	 t2)
	((or (and (null-type-p t1) (not (class-or-interface-type-reference-p t2)))
	     (and (null-type-p t2) (not (class-or-interface-type-reference-p t1)))
	     (and (class-or-interface-type-reference-p t1) (not (class-or-interface-type-reference-p t2)))
	     (and (class-or-interface-type-reference-p t2) (not (class-or-interface-type-reference-p t1))))
	 (linj-error "Can't promote types ~S and ~S" t1 t2))
	((and (boolean-type-p t1)
	      (boolean-type-p t2))
	 (boolean-type))
	((or (boolean-type-p t1)
	     (boolean-type-p t2))
	 (linj-error "Can't promote types ~S and ~S" t1 t2))
	((or (byte-type-p t1) (short-type-p t1) (char-type-p t1))
	 (merge-types (int-type) t2))
	((or (byte-type-p t2) (short-type-p t2) (char-type-p t2))
	 (merge-types t1 (int-type)))
	(t 
	 (find-if #'(lambda (type)
		      (or (equal-type-p t1 type)
			  (equal-type-p t2 type)))
		  *primitive-types-order*))))

(defun most-generic-type (types)
  (if (endp types)
    (object-type)
    (reduce #'merge-types types)))

(defun always-boolean (&rest types)
  (declare (ignore types))
  (boolean-type))

(defun always-string (&rest types)
  (declare (ignore types))
  (string-type))

;;Base class

(def-category operator-expression (expression)
  ((name :accessor operator-expression-name)))

;;;To keep all operators
(defparameter *operators* (make-hash-table))

(defstruct operator
  name
  associative-p
  unparse
  return-type)

(defmacro def-operator (type name return-type &key (associative-p nil) (unparse (princ-to-string name)))
  `(push (make-operator :name ',name 
			:associative-p ,associative-p
			:unparse ,unparse
			:return-type #',return-type)
	 (gethash ',type *operators* (list))))

(defun operator-name-p (type name)
  (member name (gethash type *operators*) :key #'operator-name))

(defun get-operator (type oper)
  (find oper (gethash type *operators*) :key #'operator-name))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;Unary operators

(defun unary-operator-name-p (oper)
  (operator-name-p :unary oper))

(def-syntax unary-operator-expression (operator-expression)
  ((?is ?name unary-operator-name-p) ?arg/expression))

(defmethod get-type ((e unary-operator-expression))
  (let ((function 
	 (operator-return-type
	  (get-operator :unary
			(operator-expression-name e)))))
    (funcall function (get-principal-type (unary-operator-expression-arg e)))))

(def-unparse unary-operator-expression (e)
  (let ((unparse (operator-unparse (get-operator :unary (unary-operator-expression-name e))))
	(arg (principal-value (unary-operator-expression-arg e))))
    (if (functionp unparse)
      (funcall unparse arg)
      (format t (if *print-out-parenthesis* "(~A ~/ppexp/)" "~A ~/ppexp/")
	      unparse
	      arg))))

;;The unary operators

(def-operator :unary lognot unary-numeric-promotion :unparse "~")
(def-operator :unary not    always-boolean
	      :unparse #'(lambda (arg)
			   (if *translate-reference-type-to-boolean*
			     (let ((type (get-principal-type arg)))
			       (if (boolean-type-p type)
				 (format t (if *print-out-parenthesis* "(! ~/ppexp/)" "! ~/ppexp/")
					 arg)
				 (format t (if *print-out-parenthesis* "(~:/ppexp/)" "~:/ppexp/")
					 (cond ((cons-type-p type)
						(with-parent ((ast-node-parent arg))
						  (parse `(endp ,arg) 'expression)))
					       ((class-or-interface-type-reference-p type)
						(with-parent ((ast-node-parent arg))
						  (parse `(= ,arg null) 'expression)))
					       (t
						(error "Can't use expression ~A in a context where a boolean is expected" arg))))))
			     (format t 
				     (if *print-out-parenthesis* "(! ~/ppexp/)" "! ~/ppexp/")
				     arg))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;Binary operators

(defun binary-operator-name-p (oper)
  (operator-name-p :binary oper))

(def-syntax binary-operator-expression (operator-expression)
  ((?is ?name binary-operator-name-p) ?arg1/expression ?arg2/expression))

(defmethod get-type ((e binary-operator-expression))
  (let ((function 
	 (operator-return-type
	  (get-operator :binary
			(operator-expression-name e)))))
    (funcall function 
	     (get-principal-type (binary-operator-expression-arg1 e))
	     (get-principal-type (binary-operator-expression-arg2 e)))))


(def-unparse binary-operator-expression (e)
  (let ((arg1 (principal-value (binary-operator-expression-arg1 e)))
	(arg2 (principal-value (binary-operator-expression-arg2 e)))
	(operator (binary-operator-expression-name e)))
    (let ((unparse (operator-unparse (get-operator :binary operator))))
      (if (functionp unparse)
	(funcall unparse arg1 arg2)
	(format t (if *print-out-parenthesis*
		    "(~@<~/ppexp/ ~A ~_~/ppexp/)~:>"
		    "~@<~/ppexp/ ~A ~_~/ppexp/~:>")
		;;	    (if *print-out-parenthesis* "(~/ppexp/ ~A ~/ppexp/)" "~/ppexp/ ~A ~/ppexp/")
		arg1
		unparse
		arg2)))))

;;A few binary
(def-operator :binary eq always-boolean :unparse "==")
(def-operator :binary neq always-boolean :unparse "!=")

(defparameter *check-overflow-shift* t)

(def-operator :binary ash
  (lambda (t1 t2)
    (declare (ignore t2))
    (unary-numeric-promotion t1))
  :unparse 
  #'(lambda (arg1 arg2)
      (flet ((out (oper arg2)
	       (format t (if *print-out-parenthesis*
			     "(~@<~/ppexp/ ~A ~_~/ppexp/)~:>"
			     "~@<~/ppexp/ ~A ~_~/ppexp/~:>")
		       arg1
		       oper
		       arg2)))
	(if (literal-p arg2) 
	    (let ((val (literal-value arg2))
		  (type1 (unary-numeric-promotion (get-type arg1))))
	      (cond ((int-type-p type1)
		     (unless (or (< -32 val 32) (not *check-overflow-shift*))
		       (linj-error "Shifting the int ~A more than +/- 31 positions seems incorrect (current ~A)." arg1 arg2)))
		    ((long-type-p type1)
		     (unless (or (< -64 val 64) (not *check-overflow-shift*))
		       (linj-error "Shifting the long ~A more than +/- 63 positions seems incorrect (current ~A)" arg1 arg2))))
	      (if (< val 0)
		  (out ">>" (make-literal (- val)))
		  (out "<<" arg2)))
	    (out "<<" arg2)))))

;;(def-operator :binary 'compute	     ash    :unparse ">>")
;;We also need these:

(def-operator :binary << ;;left-ash
  (lambda (t1 t2)
    (declare (ignore t2))
    (unary-numeric-promotion t1)))

(def-operator :binary >> ;;right-ash
  (lambda (t1 t2)
    (declare (ignore t2))
    (unary-numeric-promotion t1)))

(def-operator :binary >>> ;;right-right-ash
  (lambda (t1 t2)
    (declare (ignore t2))
    (unary-numeric-promotion t1)))

;;;These are n-ary
;;(def-operator :binary logior merge-types :unparse "|")
;;(def-operator :binary logand merge-types :unparse "&")
;;(def-operator :binary logxor merge-types :unparse "^")

(def-operator :binary =  always-boolean :unparse "==")
(def-operator :binary <  always-boolean	:unparse "<")
(def-operator :binary >  always-boolean	:unparse ">")
(def-operator :binary <= always-boolean	:unparse "<=")
(def-operator :binary >= always-boolean	:unparse ">=")
(def-operator :binary /= always-boolean :unparse "!=")

;;Some common uses:
(defmacro def-ordered-predicate (oper)
  `(def-macro-transform expression (,oper ?x ?y ?z . ?w)
     (let ((wrongs (remove-if #'atom (list* ?x ?y ?z ?w))))
       (if wrongs
	 (error "Can't expand (~S ...) with arguments ~S that are not literals or variables" ',oper wrongs)
	 (labels ((repeat (l)
			  (cons `(,',oper ,(first l) ,(second l))
				(if (endp (rest (rest l)))
				  (list)
				  (repeat (rest l))))))
	   `(and ,@(repeat (list* ?x ?y ?z ?w))))))))

(defmacro def-unordered-predicate (oper)
  `(def-macro-transform expression (,oper ?x ?y ?z . ?w)
     (let ((wrongs (remove-if #'atom (list* ?x ?y ?z ?w))))
       (if wrongs
	 (error "Can't expand (~S ...) with arguments ~S that are not literals or variables" ',oper wrongs)
	 (labels ((repeat (l)
		   (if (endp (rest (rest l)))
		     (list `(,',oper ,(first l) ,(second l)))
		     (nconc (mapcar #'(lambda (elem)
					`(,',oper ,(first l) ,elem))
				    (rest l))
			    (repeat (rest l))))))
	   `(and ,@(repeat (list* ?x ?y ?z ?w))))))))

(def-ordered-predicate <)
(def-ordered-predicate >)
(def-ordered-predicate <=)
(def-ordered-predicate >=)
(def-ordered-predicate =)
(def-unordered-predicate /=)

;;For the single argument case:
(def-transform expression (< ?ignore) t)
(def-transform expression (> ?ignore) t)
(def-transform expression (<= ?ignore) t)
(def-transform expression (>= ?ignore) t)
(def-transform expression (= ?ignore) t)
(def-transform expression (/= ?ignore) t)

;;Between mod and rem, rem is the most similar to %
(def-operator :binary rem    merge-types    :unparse "%")

;;N-Ary operators

(defun n-ary-operator-name-p (oper)
  (operator-name-p :n-ary oper))

(def-syntax n-ary-operator-expression (operator-expression)
  ((?is ?name n-ary-operator-name-p) . ?arguments/argument-list))

(defmethod get-type ((e n-ary-operator-expression))
  (let ((function
	 (operator-return-type
	  (get-operator :n-ary
			(operator-expression-name e)))))
    (funcall function
	     (mapcar #'get-principal-type (argument-list-elements (n-ary-operator-expression-arguments e))))))

(defun associative-operator-format-string (operator)
  (format nil
	  (if *print-out-parenthesis*
	    "(~~@<~~{~~/ppexp/~~^ ~A ~~_~~})~~:>"
	    "~~@<~~{~~/ppexp/~~^ ~A ~~_~~}~~:>")
	  operator))

(def-unparse n-ary-operator-expression (e)
  (let ((operator (get-operator :n-ary (n-ary-operator-expression-name e))))
    (let ((args (argument-list-elements (n-ary-operator-expression-arguments e)))
	  (unparse (operator-unparse operator)))
;;      (assert (and (not (null args)) (not (null (rest args)))))
      ;;To deal with multiple-returned-values
      (setf args (mapcar #'principal-value args))
      (when (and (eq (n-ary-operator-expression-name e) '/)
		 (endp (rest args)))
	(push (parse 1 'literal) args))
      ;;We need to freeze typecasts so that they don't disappear due to super-type-p relationships
;;       (dolist (arg args)
;; 	(when (cast-expression-p arg)
;; 	  (setf (force-cast-p arg) t)))
      (if (functionp unparse)
	(funcall unparse args)
	(cond ((and (not (endp args)) (endp (rest args))) ;;unary version
	       (format t (if *print-out-parenthesis* "(~A ~/ppexp/)" "~A ~/ppexp/")
		       unparse
		       (first args)))
	      ((operator-associative-p operator)
	       (format t (associative-operator-format-string unparse) args))
	      (t
	       (format t (if *print-out-parenthesis*
			   "(~:/ppmultiargs/)"
			   "~:/ppmultiargs/")
		       (cons unparse args))))))))

(defun unary-or-n-ary-operator-type (types)
  (if (and (not (endp types)) (endp (rest types))) ;unary version
    (unary-numeric-promotion (first types))
    (most-generic-type types)))

(def-operator :n-ary +      unary-or-n-ary-operator-type :associative-p t) ;;Note: in Linj + doesn't concatenate strings
(def-operator :n-ary -      unary-or-n-ary-operator-type)
(def-operator :n-ary *      most-generic-type :associative-p t)
(def-operator :n-ary /      most-generic-type)

(def-operator :n-ary logior most-generic-type :unparse "|" :associative-p t)
(def-operator :n-ary logand most-generic-type :unparse "&" :associative-p t)
(def-operator :n-ary logxor most-generic-type :unparse "^" :associative-p t)

(def-transform expression (logeqv ?n1 ?n2) (lognot (logxor ?n1 ?n2)))
(def-transform expression (lognand ?n1 ?n2) (lognot (logand ?n1 ?n2))) 
(def-transform expression (lognor ?n1 ?n2) (lognot (logior ?n1 ?n2)))
(def-transform expression (logandc1 ?n1 ?n2) (logand (lognot ?n1) ?n2))
(def-transform expression (logandc2 ?n1 ?n2) (logand ?n1 (lognot ?n2)))
(def-transform expression (logorc1 ?n1 ?n2) (logior (lognot ?n1) ?n2))
(def-transform expression (logorc2 ?n1 ?n2) (logior ?n1 (lognot ?n2)))

(def-transform expression (logtest ?n1 ?n2) (not (zerop (logand ?n1 ?n2))))

(def-transform expression (boole boole-clr ?ignore ?ignore) 0)
(def-transform expression (boole boole-set ?ignore ?ignore) 1)
(def-transform expression (boole boole-1 ?n1 ?ignore) ?n1)
(def-transform expression (boole boole-2 ?ignore ?n2) ?n2)
(def-transform expression (boole boole-c1 ?n1 ?ignore) (lognot ?n1))
(def-transform expression (boole boole-c2 ?ignore ?n2) (lognot ?n2))
(def-transform expression (boole boole-and ?n1 ?n2) (logand ?n1 ?n2))
(def-transform expression (boole boole-ior ?n1 ?n2) (logior ?n1 ?n2))
(def-transform expression (boole boole-xor ?n1 ?n2) (logxor ?n1 ?n2))
(def-transform expression (boole boole-eqv ?n1 ?n2) (logeqv ?n1 ?n2))
(def-transform expression (boole boole-nand ?n1 ?n2) (lognand ?n1 ?n2))
(def-transform expression (boole boole-nor ?n1 ?n2) (lognor ?n1 ?n2))
(def-transform expression (boole boole-andc1 ?n1 ?n2) (logandc1 ?n1 ?n2))
(def-transform expression (boole boole-andc2 ?n1 ?n2) (logandc2 ?n1 ?n2))
(def-transform expression (boole boole-orc1 ?n1 ?n2) (logorc1 ?n1 ?n2))
(def-transform expression (boole boole-orc2 ?n1 ?n2) (logorc2 ?n1 ?n2))


;;And & or need to adapt to non-boolean args
(def-operator :n-ary or  always-boolean
  :unparse #'(lambda (args)
	       (let ((args (mapcar #'from-reference-type-to-boolean args)))
		 (format t (associative-operator-format-string "||") args))))

(def-operator :n-ary and always-boolean
  :unparse #'(lambda (args)
	       (let ((args (mapcar #'from-reference-type-to-boolean args)))
		 (format t (associative-operator-format-string "&&") args))))


;;To concatenate strings (and other types), use the (old)Emacs-like concat
(def-operator :n-ary concat always-string
  :unparse #'(lambda (args)
	       (let ((args (if (string-type-p (get-type (first args)))
			     args
			     (cons (make-instance 'literal :value "") args))))
		 (if (endp (rest args))
		   (unparse-object (first args) *standard-output*)
		   (format t (associative-operator-format-string "+") args)))))

;;Given the fact that concat is always of type string, we can simplify concat combinations

(def-transform n-ary-operator-expression (concat)
  "")

(def-macro-transform n-ary-operator-expression (concat . ?args)
  (when (some #'(lambda (arg)
		  (let-pattern (((concat ?ignore . ?ignore) arg)) t))
	      ?args)
    `(concat ,@(mapcan #'(lambda (arg)
			   (or (let-pattern (((concat . ?args) arg)) (copy-list ?args))
			       (list arg)))
		       ?args))))

;;;;;;;;;;;;;;;;;

;;typep is applicable only to class-or-interface-type-reference

(def-syntax typep-expression (expression)
  (typep ?expression/expression '?type/type-reference))

(defmethod get-type ((e typep-expression))
  (boolean-type))

(def-unparse typep-expression (e)
  (unless (class-or-interface-type-reference-p (typep-expression-type e))
    (linj-error "In ~S, typep can only test non-primitive types" e))
  (unless (or
	   ;;subclass relationship
	   (super-type-p (get-principal-type (typep-expression-expression e))
			 (typep-expression-type e))
	   ;;submixin relationship
	   (and (mixin-declaration-p (get-type-declaration (typep-expression-type e)))
		(super-type-p (typep-expression-type e)
			      (get-principal-type (typep-expression-expression e)))))
    (linj-error "In ~S, typep can only test for a subtype of the type of the expression ~S (which is ~S)"
		e (typep-expression-expression e) (get-principal-type (typep-expression-expression e))))
  (format t (if *print-out-parenthesis* "(~/ppexp/ ~A ~/ppexp/)" "~/ppexp/ ~A ~/ppexp/")
	  (typep-expression-expression e)
	  'instanceof
	  (typep-expression-type e)))

;;;;;;;;;;;;;;;;;
;;Arrays

(def-syntax array-expression (inferred-type-node expression)
  (array ?element-type/type-reference ?dimensions/argument-list ?contents/argument-list))

(defmethod infer-type ((e array-expression))
  (with-parent (e)
    (if (unknown-type-reference-p (array-expression-element-type e))
      (let ((subtype
	     (common-type-or-object-type-for-args
	      (argument-list-elements
	       (array-expression-contents e)))))
	(setf (array-expression-element-type e) (with-parent (e) subtype))
	(make-instance 'array-type-reference
		       :subtype subtype
		       :original-form `(array-type ,(ast-node-form subtype))))
      (reduce #'(lambda (dim r)
		  (declare (ignore dim))
		  (make-instance 'array-type-reference
				 :subtype r
				 :original-form `(array-type ,(ast-node-form r))))
	      (argument-list-elements (array-expression-dimensions e))
	      :initial-value (array-expression-element-type e)
	      :from-end t))))

(defun common-type-or-object-type-for-args (args)
  (copy-type (common-type-or-object-type (mapcar #'get-type args))))

(defun common-type-or-object-type (types)
  (if (or (every #'primitive-type-reference-p types)
	  (every #'class-or-interface-type-reference-p types))
    (most-generic-type-for-array types)
    (object-type)))

(defun most-generic-type-for-array (types)
  (if (endp types)
    (object-type)
    (reduce #'merge-types-for-array types)))

(defmethod merge-types-for-array ((t1 type-reference) (t2 type-reference))
  (if (equal-type-p t1 t2)
    t1
    (merge-types t1 t2)))

;;initial-contents is composed of a nested structure of sequences. The
;;numbers of levels in the structure must equal the rank of
;;array. Each leaf of the nested structure must be of the type given
;;by element-type. If array is zero-dimensional, then initial-contents
;;specifies the single element. Otherwise, initial-contents must be a
;;sequence whose length is equal to the first dimension; each element
;;must be a nested structure for an array whose dimensions are the
;;remaining dimensions, and so on.

;;This was done after Markus Ziegler bug report.

(defun process-initial-contents (dims contents)
  (if (endp dims)
    (if (and (consp contents) (eq (first contents) 'quote))
      (if (numberp (second contents)) (second contents) contents)
      contents)
    (let ((args
	   (cond ((eq (first contents) 'quote)
		  (mapcar #'(lambda (e) `',e) (second contents)))
		 ((eq (first contents) 'list)
		  (rest contents))
		 (t
		  (error "Can't deal with ~S" contents)))))
      (assert (listp args) ()
	      "Missing initialization elements for make-array")
      (assert (= (first dims) (length args)) ()
	      "Array with :initial-contents ~A that doesn't match the length ~A of the array" contents dims)
      `(vector ,@(mapcar #'(lambda (e) (process-initial-contents (rest dims) e)) args)))))

(defun process-initial-element (dims element)
  (if (endp dims)
    element
    `(vector ,@(loop for i below (first dims)
		     collect (process-initial-element (rest dims) element)))))

(def-macro-transform expression (make-array ?dimensions . ?options)
    ;;We are looking for two types of dimensions '(...) or (list ...)
  (flet ((get-elems (expr)
	   (cond ((not (consp expr))
		  ;; (error "Array dimensions must be expressions of the form '(...) or (list ...), not ~A" expr)
		  (list expr))
		 ((eq (first expr) 'quote)
		  (if (listp (first (rest expr)))
		    (mapcar #'(lambda (e) (if (numberp e) e `',e))
			    (first (rest expr)))
		    (first (rest expr))))
		 ((eq (first expr) 'list) 
		  (rest expr))
		 (t (error "Can't deal with ~S" expr)))))
    (let ((type (getf ?options :element-type))
	  (dims (if (integerp ?dimensions)
		  (list ?dimensions)
		  (get-elems ?dimensions)))
	  (initial-contents (getf ?options :initial-contents))
	  (initial-element (getf ?options :initial-element)))
      (let ((elems (cond ((and initial-contents initial-element)
			  (error "Can't use :initial-contents and :initial-element simultaneously"))
			 (initial-contents
			  (rest (process-initial-contents dims initial-contents)))
			 (initial-element
			  (assert (atom initial-element) ()
				  "The :initial-element ~A must be an atomic expression" initial-element)
			  (assert (every #'integerp dims) ()
				  "When an :initial-element is provided, the dimensions ~A must be compile-time constants" dims)
			  (rest (process-initial-element dims initial-element)))
			 (t (list)))))
	;;this only deals with initialization of the first dimension.
	`(array ,(cond (type (second type)) ;;type must be quoted
		       (elems :infer-it)
		       (t (object-type-description)))
		,dims
		,elems)))))

(defmethod visit-current ((e array-expression) (visitor cast-and-wrap))
  (let ((type (array-type-reference-subtype (get-type e))))
    (setf (argument-list-elements (array-expression-contents e))
	  (mapcar #'(lambda (arg)
		      (convert-to-type arg type :force-cast nil))
		  (argument-list-elements (array-expression-contents e))))))

(def-unparse array-expression (e)
  (let ((dimensions (argument-list-elements (array-expression-dimensions e)))
	(contents (argument-list-elements (array-expression-contents e))))
    (multiple-value-bind (primitive-type array-dims)
	(labels ((get-dims (type &optional (count 0))
		   (if (array-type-reference-p type)
		     (get-dims (array-type-reference-subtype type) (1+ count))
		     (values type count))))
	  (get-dims (get-type e)))
      (let ((rest-dimensions (make-list (- array-dims (length dimensions)))))
	(if (endp contents)
	  (format t "new ~/pp/~{[~:/ppexp/]~}~{[~*]~}"
		  primitive-type
		  dimensions
		  rest-dimensions)
	  (format t "~@<new ~/pp/~{[~*]~}~{[~*]~} { ~4I~_~@<~{~:@/ppexp/~^, ~_~}~:> }~I~:>"
		  primitive-type
		  (argument-list-elements (array-expression-dimensions e))
		  rest-dimensions
		  contents))))))

(def-syntax array-reference (expression)
  (aref ?expression/expression . ?indexes/argument-list))

(def-unparse array-reference (e)
  (format t "~/pp/~{[~:/ppexp/]~}" 
	  (array-reference-expression e)
	  (mapcar #'(lambda (arg)
		      (convert-to-type arg (int-type)))
		  (argument-list-elements (array-reference-indexes e)))))

(defmethod array-or-values-type-reference-subtype ((e array-type-reference) dim)
  (declare (ignore dim))
  (array-type-reference-subtype e))

(defmethod get-type ((e array-reference))
  (reduce #'(lambda (dim r)
	      (array-or-values-type-reference-subtype r dim))
	  (argument-list-elements (array-reference-indexes e))
	  :initial-value (get-type (array-reference-expression e))
	  :from-end t))

;;An important syntactic element is the vector initialization.  Although
;;I'm still undecided regarding the use of vectors, its initialization can
;;be frozen right now:

(def-syntax infer-vector-initialization (inferred-type-node expression)
  (vector . ?arguments/argument-list))

(def-syntax literal-vector (infer-vector-initialization)
  (?is ?literal vectorp)
  :constructor make-literal-vector)

(defun make-literal-vector (category &key original-form literal)
  (declare (ignore category))
  (make-instance 'infer-vector-initialization
		 :original-form original-form
		 :arguments (parse (mapcar #'(lambda (elem) `(quote ,elem))
					   (coerce literal 'list))
				   'argument-list)))

(defmethod infer-type ((e infer-vector-initialization))
  (let ((subtype
	 (common-type-or-object-type-for-args
	  (argument-list-elements
	   (infer-vector-initialization-arguments e)))))
    (make-instance 'array-type-reference
		   :subtype subtype
		   :original-form `(array-type ,(ast-node-form subtype)))))

(defmethod visit-current ((e infer-vector-initialization) (visitor cast-and-wrap))
  (let ((type (array-type-reference-subtype (get-type e))))
    (setf (argument-list-elements (infer-vector-initialization-arguments e))
	  (mapcar #'(lambda (arg)
		      (convert-to-type arg type :force-cast nil))
		  (argument-list-elements (infer-vector-initialization-arguments e))))))

(def-unparse infer-vector-initialization (e)
  (let ((type (array-type-reference-subtype (get-type e))))
    (let ((args (argument-list-elements (infer-vector-initialization-arguments e))))
      (if (not *print-out-init-braces*)
	(format t "~@<{ ~@<~{~:/ppexp/~^, ~_~}~:> }~:>" args)
	(unparse-vector-inits type args)))))

(defun unparse-vector-inits (type args)
  (format t "~@<new ~/pp/[] { ~4I~_~@<~{~:@/ppexp/~^, ~_~}~:> }~I~:>" type args))

;;;;;;;;;;;;;;;;;
;;Casts

(def-syntax cast-expression (explicit-type-node expression)
  (the ?type/type-reference ?expression/expression)
  :slots ((force-cast-p :initarg :force-cast-p :initform nil :accessor force-cast-p)))

(defmethod visit-current ((e cast-expression) (visitor cast-and-wrap))
  (setf (cast-expression-expression e)
	(convert-to-type (cast-expression-expression e) (cast-expression-type e) :force-cast nil)))

(def-unparse cast-expression (e)
  (if (equal-type-p (cast-expression-type e)
		    (get-type (cast-expression-expression e)))
    (format t "~:[~:/ppexp/~;~/ppexp/~]"
	    *print-out-parenthesis*
	    (cast-expression-expression e))
    (format t "~:[(~/pp/)~/ppexp/~;((~/pp/)~/ppexp/)~]"
	      *print-out-parenthesis*
	      (cast-expression-type e)
	      (cast-expression-expression e))))

(def-syntax forced-cast-expression (cast-expression)
  (force-the ?type/type-reference ?expression/expression)
  :slots ((force-cast-p :initform t)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;And for type promises:
;;HACK. This must be merged with the above!!!!

(def-syntax assert-type-expression (explicit-type-node expression)
  (real-the ?type/type-reference ?expression/expression))

(def-unparse assert-type-expression (e)
  (if (equal-type-p (assert-type-expression-type e)
		    (get-type (assert-type-expression-expression e)))
    (format t "~:[~:/ppexp/~;~/ppexp/~]"
	    *print-out-parenthesis*
	    (assert-type-expression-expression e))
    (if (super-type-p (get-type (assert-type-expression-expression e))
		      (assert-type-expression-type e))
      (format t "~:[(~/pp/)~/ppexp/~;((~/pp/)~/ppexp/)~]"
	      *print-out-parenthesis*
	      (assert-type-expression-type e)
	      (assert-type-expression-expression e))
      (unparse-object
       (with-parent ((ast-node-parent e))
	(convert-to-type (assert-type-expression-expression e) (assert-type-expression-type e) :force-cast nil))
       *standard-output*))))

;; (def-unparse assert-type-expression (e)
;;   (format t "~:[~:/ppexp/~;~/ppexp/~]"
;; 	  *print-out-parenthesis*
;; 	  (assert-type-expression-expression e)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;outer references

(def-syntax outer-expression (explicit-type-node expression)
  (this ?type/type-reference))

(def-unparse outer-expression (e)
  (format t "~/pp/.this" (outer-expression-type e)))

;;super outer references

(def-syntax super-outer-expression (explicit-type-node expression)
  (super ?type/type-reference))

(def-unparse super-outer-expression (e)
  (format t "~/pp/.super" (super-outer-expression-type e)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass collect-type-info ()
  ((declaration :initarg :declaration :reader collect-type-info-declaration)
   (found :initform (list) :accessor collect-type-info-found)
   (escape :initarg :escape :reader collect-type-info-escape)))

(defun collect-all-type-info-for-references-to (meth variable-declaration)
  (block escape
    (let ((collect (make-instance 'collect-type-info
				  :declaration variable-declaration
				  :escape #'(lambda () (return-from escape (list))))))
      (visit meth collect)
      (collect-type-info-found collect))))

;;If there are typep-expressions in the body, abort the computation
;;because the type information collected depends on the predicate.
(defmethod visit :before ((typep typep-expression) (collect collect-type-info))
  (funcall (collect-type-info-escape collect)))

(defmethod visit :before ((assert-type assert-type-expression) (collect collect-type-info))
  (when (and (reference-p (assert-type-expression-expression assert-type))
	     (eq (find-declaration (assert-type-expression-expression assert-type))
		 (collect-type-info-declaration collect)))
    (push (assert-type-expression-type assert-type)
	  (collect-type-info-found collect))))

;;Setf expressions can also help type inference
(defmethod visit :before ((assign setf-expression) (collect collect-type-info))
  (when (and (reference-p (setf-expression-r-value assign))
	     (eq (find-declaration (setf-expression-r-value assign))
		 (collect-type-info-declaration collect)))
    (push (get-type (setf-expression-l-value assign))
	  (collect-type-info-found collect))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;Parameters

(def-syntax parameter (linj-node)
  ?expression)

(def-unparse parameter (e)
  (error "This can't appear in a Java file"))

(def-list-syntax parameter-list (linj-list-node) parameter
  :constructor make-parameter-list)

(defun make-parameter-list (category &key original-form elements)
  (declare (ignore category))
  (make-instance 'parameter-list
		 :original-form original-form
		 :elements (process-lambda-list elements)))

(defun process-lambda-list (original-arglist)
  (labels ((process-args (arglist type)
	     (if (endp arglist)
	       (list)
	       (let ((param (parameter-expression (first arglist))))
		 (case param
		   (&optional
		    (if (eq type :required)
		      (process-args (rest arglist) :optional)
		      (error "Misplaced ~A in lambda-list ~A" param original-arglist)))
		   (&rest
		    (if (or (eq type :required) (eq type :optional))
		      (process-args (rest arglist) :rest)
		      (error "Misplaced &rest in lambda-list ~A" original-arglist)))
		   (&key
		    (process-args (rest arglist) :keyword))
		   (&aux
		    (process-args (rest arglist) :auxiliary))
		   (t
		    (if (and (eq type :required)
			     (or (eq param 'this)
				 (and (consp param) (consp (cdr param)) (symbolp (cadr param))))) ;;found specializer
		      (let ((this (parse (if (eq param 'this)
					   param
					   `(,(first param) (the ,(second param))))
					 'variable-declaration)))
			(setf (get-option :specialized this) t)
			(setf (get-option :parameter-type this) type)
			(cons this (process-args (rest arglist) type)))
		      (multiple-value-bind (var-decl supplied-p)
			  (if (and (consp param) (consp (rest param)) (rest (rest param)))
			    (let ((sup (nth 2 param)))
			      (if (symbolp sup)
				(values (butlast param) sup)
				(error "Lambda parameter ~A in lambda-list ~A is not a symbol" sup original-arglist)))
			    (values param nil))
			(when (and supplied-p (or (eq type :required) (eq type :rest)))
			  (error "~:(~A~) parameter ~A in lambda-list ~A can't have supplied-p parameter" type param original-arglist))
			(let ((var (parse var-decl 'variable-declaration)))
			  (setf (get-option :parameter-type var) type)
			  (when (eq type :rest)
			    (unless (endp (rest arglist))
			      (error "Found garbage ~A in lambda-list ~A" (rest arglist) original-arglist))
			    (if (unknown-type-reference-p (inferred-type-node-type var))
			      (setf (inferred-type-node-type var) (with-parent (var) (cons-type))
				    (variable-declaration-initializer var) (with-parent (var) (parse ''() 'expression)))
			      (assert (cons-type-p (inferred-type-node-type var)))))
			  `(,var
			    ,@(if supplied-p
				(let ((new-param (parse `(,supplied-p (the boolean)) 'variable-declaration)))
				  (setf (supplied-p new-param) t)
				  (list new-param))
				(list))
			    ,@(process-args (rest arglist) type)))))))))))
    (process-args original-arglist :required)))

(def-unparse parameter-list (e)
  (format t "(~@<~{~:/ppinit/~^, ~:_~}~:>)"
	  (parameter-list-elements e)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;Classes are made of type-body-declarations

(def-category type-body-declaration (declaration-options top-level-form)
  ())

;;This ugly syntax is just to make the parser happy

(def-syntax method-declaration (inferred-type-node type-body-declaration)
  (defmethod-0 ?type/type-reference ?name/linj-name ?parameters/parameter-list
	       ?declared-throws/type-reference-list
	       ?options . ?body/statement-list)
  :constructor make-method-declaration
  :slots ((receiver-parameter :reader receiver-parameter :initarg :receiver-parameter)
	  (receiver-position :reader receiver-position :initarg :receiver-position)
	  (simple-parameter-initializations-p :reader simple-parameter-initializations-p :initarg :simple-parameter-initializations-p)
	  (computed-throws :accessor method-declaration-computed-throws)))

;;We also want to visit the computed throws (e.g., to infer imports)
(defmethod visit-descendents :after ((meth method-declaration) (visitor t))
  (when (slot-boundp meth 'computed-throws)
    (visit (slot-value meth 'computed-throws) visitor)))

(defun make-method-declaration (category &key original-form type name parameters declared-throws options body)
  (declare (ignore category))
  (labels ((get-this (params &optional (pos 0) (prevs (list)))
	     (cond ((endp params)
		    (values nil nil (nreverse prevs)))
		   ((get-option :specialized (first params))
		    (values (first params) pos (nreconc prevs (rest params))))
		   (t
		    (get-this (rest params) (1+ pos) (cons (first params) prevs))))))
    (multiple-value-bind (param pos new-parameters)
	(get-this (parameter-list-elements parameters))
      (when param
	(setf (parameter-list-elements parameters) new-parameters))
      (multiple-value-bind (real-params aux-params)
	  (break-list-if #'(lambda (param) (eq (get-option :parameter-type param) :auxiliary)) new-parameters)
	(when aux-params
	  (setf (parameter-list-elements parameters) real-params))
	(make-instance 'method-declaration
		       :receiver-parameter (or param (parse 'this 'variable-declaration))
		       :receiver-position (or pos 0)
		       :simple-parameter-initializations-p (every #'(lambda (param)
								      (or (null (variable-declaration-initializer param))
									  (typep (variable-declaration-initializer param) 'literal)))
								  new-parameters)
		       :original-form original-form
		       :type type
		       :name name
		       :parameters parameters
		       :declared-throws declared-throws
		       :options `(:receiver-position ,pos ,@options)
		       :body (if aux-params (parse `((let* ,aux-params . ,body)) 'statement-list) body))))))

(defun method-declaration-specialized-to (meth)
  (and (uninitialized-variable-declaration-p (receiver-parameter meth))
       (uninitialized-variable-declaration-type (receiver-parameter meth))))

(defun computed-method-declaration-throws-p (meth)
  (slot-boundp meth 'computed-throws))

;;To consider the specialized parameter as an alias to 'this'

(defun alias-this-reference-p (reference)
  (and (reference-p reference)
       (let ((type-decl (containing-type-declaration reference)))
	 (and type-decl
	      (eq (find-declaration reference) type-decl)))))

;;To infer type information in methods, either we are specializing an
;;inherited method or we are defining a new one:

(defparameter *check-super-method-type* t)

(defmethod infer-type ((e method-declaration))
  (or (and *check-super-method-type* (super-method-type e))
      (infer-type-from-exit-points e)))

(defmethod super-method-type ((method method-declaration))
  (let ((class (containing-type-declaration method))
	(name (method-declaration-name method)))
    (let ((super-methods
	   (remove-if-not #'(lambda (meth)
			      (and (endp (get-option :qualifiers meth))
				   (same-signature-p meth method)))
			  (find-methods-named name class))))
      (if (null super-methods)
	nil
	(let ((super-method (first super-methods)))
	  (cond ((and (class-method-p method) (not (class-method-p super-method)))
		 (error "The method ~A~% cannot override the function ~A" method super-method))
		((and (not (class-method-p method)) (class-method-p super-method))
		 (error "The function ~A~% cannot override the method ~A" super-method method))
		(t
		 (get-type super-method))))))))

(defmethod same-signature-p ((e1 method-declaration) (e2 method-declaration))
  (and (eq (method-declaration-name e1)
	   (method-declaration-name e2))
       (let ((p1 (parameter-list-elements (method-declaration-parameters e1)))
	     (p2 (parameter-list-elements (method-declaration-parameters e2))))
	 (and (= (length p1) (length p2))
	      (every #'(lambda (par1 par2)
			 (equal-type-p (get-type par1) (get-type par2)))
		     p1 p2)))))

;;We can infer the method's return type from exit points

(defmethod infer-type-from-exit-points ((e method-declaration))
  (let ((exits (list))
	(cycle-p nil))
    (apply-to-method-exit-points
     e
     #'(lambda (exit)
	 (if (in-type-inference-p exit)
	   (setf cycle-p t)
	   (push exit exits))))
    (most-generic-type-for-exit-points (reverse exits) cycle-p)))

(defun most-generic-type-for-exit-points (exits cycle-p)
  (if (endp exits)
    (if cycle-p
      (cyclic-type)
      (void-type))
    (most-generic-type (mapcar #'get-type exits))))

(defmethod merge-types ((t1 class-or-interface-type-reference)
			(t2 class-or-interface-type-reference))
  ;;Least common superclass
  (cond ((null-type-p t1)
	 t2)
	((null-type-p t2)
	 t1)
	(t
	 (common-super-type t1 t2))))

(defmethod merge-types ((t1 array-type-reference)
			(t2 array-type-reference))
  (with-parent ((ast-node-parent t1))
    (make-instance 'array-type-reference
      :subtype (merge-types (array-type-reference-subtype t1)
			    (array-type-reference-subtype t2))
      :original-form 'automagically-generated-by-merge-types-for-arrays)))

;;But we, humans, prefer a different syntax, as follows

(defun extract-options-body (body)
  (labels ((options-body (body)
	     (cond ((not (listp body))
		    (list body))
		   ((endp body) 
		    (list body))
		   ((keywordp (first body))
		    (cons (first body) 
			  (cons (if (and (eq (first body) :throws)
					 (atom (second body))
					 (not (null (second body))))
				  (list (second body))
				  (second body))
				(options-body (rest (rest body))))))
		   ((and (stringp (first body)) (not (null (rest body))))
		    (cons :documentation 
			  (cons (first body)
				(list (rest body)))))
		   (t
		    (list body)))))
    (let ((result (options-body body)))
      (let ((options (butlast result))
	    (body (first (last result))))
	(let ((throws (getf options :throws))
	      (returns (or (getf options :returns) :infer-it)))
	  (remf options :throws)
	  (remf options :returns)
	  (values options
		  body
		  throws
		  returns))))))

(def-macro-transform method-declaration (defmethod ?name . ?body)
  (let ((after-qualifiers (member-if #'listp ?body)))
    (let ((qualifiers (ldiff ?body after-qualifiers))
	  (arglist (first after-qualifiers))
	  (options&body (rest after-qualifiers)))
      (multiple-value-bind (options body throws returns)
	  (extract-options-body options&body)
	(when (or (member :before qualifiers)
		  (member :after qualifiers))
	  (assert (eq returns :infer-it))
	  (setq returns (void-type)))
	`(defmethod-0 ,returns ,?name ,arglist ,throws 
	  (,@options :visibility :public :qualifiers ,qualifiers)
	  . ,body)))))

(defun class-method-p (meth-decl)
  (eq (get-option :allocation meth-decl) :class))

(defmethod find-declaration-in ((ref reference) (e method-declaration))
  (or (find (reference-name ref)
	    (parameter-list-elements (method-declaration-parameters e))
	    :key #'variable-declaration-name)
      (and (eq (reference-name ref) (variable-declaration-name (receiver-parameter e)))
	   (containing-type-declaration e))
      (call-next-method)))

(defmethod containing-method-declaration ((e method-declaration))
  e)

(defun accessor-declaration-p (e)
  (and (method-declaration-p e)
       (member (get-option :category e) '(:reader :writer))))

(defun constructor-declaration-p (e)
  (and (method-declaration-p e)
       (eq (get-option :category e) :initializer)))

(defun abstract-method-declaration-p (e)
  (and (method-declaration-p e)
       (eq (get-option :category e) :abstract)))

(defun write-documentation (e)
  (let ((documentation (get-option :documentation e)))
    (when documentation
      (if (or (string= "/*" documentation :end2 2)
	      (string= "//" documentation :end2 2))
	(format t "~@<~@;~A~:>~:@_" documentation)
	(format t "~@<// ~@;~A~:>~:@_" documentation)))))

(defun write-options (stream e at-p colon-p)
  (declare (ignore at-p colon-p))
  (let ((visibility (get-option :visibility e))
	(allocation (get-option :allocation e))
	(constant (get-option :final e)))
    (format stream "~A~:[~;static ~]~:[~;final ~]~:[~;synchronized ~]~:[~;native ~]~:[~;transient ~]~:[~;volatile ~]~:[~;strictfp ~]~{~A ~}"
	    (case visibility
	      ((:public) "public ") ((:protected) "protected ") ((:private) "private ") (t ""))
	    (or (eq allocation :class) (get-option :static e))
	    constant
	    (get-option :synchronized e)
	    (get-option :native e)
	    (get-option :transient e)
	    (get-option :volatile e)
	    (get-option :strictfp e)
	    (get-option :modifiers e))))

(def-unparse method-declaration (e)
  (write-documentation e)
  (format t "~@<~/write-options/~:[~;abstract ~]~
~:[~*~/pp/ ~/pp/~;~/pp/~2*~]~/pp/~@[ ~2I~:_throws ~{~/pp/~^, ~}~]~:[ ~/ppblk/~;;~]~:>"
	  e
	  (abstract-method-declaration-p e)
	  (constructor-declaration-p e)
	  (if (constructor-declaration-p e) 
	    (type-declaration-name (containing-type-declaration e))
	    nil)
	  (get-type e)
	  (method-declaration-name e)
	  (method-declaration-parameters e)
	  (method-declaration-throws-list e)
	  (abstract-method-declaration-p e)
	  (method-declaration-body e)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;Declaration processing is a nice option for those who really enjoy Common Lisp


;;We only expect to see things of the form 
;;(declare declaration-specifier*) where declaration-specifier is of the form

;;(type typespec variable*) and typespec is one of the Linj types
;;(final variable*)
;;(typespec variable*)
;;(returns typespec)
;;(throws typespec*)
;;(visibility spec) where spec is one of :public :protected :private
;;(category spec) where spec is one of :abstract :reader :writer
;;(modifiers spec*) where spec is one of :public :protected :private :abstract :static :final :synchronized :native :strictfp
;;(trace spec*) where spec is one of :time :args :return (if empty, defaults to :args :return)

(defun process-declare-specifiers (declaration-specifiers)
  (let ((type-decls (list))
	(finals (list))
	(returns nil)
	(throw-decls (list))
	(category nil)
	(visibility nil)
	(modifiers (list))
	(others (list)))
    (flet ((process-type (type vars)
	     (let ((type (translate-cl-type type)))
	       (dolist (var vars)
		 (if (assoc var type-decls)
		   (error "Duplicate declaration for variable ~S" var)
		   (push (cons var type) type-decls))))))
      (dolist (spec declaration-specifiers)
	(cond ((member (first spec) '(optimize ignore trace))
	       (push spec others))
	      ((eq (first spec) 'returns)
	       (if (and returns (not (eq (first spec) returns)))
		 (error "Incompatible duplicate declaration for returned type ~S ~S" returns spec)
		 (setf returns (second spec))))
	      ((eq (first spec) 'visibility)
	       (setf visibility (second spec)))
	      ((eq (first spec) 'throws)
	       (setf throw-decls (union throw-decls (rest spec))))
	      ((eq (first spec) 'category)
	       (setf category (second spec)))
	      ((eq (first spec) 'modifiers)
	       (setf modifiers (append modifiers (rest spec)))
	       (when (member :abstract modifiers)
		 (setf category :abstract)))
	      ((eq (first spec) 'final)
	       (setf finals (append (rest spec) finals)))
	      ((eq (first spec) 'type)
	       (process-type (second spec) (rest (rest spec))))
	      (t
	       (process-type (first spec) (rest spec))))))
    (values type-decls finals returns throw-decls category visibility modifiers others)))

;;Now, regarding the declare form, we will accept it everywhere
;;(and not only on the places allowed in Common Lisp). Our idea
;;is to think of declarations as a kind of void statement that
;;is used in a before parse step to assign types the the enclosed
;;variables.

(def-syntax declare-statement (statement)
  (declare . ?declarations))

(def-unparse declare-statement (e)
  ;;no translation to Java
  (error "Unprocessed declare statement ~A" e))

(defclass process-declares ()
  ())

(defmethod visit :before ((e declare-statement) (v process-declares))
  (multiple-value-bind (decls finals returns throws category visibility modifiers others)
      (process-declare-specifiers (declare-statement-declarations e))
    (dolist (decl decls)
      (let ((var (with-parent ((ast-node-parent e)) (parse (car decl) 'reference)))
	    (type (with-parent ((ast-node-parent e)) (parse (cdr decl) 'type-reference))))
	(let ((decl (strict-find-declaration var)))
	  (if (typep decl 'inferred-type-node)
	    (if (unknown-type-reference-p (inferred-type-node-type decl))
		(setf (inferred-type-node-type decl) type)
	      (if (equal-type-p (inferred-type-node-type decl) type)
		(warn "Duplicate type declaration for ~S" decl)
		(linj-error "Confliting type declarations for ~S (~S ~S)"
		       decl (inferred-type-node-type decl) type)))
	    (linj-error "Can't assert type of variable ~S" var)))))
    (dolist (final finals)
      (let ((var (with-parent ((ast-node-parent e)) (parse final 'reference))))
	(let ((decl (strict-find-declaration var)))
	  (setf (get-option :final decl) t))))
    (when (or returns throws category modifiers visibility others)
      (let ((meth (containing-method-declaration e)))
	(when returns
	  (setf (method-declaration-type meth)
		(with-parent (meth) (parse returns 'type-reference))))
	(dolist (throw throws)
	  (push (with-parent (meth) (parse throw 'type-reference))
		(type-reference-list-elements (method-declaration-declared-throws meth))))
	(when category
	  (setf (get-option :category meth) category))
	(when visibility
	  (setf (get-option :visibility meth) visibility))
	(setf (method-declaration-options meth)
	      (append (mapcan #'(lambda (mod) (list mod t)) modifiers)
		      (method-declaration-options meth)))
	(dolist (other others)
	  (setf (get-option (make-keyword (first other)) meth) other)))))
  ;;After processing, we remove ourselves from our parent
  (setf (statement-list-elements (ast-node-parent e))
	(delete e (statement-list-elements (ast-node-parent e)))))

;;;Trace
(defconstant +traced-name-posfix+ '-under-trace)

(defun make-traced-method-name (name)
  (conc-symbol name +traced-name-posfix+))

(defun generate-trace-method (meth)
  (let ((new-meth (with-parent ((ast-node-parent meth))
		    (make-trace-method meth (or (rest (needs-trace-method-p meth)) '(:args :returns))))))
    ;;we change the old method's name
    (setf (method-declaration-name meth)
	  (parse (make-traced-method-name (method-declaration-name meth)) 'linj-name))
    (apply-visitors 'after-parse new-meth)
    (apply-visitors 'before-dump new-meth)
    new-meth))

;;This is useful for tracing purposes
(defun parse-method (form)
  (parse form 'method-declaration))

(defun make-trace-method (meth-decl trace-options)
  (let ((name (method-declaration-name meth-decl))
	(parameters (parameter-list-elements (method-declaration-parameters meth-decl)))
	(options (method-declaration-options meth-decl)))
    (let ((parameter-names (mapcar #'variable-declaration-name parameters)))
      (let ((timed-output 
	     (if (member :time trace-options)
		 `((let ((end-time (in (the system) (current-time-millis))))
		     (in (the linj.trace) (out))
		     (format *trace-output*
			     ,(format nil "~A took ~~A milliseconds~~%" (linj-original-name name))
			     (- end-time start-time))
		     (in (the linj.trace) (print-level))))
		 '((in (the linj.trace) (out))))))
	(let ((body (if (void-type-p (get-type meth-decl))
			`(progn
			  (,(make-traced-method-name name) ,@parameter-names)
			  ,@timed-output
			  (format *trace-output* ,(format nil "~A returned void~~%" (linj-original-name name)) result))
			`(let ((result (,(make-traced-method-name name) ,@parameter-names)))
			  ,@timed-output
			  (format *trace-output* 
			   ,(if (member :returns trace-options)
				(format nil "~A returned ~~S~~%" (linj-original-name name))
				(format nil "~A returned ...~~%" (linj-original-name name)))
			   result)
			  result))))
	  (parse-method
	   `(defmethod ,name
	     ,parameter-names
	     ,@options
	     (declare 
	      ,@(mapcar #'(lambda (var)
			    `(,(get-type var) ,(variable-declaration-name var)))
			parameters)
	      (throws ,@(mapcar #'type-reference-name (method-declaration-throws-list meth-decl))))
	     (in (the linj.trace) (in))
	     (format *trace-output*
	      ,(if (member :args trace-options)
		   (format nil "(~A ~{~*~~S~^ ~})~~%" name parameters)
		   (format nil "(~A ...)~~%" name))
	      ,@parameter-names)
	     ,(if (member :time trace-options)
		  `(let ((start-time (in (the system) (current-time-millis))))
		    ,body)
		  body))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;To allow the use of (setf name) in the method name, we will use a simple macro:

(defconstant +accessor-name-prefix+ 'setf-)

(def-macro-transform method-declaration (defmethod-0 ?type (setf ?name) ?arglist . ?rest)
  `(defmethod-0 ,?type ,(conc-symbol +accessor-name-prefix+ ?name) ,?arglist . ,?rest))

;;When the l-value of a setf-expression is a method-call-expression, we rewrite it to a
;;setf-something method-call-expression.

(defparameter *standard-setf-places* (list 'aref 'slot-value 'the))

(def-macro-transform setf-expression (setf (?name . ?args) ?value)
  (unless (member ?name *standard-setf-places*)
    (when (unreserved-word-p ?name)
      `(,(conc-symbol +accessor-name-prefix+ ?name) ,?value ,@?args))))

;;(the ??) as place

(def-transform setf-expression (setf (the ?type ?var) ?val) (setf ?var (the ?type ?val)))

;;We want to be specific:
(def-macro-transform setf-expression (setq ?var ?val)
  (assert (symbolp ?var))
  `(setf ,?var ,?val))

(def-macro-transform statement (setq . ?vars-vals)
  (dolist-2 ((var val) ?vars-vals)
    (declare (ignore val))
    (assert (symbolp var)))
  `(setf . ,?vars-vals))

;;In some contexts (statements) we can accept a multi-argument setf

(def-macro-transform statement (setf ?var1 ?val1 . (?is ?others consp))
  (assert (evenp (length ?others)) ()
	  "Odd number of args to setq in ~a" `(setf ,?var1 ,?val1 . ,?others))
  `(progn
     ,@(loop for (var val) on `(,?var1 ,?val1 ,@?others) by #'cddr
	     collect `(setf ,var ,val))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(def-syntax incf-decf-expression (statement-expression)
  ((?is ?oper (lambda (oper) (member oper '(incf decf post-incf post-decf)))) ?place/expression ?delta/expression))

(defmethod get-type ((e incf-decf-expression))
  (get-type (incf-decf-expression-place e)))

;; (def-syntax decf-expression (statement-expression)
;;   (decf ?place/expression ?delta/expression))

(defmethod visit-current ((e incf-decf-expression) (visitor cast-and-wrap))
  (check-not-final-variable (incf-decf-expression-place e))
  (let ((delta (incf-decf-expression-delta e)))
    (setf (incf-decf-expression-delta e)
	  (convert-type-to-lvalue (incf-decf-expression-place e) delta))))

(defun unparse-update-expression (oper place delta post-p)
  (check-not-final-variable place)
  (when *print-out-parenthesis*
    (format t "("))
  (if (and (literal-p delta) (eql (literal-value delta) 1))
    (if post-p
      (format t "~/ppexp/~A~A" place oper oper)
      (format t "~A~A~/ppexp/" oper oper place))
    (progn
      (assert (not post-p))
      (format t "~/ppexp/ ~A= ~:/ppexp/" place oper delta)))
  (when *print-out-parenthesis*
    (format t ")")))

(def-unparse incf-decf-expression (e)
  (unparse-update-expression
   (case (incf-decf-expression-oper e) 
     ((incf post-incf) "+") ((decf post-decf) "-"))
   (incf-decf-expression-place e)
   (incf-decf-expression-delta e)
   (member (incf-decf-expression-oper e) '(post-incf post-decf))))

;; (def-unparse decf-expression (e)
;;   (unparse-update-expression "-" (decf-expression-place e) (decf-expression-delta e)))

(def-transform statement-expression (incf ?place) (incf ?place 1))
(def-transform statement-expression (decf ?place) (decf ?place 1))
(def-transform statement-expression (post-incf ?place) (post-incf ?place 1))
(def-transform statement-expression (post-decf ?place) (post-decf ?place 1))
(def-transform statement-expression (setf (?is ?x symbolp) (+ ?x 1)) (incf ?x))
(def-transform statement-expression (setf (?is ?x symbolp) (1+ ?x)) (incf ?x))
(def-transform statement-expression (setf (?is ?x symbolp) (+ 1 ?x)) (incf ?x))
(def-transform statement-expression (setf (?is ?x symbolp) (1- ?x)) (decf ?x))
(def-transform statement-expression (setf (?is ?x symbolp) (- ?x 1)) (decf ?x))
;;HACK missing transforms for += and -= ?
				      					     
(def-transform statement-expression (incf (?is ?x consp) ?delta) (setf ?x (+ ?x ?delta)))
(def-transform statement-expression (decf (?is ?x consp) ?delta) (setf ?x (- ?x ?delta)))


;;Constructor declaration

(def-macro-transform method-declaration (defnew ?parameters . ?options&body)
  (multiple-value-bind (options body throws)
      (extract-options-body ?options&body)
    `(defmethod-0 ,(void-type-description) :initialize-instance ,?parameters ,throws
		  (,@options :category :initializer :visibility :public)
		  . ,body)))

(def-macro-transform method-declaration (defafternew . ?options&body)
  (multiple-value-bind (options body throws)
      (extract-options-body ?options&body)
    `(defmethod-0 ,(void-type-description) finish-initialize-instance () ,throws
		  (,@options
		   :category :initialize-after 
		   ;;this must be private to prevent override of this method in subclasses
		   :visibility :private)
		  . ,body)))

(defun after-new-declaration-p (e)
  (and (method-declaration-p e)
       (eq (get-option :category e) :initialize-after)))

;;Main entry point for a class file

;; (def-macro-transform method-declaration (defmain ?parameters . ?body)
;;   `(defmethod-0 ,(void-type-description) main
;;      ((,(if (or (null ?parameters)
;; 		(not (symbolp ?parameters)))
;; 	  'outside-args 
;; 	  ?parameters) (the ,(string-array-type-description))))
;;      ()
;;      (:allocation :class :visibility :public :category :main)
;;      . ,(if (or (symbolp ?parameters)
;; 		(null ?parameters))
;; 	  ?body
;; 	  `((unless (= (length outside-args) ,(length ?parameters))
;; 	      (error "Incorrect number of arguments"))
;; 	    (let (,@(mapcar #'(lambda (param i)
;; 				(if (name&type-p param)
;; 				  (multiple-value-bind (name type)
;; 				      (extract-name&type param)
;; 				    `(,name
;; 				      ,(from-string-type-to-type type
;; 								 `(aref outside-args ,i))))
;; 				  (error "The main method must use the simplified form of typed variables")))
;; 			    ?parameters
;; 			    (iota (length ?parameters))))
;; 	      . ,?body)))))

  
(def-transform method-declaration (defun main ?parameters . ?body)
  (defmethod main ?parameters
    :visibility :public :allocation :class :returns void :main t :no-key-method t
    . ?body))

(defmethod visit :before ((e method-declaration) (visitor parse-tree-finish))
  (when (get-option :main e)
    (setf (get-option :main e) nil)
    (let ((new-meth (from-normal-to-main-method e)))
      (setf (method-declaration-parameters e) (method-declaration-parameters new-meth)
	    (method-declaration-body e) (method-declaration-body new-meth)))))

(defun from-string-type-to-type (type expr)
  (cond ((string-type-p type)
	 expr)
	((char-type-p type)
	 `(char-at ,expr 0))
	((int-type-p type)
	 `(send (the java.lang.Integer) parse-int ,expr))
	((short-type-p type)
	 `(send (the java.lang.Short) parse-short ,expr))
	((long-type-p type)
	 `(send (the java.lang.Long) parse-long ,expr))
	((float-type-p type)
	 `(send (send (the Double) value-of ,expr) float-value))
	((double-type-p type)
	 `(send (send (the Double) value-of ,expr) double-value))
	((object-type-p type)
	 `(read (new 'linj.linj-reader (new 'string-reader ,expr))))
	((bignum-type-p type)
	 `(in (the linj.bignum) (value-of ,expr)))
	(t
	 (error "Don't know (yet) how to deal with conversion from string type to ~S" type))))

(defun from-normal-to-main-method (meth)
  (with-parent ((ast-node-parent meth))
    (parse-method
     `(defmethod main (outside-args/java.lang.string[])
       :visibility :public :allocation :class :returns void
       ,@(with-main-arguments-lexicals 'outside-args
				       (method-declaration-parameters meth)
				       (method-declaration-body meth))))))

(defun with-main-arguments-lexicals (outparam parameters body)
  (let ((params (parameter-list-elements parameters)))
    (labels ((resolve (params count)
	       (if (endp params)
		 body
		 (let ((param (first params)))
		   (ecase (get-option :parameter-type param)
		     (:required
		      `((let ((,(variable-declaration-name param)
			       ,(from-string-type-to-type (get-type param) `(aref ,outparam ,count))))
			  ,@(resolve (rest params)
				     (1+ count)))))
		     (:optional
		      `((let ((,(variable-declaration-name param)
			       (if (>= (length ,outparam) ,count)
				 ,(from-string-type-to-type (get-type param) `(aref ,outparam ,count))
				 ,(or (variable-declaration-initializer param)
				      (get-default-initializer (get-type param))))))
			  ,@(resolve (rest params)
				     (1+ count)))))
		     (:keyword
		      `((let ((keyargs (make-hash-table :test #'equals)))
			  (do ((i ,count (+ i 2)))
			      ((= i (length ,outparam)))
			    (setf (gethash (aref ,outparam i) keyargs) (aref ,outparam (1+ i))))
			  ,@(process-keyword-params params))))))))
	     (process-keyword-params (params)
	       (if (endp params)
		 body
		 (let ((param (first params)))
		   (let ((key (format nil "--~A" (ast-node-form (variable-declaration-name param)))))
		     (let ((form (from-string-type-to-type (get-type param) `(the java.lang.string (gethash ,key keyargs)))))
		       `((let ((,(variable-declaration-name param)
				,(if (variable-declaration-initializer param)
				   `(if (contains-key keyargs ,key)
				      ,form
				      ,(variable-declaration-initializer param))
				   form)))
			   ,@(process-keyword-params (rest params))))))))))
      (resolve params 0))))

;;Slots

(def-syntax slot-declaration (type-body-declaration)
  (defslot-0 ?statement/variable-declaration . ?options))

(defmethod get-type ((e slot-declaration))
  (get-type (slot-declaration-statement e)))

(def-unparse slot-declaration (e)
  (let ((var-decl (slot-declaration-statement e)))
    (write-documentation e)
    (format t "~@<~/write-options/~/pp/ ~/unlinj-name/~:[~; = ~4I~_~:/ppexp/~I~];~:>"
	    e
	    (get-type var-decl)
	    (variable-declaration-name var-decl)
	    (and (not (null (variable-declaration-initializer var-decl)))
		 (not (member :initarg (slot-declaration-options e)))) ;;avoid duplicate slot initialization
	    (variable-declaration-initializer var-decl))))

(defmethod constant-declaration-p ((e type-body-declaration))
  (get-option :final e))

;;Slots come in three varieties:
;;Normal instance slots
(def-macro-transform slot-declaration (defslot ?name ?initial-value-or-type . ?documentation)
  `(defslot-0 (,?name ,?initial-value-or-type)
    :visibility :protected
    ,@(when ?documentation `(:documentation ,@?documentation))))

;;Class slots
(def-macro-transform slot-declaration (defvar ?name ?initial-value-or-type . ?documentation)
  `(defslot-0 (,?name ,?initial-value-or-type)
    :allocation :class 
    :visibility :public
    ,@(when ?documentation `(:documentation ,@?documentation))))

(defmethod defvar-declaration-p ((e type-body-declaration))
  (eq (get-option :allocation e) :class))

(def-transform slot-declaration (defparameter ?name ?initial-value . ?documentation)
  (defvar ?name ?initial-value . ?documentation))

(def-macro-transform slot-declaration (defconstant ?name ?initial-value . ?documentation)
  `(defslot-0 (,?name ,?initial-value) 
    :allocation :class
    :final t
    :visibility :public 
    ,@(when ?documentation `(:documentation ,@?documentation))))

(defmethod defconstant-declaration-p ((e type-body-declaration))
  (and (eq (get-option :allocation e) :class)
       (get-option :final e)))

;;'Assembly' language, which might appear anywhere (as an expression or statement)
(def-syntax java-code (expression statement)
  (java (?is ?text stringp)))

(defmethod get-type ((e java-code))
  (error "BUM"))

(def-unparse java-code (e)
  (princ (java-code-text e)))

;; Java expressions
(def-syntax java-expression (expression)
  (java-expression ?type/type-reference (?is ?text stringp)))

(defmethod get-type ((e java-expression))
  (java-expression-type e))

(def-unparse java-expression (e)
  (princ (java-expression-text e)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;throw

(def-syntax throw-statement (statement)
  (throw ?argument/expression))

(def-unparse throw-statement (e)
  (format t "throw ~/pp/;"
	  (throw-statement-argument e)))

;;Special Common Lisp case
(def-transform throw-statement (error (?is ?fmt stringp) . ?args)
  (throw (new 'error (format nil ?fmt . ?args))))

;;Now, several arguments but the first one is a symbol
(def-transform throw-statement (error '(?is ?type symbolp) . ?args)
  (throw (new '?type . ?args)))

;;Computed error
(def-transform throw-statement (error ?expr)
  (throw ?expr))

;;Note that the previous macros can only be used as statement and not as an
;;expression, which invalidates code like
;;(let ((x (if test result (error ...)))) ...)
;;However, the problem can be solved by defining a class method on some
;;utility class that throws the exception.  By the way, it looks
;;increasingly urgent to define such a class to hang up on it lots of stuff
;;that is generically usefull.  Such class could even include the cons
;;stuff that is already being intensively used.

;;;;;;;;;;;;;;;;
;;Method calls are a fundamental part of Linj.  The first type of method
;;call is similar to Smalltalks's messages being sent between objects.

(def-syntax method-call-expression (cached-declaration statement-expression)
  (send ?receiver/expression ?name/linj-name . ?arguments/argument-list))

(def-syntax class-method-call-expression (method-call-expression)
  (send (the ?receiver/type-reference) ?name/linj-name . ?arguments/argument-list))

(defmethod find-declaration ((e method-call-expression))
  (find-declaration-in e (get-type-declaration (method-call-expression-receiver e))))

(defmethod get-type ((e method-call-expression))
  (get-type (strict-find-declaration e)))

;;There is a special kind of method call that creates instances: when the
;;message :initialize-instance is send to a class it returns an instance of
;;that class.  These methods calls are named constructor-calls:

(defmethod constructor-call-p ((e method-call-expression))
  (eq (method-call-expression-name e) :initialize-instance))

;;When we emit the Java code we must distinguish between constructor-calls
;;and other calls as Java has different syntax for these: 
(def-unparse method-call-expression (e)
  (check-initialization e)
  (let ((receiver (method-call-expression-receiver e)))
    (cond ((constructor-call-p e)
	   (if (constructor-declaration-p (containing-method-declaration e))
	     ;;this is not entirely correct. Must check the class
	     (format t "~/pp/~/pp/" receiver (method-call-expression-arguments e))
	     (format t "new ~/pp/~/pp/" receiver (method-call-expression-arguments e))))
	  (t
	   (let ((real-receiver
		  (if (assert-type-expression-p receiver)
		    (assert-type-expression-expression receiver)
		    receiver)))
	     (format t
		     "~@<~:[~*~;~/ppexp/.~1I~_~I~]~/pp/~/pp/~:>"
		     (not (or (this-reference-p real-receiver)
			      (alias-this-reference-p real-receiver)
			      (this-type-reference-p real-receiver)))
		     receiver
		     (method-call-expression-name-for-unparse e)
		     (method-call-expression-arguments e)))))))

(defmethod check-initialization ((call method-call-expression))
  ;;do nothing
  ;;but subclasses will do something
  )

(defmethod method-call-expression-name-for-unparse ((e method-call-expression))
  (method-call-expression-name e))

(defun this-type-reference-p (reference)
  (and (type-reference-p reference)
;;;       (eq (get-option :allocation (containing-method-declaration reference)) :class)
       (let ((containing-type-declaration (containing-type-declaration reference)))
	 ;;We check existence because we might want to unparse a disconnected ast
	 (and containing-type-declaration
	      (equal-type-p reference (type-declaration-name containing-type-declaration))))))

(defmethod declares-p ((elem method-declaration) (call method-call-expression))
  (and (eq (method-call-expression-name call)
	   (method-declaration-name elem))
       (let ((params (parameter-list-elements (method-declaration-parameters elem)))
	     (args (argument-list-elements (method-call-expression-arguments call))))
	 (and (= (length params) (length args))
	      (every #'(lambda (param arg)
			 (super-type-p (get-type param)
				       (get-principal-type arg)))
		     params
		     args)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;Now, we introduce a more CommonLispy form of method call where the
;;arguments can have keywords and we must resolve the keywords.  Besides,
;;casts and wrappers are inserted as needed.

(def-syntax key-method-call-expression (method-call-expression)
  (key-send ?receiver/expression ?name/linj-name . ?arguments/argument-list)
  :slots ((args-passed :accessor method-call-expression-args-passed :initform :unknown)
	  (phase :accessor computing-phase)))

(def-syntax class-key-method-call-expression (key-method-call-expression)
  (key-send (the ?receiver/type-reference) ?name/linj-name . ?arguments/argument-list))

;;Keyword resolution is done in two phases: first, we look for a perfect
;;match, then we look for a match with casts and wrappers.
;;I'm abusing of the args-passed slot to contain the several search
;;phases. In the end, it will contain either a number or :all.
(defparameter *resolve-keyword-args* t) 

(defmethod check-initialization ((call key-method-call-expression))
  (if *resolve-keyword-args*
    (when (eq (method-call-expression-args-passed call) :unknown)
      ;;To avoid infinite regression
      (setf (method-call-expression-args-passed call) :computing)
      (respecify-method-call call (strict-find-declaration call)))
    (setf (method-call-expression-args-passed call) :all)))

;;To find a method declaration that satisfies a method call we must search
;;all methods implemented by the receiver for one that 'matches'  the
;;keyword parameters.  This might be a little difficult because of two things:
;; - overloading: there might be several methods with the same name,
;; specially in library classes
;;
;; - casts and wrapping: we might need to cast or wrap certain arguments in
;;                       order for them to satisfy the parameters.
;;
;;I think the best solution is to try several possibilities, that is, for
;;each method declaration that matches the method call message (thank God
;;there's something fixed), I'll try to resolve keyword arguments and cast
;;and/wrap arguments in a standard way. If this process fails, the
;;declaration can't be used and I try a different one.  The one declaration
;;that succeeds is permanently attached to the method call (via the
;;cached-declaration mixin) so that the process isn't repeated.
;;I must be carefull, however, to try the matching process first _without_
;;casts and wraps as there might be a method that matches exactly the
;;arguments and this should be prefered to others that need casts and wraps.

;;The tricky part in this process is that most (if not all) parse tree
;;operations are destructive, so I must have a way to 'undo' each failed
;;attempted matching.  Due to the automatic management of parent/child
;;links in the parse tree, I guess that it is enough to keep the original
;;argument list and restore it before each matching.

(defmethod find-declaration ((call key-method-call-expression))
  (some #'(lambda (phase)
	    (setf (computing-phase call) phase)
	    (call-next-method))
	(if (some #'keyword-reference-p
		  (argument-list-elements (key-method-call-expression-arguments call)))
	  '(:computing-keyword-match :computing-aprox-match)
	  '(:computing-perfect-match :computing-keyword-match :computing-aprox-match))))

;;We will use the args-passed slot, somehow violating Pitman's
;;two-bit rule but, for the moment, it seems ok.
(defmethod declares-p ((decl method-declaration) (call key-method-call-expression))
  (and (eq (method-call-expression-name call)
	   (method-declaration-name decl))
       (ecase (computing-phase call)
	 (:computing-perfect-match
	  (call-next-method)
;; 	  (resolve-cl-arguments
;; 	   call
;; 	   decl
;; 	   #'(lambda (param arg)
;; 	       (if (equal-type-p (get-type param)
;; 				 (get-principal-type arg))
;; 		 arg
;; 		 (return-from declares-p nil))))
	  )
	 (:computing-keyword-match
	  (resolve-cl-arguments
	   call
	   decl
	   #'(lambda (param arg)
	       (if (super-type-p (get-type param)
				 (get-principal-type arg))
		 arg
		 (return-from declares-p nil)))))
	 (:computing-aprox-match
	  (resolve-cl-arguments 
	   call
	   decl
	   #'(lambda (param arg)
	       (cast-and-wrap-if-needed
		(get-type param)
		(get-type arg)
		arg
		#'(lambda (expected current expr)
		    (declare (ignore expected current expr))
		    (return-from declares-p nil)))))))))

(defmethod respecify-method-call ((call key-method-call-expression) (decl method-declaration))
  (let ((arguments (key-method-call-expression-arguments call))
	(parameters (method-declaration-parameters decl)))
    (multiple-value-bind (args-passed resolved-args)
	(resolve-cl-arguments call
			       decl
			       #'(lambda (param arg)
				   (convert-to-type arg (get-type param) :force-cast nil)))
      (if args-passed
	(if (= (logcount args-passed)
	       (length (remove :required (parameter-list-elements parameters)
			       :key #'(lambda (param) (get-option :parameter-type param)))))
	  ;;all args used
	  (progn
	    (setf (method-call-expression-args-passed call) :all)
	    (setf (argument-list-elements arguments) resolved-args))
	  (progn
	    (setf (method-call-expression-args-passed call) args-passed)
	    (setf (argument-list-elements arguments)
		  (if (needs-key-method-p decl)
		    (nconc resolved-args (list (parse args-passed 'literal)))
		    resolved-args))))
	(linj-error "Not enough arguments in ~S" call)))))

(defmethod resolve-cl-arguments ((call key-method-call-expression) 
				 (decl method-declaration)
				 transform)
  (let ((args (argument-list-elements (key-method-call-expression-arguments call)))
	(params (parameter-list-elements (method-declaration-parameters decl))))
    (labels ((resolve (params count count-opts unkey-args prev-supplied-p present-args remaining-args)
	       (if (endp params)
		 (and (endp remaining-args)
		      (values present-args (nreverse unkey-args) remaining-args))
		 (let ((param (first params)))
		   (if (supplied-p param)
		     (resolve (rest params)
			      count
			      count-opts
			      (if (simple-parameter-initializations-p decl)
				(cons (parse (if prev-supplied-p 't 'nil) 'literal) unkey-args)
				unkey-args) ;;it will be dealt with in the key method
			      nil
			      present-args
			      remaining-args)
		     (ecase (get-option :parameter-type param)
		       (:required
			(multiple-value-bind (arg found-p)
			    (get-positional-argument count args)
			  (if found-p
			    (resolve (rest params)
				     (1+ count)
				     count-opts
				     (cons (funcall transform param arg)
					   unkey-args)
				     found-p
				     present-args;;(logior present-args (ash 1 count-opts))
				     (remove arg remaining-args :count 1))
			    nil))) ;;; This must fail so that another method can be tried
		       ;;;(linj-error "Missing required argument ~S in ~S" param call)
		       (:optional
			(multiple-value-bind (arg found-p)
			    (get-positional-argument count args)
			  (if found-p
			    (resolve (rest params)
				     (1+ count)
				     (1+ count-opts)
				     (cons (funcall transform param arg)
					   unkey-args)
				     found-p
				     (logior present-args (ash 1 count-opts))
				     (remove arg remaining-args :count 1))
			    (resolve (rest params)
				     (1+ count)
				     (1+ count-opts)
				     (cons (parse
					    (if (and (simple-parameter-initializations-p decl)
						     (initialized-variable-declaration-p param))
					      (ast-node-form (variable-declaration-initializer param))
					      (get-default-initializer (get-type param))) ;;only accept literals
					    'literal)
					   unkey-args)
				     found-p
				     present-args
				     remaining-args))))
		       (:keyword
			(multiple-value-bind (key arg)
			    (get-key-argument (make-keyword 
					       (linj-original-name 
						(variable-declaration-name param)))
					      args)
			  (if key
			    (resolve (rest params)
				     (1+ count)
				     (1+ count-opts)
				     (cons (funcall transform param arg)
					   unkey-args)
				     key
				     (logior present-args (ash 1 count-opts))
				     (remove key (remove arg remaining-args :count 1) :count 1))
			    (resolve (rest params)
				     (1+ count)
				     (1+ count-opts)
				     (cons (parse
					    (if (and (simple-parameter-initializations-p decl)
						     (initialized-variable-declaration-p param))
					      (ast-node-form (variable-declaration-initializer param))
					      (get-default-initializer (get-type param)))
					    'literal)
					   unkey-args)
				     key
				     present-args
				     remaining-args))))
		       (:rest
			(let ((arg (with-parent (call) (parse `(list ,@remaining-args) 'expression))))
			  (apply-visitors 'after-parse arg)
			  (resolve (rest params)
				   (1+ count)
				   (1+ count-opts)
				   (cons (funcall transform param arg)
					 unkey-args)
				   t
				   (logior present-args (ash 1 count-opts))
				   (list))))))))))
      (resolve params 0 0 (list) nil 0 args))))


(defun get-key-argument (key arg-list)
  (labels ((search-keys (args)
	     (cond ((endp args)
		    (values nil nil))
		   ((keyword-reference-p (first args))
		    (if (eq (reference-name (first args)) key)
		      (values (first args) (second args))
		      (search-keys (rest (rest args)))))
		   (t
		    (linj-error "Malformed argument list ~S" arg-list)))))
    (search-keys (member-if #'keyword-reference-p arg-list))))

(defun get-positional-argument (count arg-list)
  (cond ((endp arg-list)
	 (values nil nil))
	((keyword-reference-p (first arg-list))
	 (values nil nil))
	((zerop count)
	 (values (first arg-list) t))
	(t
	 (get-positional-argument (1- count) (rest arg-list)))))

(defmethod all-arguments-passed-p ((call method-call-expression))
  (not (numberp (method-call-expression-args-passed call))))

(defmethod method-call-expression-name-for-unparse ((e key-method-call-expression))
  (if (or (all-arguments-passed-p e)
	  (simple-parameter-initializations-p (find-declaration e)))
    (method-call-expression-name e)
    (parse (generate-key-method-name
	    (method-call-expression-name e)) 'linj-name)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun cast-and-wrap-if-needed (expected current expr error-action &key (force-cast nil))
  (labels ((coercion-error ()
	     (funcall error-action expected current expr))
	   (wrap-for-types (type types)
	     (if (member current types :test #'equal-type-p)
	       ;;`(new ',(ast-node-form expected) ,expr)
	       (make-instance 'allocation-expression
		 :receiver (copy-type type)
		 :arguments (make-instance 'argument-list
			      :original-form 'auto-wrap-for-types
			      :elements (list expr))
		 :parent (ast-node-parent expr))
	       (coercion-error)))
	   (value-of-for-types (type types)
	     (if (member current types :test #'equal-type-p)
	       ;;`(value-of ,(ast-node-form expected) ,expr)
	       (make-instance 'method-call-expression
		 :receiver (copy-type type)
		 :name (parse 'value-of 'linj-name)
		 :original-form 'auto-value-of-for-types
		 :arguments (make-instance 'argument-list
			      :original-form 'auto-arg-value-of-for-types
			      :elements (list expr))
		 :parent (ast-node-parent expr))
	       (coercion-error)))
	   (unwrap-with-method-call (msg)
	       ;;`(send ,expr ',msg)
	     (make-instance 'method-call-expression
	       :receiver expr
	       :name (parse msg 'linj-name)
	       :arguments (parse '() 'argument-list)
	       :original-form 'auto-unwrap-with-method-call
	       :parent (ast-node-parent expr)))
	   (cast-to-expected-type ()
	     ;;`(the ,(ast-node-form expected) ,expr)
	     (make-instance 'cast-expression 
	       :original-form 'auto-cast-to-expected-type
	       :type (copy-type expected)
	       :expression expr
	       :parent (ast-node-parent expr)
	       :force-cast-p force-cast)))
    (cond ((equal-type-p expected current)
	   expr)
	  ((values-type-reference-p current)
	   (if (values-type-reference-p expected)
	     expr
	     (cast-and-wrap-if-needed
	      expected
	      (get-principal-type current)
	      (get-principal-value current expr)
	      error-action
	      :force-cast force-cast)))
	  ((and (primitive-type-reference-p expected)
		(primitive-type-reference-p current))
	   (if (super-type-p expected current)
	       (if force-cast
		   (cast-to-expected-type)
		   expr)
	       (if (super-type-p current expected)
		   (cast-to-expected-type)
		   (coercion-error))))
	  ((primitive-type-reference-p expected)
	   (cond ((equal-type-p current (char-wrapper-type))
		  (if (equal-type-p expected (char-type))
		    (unwrap-with-method-call 'char-value)
		    (coercion-error)))
		 ((equal-type-p current (boolean-wrapper-type))
		  (if (equal-type-p expected (boolean-type))
		    (unwrap-with-method-call 'boolean-value)
		    (coercion-error)))
		 ((or (equal-type-p current (int-wrapper-type))
		      (equal-type-p current (long-wrapper-type))
		      (equal-type-p current (float-wrapper-type))
		      (equal-type-p current (double-wrapper-type))
		      (equal-type-p current (number-wrapper-type))
		      ;;The next ones are a bit dangerous...
		      (equal-type-p current (big-integer-type))
		      (equal-type-p current (big-decimal-type))
		      (equal-type-p current (bignum-type)))
		  (cond ((equal-type-p expected (int-type))
			 (unwrap-with-method-call 'int-value))
			((equal-type-p expected (long-type))
			 (unwrap-with-method-call 'long-value))
			((equal-type-p expected (float-type))
			 (unwrap-with-method-call 'float-value))
			((equal-type-p expected (double-type))
			 (unwrap-with-method-call 'double-value))
			(t
			 (coercion-error))))
		 ((and (equal-type-p expected (boolean-type))
		       (class-or-interface-type-reference-p current))
		  (from-reference-type-to-boolean expr))
		 ((equal-type-p current (object-type))
		  (cast-and-wrap-if-needed
		   expected
		   (generic-wrapper-type expected)
		   (cast-and-wrap-if-needed
		    (generic-wrapper-type expected)
		    current
		    expr
		    error-action)
		   error-action))
		 (t
		  (coercion-error))))
	  ((primitive-type-reference-p current)
	   (cond ((and (boolean-type-p current) (false-literal-p expr))
		  ;;to allow (and a b c) where a b c return object
		  (make-literal (null-value)))
		 ((equal-type-p expected (char-wrapper-type))
		  (wrap-for-types expected (list (char-type))))
		 ((equal-type-p expected (boolean-wrapper-type))
		  (value-of-for-types expected (list (boolean-type))))
		 ((equal-type-p expected (int-wrapper-type))
		  ;;Integer only accepts int
		  (wrap-for-types expected (list (int-type))))
		 ((equal-type-p expected (long-wrapper-type))
		  ;;Long accepts long and int (which is automatically converted to long)
		  (wrap-for-types expected (list (int-type) (long-type))))
		 ((or (equal-type-p expected (float-wrapper-type))
		      ;;Float or Double accepts either double or float
		      (equal-type-p expected (double-wrapper-type)))
		  (wrap-for-types expected (list (float-type) (double-type))))
		 ;;Special case: bignums
		 ((equal-type-p expected (bignum-type))
		  (value-of-for-types expected (list (int-type) (long-type))))
		 ;;Special case: BigIntegers
		 ((equal-type-p expected (big-integer-type))
		  (value-of-for-types expected (list (int-type) (long-type))))
		 ((equal-type-p expected (big-decimal-type))
		  (if (or (equal-type-p current (float-type))
			  (equal-type-p current (double-type)))
		    ;;use allocation
		    (wrap-for-types expected (list (float-type) (double-type)))
		    ;;use value-of
		    (value-of-for-types expected (list (int-type) (long-type)))))
		 ((equal-type-p expected (number-wrapper-type))
		  (if (or (equal-type-p current (int-type))
			  (equal-type-p current (long-type))
			  (equal-type-p current (float-type))
			  (equal-type-p current (double-type)))
		    (wrap-for-types (wrapper-type current) (list current))
		    (coercion-error)))
		 ;;special case - from a primitive type to a generic
		 ;;reference type <object>
		 ((equal-type-p expected (object-type))
		  (cond ((and *bignum-arithmetic-p*
			      (or (int-type-p current) (long-type-p current)))
			 (value-of-for-types (bignum-type) (list (int-type) (long-type))))
			((boolean-type-p current)
			 (value-of-for-types (boolean-wrapper-type) (list current)))
			(t 
			 (wrap-for-types (wrapper-type current) (list current)))))
		 (t
		  (coercion-error))))
	  ;;both non-primitive
	  ((and (class-or-interface-type-reference-p expected)
		(class-or-interface-type-reference-p current))
	   (cond ((super-type-p expected current)
		  (if force-cast
		    (cast-to-expected-type)
		    expr))
		 ((super-type-p current expected)
		  ;;Here, we assume the programmer want's an automatic type-cast
		  (cast-to-expected-type))
		 ;;Special case BigInteger -> BigDecimal
		 ((equal-type-p expected (big-decimal-type))
		  (wrap-for-types expected (list (big-integer-type))))
		 ((equal-type-p expected (bignum-type))
		  (value-of-for-types expected (list (big-integer-type))))
		 ((and (equal-type-p expected (big-integer-type))
		       (equal-type-p current (bignum-type)))
		  (unwrap-with-method-call 'to-big-integer))
		 (t
		  (coercion-error))))
	  (t
	   (coercion-error)))))

(defun convert-to-type (e type &key (force-cast t))
  (cast-and-wrap-if-needed type
			   (get-type e)
			   e
			   #'(lambda (expected current expr)
			       (linj-error "Coercion error! Expr ~S has type ~S but expecting ~S" expr current expected))
			   :force-cast force-cast))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;Alocation

(def-syntax allocation-expression (key-method-call-expression)
  (new '?receiver/type-reference . ?arguments/argument-list)
  :slots ((name :initform (parse ':initialize-instance 'linj-name))))

(defmethod get-type ((e allocation-expression))
  (method-call-expression-receiver e))

(def-unparse allocation-expression (e)
  (check-initialization e)
  (format t "new ~/pp/~/pp/"
	  (method-call-expression-receiver e)
	  (method-call-expression-arguments e)))

;;;;;;;;;;;;;
;;Let's allow for a more Common Lispy way:

(def-macro-transform allocation-expression (make-instance '?type . ?args)
  `(new ',?type . ,?args))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;Let's replace super.???(...) with call-next-method

(def-syntax next-method-call-expression (method-call-expression)
  (call-next-method . ?arguments/argument-list))

(defmethod method-call-expression-receiver :before ((e next-method-call-expression))
  (check-initialization e))

(defmethod method-call-expression-name :before ((e next-method-call-expression))
  (check-initialization e))

(defmethod method-call-expression-arguments :before ((e next-method-call-expression))
  (check-initialization e))

(defmethod visit :before ((e next-method-call-expression) (visitor parse-tree-finish))
  (check-initialization e))

(defmethod check-initialization ((e next-method-call-expression))
  (unless (slot-boundp e 'receiver)
    (let ((method (containing-method-declaration e))
	  (args (argument-list-elements (next-method-call-expression-arguments e))))
      (if (endp args)
	(setf (method-call-expression-arguments e)
	      (parse (mapcar #'variable-declaration-name
			     (parameter-list-elements
			      (method-declaration-parameters method)))
		     'argument-list))
	(let ((receiver (find-if #'alias-this-reference-p args)))
	  (when receiver
	    (setf (argument-list-elements (next-method-call-expression-arguments e))
		  (delete receiver args)))))
      ;;We must distinguish the case of a recently 'adapted' :around-combination
      ;;and the general case
      (if (member :around-combination (get-option :qualifiers method))
	(setf (method-call-expression-name e) (parse (make-primary-name (method-declaration-name method)) 'linj-name)
	      (method-call-expression-receiver e) (parse 'this 'reference))
	(setf (method-call-expression-name e) (method-declaration-name method)
	      (method-call-expression-receiver e) (parse 'super 'reference))))))

;;When searching for the type of a next-method-call-expression we don't
;;need to look at the superclass.  We know the type is the same as the
;;return type of the containing method. This is specially important in
;;mixins, where we can't get the type of a next-method-call-expression
;;because the superclass doesn't exist.

(defmethod get-type ((e next-method-call-expression))
  (get-type (or (find-declaration e) (containing-method-declaration e))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;Slot access.  In theory, slot access will be mediated by readers and
;;writers.  It's easier, however, to implement basic means to access the
;;slot and define readers and writers on top of this.
(def-syntax slot-value-reference (expression cached-declaration)
  (slot-value ?object/expression '?slot/reference))

;;For legacy reasons, we also accept the following:
(def-syntax special-slot-value-reference (slot-value-reference)
  (slot-value (the ?object/type-reference) '?slot/reference))

;;HACK : Must use read-macro #s(?object slot)

(defmethod find-declaration ((e slot-value-reference))
  (find-declaration-in (slot-value-reference-slot e)
		       (get-type-declaration (slot-value-reference-object e))))

(defmethod find-declaration-in ((ref reference) (e slot-value-reference))
  (if (eq ref (slot-value-reference-slot e))
    (find-declaration e)
    (call-next-method)))

(defmethod get-type ((e slot-value-reference))
  ;;doesn't need to check this and super
  (get-type (strict-find-declaration e)))

(def-unparse slot-value-reference (e)
  (if (or (this-reference-p (slot-value-reference-object e))
	  (alias-this-reference-p (slot-value-reference-object e)))
    (let ((decl (find-declaration-in (slot-value-reference-slot e)
				     (ast-node-parent e)))
	  (class-decl (find-declaration e)))
      (if (and (not (null class-decl)) (eq decl class-decl))
	(format t "~/pp/" (slot-value-reference-slot e))
	(format t "~/ppexp/.~/unlinj-name/"
		(slot-value-reference-object e) (reference-name (slot-value-reference-slot e)))))
    (format t "~/ppexp/.~/unlinj-name/"
	    (slot-value-reference-object e) (reference-name (slot-value-reference-slot e)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;We now(??) reach compilation-units. 
;;Each file is a compilation unit, which is composed by:
;;zero or one package declaration,
;;zero or more import statements,
;;one or more class declarations, including one public class declaration
;;which names the file.

;;In addition, (java lang *) is automatically imported on every compilation
;;unit (7.)

(def-syntax compilation-unit-member (top-level-form)
  (never-matches))

(defmacro with-compilation-options ((options) &rest body)
  (let ((vars '(*write-category-comment* 
		*check-super-method-type*
		*check-assignments-to-closure-variables*
		*parallel-assignment-can-reorder*)))
    `(let ,(mapcar #'(lambda (var)
		       `(,var ,var))
		   vars)
      (destructuring-bind (&key ,@(mapcar #'(lambda (var)
					      `((,(intern (subseq (symbol-name var) 1 (1- (length (symbol-name var))))
							  (find-package :keyword))
						 ,var) ,var))
					  vars))
	  ,options
	,@body))))

;;package

(def-syntax package-declaration (compilation-unit-member)
  (package ?name))

(defmethod package-declaration-components ((e package-declaration))
  (if (null (package-declaration-name e))
    (empty-package)
    (with-linj-syntax ()
      (mapcar #'read-from-string (parse-dots (princ-to-string (package-declaration-name e)))))))

(def-unparse package-declaration (e)
  (format t "package ~{~/pp/~^.~};" (package-declaration-components e)))

;;imports
(def-syntax import-declaration (compilation-unit-member)
  (import ?type/type-reference))

(defmethod visit ((n import-declaration) (visitor t))
  ;;don't visit the type
  (visit-current n visitor))

(defmethod visit :before ((n import-declaration) (visitor parse-tree-finish))
  (set-if-unknown-package (import-declaration-type n) (empty-package)))

(defun import-declaration-components (import)
  (let ((type (import-declaration-type import)))
    (append (class-or-interface-type-reference-package type)
	    (list (class-or-interface-type-reference-name type)))))

(def-unparse import-declaration (e)
  (let ((type (import-declaration-type e)))
    (if (empty-package-p (class-or-interface-type-reference-package type))
	(format t "import ~/unlinj-type/;"
		(class-or-interface-type-reference-name type))
	(format t "import ~{~A.~}~/unlinj-type/;"
		(class-or-interface-type-reference-package type)
		(class-or-interface-type-reference-name type)))))

(defun new-import-declaration (type)
  (make-instance 'import-declaration
    :type type))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;in declarations

(def-syntax in-declaration (compilation-unit-member)
  (in (the ?object/type-reference)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;type declarations

(def-list-syntax type-body (linj-list-node) type-body-declaration)

(def-category type-declaration (declaration-options compilation-unit-member)
  ((name :reader type-declaration-name)
   (body :accessor type-declaration-body)))

(defmethod get-type ((e type-declaration))
  (type-declaration-name e))


(def-syntax class-declaration (type-body-declaration type-declaration)
  (defclass-0 ?name/type-reference
      ?superclass/type-reference
    ?mixins/type-reference-list
    ?options . ?body/type-body))

(def-syntax root-class-declaration (class-declaration)
  (defclass-0 ?name/type-reference nil
    ?mixins/type-reference-list
    ?options . ?body/type-body)
  :slots ((superclass :initform (make-instance 'class-or-interface-type-reference
				  :name nil
				  :inferred-package nil))))

(defmethod class-slots ((e class-declaration))
  (remove-if-not #'slot-declaration-p (type-body-elements (class-declaration-body e))))

(defmethod class-statics ((e class-declaration))
  (remove-if-not #'defvar-declaration-p (type-body-elements (class-declaration-body e))))

(defmethod self-or-containing-type-declaration ((e type-declaration))
  e)

;;;;;;;;;;;;;;

(defmethod declares-p ((elem t) (what t))
  nil)

(defmethod declares-p ((elem slot-declaration) (ref reference))
  (eq (reference-name ref)
      (variable-declaration-name (slot-declaration-statement elem))))

(defmethod declares-p ((elem type-declaration) (ref type-reference))
  (equal-type-p (type-declaration-name elem) ref))

(defmethod find-declaration-in (what (e class-declaration))
  (or ;;find in this class
      (find-declaration-in-type what e)
      ;;go through the superclass before going through the outerclass
      ;;except when we are at the root class
      (and (not (root-class-declaration-p e))
	   (or (find-declaration-in what (get-type-declaration (class-declaration-superclass e)))
	       ;;go through the mixins before going through the outerclass
	       (some #'(lambda (mixin)
			 (find-declaration-in what (get-type-declaration mixin)))
		     (type-reference-list-elements (class-declaration-mixins e)))
	       (call-next-method)))))

;;Allocation expressions have a special rule. If a constructor is found on
;;the current class, we can't use another one from a superclass.  Moreover,
;;if a constructor is not found, then the default constructor (that will be
;;built automatically by the Java compiler doesn't accept arguments.
(defparameter *default-constructor* (parse '(defnew ()) 'method-declaration))

(defmethod find-declaration-in ((alloc allocation-expression) (e class-declaration))
  ;;First, search on current class for constructors
  (let ((name (method-call-expression-name alloc)))
    (if (some #'(lambda (elem)
		  (and (method-declaration-p elem)
		       (eq name (method-declaration-name elem))))
	      (type-body-elements (class-declaration-body e)))
      ;;There are constructors. We _must_ find one here.
      (find-declaration-in-type alloc e)
      ;;Only allow for default constructor
      *default-constructor*)))


(defmethod find-declaration-in-type (what (e type-declaration))
  (find-if #'(lambda (elem)
	       (declares-p elem what))
	   (type-body-elements (type-declaration-body e))))

(defmethod find-declaration-in-type ((what type-reference) (e type-declaration))
  (if (equal-type-p what (type-declaration-name e))
    e
    (call-next-method)))

(defmethod find-declaration-in-type ((what method-call-expression) (e class-declaration))
  (let ((meths (remove-if-not #'(lambda (elem)
				  (declares-p elem what))
			      (type-body-elements (class-declaration-body e)))))
    (cond ((endp meths)
	   nil)
	  ((endp (rest meths))
	   (first meths))
	  (t
	   (first (sort meths ;;Must choose most specific method.
			#'(lambda (params1 params2)
			    (every #'super-type-p (mapcar #'get-type params2) (mapcar #'get-type params1)))
			:key #'(lambda (m)
				 (parameter-list-elements (method-declaration-parameters m)))))))))

(defmethod find-methods-named (name (e class-declaration) &optional (exclude-self-p t))
  (append
   (and (not exclude-self-p)
	(remove-if-not #'(lambda (elem)
			   (and (method-declaration-p elem)
				(eq name (method-declaration-name elem))))
		       (type-body-elements (class-declaration-body e))))
   (and (not (root-class-declaration-p e))
	(append
	 ;;go through the superclass
	 (find-methods-named name
			     (get-type-declaration (class-declaration-superclass e)) 
			     nil)
	 ;;go through the mixins
	 (reduce #'append
		 (type-reference-list-elements (class-declaration-mixins e))
		 :key #'(lambda (mixin)
			  (find-methods-named name (get-type-declaration mixin) nil))
		 :from-end t)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defparameter *write-category-comment* t)

(defun write-type-body-elements (text elems)
  (unless (null elems)
    (if *write-category-comment*
      (format t "~:@_~:@_~A~:@_" text)
      (format t "~:@_"))
    (format t "~{~:@_~/pp/~^~:@_~}" elems)))

(defparameter *key-method-just-for-initialized-parameters* nil)

(defun needs-key-method-p (decl)
  (and (not (getf (method-declaration-options decl) :no-key-method))
       (some (if *key-method-just-for-initialized-parameters*
	       #'initialized-variable-declaration-p
	       #'(lambda (param)
		   (and (member (get-option :parameter-type param)
				'(:optional :keyword))
			(initialized-variable-declaration-p param)
			(not (typep (variable-declaration-initializer param) 'literal)))))
	     (parameter-list-elements (method-declaration-parameters decl)))))

;;Trace
(defun needs-trace-method-p (decl)
  (getf (method-declaration-options decl) :trace))

(defun forget-trace-method (decl)
  (setf (getf (method-declaration-options decl) :trace) nil))

(defun abstract-class-declaration-p (e)
  (or (eq (get-option :category e) :abstract)
      (some #'abstract-method-declaration-p
	    (type-body-elements (type-declaration-body e)))))

(defmethod class-allocated-reference-p ((e reference))
  (and (not (this-reference-p e))
       (not (super-reference-p e))
       (not (alias-this-reference-p e))
       (let ((decl (strict-find-declaration e)))
	 (and (slot-declaration-p decl)
	      (eq (get-option :allocation decl) :class)))))

(def-unparse class-declaration (e)
  (pprint-logical-block (*standard-output* nil)
    (write-documentation e)
    (format t "~:[~;abstract ~]~/write-options/class ~/pp/" 
	    (abstract-class-declaration-p e) e (class-declaration-name e))
    (let ((super (class-declaration-superclass e))
	  (mixins (type-reference-list-elements (class-declaration-mixins e))))
      (unless (root-class-declaration-p super)
	(format t " extends ~/pp/" super))
      (unless (null mixins)
	(format t " implements ~{~/pp/~^, ~}" mixins)))
    (unparse-type-body-declaration
     (type-body-elements (type-declaration-body e)))))

(defparameter *type-body-declarations-order*
  '(("// constructors" :constructors)
    ("// member classes" :member-classes)
    ("// finalizers" :finalizers)
    ("// accessors" :accessors)
    ("// methods" :methods)
    ("// key methods" :key-methods)
    ("// trace methods" :tracing-methods)
    ("// constants" :constants)
    ("// slots" :slots)
    ("// static blocks" :static-blocks)))

(defmethod unparse-type-body-declaration (elems)
  (format t " {~4I")
  (let ((cats (make-hash-table :test #'eq)))
    (flet ((add-to-category (elem cat)
	     (push elem (gethash cat cats (list))))
	   (category-elements (cat)
	     (reverse (gethash cat cats))))
      (dolist (e elems)
	(cond ((constructor-declaration-p e)
	       (add-to-category e :constructors)
	       (when (needs-key-method-p e)
		 (add-to-category (generate-key-method e) :key-methods)))
	      ((type-declaration-p e)
	       (add-to-category e :member-classes))
	      ((accessor-declaration-p e)
	       (add-to-category e :accessors))
	      ((method-declaration-p e)
	       (add-to-category e :methods)
	       (when (needs-key-method-p e)
		 (add-to-category (generate-key-method e) :key-methods))
	       (when (needs-trace-method-p e)
		 ;;save old-name
		 (add-to-category (cons (method-declaration-name e) e) :traced-methods)
		 ;;as it will be changed after this
		 (add-to-category (generate-trace-method e) :tracing-methods)))
	      ((constant-declaration-p e)
	       (add-to-category e :constants))
	      ((slot-declaration-p e)
	       (add-to-category e :slots))
	      ((static-block-p e)
	       (add-to-category e :static-blocks))
	      (t
	       (error "Unknown declaration ~W" e))))
      (loop for (comment category) in *type-body-declarations-order*
	    do (write-type-body-elements comment (category-elements category)))
      (format t "~I~:@_}")
      ;;restore traced methods
      (loop for (name . meth) in (category-elements :traced-methods)
	    do (setf (method-declaration-name meth) name)))))

;;method-declarations

(defun generate-key-method (meth)
  (let ((new-meth (with-parent ((ast-node-parent meth))
		    (make-key-method meth))))
    (apply-visitors 'after-parse new-meth)
    new-meth))

;;A strategy that is also applicable to constructors
(defun make-key-method (meth-decl)
  (let ((name (method-declaration-name meth-decl))
	(parameters (parameter-list-elements (method-declaration-parameters meth-decl)))
	(options (method-declaration-options meth-decl))
	(count 0)
	(last-name 'args-passed))
    (let ((new-name (generate-key-method-name name))
	  (call-expr
	   `(send this ,name
		  ,@(mapcar #'(lambda (param)
				(if (eq (get-option :parameter-type param) :required)
				  (linj-original-name (variable-declaration-name param))
				  (if (supplied-p param)
				    `(not (= (logand ,last-name ,(ash 1 (1- count))) 0))
				    (prog1
					`(if (= (logand ,last-name ,(ash 1 count)) 0)
					  ,(or (and (variable-declaration-initializer param)
						    (ast-node-form (variable-declaration-initializer param)))
					       (get-default-initializer (get-type param)))
					  ,(linj-original-name (variable-declaration-name param)))
				      (incf count)))))
			    parameters)))
	  (key-params (remove-if #'supplied-p parameters)))
      (parse-method
       `(defmethod ,new-name
	 (,@(mapcar #'variable-declaration-name key-params) ,last-name)
	 ,@options
	 (declare ,@(mapcar #'(lambda (var)
				`(,(get-type var) ,(variable-declaration-name var)))
			    key-params)
	  (,(int-type) ,last-name)
	  ;;missing throws (reported by Espen Wiborg <espenhw@grumblesmurf.org>)
	  (throws ,@(mapcar #'type-reference-name (method-declaration-throws-list meth-decl))))
	 ,call-expr)))))

(defun generate-key-method-name (name)
  (conc-symbol name '-key))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def-syntax nested-class-declaration (type-body-declaration)
  ?statement/class-declaration)

(def-unparse nested-class-declaration (e)
  (unparse-object (nested-class-declaration-statement e) *standard-output*))

;;Each slot is something like
;;(name :type type :initform init :visibility :public :allocation :class :reader get-name)
;;or, to follow the convention for variable declarations
;;(name/type :initform init :visibility :public :allocation :class :reader get-name)

(defun parse-slot-declaration (slot)
  ;;First, detect slot/type form
  (when (name&type-p (first slot))
    (multiple-value-bind (name type)
	(extract-name&type (first slot))
      (setf slot (list* name :type type (rest slot)))))
  (if (member :initform (rest slot))
    (values (first slot)
	    (getf (rest slot) :type)
	    ;;For the init we build a list because nil is also a possible init (meaning Java's false)
	    (list (getf (rest slot) :initform))
	    (rest slot))
    (values (first slot)
	    (or (getf (rest slot) :type) (object-type))
	    nil
	    (rest slot))))

(defconstant +reader-name-prefix+ 'get-)

(defconstant +writer-name-prefix+ 'set-)

(defun refine-slot-options (name options)
  (cond ((endp options)
	 (list))
	((endp (rest options))
	 (error "Malformed slot list terminating with ~A" options))
	((eq (second options) 't)
	 (ecase (first options)
	   ((:initarg)
	    (cons (first options)
		  (cons (make-keyword name)
			(refine-slot-options name (rest (rest options))))))
	   ((:reader)
	    (cons (first options)
		  (cons (conc-symbol +reader-name-prefix+ name)
			(refine-slot-options name (rest (rest options))))))
	   ((:writer)
	    (cons (first options)
		  (cons (conc-symbol +writer-name-prefix+ name)
			(refine-slot-options name (rest (rest options))))))
	   ((:accessor)
	    (refine-slot-options
	     name
	     (append (list :reader t :writer t)
		     (rest (rest options)))))
	   ((:type :initform :final :transient :strictfp)
	    (cons (first options)
		  (cons (second options)
			(refine-slot-options name (rest (rest options))))))))
	(t
	 (ecase (first options)
	   ((:accessor)
	    (refine-slot-options
	     name
	     (append (list :reader (second options) :writer `(setf ,(second options)))
		     (rest (rest options)))))
	   ((:reader :writer :type :documentation :initarg
	     :initform :final :transient :strictfp :visibility)
	    (cons (first options)
		  (cons (second options)
			(refine-slot-options name (rest (rest options))))))))))

(defun create-reader-method (reader-name name type)
  `(defmethod-0 ,(or type :infer-it) ,reader-name
     (this) ()
     ,(list :category :reader :visibility :public) ;;might be destructively modified.
     (slot-value this ',name)))

(defun create-writer-method (writer-name name type inits)
  `(defmethod-0 :infer-it ,writer-name
    ,(if (symbolp writer-name)
	 `(this ,(build-variable-declaration-description name type inits))
	 `(,(build-variable-declaration-description name type inits) this))
    ()
    ,(list :category :writer :visibility :public) ;;might be destructively modified.
    (setf (slot-value this ',name) ,name)))

(defun build-variable-declaration-description (name type inits)
  (cond ((and type inits) `(,name (the ,type ,(first inits))))
	(type `(,name (the ,type)))
	(inits `(,name (the :infer-it ,(first inits))))
	(t `(,name (the ,(object-type-description))))))

(defun unbuild-variable-declaration-description (decl)
  (values (first decl)
	  (second (second decl))
	  (and (rest (rest (second decl)))
	       (list (third (second decl))))))

(defun define-slots-and-accessors (slots)
  (mapcan #'(lambda (slot)
	      (multiple-value-bind (name type inits options)
		  (parse-slot-declaration slot)
		(let ((options (refine-slot-options name options)))
		  (cons `(defslot-0 
			     ,(build-variable-declaration-description name type inits)
			     ,@options :visibility :protected)
			(let ((meths (list)))
			  (dolist-2 ((key value) options)
			    (case key
			      ((:reader)
			       (push (create-reader-method value name type) meths))
			      ((:writer)
			       (push (create-writer-method value name type inits) meths))
			      (t
			       )))
			  (nreverse meths))))))
	  slots))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;There are several things we want to do on class-declarations, namely
;;automatically generate constructors and also importing mixin code.

;;One of the most stupid things about the java language is the need for
;;constructors with as many parameters as the non-initialized class slots
;;and which just assign to 'this.slot' the value of the parameter 'slot'.
;;We will mechanize this.

;;Another of the (many) shortcomings of the Java language is the
;;non-inheritable constructors.  It would be very nice if all subclasses
;;could be initialized using the same constructor signature of some
;;superclass.
(defparameter *no-mixin-inheritance* nil
  "Don't use mixin inheritance.")

(defmethod visit :before ((e class-declaration) (visitor parse-tree-finish))
  ;;Mixins
  (unless *no-mixin-inheritance*
    (let ((mixins (mapcar #'get-type-declaration
			  (type-reference-list-elements (class-declaration-mixins e)))))
      (copy-mixins-declarations mixins e)))
  ;;Default constructors:
;;;Anonymous classes deserve special treatment:
;;;15.9.5.1 Anonymous Constructors
;;;An anonymous class cannot have an explicitly declared
;;;constructor. Instead, the compiler must automatically provide an
;;;anonymous constructor for the anonymous class. 
  (unless (or (get-option :no-default-constructor e)
	      (anonymous-class-declaration-p e) ;;don't apply this to anonymous classes!!
	      (find-if #'constructor-declaration-p
		       (type-body-elements (class-declaration-body e))))
    (add-constructors e))
  ;;Method combination:
  (unless (or (get-option :no-method-combinations e)
	      (mixin-declaration-p (find-declaration (class-declaration-superclass e))))
    (operate-methods-combination e))
  ;;Multiple dispatch:
  (unless (get-option :no-multiple-dispatch e)
    (operate-method-multi-dispatch e))
  ;;Parse methods.
  (when (or (get-option :make-xml-parse-method e)
	    (get-option :make-parse-method e))
    (let ((return-type (type-declaration-name e))
	  (slots (remove-if-not #'(lambda (elem)
				    (and (slot-declaration-p elem)
					 (not (constant-declaration-p elem))))
				(collect-all-slots e))))
      (let ((methods
	     (if (get-option :make-parse-method e)
	       (generate-parse-methods return-type slots)
	       (generate-xml-parse-methods return-type slots)))
	    (elems (type-body-elements (class-declaration-body e))))
	(dolist (meth methods)
	  (push (with-parent (elems) (parse-method meth))
		(type-body-elements (class-declaration-body e))))))))

;;To be used just after importing the mixins
(defmethod find-redefined-method (method (class class-declaration) &optional (exclude-self-p t))
  (or (and (not exclude-self-p)
	   (find-if #'(lambda (elem)
			(and (method-declaration-p elem)
			     (same-signature-p method elem)))
		    (type-body-elements (class-declaration-body class))))
      (and (not (root-class-declaration-p class))
	   ;;go through the superclass
	   (find-redefined-method method
				  (get-type-declaration (class-declaration-superclass class))
				  nil))))

(defmethod primary-method-p ((meth method-declaration))
  (endp (get-option :qualifiers meth)))

(defmethod before-method-p ((meth method-declaration))
  (member :before (get-option :qualifiers meth)))

(defmethod after-method-p ((meth method-declaration))
  (member :after (get-option :qualifiers meth)))

(defmethod around-method-p ((meth method-declaration))
  (member :around (get-option :qualifiers meth)))

(defun make-primary-name (name)
  (conc-symbol 'primary- name))

(defun make-before-name (name class-name)
  (conc-symbol 'before- name '- class-name))

(defun make-after-name (name class-name)
  (conc-symbol 'after- name '- class-name))

(defun operate-methods-combination (class)
  (let ((same-signature-methods (list))
	(class-name (type-declaration-name class)))
    (dolist (elem (type-body-elements (class-declaration-body class)))
      (when (method-declaration-p elem)
	(let ((bind (assoc elem same-signature-methods :test #'same-signature-p)))
	  (if bind
	    (setf (cdr bind) (cons elem (cdr bind)))
	    (setf same-signature-methods (acons elem nil same-signature-methods))))))
    (dolist (methods same-signature-methods)
      (let ((befores (remove-if-not #'before-method-p methods))
	    (afters (remove-if-not #'after-method-p methods))
	    (around (find-if #'around-method-p methods))
	    (primary (find-if #'primary-method-p methods))
	    (name (ast-node-form (method-declaration-name (first methods))))
	    (parameters (method-declaration-parameters (first methods)))
	    (redef (find-redefined-method (first methods) class)))
	(let ((redef-combination (and redef (intersection '(:standard-combination :around)
							  (get-option :qualifiers redef)))))
	  (dolist (method methods)
	    (cond ((primary-method-p method)
		   (when (or befores afters redef-combination)
		     (setf (method-declaration-name method)
			   (parse (make-primary-name name) 'linj-name))))
		  ((before-method-p method)
		   (setf (method-declaration-name method)
			 (parse (make-before-name name class-name) 'linj-name)))
		  ((after-method-p method)
		   (setf (method-declaration-name method)
			 (parse (make-after-name name class-name) 'linj-name)))
		  ((around-method-p method)
		   (when (or befores afters primary)
		     (error "Can't mix primary, before or after method with an around on the same class"))
		   (unless redef-combination
		     ;;Around without previous method combination.
		     ;;Must use around but converting call-next-method to call the primary
		     ;;We will leave that to the next-method-call
		     (push :around-combination (get-option :qualifiers method))))
		  (t
		   (error "Unknown method ~A" method))))
	  (when (or befores afters around)
	    (let ((args (mapcar #'variable-declaration-name (parameter-list-elements parameters))))
	      (unless (or primary redef-combination)
		(setf primary
		      (parse-method
		       `(defmethod ,(make-primary-name name) ,(ast-node-form parameters)
			 (send super ,name ,@args))))
		(push primary (type-body-elements (class-declaration-body class))))
	      (unless around
		;;Must build a method combination
		(let ((call (if redef-combination
			      `(call-next-method)
			      `(send this ,(make-primary-name name) ,@args))))
		  (push (parse-method
			 `(defmethod ,name :standard-combination ,(ast-node-form parameters)
			   ,@(mapcar #'(lambda (before)
					 (declare (ignore before))
					 ;;HACK: this must be improved to concat all the befores
					 `(send this ,(make-before-name name class-name) ,@args))
				     befores)
			   ,@(if afters
				 ;;HACK: the same thing must be done here...
				 (let ((forms `(,call
						(send this ,(make-after-name name class-name) ,@args))))
				   (if (void-type-p (get-type (or primary redef)))
				     forms
				     `((prog1 ,@forms))))
				 `(,call))))
			(type-body-elements (class-declaration-body class))))))))))))

;; (defun make-class-name (name class-name)
;;   (conc-symbol name '- class-name))

(defun specialized-parameters (meth)
  (remove-if-not #'(lambda (param)
		     (get-option :specialized param))
		 (parameter-list-elements (method-declaration-parameters meth))))

(defun operate-method-multi-dispatch (class)
  (let ((multi-methods (list)))
    (dolist (elem (type-body-elements (class-declaration-body class)))
      (when (and (method-declaration-p elem)
		 (some #'(lambda (param)
			   (get-option :specialized param))
		       (parameter-list-elements (method-declaration-parameters elem)))
		 (not (some #'(lambda (multi-method-list)
				(member elem multi-method-list))
			    multi-methods)))
	;;This method needs double dispatch
	(let ((ref-params (parameter-list-elements (method-declaration-parameters elem))))
	  (let ((generic-function-methods
		 (remove-if-not
		  #'(lambda (meth)
		      (let ((params
			     (parameter-list-elements
			      (method-declaration-parameters meth))))
			(and (= (length ref-params) (length params))
			     (every #'(lambda (ref-param param)
					(let ((ref-specialized (get-option :specialized ref-param))
					      (specialized (get-option :specialized param)))
					  (eq (and ref-specialized t)
					      (and specialized t))))
				    ref-params
				    params))))
		  (find-methods-named (method-declaration-name elem) class nil))))
	    (push (stable-sort
		   (remove-duplicates generic-function-methods :test #'same-signature-p :from-end t)
		   #'(lambda (params1 params2)
		       (every #'super-type-p (mapcar #'get-type params1) (mapcar #'get-type params2)))
		   :key #'specialized-parameters)
		  multi-methods)))))
    (dolist (generic-function-methods multi-methods)
      (let ((bodies (mapcar (compose #'ast-node-form #'method-declaration-body) generic-function-methods)))
	(loop
	 for (base-meth . meths) on generic-function-methods
	 and base-body in bodies 
;;	 do (print (list base-meth meths))
	 do (let* ((name (ast-node-form (method-declaration-name base-meth)))
		   (base-params (parameter-list-elements (method-declaration-parameters base-meth)))
		   (base-param (find-if #'(lambda (param) (get-option :specialized param)) base-params))
		   (dispatch-position (position base-param base-params))
		   (supertype
		    (reduce #'merge-types
			    (cons base-meth meths)
			    :key #'(lambda (meth)
				     (get-type
				      (nth dispatch-position
					   (parameter-list-elements
					    (method-declaration-parameters meth)))))))
		   (more-specific
		    (position-if #'(lambda (m)
				     ;;(format *trace-output* "Method: ~A~%base-param: ~A" m base-param)
				     (and (member m (type-body-elements (class-declaration-body class)))
					  (let* ((base-params (parameter-list-elements (method-declaration-parameters m)))
						 (base-param2 (find-if #'(lambda (param) (get-option :specialized param)) base-params)))
					    ;;(format *trace-output* "base-param2: ~A~%" base-param2)
					    (super-type-p (get-type base-param2) (get-type base-param)))))
				 generic-function-methods
				 :from-end t)))
	      (if (equal-type-p supertype (get-type base-param))
		(if (member base-meth (type-body-elements (class-declaration-body class)))
		  (setf (method-declaration-body base-meth)
			(parse (list (dispatch-body
				      name
				      (first (ast-node-form base-param))
				      dispatch-position
				      (reverse meths)
				      (if more-specific
					`((macrolet ((call-next-method ()
						       `,',(let ((new-params (parameter-list-elements (method-declaration-parameters (nth more-specific generic-function-methods)))))
								`(send this ,name
								  ,@(mapcar #'(lambda (param)
										(if (get-option :specialized param)
										  (parse `(force-the ,(copy-type (get-type param)) ,(first (ast-node-form base-param)))
											 'cast-expression)
										  (first (ast-node-form param))))
									    new-params)))))
					    ,@base-body))
					base-body)))
			       'statement-list)
			(inferred-type-node-type base-param) (with-parent (base-param) supertype))
		  (push (parse-method
			 `(defmethod ,name (,(first
					      (ast-node-form
					       (method-declaration-parameters base-meth)))
					    ,@(mapcar #'(lambda (param)
							  (if (eq param base-param)
							    `(,(first (ast-node-form param))
							      (the ,supertype))
							    param))
						      base-params))
			   ,(dispatch-body
			     name
			     (first (ast-node-form base-param))
			     dispatch-position
			     (reverse meths)
			     ;;This method came from a superclass. Do we
			     ;;have a more specific version (that is, a
			     ;;method belonging to this class that is
			     ;;specialized in a superclass of the
			     ;;current parameter specializer)?
			     (let ((more-specific
				    (position-if #'(lambda (m)
						     ;;(format *trace-output* "Method: ~A~%base-param: ~A" m base-param)
						     (and (member m (type-body-elements (class-declaration-body class)))
							  (let* ((base-params (parameter-list-elements (method-declaration-parameters m)))
								 (base-param2 (find-if #'(lambda (param) (get-option :specialized param)) base-params)))
							    ;;(format *trace-output* "base-param2: ~A~%" base-param2)
							    (super-type-p (get-type base-param2) (get-type base-param)))))
						 generic-function-methods
						 :from-end t)))
			       (if more-specific
				 (nth more-specific bodies)
				 `((call-next-method)))))))
			(type-body-elements (class-declaration-body class))))
		(push (parse-method
		       `(defmethod ,name (this
					  ,@(mapcar #'(lambda (param)
							(if (eq param base-param)
							  `(,(first (ast-node-form param))
							    (the ,supertype))
							  param))
						    base-params))
			 ,(dispatch-body
			   name
			   (first (ast-node-form base-param))
			   dispatch-position
			   (reverse (cons base-meth meths))
			   `((error ,(format nil "No methods applicable for ~A with arg ~~A" name)
			      ,(first (ast-node-form base-param)))))))
		      (type-body-elements (class-declaration-body class))))))))))

(defun dispatch-body (name spec-param dispatch-position new-meths body)
  (if new-meths
    (let ((clauses
	   (mapcar #'(lambda (ref-meth)
		       (let ((new-params (parameter-list-elements (method-declaration-parameters ref-meth))))
			 (let ((new-specialized-param (nth dispatch-position new-params)))
			   `((or (null ,spec-param)
			      (typep ,spec-param ',(copy-type (get-type new-specialized-param))))
			     (send this ,name
			      ,@(mapcar #'(lambda (param)
					    (if (get-option :specialized param)
					      (parse `(force-the ,(copy-type (get-type param)) ,spec-param)
						     'cast-expression)
					      (first (ast-node-form param))))
					new-params))))))
		   new-meths)))
      `(cond ,@clauses
	(t ,@body)))
    `(progn ,@body)))

(defun initable-slots (slots)
  (remove-if #'(lambda (slot)
		 (or (eq (get-option :allocation slot) :class)
		     (null (get-option :initarg slot))
		     (get-option :final slot)))
	     slots))

(defun merge-default-initargs (slots default-initargs)
  (if default-initargs
    (mapcar #'(lambda (slot)
		(let ((init-name (get-option :initarg slot)))
		  (if init-name
		    (let ((init (getf default-initargs init-name)))
		      (if init
			(let ((defslot-0-form (ast-node-form slot)))
			  ;;(defslot-0 (name (the <type> ...)) :etc etc)
			  (multiple-value-bind (name type inits)
			      (unbuild-variable-declaration-description (second defslot-0-form))
			    (declare (ignore inits))
			    (with-parent ((ast-node-parent slot))
					 (parse `(defslot-0 
						   ,(build-variable-declaration-description name type (list init))
						   ,@(rest (rest defslot-0-form)))
						'slot-declaration))))
			slot))
		    slot)))
	    slots)
    slots))

(defmethod collect-all-slots ((e class-declaration) &optional (defaults (list)))
  (if (root-class-declaration-p e)
    (list)
    (append (merge-default-initargs (class-slots e) defaults) 
	    (collect-all-slots (get-type-declaration (class-declaration-superclass e)) 
			       (append (get-option :default-initargs e (list))
				       defaults)))))

;;To define constructors, we will consider several strategies

;;0 - the basic strategy is to use a defmethod form on something
;;related to 'initialize-instance' (currently, defnew and defafternew
;;forms) that is solely responsible for initializing the current slots
;;and call-next-method.  Let's call these constructors 'NEW
;;constructors'.

;;1 - the classical strategy is to collect initargs from current and
;;superclasses and define a constructor with all initargs that calls
;;the super construtor with all super initargs and sets the current
;;slots.  Being repeated on every class, this creates a natural set of
;;constructors.  However, there are no fancy initializations, e.g.,
;;computing initializations from other initializations.  Let's call
;;these constructors 'KEY constructors'.

;;2 - the 'Java' strategy is to allow a kind of 'BOA constructor'
;;where we specify the parameter list, presumably using some &aux
;;parameters to specify dependent initializations.  It's obvious that
;;we can initialize our own slots using the arguments passed to the
;;BOA lambda list.  The problem is the initialization of the inherited
;;slots.  We cannot simply set them to the corresponding arguments
;;because not calling the superclass constructor entails that a
;;default constructor is automatically called in the superclass, and
;;this default constructor might not even exist.  There are several
;;options here:

;;2.0 - the superclass implements a KEY constructor.  This is good,
;;because we can simply call that constructor with all its initarg
;;slots that have a corresponding value in the BOA lambda list.

;;2.1 - the superclass implements one or more BOA constructors.  We
;;can choose from that set one that closely matches the non-local
;;slots that are available in the BOA lambda list.  Note that this
;;identification is done using the slot names (and maybe also their
;;types).

;;2.2 - superclass implements one or more NEW constructors.  We could
;;try to apply the same logic of identifying the best constructor
;;according to the names (and types) of the parameters but,
;;unfortunately, NEW constructors have too much latitude of
;;implementation to allow a reliable selection.

;;Final considerations:

;; - if there are initargs in the current class, there must be a KEY
;; constructor.

;; - if there are no initargs in the current class, neither there are
;; BOA constructors or NEW constructors, but there is a KEY
;; constructor in the superclass, there must be a KEY constructor.

(defmethod add-constructors ((e class-declaration))
  (let ((superclass (get-type-declaration (class-declaration-superclass e))))
    (let ((boas (get-option :constructor e))
	  (super-boas (get-option :constructor superclass)))
      (let ((default-initargs (get-option :default-initargs e (list))))
	(let ((inits (initable-slots (merge-default-initargs (class-slots e) default-initargs)))
	      (super-inits (initable-slots (collect-all-slots superclass default-initargs))))
	  (let ((lambda-lists
		 (if (or (not (endp inits))  ;;we have initargs or
			 (and (not (endp super-inits)) ;;we have super initargs
			      (endp boas)              ;;and no BOA constructor nor NEW constructor
			      (notany #'constructor-declaration-p (type-body-elements (class-declaration-body e)))))
		   (cons (make-lambda-list-from-inits (append inits super-inits))
			 boas)
		   boas)))
	    (dolist (constructor (make-constructors lambda-lists (class-slots e) super-boas super-inits))
	      (push constructor (type-body-elements (class-declaration-body e)))
	      (apply-visitors 'after-parse constructor))))))))
;; 	  (unless (and (endp slots) (endp superclasses-slots)) ;;a default constructor
;; 	    ;;is assured by java itself, as long as there is no other constructor
;; 	    ))))))

(defun initparam (slot)
  (let ((ast (ast-node-form (slot-declaration-statement slot)))
	(name (get-option :initarg slot)))
    ;;bc the symbol is usually in the package keyword
    (if name `(,(read-from-string (princ-to-string name)) ,@(rest ast)) ast)))

(defun make-lambda-list-from-inits (inits)
  `(&key ,@(mapcar #'initparam inits)))

(defun in-lambda-list-p (name lambda-list)
  (member name lambda-list :key #'(lambda (param) (if (consp param) (first param) param))))

(defun find-super-boa (boas lambda-list)
  (let ((good-boas
	 (sort 
	  (remove-if-not #'(lambda (params)
			     (every #'(lambda (param)
					(in-lambda-list-p (if (consp param) (first param) param) lambda-list))
				    (break-list-if #'(lambda (param)
						       (member param lambda-list-keywords))
						   params)))
			 boas)
	  #'>
	  :key #'length)))
    (if good-boas
      (let ((args
	     (loop for param in (first good-boas)
		   until (member param lambda-list-keywords)
		   when (in-lambda-list-p (if (consp param) (first param) param) lambda-list)
		   collect param)))
	(if args
	  (list `(call-next-method ,@args))
	  (list)))
      (list))))

(defun make-constructors (lambda-lists slots super-boas super-inits)
  (let ((superslots-params (mapcar #'initparam super-inits)))
    (mapcar #'(lambda (lambda-list)
		(let ((slots (remove-if-not #'(lambda (slot) (in-lambda-list-p (first (initparam slot)) lambda-list)) slots))
		      (superslots-params (remove-if-not #'(lambda (slot) (in-lambda-list-p (first slot) lambda-list)) superslots-params)))
		  (parse-method
		   `(defnew ,lambda-list
		     ,@(if (null super-inits) ;;no KEY constructor on superclass
			   (find-super-boa super-boas lambda-list)
			   `((call-next-method ,@(mapcar #'first superslots-params))))
		     ,@(mapcar
			#'(lambda (slot)
			    (let ((slot-name
				   (linj-original-name (variable-declaration-name (slot-declaration-statement slot)))))
			      (let ((key-name (or (get-option :initarg slot) slot-name)))
				`(setf (slot-value this ',slot-name)
				  ,(read-from-string (princ-to-string key-name))))))
			slots)))))
	    lambda-lists)))

(defun copy-mixins-declarations (mixins e)
  (dolist (mixin mixins)
    (copy-mixins-declarations (mapcar #'get-type-declaration
				      (type-reference-list-elements (mixin-declaration-supermixins mixin)))
			      e)
    (let ((mixin-elems (type-body-elements (mixin-declaration-body mixin))))
      (dolist (elem mixin-elems)
	(cond ((or (defvar-declaration-p elem)
		   (abstract-method-declaration-p elem))
	       nil) ;;do-nothing
	      ((or (method-declaration-p elem)
		   (slot-declaration-p elem))
	       (let ((copy (with-parent (e)
			     (parse (ast-node-form elem)
				    'type-body-declaration)))) ;;HACK This is
		 ;;wrong bc it might cause package capture problems.
		 ;;There's also the problem of not dealing with local-macros.
		 (setf (type-body-elements (class-declaration-body e))
		       (nconc (type-body-elements (class-declaration-body e)) (list copy)))
;		 (apply-visitors 'after-parse copy)
		 ))
	      (t
	       (linj-error "What's this? (~W)" elem)))))))

;;This must be improved to include the package name in the external representation
(defun generate-parse-methods (type-ref slots)
  (let ((type (ast-node-form type-ref)))
    (let ((name (class-or-interface-type-reference-name type-ref))
	  (pkg (class-or-interface-type-reference-package type-ref)))
      (labels ((make-initarg-keyword (initarg name)
		 (if (eq initarg t)
		   (make-keyword name)
		   initarg))
	       (make-init-and-let-binding (slot)
		 (let ((initarg (get-option :initarg slot)))
		   (when initarg 
		     (let ((var (slot-declaration-statement slot)))
		       (let ((name (variable-declaration-name var))
			     (init (variable-declaration-initializer var))
			     (type (get-type var)))
			 (let ((initarg-key (make-initarg-keyword initarg name)))
			   (list
			    `(,type ,name ,initarg-key ,init)))))))))
	(let ((inits-binds (mapcan #'make-init-and-let-binding slots)))
	  (list
	   `(defun parse (internal-raw-data/cons)
	     (let* ((internal-raw-data-keys (rest internal-raw-data)))
	       (if (not (eq ',name (first internal-raw-data)))
		 (error 'class-parse-exception
			(format nil "Error parsing class ~S object: ~S"
				',name internal-raw-data))
		 (make-instance
		     ',type
		   ,@(mapcan #'(lambda (init-bind)
				 (let ((initarg-key (third init-bind))
				       (init (fourth init-bind)))
				   `(,initarg-key
				     (getf internal-raw-data-keys
				      ',initarg-key
				      ,(or (and init (ast-node-form init))
					   'null)))))
			     inits-binds)))))
	   `(defmethod to-string ()
	     (format nil
	      ,(format nil "#S(~A ~{:~A ~~A~^ ~})" 
		       name
		       (mapcar #'(lambda (init-bind)
				   (linj-original-name (second init-bind)))
			       inits-binds))
	      ,@(mapcar #'(lambda (init-bind)
			    (let ((type (first init-bind))
				  (name (second init-bind)))
			      (if (string-type-p type)
				`(format nil "\"~A\"" ,name)
				name)))
			inits-binds)))))))))

(defun generate-xml-parse-methods (type-ref slots)
  type-ref;;to be finished
  (list
   `(defmethod-0 object from-xml (xml/java.lang.string) ()
      (:visibility :public)
      (new 'object))
   `(defmethod-0 java.lang.string to-xml () ()
      (:visibility :public)
      (format nil
	      ,(format nil "~{<~A>~%~~A~%</~:*~A>~%~}" 
		       (mapcar #'(lambda (slot)
				   (variable-declaration-name (slot-declaration-statement slot)))
			       slots))
	      ,@(mapcar #'(lambda (slot)
			    (variable-declaration-name (slot-declaration-statement slot)))
			slots)))))

(defun process-type-options (slots options)
  (declare (ignore slots))
  (let ((body (list))
	(new-options (list)))
    (dolist (option options)
      (ecase (first option)
	(:body (setf body (append body (rest option))))
	;; see <../2001/20010324#* Linj> for a discussion on the following
	((:make-parse-method :make-xml-parse-method :visibility :documentation :category)
	 (setf new-options (append option new-options)))
	((:default-initargs :constructor)
	 (setf new-options (cons (first option) (cons (rest option) new-options))))))
    (values new-options body)))

;;HACK: It would be more helpfull to be able to inherit exclusively
;;from mixins without being forced to also include object!
(def-macro-transform class-declaration
    (defclass ?class ?superclasses ?slots . ?options&body)
    (multiple-value-bind (options body)
	(process-type-options ?slots ?options&body)
      `(defclass-0 ,?class ,(or (first (last ?superclasses)) (object-type-description))
	 ,(butlast ?superclasses)
	 ,options
	 ,@(define-slots-and-accessors ?slots)
	 ,@body)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;The defstruct is sometimes usefull

;;Warning: this doesn't allow for the specification of a superclass.  To be
;;able to do that I would have to instruct the Linj compiler to save the
;;defstruct slots of each definition so that they might be used latter.
;;Nothing impossible but I don't feel like opening that door right
;;now. (Anyway, with the (lisp ...) and (lisp-effect ...) forms it seems
;;quite easy to do that.
(def-macro-transform class-declaration
  (defstruct ?name . ?slots)
  (multiple-value-bind (name options)
      (if (atom ?name)
	(values ?name (list))
	(values (first ?name) (rest ?name)))
    (multiple-value-bind (slots body)
	(break-list-if #'(lambda (form) (and (consp form) (eq (first form) :body))) ?slots)
      (let ((struct
	     `(defclass ,name ()
		,(mapcar #'(lambda (slot)
			     (multiple-value-bind (slot-name initform options)
				 (if (symbolp slot)
				   (values slot nil nil)
				   (values (first slot) (second slot) (rest (rest slot))))
			       (let ((accessor (conc-symbol name '- slot-name))
				     (initarg (make-keyword slot-name)))
				 (if (or (atom slot) (endp (rest slot)))	;;slot or (slot)
				   `(,slot-name :type object :accessor ,accessor :initarg ,initarg)
				   (let ((reader-or-accessor (if (getf options :read-only) :reader :accessor)))
				     `(,slot-name :initform ,initform
						  ,@(and (getf options :type) `(:type ,(getf options :type)))
						  ,reader-or-accessor ,accessor
						  :initarg ,initarg))))))
			 slots)
		;;HACK should this be set by default?       (:make-parse-method t)
		,@body)))
	(let ((constructors (remove :constructor options :key #'first :test-not #'eq)))
	  (if constructors
	    `(progn
	       ,struct
	       ,@(mapcar #'(lambda (constructor)
			     (destructuring-bind (constructor-name lambda-list)
				 (rest constructor)
			       `(defun ,constructor-name ,lambda-list
				  (make-instance ',name
						 ,@(mapcan #'(lambda (param)
							       (cond ((consp param) (list (make-keyword (first param)) (first param)))
								     ((member param lambda-list-keywords) (list))
								     (t (list (make-keyword param) param))))
							   lambda-list)))))
			 constructors))
	    struct))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;We must keep package information available at runtime.
;;We will represent packages as a sequence of hashtables.

(defparameter *packages* (make-hash-table :test #'equal))

(defun add-package-type-info (package type info)
  (labels ((add-info (table package)
	     (if (endp package)
	       (setf (gethash type table) info)
	       (let ((subtable (gethash (first package) table)))
		 (unless subtable
		   (setq subtable (make-hash-table :test #'equal))
		   (setf (gethash (first package) table) subtable))
		 (add-info subtable (rest package))))))
    (add-info *packages* package)))

(defun get-package-type-info (package type)
  (labels ((get-info (table package)
	     (if (endp package)
	       (gethash type table)
	       (let ((subtable (gethash (first package) table)))
		 (and subtable
		      (get-info subtable (rest package)))))))
    (get-info *packages* package)))

(defun add-type-declaration-info (type-decl)
  (let ((type-def (type-declaration-name type-decl)))
    (add-package-type-info (class-or-interface-type-reference-package type-def)
			   (class-or-interface-type-reference-name type-def)
			   type-decl)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;(defparameter *java-server-command* 
;;;    (format nil "cd ~ALMI; java JavaToLMI"
;;;            (make-pathname :directory (pathname-directory *load-truename*))))

(defparameter *java-server-process* (create-server-process))

(defun get-package-type-info-from-java-server (package name)
  (with-linj-syntax () ;;The class loader needs $ to disambiguate between package.class and class.inner-class
    (let ((type (format nil "~{~A.~}~{~A~^$~}" package (split-at-char (princ-to-string name) #\/))))
      (let ((decl (ask-server *java-server-process* type)))
	(when decl
	  (format *trace-output* "Reading info for ~A~%" type)
	  (let ((type (parse decl 'type-declaration)))
	    (save-foreign-type-declaration type)
	    type))))))

(defmethod save-foreign-type-declaration ((type type-declaration))
  (setf (get-option :foreign type) t)
  (add-type-declaration-info type))

(defmethod foreign-type-p (type)
  (get-option :foreign type nil))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;HACK:: All this anonymous stuff must be changed
;;Anonymous type references are just like normal references but
(defun anonymous-type-reference-p (type-reference)
  (null (symbol-package (class-or-interface-type-reference-name type-reference))))

(defmethod get-type-declaration ((type class-or-interface-type-reference))
  (if (anonymous-type-reference-p type)
    (ast-node-parent type)
    (or (let ((containing-type-declaration (containing-type-declaration type)))
  	  (and containing-type-declaration
  	       (find-declaration-in type containing-type-declaration)))
	(let ((package (class-or-interface-type-reference-package type))
	      (name (class-or-interface-type-reference-name type)))
	  (or (get-package-type-info package name)
	      (let ((location (find-package-type-location package name)))
		(and location
		     (let ((unit (get-compilation-unit-from-location location)))
		       (unless (package= package
					 (package-declaration-components
					  (compilation-unit-package unit)))
			 (error "Inferred package: ~A vs compilation unit package: ~A"
				package
				(package-declaration-name
				 (compilation-unit-package unit))))
		       (find type (compilation-unit-type-declarations unit)
			     :key #'type-declaration-name
			     :test #'equal-type-p))))
	      (get-package-type-info-from-java-server package name)
	      (linj-error "Couldn't find type declaration for ~S in package ~S"
			  type package))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defparameter *package-locations* ())

(defun add-package-location (location)
  (push (parse-namestring location) *package-locations*))

(defun find-package-type-location (package type)
  (with-linj-syntax ()
    (let ((path (make-pathname
		 :directory (cons :relative
				  (if (empty-package-p package)
				    ()
				    (mapcar #'linj-name-to-linj-file-name package)))
		 :name (first (split-at-char (princ-to-string (linj-original-name type)) #\/))
		 :type "linj")))
      (dolist (loc *package-locations* nil)
	(let ((path (merge-pathnames path loc)))
	  (when (probe-file path)
	    (return path)))))))

(defun add-package-location-from-linjpath ()
  (let ((linjpath (or (get-env "LINJPATH")
		      (directory-namestring *load-truename*))))		       
    (dolist (path (split-at-char linjpath #\:))
      (let ((comps (remove "" (split-at-char path #\/) :test #'string=)))
	(unless (null comps)
	  (push (make-pathname :directory
			       (if (string= (first comps) ".")
				 (cons :relative (rest comps))
				 (cons :absolute comps)))
		*package-locations*))))))


(add-package-location-from-linjpath)

;;;;;;;;;;;;;;Reading compilation units;;;;;;;;;;;;;;;;;;;;

(def-list-syntax compilation-unit-list (linj-list-node) compilation-unit-member)

(def-syntax compilation-unit (linj-node)
  (compilation-unit . ?components/compilation-unit-list)
  :slots
  ((name
    :accessor compilation-unit-name
    :initform nil)
   (location
    :accessor compilation-unit-location
    :initform nil)
   (time-stamp
    :accessor compilation-unit-time-stamp
    :initform nil)
   (parameters
    :accessor compilation-unit-options
    :initform nil)
   (package 
    :accessor compilation-unit-package 
    :initform nil)
   (imports
    :accessor compilation-unit-imports 
    :initform (list))
   (ins
    :accessor compilation-unit-ins
    :initform (list))
   (type-declarations
    :accessor compilation-unit-type-declarations
    :initform (list))))

(def-unparse compilation-unit (e)
  (unless (empty-package-p (package-declaration-components (compilation-unit-package e)))
    (format t "~/pp/~%~%" (compilation-unit-package e)))
  (let ((imports (sort (remove (java.lang.*-type)
			       (compilation-unit-imports e)
			       :test #'equal-type-p
			       :key #'import-declaration-type)
		       #'string<
		       :key #'(lambda (import)
				(format nil "~/pp/" import)))))
    (unless (endp imports)
      (format t "~{~/pp/~%~}~%" imports)))
  (format t "~{~/pp/~^~3%~}" (compilation-unit-type-declarations e)))

(defmethod containing-compilation-unit ((e compilation-unit))
  e)

(defmethod containing-compilation-unit ((e linj-node))
  (containing-compilation-unit (ast-node-parent e)))

;;Escaped from ast-tree
(defmethod containing-compilation-unit ((e null))
  (error "Empty parent"))

(defun list-difference (l1 l2)
  (remove-if #'(lambda (e) 
		 (member e l2))
	     l1))

(defun split-if (pred list)
  (let ((list-pred (remove-if-not pred list)))
    (values list-pred (list-difference list list-pred))))

(defmethod refine-compilation-unit ((e compilation-unit))
  (let ((types (compilation-unit-type-declarations e)))
    (let ((public-type
	   (or (find (compilation-unit-name e) types
		     :key (compose #'type-reference-name #'type-declaration-name))
	       (first types))))
      (assert (or (null (get-option :visibility public-type))
		  (eq (get-option :visibility public-type) :public)))
      (setf (get-option :visibility public-type) :public) ;;one of them must be public
      (dolist (type (remove public-type types)) ;;and the others have package visibility
	(unless (get-option :visibility type)
	  (setf (get-option :visibility type) :package))))
    (dolist (type types)
      ;;Top-level type declarations have the compilation-unit package
      (set-type-definition-package
       (type-declaration-name type)
       (package-declaration-components (compilation-unit-package e)))
      ;;All the others have a null package (they're accessed through the
      ;;containing class
      (set-all-unknown-package-type-definition type (empty-package)))
    e))

;;;To define the package in type declarations:

(defmethod set-type-definition-package ((e class-or-interface-type-reference) package)
  (setf (class-or-interface-type-reference-inferred-package e) package))

(defclass set-unknown-package-visitor ()
  ((package :initarg :package :reader visitor-package)))

(defmethod visit :before ((e type-declaration) (visitor set-unknown-package-visitor))
  (set-if-unknown-package (type-declaration-name e) (visitor-package visitor)))

(defmethod set-all-unknown-package-type-definition ((type type-declaration) package)
  (visit type (make-instance 'set-unknown-package-visitor :package package)))

;;To resolve static references:

(defmethod find-declaration-in ((ref reference) (e compilation-unit))
  (or (some #'(lambda (type)
		(find-declaration-in-type ref type))
	    (remove-if-not #'type-declaration-p
			   (compilation-unit-list-elements
			    (compilation-unit-components e))))
      (some #'(lambda (in-decl)
		(find-declaration-in-type ref (get-type-declaration (in-declaration-object in-decl))))
	    (remove-if-not #'in-declaration-p
			   (compilation-unit-list-elements
			    (compilation-unit-components e))))))
  
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defparameter *compilation-units* (make-hash-table :test #'equal))

(defun add-loaded-compilation-unit (unit)
  (setf (gethash (compilation-unit-location unit) *compilation-units*)
    unit))

(defparameter *always-load-p* nil)

(defun get-loaded-compilation-unit (location)
  (and (not *always-load-p*)
       (gethash location *compilation-units*)))

(defun get-compilation-unit-from-location (location &optional (error-value :error))
  (let ((unit (get-loaded-compilation-unit location)))
    (if (or (null unit)
	    (let ((time-stamp (compilation-unit-time-stamp unit)))
	      (and (probe-file location) ;;might have been deleted...
		   (> (file-write-date location) time-stamp)
		   (progn
		     (format *trace-output* "Rereading location ~A~%" location)
		     t))))
      (read-compilation-unit-from-location location error-value)
      unit)))

(defun read-compilation-unit-from-location (location &optional (error-value :error))
  (with-linj-syntax ()
    (with-open-file (f location
		       :direction :input
		       :if-does-not-exist error-value)
      (when f
	(format *trace-output* "Reading file ~A~%" location)
	(let ((unit (read-compilation-unit-from-stream
		     f
		     location
		     (file-write-date location))))
	  (add-loaded-compilation-unit unit)
	  (apply-visitors 'after-parse unit)
	  unit)))))

(defun read-one-form (stream eof-errorp eof-value)
  (read stream eof-errorp eof-value))
;;This is experimental to accept inlined Java code between Linj code
;   (let ((ch (peek-char t stream eof-errorp eof-value)))
;     (cond ((eq ch eof-value)
; 	   eof-value)
; 	  ((char= ch #\()
; 	   (read stream eof-errorp eof-value))
; 	  ((char= ch #\;)
; 	   (read-line stream eof-errorp eof-value)
; 	   (read-one-form stream eof-errorp eof-value))
; 	  (t
; 	   (let ((buffer (make-string-output-stream)))
; 	     (do ((line (read-line stream eof-errorp eof-value) (read-line stream eof-errorp eof-value)))
; 		 ((or (eq line eof-value)
; 		      (char= (peek-char t stream eof-errorp eof-value) #\())
; 		  (get-output-stream-string buffer))
; 	       (write-line line buffer)))))))


(defun read-all-forms-until-eof (stream)
  (labels ((read-forms-until-eof
	    ()
	    (let ((form (read-one-form stream nil :eof)))
	      (cond ((eq form :eof)
		     (list))
		    ((stringp form)  ;;Parse here or in the parse methods?
		     (cons form (read-forms-until-eof)))
		    (t
		     (cons form (read-forms-until-eof)))))))
    (read-forms-until-eof)))

;;We impose some restrictions on what we expect:
;;first, an optional package declaration,
;;second, optional package imports,
;;third, an optional type declaration, if not present a defstruct is generated
;;then all the remaining mess that will belong to the first class above it or, in
;;case of properly specialized methods, to the referred type
(defun combine-compilation-unit-forms (unit forms &optional (expecting :package))
  (if (endp forms)
    (if (eq expecting :types)
      ;;The end! Define the components
      (setf (compilation-unit-components unit)
	    (parse (cons (compilation-unit-package unit)
			 (append (compilation-unit-imports unit)
				 (append (compilation-unit-ins unit)
					 (compilation-unit-type-declarations unit))))
		   'compilation-unit-list))
      (error "Was expecting a type declaration but found none"))
    (let ((form (first forms)))
      (ecase expecting
	(:package
	 (cond ((package-declaration-p form)
		(setf (compilation-unit-package unit) form)
		(combine-compilation-unit-forms unit (rest forms) :imports))
	       (t
		(setf (compilation-unit-package unit)
		      (with-parent (unit) (parse `(package nil) 'package-declaration)))
		(combine-compilation-unit-forms unit forms :imports))))
	(:imports
	 (cond ((package-declaration-p form)
		(error "Unexpected package declaration ~A" form))
	       ((import-declaration-p form)
		(setf (compilation-unit-imports unit) (nconc (compilation-unit-imports unit) (list form)))
		(combine-compilation-unit-forms unit (rest forms) :imports))
	       ((in-declaration-p form)
		(setf (compilation-unit-ins unit) (nconc (compilation-unit-ins unit) (list form)))
		(combine-compilation-unit-forms unit (rest forms) :imports))
	       (t 
		(combine-compilation-unit-forms unit forms :types))))
	(:types
	 (cond ((package-declaration-p form)
		(error "Unexpected package declaration ~A" form))
	       ((import-declaration-p form)
		(error "Unexpected import statement ~A" form))
	       ((in-declaration-p form)
		(error "Unexpected in declaration ~A" form))
	       ((type-declaration-p form)
		(setf (compilation-unit-type-declarations unit) (nconc (compilation-unit-type-declarations unit) (list form)))
		(combine-compilation-unit-forms unit (rest forms) :types))
	       ((type-body-declaration-p form)
		(let ((types (compilation-unit-type-declarations unit)))
		  (if (endp types)
		      (combine-compilation-unit-forms unit
						      (cons (with-parent (unit)
							      (parse `(defstruct ,(compilation-unit-name unit)) 'type-declaration)) forms)
						      expecting)
		      (let ((type
			     (or (and (method-declaration-p form)
				      (let ((type (method-declaration-specialized-to form)))
					(and type
					     ;;we search for equal type names because we can't infer yet the type packages
					     (or (find (type-reference-name type) types
						       :from-end t
						       :key (compose #'type-reference-name #'type-declaration-name)
						       :test #'equal-type-reference-name)
						 (error "Method specialized for unknown type ~A" form)))))
				 (first (last types)))))
			(setf (type-body-elements (type-declaration-body type))
			      (nconc (type-body-elements (type-declaration-body type)) (list form)))
			(combine-compilation-unit-forms unit (rest forms) expecting)))))
	       (t
		(error "Impossible syntatic category ~A" form))))))))

(def-syntax macro-definition (compilation-unit-member)
  (defmacro ?name . ?body))

(def-syntax syntax-macro-definition (compilation-unit-member)
  (defmacro-syntax ?name ?cat . ?body))

(defgeneric add-macro-definition (macro-def)
  (:method ((macro-def macro-definition))
    (let ((name (macro-definition-name macro-def))
	  (body (macro-definition-body macro-def)))
      (funcall (compile nil `(lambda () (def-macro ,name ,@body))))))
  (:method ((macro-def syntax-macro-definition))
    (let ((name (syntax-macro-definition-name macro-def))
	  (cat (syntax-macro-definition-cat macro-def))
	  (body (syntax-macro-definition-body macro-def)))
      (funcall (compile nil `(lambda () (def-syntax-macro ,name ,cat ,@body)))))))

(def-list-syntax top-level-forms (linj-list-node) top-level-form)

;;;But we also accept progns
(def-syntax progn-code (top-level-form)
  (progn . ?elements/top-level-forms))

(defun flatten-progn-code (form)
  (if (progn-code-p form)
    (mapcan #'flatten-progn-code (top-level-forms-elements (progn-code-elements form)))
    (list form)))

(defparameter *default-in-declarations*
  '(java.lang.math
    java.lang.system
    java.lang.thread
    linj.util))

(defun default-in-declarations ()
  (mapcar #'(lambda (type)
	      (parse `(in (the ,type)) 'in-declaration))
	  *default-in-declarations*))

(defun read-compilation-unit-from-stream (stream location time)
  (let ((type-form (read-from-string (with-<> (pathname-name location)))))
    (let ((name (type-reference-name (parse type-form 'type-reference)))
	  (forms (read-all-forms-until-eof stream)))
      ;;Each form can be:
      ;;a compilation-unit-member (package declaration, imports, class or mixin definitions)
      ;;a type-body-declaration (defslots, defconstants, defmethods, defuns, static blocks, etc)
      ;;a macro-definition (defmacro)
      ;;a progn that results from the expansion of a macro

      ;;First, we will collect all linj-options to prepare the compiler
      (multiple-value-bind (options forms)
	  (split-if #'(lambda (form) (let-pattern (((linj-options . ?ignore) form)) t)) forms)
	;;Next, we apply the options and we start parsing:
	(let ((all-options (reduce #'append options :key #'rest)))
	  (with-compilation-options (all-options)
	    (let ((parsed (mapcan #'(lambda (form)
				      (let ((macro (or (try-to-parse form 'macro-definition)
						       (try-to-parse form 'syntax-macro-definition))))
					(cond (macro
					       (unless (eq macro *ignore-parse*)
						 (add-macro-definition macro))
					       (list))
					      (t
					       (flatten-progn-code
						(or (try-to-parse form 'top-level-form)
						    (error "Couldn't parse form ~A" form)))))))
				  forms)))
	      ;;Now we must reorganize the forms so that type declarations belong to the compilation unit
	      ;;and type-body-declarations belong to the correct type-declaration
	      (let ((unit (make-instance 'compilation-unit)))
		(setf (compilation-unit-name unit) name)
		(setf (compilation-unit-location unit) location)
		(setf (compilation-unit-time-stamp unit) time)
		(setf (compilation-unit-imports unit) (list (new-import-declaration (java.lang.*-type))))
		(setf (compilation-unit-ins unit) (default-in-declarations))
		(setf (compilation-unit-options unit) all-options)
		(combine-compilation-unit-forms
		 unit
		 (mapcar #'(lambda (form) (with-parent (unit) form)) parsed))
		(refine-compilation-unit unit)
		(dolist (type (compilation-unit-type-declarations unit))
		  (add-type-declaration-info type))
		unit))))))))

(defmethod imported-type-p ((e class-or-interface-type-reference) (unit compilation-unit))
  (some #'(lambda (import)
	    (match-type
	     (import-declaration-type import)
	     e))
	(compilation-unit-imports unit)))

(defun linj-pathname (pathname)
  (with-simple-restart (abort "Abort Linjing pathname ~A" pathname)
    (loop
     (with-simple-restart (retry "Linj again pathname ~A" pathname)
       (let ((unit (get-compilation-unit-from-location pathname)))
	 (when (null unit)
	   (error "Couldn't find file ~A" pathname))
	 (return (write-compilation-unit unit)))))))

(defun linj2java (name &optional (directory (get-current-directory)))
  (unless (typep directory 'pathname)
    (setq directory (parse-namestring directory)))
  (linj-pathname (merge-pathnames (make-pathname :name (if (symbolp name) ;;backward compatability
							 (format nil "~(~A~)" name)
							 (format nil "~A" name))
						 :type "linj")
				  directory)))

(defun linj2java-directory (&optional (directory (get-current-directory)))
  (unless (typep directory 'pathname)
    (setq directory (parse-namestring directory)))
  (let ((pathnames
	 (directory
	  (make-pathname :directory (pathname-directory directory)
			 :name :wild :type "linj"))))
    (with-simple-restart (abort "Abort Linjing directory ~A" directory)
      (mapc #'linj-pathname pathnames))))

(defun java-name-from-class-name (name)
  (format nil "~W.java" name))

(defmethod write-compilation-unit ((unit compilation-unit))
  (with-linj-syntax ()
    (let ((name (linj-name-to-java-type-name (pathname-name (compilation-unit-location unit)))))
      (let ((location (merge-pathnames (make-pathname :name name :type "java")
				       (compilation-unit-location unit))))
	(with-open-file (f location :direction :output :if-exists :supersede)
	  (format *trace-output* "(Re)Writing file ~a~%" location)
	  (write-compilation-unit-to-stream unit f)
	  name)))))

(defmethod write-compilation-unit-to-stream (unit stream)
  (with-compilation-options ((compilation-unit-options unit))
    (apply-visitors 'before-dump unit)
    (unparse-linj unit stream)))

(defun unparse-linj (ast &optional (stream *standard-output*))
  (let ((*print-right-margin* 120)
 	(*print-miser-width* nil)  ;;The Java text editor never uses miser style
	(*print-length* nil)
	(*print-level* nil)
	(*print-pretty* t))
    (with-linj-syntax ()
      (unparse-object ast stream))))
  

(defun dump-loaded-compilation-units ()
  (maphash #'(lambda (path unit)
	       (declare (ignore path))
	       (write-compilation-unit unit))
	   *compilation-units*))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;The visitors scheme is based on transformations that are applied
;;;immediately after parse and immediately before unparse.  This separation
;;;is useful to avoid transformations that affect other transformations.

(defparameter *visitors* (make-hash-table))

(defun add-visitor (type visitor &optional (position :end))
  (setf (gethash type *visitors*)
    (cond ((eq position :end)
	   (nconc (gethash type *visitors*) (list visitor)))
	  ((eq position :begin)
	   (cons visitor (gethash type *visitors*)))
	  (t
	   (linj-error "Don't understand ~A" position)))))

(defun remove-visitor (type visitor)
  (setf (gethash type *visitors*)
    (delete visitor (gethash type *visitors*))))

(defvar *previous-visitors* (list))

(defun apply-visitors (type ast)
  (let ((visitors (gethash type *visitors*)))
    (assert (not (null visitors)))
    (let ((*previous-visitors* (list)))
      (dolist (visitor-class visitors ast)
	(let ((visitor (make-instance visitor-class)))
	  (visit ast visitor)
	  (push visitor *previous-visitors*))))))

(defun apply-previous-visitors (ast)
  (dolist (visitor *previous-visitors*)
    (visit ast visitor)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;Overriding methods:

;;Sometimes, we need to override a method.  Unfortunately, as soon as we
;;change the type of an argument or the number of arguments, we are
;;overriding nothing.  It would be interesting to be sure that a method
;;declaration is, in fact, overriding another method declaration on some
;;super-super-\ldots{}-class.  The idea to implement this is just to define
;;a visitor that walks the parse tree and that, on each method
;;declaration, checks the existence of an identical method (in terms of its
;;name) in the superclass path.  If the type of the parameters in both
;;method disagree, we generate an error:

;; (defclass a () ())
;; (defclass b (a) ())
;; (defclass c (b) ())
;; (defclass d (c) ())
;; (defclass e (c) ())

;; (defmethod xpto ((x a))
;;   1)

;; (defmethod xpto :after ((x b))
;;   (print 'after-b))

;; (defmethod xpto :before ((x c))
;;   (print 'before-c))

;; (defmethod xpto :after ((x c))
;;   (print 'after-c))

;; (defmethod xpto ((x d))
;;   2)

;; (defmethod xpto ((x e))
;;   3)

;; (defmethod xpto :before ((x e))
;;   (print 'before-e))

;; (defmethod xpto :after ((x e))
;;   (print 'after-e))
;; -------------------------------

;; (defmethod xpto ((x a))
;;   1)

;; (defmethod xpto ((x b))
;;   (prog1
;;       (primary-xpto x)
;;     (after-xpto-b x)))

;; (defmethod primary-xpto ((x b))
;;   (xpto super))

;; (defmethod after-xpto-b ((x b))
;;   (print 'after))

;; (defmethod xpto ((x c))
;;   (before-xpto-c x)
;;   (prog1
;;       (call-next-method)
;;     (after-xpto-c x)))

;; (defmethod primary-xpto ((x d))
;;   2)

;; (defmethod primary-xpto ((x e))
;;   3)

;; (defmethod xpto ((x e))
;;   (before-xpto-e x)
;;   (prog1
;;       (call-next-method)
;;     (after-xpto-e x)))
;; -------------------------------


;; (defclass overrides-visitor ()
;;   ())

;; (defmethod visit ((method method-declaration) (visitor overrides-visitor))
;;   (unless (constructor-declaration-p method)
;;     (let ((class (containing-type-declaration method)))
;;       (when (class-declaration-p class) ;;it might be a mixin
;; 	(let ((super-method (find-declaration-in method class)))
;; 	  (unless (or (null super-method)
;; 		      (same-signature-p method super-method))
;; 	    (override-error method super-method)))))))

;; (defun override-error (method super-method)
;;   (linj-error "The method ~W 
;; do not obeys the signature specified by the same method ~W
;; in the superclass ~W"
;; 	 method 
;; 	 super-method 
;; 	 (class-declaration-name (containing-type-declaration super-method))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;We want to be able to define :after methods on default constructors
(defclass link-afternew-transform ()
  ())

(defmethod visit :after ((e class-declaration) (visitor link-afternew-transform))
  (let ((after-new-decl (find-if #'after-new-declaration-p
				   (type-body-elements (class-declaration-body e)))))
    (when (not (null after-new-decl))
      (add-after-new-call (method-declaration-name after-new-decl) e))))


(defmethod add-after-new-call (after-new-name (e class-declaration))
  (if (anonymous-class-declaration-p e)
    (linj-error "Anonymous classes can't have defafternew declarations~%")
    (let ((constructors (remove-if-not #'constructor-declaration-p
				       (type-body-elements (class-declaration-body e)))))
      (if (null constructors)
	;; We have to generate the default one to call the after-new
	(let ((c (parse-method
		  `(defnew ()
		    (call-next-method)
		    (,after-new-name this)))))
	  (push c (type-body-elements (class-declaration-body e)))
	  (apply-visitors 'after-parse c))
	(dolist (c constructors)
	  (unless (eq :initialize-instance-key (method-declaration-name c))
	    (let ((s (parse `(,after-new-name this) 'statement)))
	      (setf (statement-list-elements (method-declaration-body c))
		    (append (statement-list-elements (method-declaration-body c))
			    (list s)))
	      (apply-visitors 'after-parse s))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;To access the class of a type reference
;;To access the class of an object
(def-transform expression (class-of ?expr) (get-class ?expr))

(def-syntax class-of-class-expression (expression)
  (get-class (the ?class/type-reference)))

(defmethod get-type ((e class-of-class-expression))
  (parse 'java.lang.Class 'type-reference))

(def-unparse class-of-class-expression (e)
  (format t "~/ppexp/.class" (class-of-class-expression-class e)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;The use of a generic function approach on a non-multi-method system has
;;some drawbacks which I really would like to solve.  Consider the
;;following example:  we want to define a method that adds an element to a
;;list.  Since, in linj, we must attach methods to classes, we must decide
;;where to put it.  Either we put it on our 'root' class or we put it on a
;;<list> class. The first option forbids us to insert other objects
;;belonging to the Java 'root' class.  The second options forces us to
;;define the method in such a way that the first argument of the invocation
;;is the list and the second argument is the object we want to add,
;;i.e. (cons <list> <object>).

;;While the first option is plainly impossible to use, the second one is a
;;source of bugs.  Remember that linj tries to copy Common Lisp as far as
;;possible, thus most operations over lists (cons, remove, mapcar, etc)
;;that accept a non-list first argument must be rewritten with a different
;;calling syntax, and everybody (me, specially) tend to forget it.

;;My idea for this transformation is to allow methods to identify which
;;parameter is the 'receiver' (more about this latter) and then treat all
;;method-calls as generic calls that must be further refined in order to
;;properly identify the correct receiver.  To this end, we must check all
;;arguments and identify wether an argument's class define such a method.
;;In case more we have more than one definition we must abort because we
;;don't have multi-methods (or else we can use some metric such as
;;inheritance-path-length to pick up the preferred one).  In case we have
;;just one method, we check which parameter is the receiver and we remove the
;;correspondent argument from the arg list and put it as method-call-receiver.

;;Let's go back a little and think about out to identify the receiver on
;;the parameter list of a method.  A simple idea is to find a parameter
;;whose type is the same as the class where the method is being defined.
;;This has a problem when there is a method with more than one such
;;parameter and the method does some side-effects. Changing the receiver or
;;the 'other'  is a totally different matter. Without side-effects there
;;seems to be no problem.  Another idea (from JCachopo) is to use the word
;;'this' to distinguish it.  This one has the advantage that we don't have
;;to alpha-convert the receiver parameter name in the method body because
;;it coincides with Java's expectations.  Let's try to use this 'this'.

;; (def-macro-transform method-declaration
;;     (defmethod-0 ?type ?name ?parameters ?throws ?options . ?body)
;;   (let ((receiver-position (position 'this ?parameters)))
;;     (when receiver-position
;;       `(defmethod-0 ,?type ,?name ,(remove 'this ?parameters) ,?throws
;; 		    (:receiver-position ,receiver-position . ,?options) . ,?body))))

;;Generic calls are a kind of generic function calls, `a la' CLOS

(def-syntax generic-call-expression (key-method-call-expression)
  (?name/unreserved-linj-name . ?arguments/argument-list)
  :slots ((receiver :initform nil)) ;;don't bother to visit this now. It's on the args, anyway
  :components (?receiver))

;;The inherited check-initialization is enough. We just have to further
;;specify the define-arguments method:

(defparameter *resolve-generic-call* t)

(defmethod check-initialization ((call generic-call-expression))
  (if *resolve-generic-call*
    (call-next-method)
    (let ((args (generic-call-expression-arguments call)))
      (setf (method-call-expression-receiver call)
	(with-parent (call) (first (argument-list-elements args))))
      (setf (argument-list-elements args)
	(rest (argument-list-elements args)))
      (setf (method-call-expression-args-passed call) :all))))

;;The idea, now, is just to try (and I repeat 'try') to find a class in one
;;of the arguments that implements the method.  This argument becomes then
;;the receiver.

;;Note that there are only a few possibilities, namely, the receiver must
;;be of a reference type and we can't use keyword args as receivers (this
;;is consistent with CLOS)

(defun possible-receivers (args)
  (let ((combs (list)))
    (dotimes (i (length args))
      (let ((arg (nth i args)))
	(if (keyword-reference-p arg)
	  (return)
	  (let ((type (get-principal-type arg)))
	    (unless (or (primitive-type-reference-p type)
			(null-type-p type))
	      (push (cons arg (append (subseq args 0 i) (subseq args (1+ i))))
		    combs))))))
    (nreverse combs)))

(defun get-method (call receiver args)
  (find-declaration
   (with-parent ((ast-node-parent call))
     (make-instance 'key-method-call-expression
		    :name (method-call-expression-name call)
		    :receiver receiver
		    :arguments (make-instance 'argument-list :elements args)
		    :original-form `(trying ,(ast-node-form (method-call-expression-name call))
				     on
				     ,(ast-node-form receiver)
				     with-args
				     (,@(mapcar #'ast-node-form args)))))))

(defmethod find-declaration ((call generic-call-expression))
  (let ((gen-args (argument-list-elements (method-call-expression-arguments call))))
    (flet ((instance-call (comb)
	     (destructuring-bind (receiver . args) comb 
	       ;;which argument's class implement such method?
	       (let ((method (get-method call receiver args)))
		 (when (and method
			    ;;we use gen-args because the (method-call-expression-arguments call)
			    ;;might have been changed in a recursive computation.
			    (= (position receiver gen-args)
			       (receiver-position method)))
		   (setf (argument-list-elements (method-call-expression-arguments call))
			 args)
		   (setf (method-call-expression-receiver call)
			 (with-parent (call) receiver))
		   method))))
	   (class-call (receiver)
	     (let ((method (get-method call receiver gen-args)))
	       (when (and method
			  (or (null (method-call-expression-receiver call))
			      (equal-type-p (method-call-expression-receiver call) receiver)))
		 (setf (method-call-expression-receiver call)
		       (with-parent (call)
			 (copy-type receiver)))
		 method))))
      (or (some #'instance-call (possible-receivers gen-args))
	  ;;Use 'in' forms first
	  (some #'class-call (mapcar #'get-type (collect-upward-in-forms call)))
	  ;;and the containing classes second
	  (some #'class-call (mapcar #'get-type (containing-type-declarations call)))
	  ;;and all top-level classes and in declarations (bottom up in the file)
	  (some #'class-call (mapcar #'get-type (top-level-type-declarations call)))))))

(defun containing-type-declarations (node)
  (let ((containing (containing-type-declaration node)))
    (if containing
      (cons containing (containing-type-declarations containing))
      (list))))

(defun top-level-type-declarations (node)
  (let ((collect (list)))
    (dolist (elem (compilation-unit-list-elements (compilation-unit-components (containing-compilation-unit node))))
      (cond ((type-declaration-p elem)
	     (push elem collect))
	    ((in-declaration-p elem)
	     (push (in-declaration-object elem) collect))))
    collect))

;;The defun macro is just syntatic sugar for a class allocated method:

(def-transform method-declaration 
    (defun ?name ?arglist . ?body)
  (defmethod ?name ?arglist :allocation :class . ?body))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;Mixins: There's no multiple inheritance in Java, but we can avoid copying
;;and pasting of code.  The idea is to use mixins.
;;First, we define a new kind of class declaration, the mixin:

(def-syntax mixin-declaration (type-body-declaration type-declaration)
  (defmixin-0 ?name/type-reference
      ?supermixins/type-reference-list 
    ?options . ?body/type-body)
  :strict-p t)

(def-macro-transform mixin-declaration
    (defmixin ?name ?supermixins ?slots . ?options&body)
    (multiple-value-bind (options body)
	(process-type-options ?slots ?options&body)
      `(defmixin-0 ,?name ,?supermixins
	 ,options
	 ,@(define-slots-and-accessors ?slots)
	 ,@body)))

;;As in Java, this class contains constant declarations and abstract
;;methods.  Let's define the abstract methods by syntax extension:

(def-macro-transform method-declaration
    (defabstract ?name ?arglist . ?options&body)
  (multiple-value-bind (options body throws returns)
      (extract-options-body ?options&body)
    (when body
      (linj-error "Abstract methods can't have a body"))
    `(defmethod ,?name ,?arglist 
		:category :abstract :throws ,throws :returns ,returns ,@options)))

;;Besides having constants and abstract methods, the mixin can have
;;'normal' slots and methods, which are copied to the inheriting classes
;;However, during unparse, these slots and method must be invisivel because
;;this class unparses in the form of a Java interface, which can't contain them.

(def-unparse mixin-declaration (e)
  (pprint-logical-block (*standard-output* nil)
    (format t "interface ~/pp/" (mixin-declaration-name e))
    (let ((mixins (type-reference-list-elements (mixin-declaration-supermixins e))))
      (unless (null mixins)
	(format t " extends ~{~/pp/~^, ~}" mixins)))
    ;;HACK: This isn't elegant but, for now, it is sufficient
    (let ((non-abstract (remove-if-not #'(lambda (elem)
					   (and (method-declaration-p elem)
						(primary-method-p elem)))
				       (type-body-elements (type-declaration-body e)))))
      (unparse-type-body-declaration
       (translate-for-interface (type-declaration-body e)))
      (dolist (elem non-abstract)
	(setf (get-option :category elem) nil)))))

(defmethod translate-for-interface (body)
  (mapcan #'(lambda (elem)
	      (cond ((or (constant-declaration-p elem)
			 (abstract-method-declaration-p elem))
		     (list elem))
		    ((and (method-declaration-p elem)
			  (primary-method-p elem))
		     ;;HACK: this isn't elegant.
		     (setf (get-option :category elem) :abstract)
		     (list elem))
		    (t
		     (list))))
	  (type-body-elements body)))

(defmethod find-declaration-in (what (e mixin-declaration))
  (or (find-declaration-in-type what e)
      ;;go through the mixins before going through the outerclass
      (some #'(lambda (mixin)
		(find-declaration-in what (get-type-declaration mixin)))
	    (type-reference-list-elements (mixin-declaration-supermixins e)))
      (call-next-method)))

(defmethod find-methods-named (name (e mixin-declaration) &optional (exclude-self-p t))
  (append
   (and (not exclude-self-p)
	(remove-if-not #'(lambda (elem)
			   (and (method-declaration-p elem)
				(eq name (method-declaration-name elem))))
		       (type-body-elements (mixin-declaration-body e))))
   ;;go through the mixins
   (reduce #'append
	   (type-reference-list-elements (mixin-declaration-supermixins e))
	   :key #'(lambda (mixin)
		    (find-methods-named name (get-type-declaration mixin) nil))
	   :from-end t)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun unwrap-if-needed (type form)
  (if (primitive-type-reference-p type)
    `(send (the ,(generic-wrapper-type type) ,form)
	   ,(type-to-type-message type))
    (if (object-type-p type)
      form
      `(the ,(copy-type type) ,form))))

(defun wrapper-type (type)
  (cond ((boolean-type-p type) (boolean-wrapper-type))
	;; HACK!!  wrapper-types for int and float are Long and Double
	;; because that's what linj-reader returns and it allows
	;; mixing ints and longs (resp. floats and doubles)
	((int-type-p type) (long-wrapper-type))
	((long-type-p type) (long-wrapper-type))
	((char-type-p type) (char-wrapper-type))
	((double-type-p type) (double-wrapper-type))
	((float-type-p type) (double-wrapper-type))
	(t (error "Don't know wrapper type for ~S" type))))

(defun generic-wrapper-type (type)
  (cond ((boolean-type-p type) 
	 (boolean-wrapper-type))
	((char-type-p type)
	 (char-wrapper-type))
	((or (int-type-p type) 
	     (long-type-p type)
	     (float-type-p type)
	     (double-type-p type))
	 (number-wrapper-type))
	(t 
	 (error "Don't know wrapper type for ~S" type))))

(defun type-to-type-message (type)
  (cond ((boolean-type-p type) 'boolean-value)
	((int-type-p type) 'int-value)
	((long-type-p type) 'long-value)
	((char-type-p type) 'char-value)
	((double-type-p type) 'double-value)
	((float-type-p type) 'float-value)
	(t (error "Don't know wrapper type for ~S" type))))

;;One simple idea would be to extend the previous argument list to deal with keyword arguments

;;Unfortunately,
;;these can't be combined with the previous keyword arguments bc it is
;;impossible to distinguish what is a keyword and what is part of the rest
;;arguments. But that's a minor problem.  Having both ...[TO BE CONTINUED]

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;To implement symbols, I though about converting symbols to ints (or
;;longs) but I couldn't find a sufficiently small solution that satisfied me.
;;The convertion to ints would have the advantage to allow a case
;;implementation based on a Java switch.  On the other hand, Common Lisp
;;never had such an implementation, being its case based on sucessive eq
;;comparisons.  As a result, I decided to implement symbols based on
;;interned strings (as they should be) and provide a case which isn't
;;mapped on a switch but is, instead, just like the Common Lisp case.

(def-macro-transform expression '?argument
  ;;numbers and strings are self-evaluating
  (with-linj-syntax ()
    (cond ((or (numberp ?argument)
	       (stringp ?argument)
	       (characterp ?argument)
	       (simple-vector-p ?argument))
	   ?argument)
	  ((keywordp ?argument)
	   `(intern ,(format nil ":~A" ?argument)))
	  ((and (symbolp ?argument) (not (null ?argument)))
	   ;;stupid mix between NIL and ()
	   `(intern ,(princ-to-string ?argument)))
	  (t 
	   ;;fail
	   nil))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;It is ridicule to try to work with only half of Common Lisp.  (I should say
;;half of the Common Lisp I known, as it may be just 1% of the real thing).
;;One missing thing is multiple-value-bind and values.
;;To implement this, I could translate the code to CPS, but I would be
;;unable to unparse it properly.  Don't forget that I want readable Java code!
;;An alternative is to use the old trick of asking the callee to collect
;;all return values into an array and then dismantle it in the caller to
;;obtain the values. 

(def-syntax values-expression (expression)
  (values . ?arguments/argument-list))

;;We will introduce a special type to deal with a values expression as we
;;want to recover all the arguments types on the caller.

(def-list-syntax values-type-reference (type-reference linj-list-node) type-reference
  :slots
  ((original-form :initform nil)
   (name :initform :values-type)))

;;We have a different principal type
(defmethod get-principal-type ((e values-type-reference))
  (let ((types (values-type-reference-elements e)))
    (if (endp types)
      (void-type)
      (first types))))

(defmethod array-or-values-type-reference-subtype ((e values-type-reference) (dim literal))
  ;;(nth (literal-value dim) (values-type-reference-elements e)))
  (let ((common-type (common-type-or-nil e)))
    (if (not (null common-type))
      common-type
      (object-type))))

(defmethod copy-type ((e values-type-reference))
  (make-instance (type-of e) ;;also used in subclasses
    :elements (values-type-reference-elements e)
    :original-form `(copy-of ,(ast-node-form e))))

(defmethod equal-type-p ((t1 values-type-reference) (t2 values-type-reference))
  (every #'equal-type-p
	 (values-type-reference-elements t1)
	 (values-type-reference-elements t2)))

(defmethod super-type-p ((type1 values-type-reference) (type2 values-type-reference))
  (every #'super-type-p 
	 (values-type-reference-elements type1)
	 (values-type-reference-elements type2)))

(defmethod merge-types ((t1 values-type-reference) (t2 values-type-reference))
  (if (= (length (values-type-reference-elements t1))
	 (length (values-type-reference-elements t2)))
    (with-parent ((ast-node-parent t1))
      (make-instance (type-of t1) ;;also used in subclasses
       :elements (mapcar #'merge-types
			 (values-type-reference-elements t1)
			 (values-type-reference-elements t2))
       :original-form `(merge-type ,(ast-node-form t1) ,(ast-node-form t2))))
    (linj-error "Can't merge values with diferent arity")))


(defmethod get-type ((e values-expression))
  (with-parent ((ast-node-parent e))
    (make-instance 'values-type-reference
      :elements (mapcar #'get-principal-type
			(argument-list-elements (values-expression-arguments e)))
      :original-form `(values-type ,(ast-node-form e)))))

(defmethod common-type-or-nil ((e values-type-reference))
  (let ((types (values-type-reference-elements e)))
    (if (every #'(lambda (other-type) 
		   (equal-type-p (first types) other-type))
	       (rest types))
      (first types)
      nil)))

(def-unparse values-type-reference (e)
  (let ((common-type (common-type-or-nil e)))
    (if common-type
      (format t "~/pp/[]" common-type)
      (format t "Object[]"))))

(def-unparse values-expression (e)
  (let ((common-type (common-type-or-nil (get-type e))))
    (if common-type
      (unparse-vector-inits
       common-type
       (mapcar #'principal-value (argument-list-elements (values-expression-arguments e))))
      (unparse-vector-inits
       (with-parent (e) (object-type))
       (mapcar #'(lambda (arg)
		   (let ((type (get-principal-type arg)))
		     (if (primitive-type-reference-p type)
			 (if (boolean-type-p type)
			     (with-parent (e)
			       (make-instance 'method-call-expression
					      :receiver (boolean-wrapper-type)
					      :name (parse 'value-of 'linj-name)
					      :original-form 'auto-value-of-for-types
					      :arguments (make-instance 'argument-list
									:original-form 'auto-arg-value-of-for-types
									:elements (list arg))))
			     (with-parent (e)
			       (make-instance 'allocation-expression
					      :receiver (wrapper-type type)
					      :arguments (make-instance 'argument-list :elements (list arg)))))
			 (principal-value arg))))
	       (argument-list-elements (values-expression-arguments e)))))))

(def-syntax nth-value-expression (expression)
  (nth-value (?is ?n numberp) ?argument/expression))

(defmethod get-type ((e nth-value-expression))
  (let ((type (get-type (nth-value-expression-argument e))))
    (if (values-type-reference-p type) 
      (nth (nth-value-expression-n e) (values-type-reference-elements type))
      type)))

(def-unparse nth-value-expression (e)
  (let ((type (get-type (nth-value-expression-argument e))))
    (if (values-type-reference-p type)
      (let ((common-type (common-type-or-nil type)))
	(if common-type
	  (format t "~/pp/"
		  (with-parent (e) ;;HACK: This is dangerous bc it doesn't
	            ;;consider local macros.
		    (make-instance 'array-reference
				   :original-form :computed
				   :expression (nth-value-expression-argument e)
				   :indexes (make-instance
					     'argument-list
					     :elements (list (make-instance
							      'literal
							      :value (nth-value-expression-n e)))))))
	  (format t "~/pp/"
		  (with-parent (e)
		    (parse (unwrap-if-needed (copy-type (get-type e))
					     `(aref ,(nth-value-expression-argument e) ,(nth-value-expression-n e)))
			   'expression)))))
      (unparse-linj (nth-value-expression-argument e)))))


(defmethod get-principal-value ((e values-type-reference) expr)
  (make-instance 'nth-value-expression
		 :original-form 'auto-nth-value-expression
		 :n 0
		 :argument expr))


(def-macro-transform statement (multiple-value-bind ?parameters 
				   ?values-form
				 . ?body)
  (cond ((endp ?parameters)
	 `(progn ,?values-form ,@?body))
	((endp (rest ?parameters))
	 `(let ((,(first ?parameters) ,?values-form)) ,@?body))
	(t
	 (let ((multiple-results 'multiple-results))
	   `(let ((,multiple-results ,?values-form))
	      (let ,(loop for count from 0 and param in ?parameters
			  collect `(,param (nth-value ,count ,multiple-results)))
		,@?body))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;Futures

(def-syntax future (expression)
  (future ?expression/expression)
  :components
  (?translation)
  :slots
  ((translation :accessor future-translation :initarg :translation))
  :constructor make-future)

(defun make-future (category &key original-form expression)
  (declare (ignore category))
  (make-instance 'future
    :original-form original-form
    :expression expression
    :translation (parse `(new 'linj.future #'(lambda () ,(ast-node-form expression))) 'expression)))

;;We will use the values-type-reference machinery
(def-category future-type-reference (values-type-reference)
  ())

(defmethod future-type-reference-subtype ((e future-type-reference))
  (first (values-type-reference-elements e)))

(defmethod get-type-declaration ((e future-type-reference))
  (get-type-declaration (parse 'linj.future 'type-reference)))

(defmethod get-type ((e future))
  (with-parent ((ast-node-parent e))
    (make-instance 'future-type-reference
      :original-form `(future-type ,(ast-node-form e))
      :elements (list (get-principal-type (future-expression e))))))

(def-unparse future-type-reference (e)
  ;;this should not be used
  (format t "~/pp/" (with-parent (e) (parse 'linj.future 'type-reference))))

(def-unparse future (e)
;;;  (format t "Hummm")
  (format t "~/pp/" (future-translation e)))

(def-syntax make-future-present (expression)
  (touch ?argument/expression))

(defmethod get-type ((e make-future-present))
  (let ((type (get-type (make-future-present-argument e))))
    (if (future-type-reference-p type)
      (future-type-reference-subtype type)
      type)))

(def-unparse make-future-present (e)
  (let ((type (get-type (make-future-present-argument e))))
    (if (future-type-reference-p type)
      (format t "~/pp/"
	      (with-parent (e)
		(parse (unwrap-if-needed (copy-type (get-type e))
					 `(send ,(make-future-present-argument e) get-value))
		       'expression))))))

(defmethod get-principal-value ((e future-type-reference) expr)
  (make-instance 'make-future-present
		 :original-form 'auto-make-future-present
		 :argument expr))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;The try statement is a fundamental one.
;;The agreed syntax is something similar to the Common Lisp's handler-case
;; (try (form1 form2 formn) ((var1 type1) . body1) ((var2 type2) . body2)
;; ...  (finally . bodyn))

(def-syntax default-handler (linj-node)
  (finally . ?body/statement-list))

(def-unparse default-handler (e)
  (format t "finally ~/ppblk/"
	  (default-handler-body e)))

(def-syntax handler-variable-declaration (variable-declaration)
  (?name/linj-name ?type/type-reference))

(def-syntax handler (default-handler)
  (?binding/handler-variable-declaration . ?body/statement-list))

(def-unparse handler (e)
  (format t "catch (~/pp/) ~/ppblk/"
	  (handler-binding e)
	  (handler-body e)))

(defmethod find-declaration-in ((ref reference) (e handler))
  (if (eq (reference-name ref) (variable-declaration-name (handler-binding e)))
    (handler-binding e)
    (call-next-method)))

(def-list-syntax handler-list (linj-list-node) default-handler)

(def-unparse handler-list (e)
  (format t "~{ ~/pp/~}" (handler-list-elements e)))

(def-syntax try-statement (statement)
  (try ?form/statement . ?handlers/handler-list))

(defun handled-throws (try)
  (let ((throws (list)))
    (dolist (clause (handler-list-elements (try-statement-handlers try)))
      (when (handler-p clause)
	(push (handler-variable-declaration-type (handler-binding clause)) throws)))
    throws))

(def-unparse try-statement (e)
  (format t "~@<try ~/ppstm/~/pp/~:>"
	  (try-statement-form e)
	  (try-statement-handlers e)))

;;; Macro HANDLER-CASE
;;; Syntax:
;;; handler-case expression [[{error-clause}* | no-error-clause]] => result*
;;; clause::= error-clause | no-error-clause 
;;; error-clause::= (typespec ([var]) declaration* form*) 
;;; no-error-clause::= (:no-error lambda-list declaration* form*) 

(defun translate-handler-case-clause (clause ?form ?clauses)
  (if (eq (first clause) :no-error)
    (error "Linj handler case does not support a :no-error clause")
    `((,(if (endp (second clause))
	    (gen-new-name 'e (cons ?form ?clauses))
	    (first (second clause)))
       ,(first clause))
      ,@(rest (rest clause)))))

(def-macro-transform try-statement
    (handler-case ?form . ?clauses)
  `(try
    ,?form
    ,@(mapcar #'(lambda (clause)
		  (translate-handler-case-clause clause ?form ?clauses))
	      ?clauses)))
;;;Synchronization

(def-syntax synchronized-statement (statement)
  (with-lock (?expression/expression) . ?body/statement-list))

(def-unparse synchronized-statement (e)
  (when (primitive-type-reference-p (get-type (synchronized-statement-expression e)))
    (linj-error "Can't lock a member of a primitive type: ~A" e))
  (format t "~@<synchronized (~:/ppexp/) ~/ppblk/~:>"
	  (synchronized-statement-expression e)
	  (synchronized-statement-body e)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;Now, some helpfull macros
; (def-transform try-statement (unwind-protect ?form . ?cleanup-forms)
;   (try ?form
;        ((generated-exception <exception>))
;        (finally . ?cleanup-forms)))

(def-macro-transform try-statement (unwind-protect ?form . ?cleanup-forms)
  (or (let-pattern (((handler-case ?form . ?clauses) ?form))
	`(try ,?form
	  ,@(mapcar #'(lambda (clause)
			(translate-handler-case-clause clause ?form ?clauses))
		    ?clauses)
	  (finally ,@?cleanup-forms)))
      `(try ,?form
	(finally ,@?cleanup-forms))))

(def-macro-transform try-statement (ignore-errors . ?forms)
  `(try (progn . ,?forms) ((,(gen-new-name 'e ?forms) throwable))))

(def-macro-transform try-statement (without-checked-exceptions . ?forms)
  (let ((var (gen-new-name 'e ?forms)))
    `(try (progn . ,?forms) ((,var exception) (print-stack-trace ,var) (error "Can't continue")))))

(def-macro-transform let-statement (fluid-let ?bindings . ?body)
  `(let ,(mapcar #'(lambda (binding)
		     `(,(conc-symbol 'fluid-let- (car binding)) ,(car binding)))
	  ?bindings)
     (unwind-protect
	 (progn
	   ,@(mapcar #'(lambda (binding)
			 `(setf ,@binding))
		     ?bindings)
	   ,@?body)
       ,@(mapcar #'(lambda (binding)
		     `(setf ,(car binding) ,(conc-symbol 'fluid-let- (car binding))))
		 ?bindings))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;x
;;static blocks are like top-level code:

; (def-syntax static-block (type-body-declaration)
;   (static-block . ?body/statement-list))

; (def-unparse static-block (e)
;   (format t "~@<static ~/ppstm/~:>"
; 	  (static-block-body e)))

;;I prefer to separate each statement in a unique static block.  You have
;;progn, anyway.

(def-syntax static-block (type-body-declaration)
  ?statement/statement)

(def-unparse static-block (e)
  (format t "~@<static {~4I~:@_~/ppblk/~I~:@_}~:>"
	  (static-block-statement e)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;x
;;A kind of code-walker:

(defmethod apply-to-method-exit-points ((e method-declaration) f)
  (apply-to-exit-point (method-declaration-body e) f (list 'normal-flow (method-declaration-name e))))

(defmethod apply-to-exit-point ((e statement-list) f blocks)
  (if (endp (statement-list-elements e))
    (unless (member 'non-normal-flow blocks)
      (funcall f (make-instance 'explicit-type-node :type (void-type))))
    (progn
      (dolist (statement (butlast (statement-list-elements e)))
	(apply-to-exit-point statement f (cons 'non-normal-flow blocks)))
      (apply-to-exit-point (first (last (statement-list-elements e))) f blocks))))

(defmethod apply-to-exit-point ((e statement) f blocks)
  (declare (ignore f blocks)))

(defmethod apply-to-exit-point ((e when-statement) f blocks)
  (apply-to-exit-point (when-statement-body e) f blocks)
  ;;the when-else is like an empty else in an if-then-else
  (apply-to-exit-point (make-instance 'statement-list :elements (list)) f blocks))
  ;;This is necessary so that when-statements force methods to have void return type
;;In fact, it is not needed bc the statement-list already does that.
;;   (unless (member 'non-normal-flow blocks)
;;     (funcall f (make-instance 'explicit-type-node :type (void-type)))))

(defmethod apply-to-exit-point ((e expression-statement) f blocks)
  (unless (member 'non-normal-flow blocks)
    (funcall f e)))

(defmethod apply-to-exit-point ((e block-statement) f blocks)
  (apply-to-exit-point (block-statement-body e)
		       f
		       (cons (block-statement-name e) blocks)))

(defmethod apply-to-exit-point ((e return-from-statement) f blocks)
  (unless (member 'non-normal-flow (rest (member (return-from-statement-label e) blocks)))
    (funcall f e)))

(defmethod apply-to-exit-point ((e return-statement) f blocks)
  (declare (ignore blocks))
  (funcall f e))

(defmethod apply-to-exit-point ((e for-statement) f blocks)
  (apply-to-exit-point (for-statement-body e)
		       f
		       (cons 'non-normal-flow blocks)))

(defmethod apply-to-exit-point ((e let-statement) f blocks)
  (apply-to-exit-point (let-statement-body e) f blocks))

(defmethod apply-to-exit-point ((e cond-statement) f blocks)
  (dolist (clause (clause-list-elements (cond-statement-clauses e)))
    (apply-to-exit-point (clause-body clause) f blocks)))

(defmethod apply-to-exit-point ((e case-statement) f blocks)
  (dolist (clause (case-clause-list-elements (case-statement-clauses e)))
    (apply-to-exit-point (default-case-clause-body clause) f blocks)))

(defmethod apply-to-exit-point ((e if-statement) f blocks)
  (apply-to-exit-point (if-statement-then e) f blocks)
  (apply-to-exit-point (if-statement-else e) f blocks))

(defmethod apply-to-exit-point ((e try-statement) f blocks)
  (apply-to-exit-point (try-statement-form e) f blocks)
  (dolist (handler (handler-list-elements (try-statement-handlers e)))
    (if (handler-p handler)
      (apply-to-exit-point (default-handler-body handler) f blocks)
      (apply-to-exit-point (default-handler-body handler) f (cons 'non-normal-flow blocks)))))

(defmethod apply-to-exit-point ((e in-statement) f blocks)
  (apply-to-exit-point (in-statement-body e) f blocks))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;Extensions that depend on java support code

;;The idea is to translate lambda expressions to java inner classes
;;depending on the return type (in particular, distinguishing the classical
;;cases of boolean-predicates, Object-functions and void-procedures) and on
;;the number of parameters (distinguishing unary, binary, etc).  Notice
;;that non-unary methods have not been used in the past because it was
;;ackward to define all of them.

;;Here is an example of a lambda expression translated into java
;; (lambda boolean ((component c))
;;   (return (is-visible c)))

;;new Predicate() { 
;;  public boolean funcall(Object arg) { 
;;     Component c = (Component)arg; 
;;     return c.isVisible(); }}


;;As a preliminary, we should define the concept of anonymous inner class
;;expression:

;;this is a simplification justified by the fact that, in general,
;;anonymous superclasses do not define new methods, they just override
;;them

(def-macro-transform class-declaration (class ?class . ?body)
  (let ((real-class (parse ?class 'type-reference)))
    `(defclass-0 (class-or-interface-type 
		  ,(empty-package)
		  ,(gensym (princ-to-string (conc-symbol 'anonymous- (ast-node-form (class-or-interface-type-reference-name real-class))))))
       ,real-class () ()
       . ,?body)))

(defmethod anonymous-class-declaration-p ((class class-declaration))
  (anonymous-type-reference-p (class-declaration-name class)))

(def-syntax anonymous-class-allocation-expression (allocation-expression)
  (new ?class/class-declaration . ?arguments/argument-list)
  :slots ((receiver :initform (list))))

(defmethod method-call-expression-receiver ((e anonymous-class-allocation-expression))
  (class-declaration-superclass (anonymous-class-allocation-expression-class e)))

(defmethod get-type-declaration ((e anonymous-class-allocation-expression))
  (anonymous-class-allocation-expression-class e))

;;Sometimes we need to locate a default constructor on a mixin-declaration
(defmethod find-declaration-in ((alloc anonymous-class-allocation-expression) (e mixin-declaration))
  *default-constructor*)


(def-unparse anonymous-class-allocation-expression (e)
  (format t "~@<new ~/pp/~/pp/ {~4I~{~:@_~/pp/~^~:@_~}}~:>"
	  (class-declaration-superclass (anonymous-class-allocation-expression-class e))
	  (allocation-expression-arguments e)
	  (type-body-elements (class-declaration-body (anonymous-class-allocation-expression-class e)))))

;; (defmethod get-type ((e anonymous-class-allocation-expression))
;;   (get-type (anonymous-class-allocation-expression-class e)))

(defclass free-references-collector ()
  ((form :initarg :form :reader get-form)
   (references :initform (list) :accessor get-references)))

(defun contained-in (e form)
  (or (eq e form)
      (and e (contained-in (ast-node-parent e) form))))

(defmethod visit :before ((e reference) (visitor free-references-collector))
  (unless (or (type-reference-p e)
	      (this-reference-p e)
	      (super-reference-p e)
	      (keyword-reference-p e)
	      (alias-this-reference-p e))
    (let ((decl (strict-find-declaration e)))
      (unless (slot-declaration-p decl)
	(unless (contained-in decl (get-form visitor))
	  (push e (get-references visitor)))))))

(defun free-references (form)
  (let ((visitor (make-instance 'free-references-collector :form form)))
    (visit form visitor)
    (get-references visitor)))


(defclass define-finals-visitor ()
  ())

(defmethod visit :after ((e anonymous-class-allocation-expression) (visitor define-finals-visitor))
  (dolist (reference (free-references (class-declaration-body (anonymous-class-allocation-expression-class e))))
    (let ((decl (strict-find-declaration reference)))
      (define-final-on-variable-declaration decl))))

(defun define-final-on-variable-declaration (var-decl)
  (setf (get-option :final var-decl) t))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;Extensions:

(def-transform expression *standard-input* (slot-value (the java.lang.System) 'in))
(def-transform expression *standard-output* (slot-value (the java.lang.System) 'out))
(def-transform expression *error-output* (slot-value (the java.lang.System) 'err))
(def-transform expression *trace-output* *error-output*)

(def-transform setf-expression (setf *standard-input* ?stream) (send (the java.lang.System) set-in ?stream))
(def-transform setf-expression (setf *standard-output* ?stream) (send (the java.lang.System) set-out ?stream))
(def-transform setf-expression (setf *error-output* ?stream) (send (the java.lang.System) set-err ?stream))
(def-transform setf-expression (setf *trace-output* ?stream) (setf *error-output* ?stream))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass imports-visitor ()
  ((packages :accessor imports-visitor-packages :initform (make-hash-table))))

(defun add-import-info (type visitor)
  (unless (empty-package-p (class-or-interface-type-reference-package type))
    (pushnew type
	     (gethash (class-or-interface-type-reference-name type)
		      (imports-visitor-packages visitor)
		      '())
	     :test #'(lambda (e1 e2)
		       (equal-type-reference-package (class-or-interface-type-reference-package e1)
						     (class-or-interface-type-reference-package e2))))))


;;To determine imports, the method-call-expression must be initialized
(defmethod visit :before ((e method-call-expression) (visitor imports-visitor))
  (check-initialization e))

;;nodes with type information
(defmethod visit-current ((e class-or-interface-type-reference) (visitor imports-visitor))
  (unless (null (class-or-interface-type-reference-package e)) ;;arrays don't have package
    (add-import-info e visitor)))

;;but excluding in-declarations (their type information is spread of its uses).
(defmethod visit ((e in-declaration) (visitor imports-visitor)))

;;some literals correspond to class instances
(defmethod visit-current ((e literal) (visitor imports-visitor))
  (let ((type (get-type e)))
    (unless (primitive-type-reference-p type)
      (add-import-info type visitor))))

(defclass determine-imports ()
  ())

(defparameter *determine-imports* t)

(defmethod visit ((e compilation-unit) (v determine-imports))
  (when *determine-imports*
    (let ((visitor (make-instance 'imports-visitor)))
      (visit e visitor)
      (let ((unit-package (compilation-unit-package e))
	    (previous-imports (compilation-unit-imports e))
	    (extra-imports (list)))
	(maphash #'(lambda (name types)
		     (declare (ignore name))
		     (when (endp (rest types))
		       (let ((type (first types)))
			 (when (not (or (package= (class-or-interface-type-reference-package type)
						  (package-declaration-components unit-package))
					(some #'(lambda (import)
						  (match-type
						   (import-declaration-type import)
						   type))
					      previous-imports)))
			   (push (first types) extra-imports)))))
		 (imports-visitor-packages visitor))
	(when extra-imports
	  (format *trace-output* "Add imports:~%")
	  (setf (compilation-unit-imports e)
		(append previous-imports
			(mapcar #'(lambda (import)
				    (let ((import (parse `(import ,(copy-type import)) 'import-declaration)))
				      (unparse-linj import *trace-output*)
				      (terpri *trace-output*)
				      import))
				extra-imports))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;Visitors' sequence

(add-visitor 'after-parse 'adjust-parents)
(add-visitor 'after-parse 'process-declares)
(add-visitor 'after-parse 'parse-tree-finish)
(add-visitor 'after-parse 'expand-macros-visitor)
;;(add-visitor 'after-parse 'mixin-transform)
;;(add-visitor 'after-parse 'inherit-constructors-transform)
(add-visitor 'after-parse 'return-type-inference-visitor)
(add-visitor 'after-parse 'link-afternew-transform)
(add-visitor 'after-parse 'process-return-from-statements)
(add-visitor 'after-parse 'compress-blocks)

(add-visitor 'before-dump 'remove-unneded-blocks)
;;(add-visitor 'before-dump 'overrides-visitor)
(add-visitor 'before-dump 'define-finals-visitor)
(add-visitor 'before-dump 'cast-and-wrap)
(add-visitor 'before-dump 'add-method-throws-visitor)
(add-visitor 'before-dump 'determine-imports)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;Standard method combination:

;;We want to provide the Common Lisp standard method combination, based on
;;primary, before and after methods.

;;The idea is that when we have an :after method (for example), we can
;;automatically generate a method that invokes a call-next-method.  We can
;;even make some simplifying assumptions such as avoiding the return type
;;and the argument list (although I'm not so sure this is a good idea).


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



;;The function concept:  each function is a static method on the class
;;file.  Each invocation is replaced by the correspondent method
;;invocation.  Each file must import other files to be able to use its
;;functions. Let's do it.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;For the emacs-lisp connection
#+allegro
(defclass linj-request (lep::compile/load-file-request)
  ())

#+allegro
(defmethod lep::compute-reply ((session linj-request) 
			       &key filename directory)
  (format *trace-output* "Filename: ~A~%" filename)
  (let ((curr-dir (format nil "~A" (get-current-directory))))
    (excl:chdir directory)
    (prog1
	(linj2java filename)
      (excl:chdir curr-dir))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;Containing blocks

(defmethod containing-block-named ((e linj-node) name)
  (containing-block-named (ast-node-parent e) name))

(defmethod containing-block-named ((e method-declaration) name)
  (if (eq name (method-declaration-name e))
    e
    (linj-error "Can't find block named ~A in method ~A" name e)))

(defmethod containing-block-named ((e block-statement) name)
  (if (eq (block-statement-name e) name)
    e
    (call-next-method)))


(defmethod jumped-over-blocks ((e linj-node) name)
  (jumped-over-blocks (ast-node-parent e) name))

(defmethod jumped-over-blocks ((e method-declaration) name)
  (declare (ignore name))
  nil)

(defmethod jumped-over-blocks ((e block-statement) name)
  (if (eq (block-statement-name e) name)
    (list)
    (cons (block-statement-name e)
	  (call-next-method))))

(defmethod jumped-over-blocks ((e case-statement) name)
  (declare (ignore name))
  ;;Warn: we must consider case-statements as invisible blocks to
  ;;avoid incorrect breaks.
  (cons (gensym)
	(call-next-method)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;Collect throws
;;Must be done before unparsing so that the correct import statements can be derived.
(defclass add-method-throws-visitor ()
  ())

(defparameter *infer-method-throws* t)

(defmethod visit :after ((e method-declaration) (visitor add-method-throws-visitor))
  (when *infer-method-throws*
    (method-declaration-throws-list e)))

(defparameter +error-type+ (parse 'java.lang.error 'type-reference))

(defparameter +runtime-exception-type+ (parse 'java.lang.runtime-exception 'type-reference))

(defmethod method-declaration-throws-list ((e method-declaration))
  (cond ((computed-method-declaration-throws-p e)
	 (method-declaration-computed-throws e))
	(*infer-method-throws*
	 (setf (method-declaration-computed-throws e)
	       (infer-method-throws e))
	 (method-declaration-computed-throws e))
	(t
	 (type-reference-list-elements (method-declaration-declared-throws e)))))

(defun checked-exceptions (types)
  (remove-if #'(lambda (type)
		 (or (super-type-p +error-type+ type)
		     (super-type-p +runtime-exception-type+ type)))
	     types))

(defun type-union (types)
  (let ((new-types (list)))
    (mapl #'(lambda (types)
	      (let ((first-type (first types)))
		(unless (or (some #'(lambda (other-type)
				      (super-type-p other-type first-type))
				  (rest types))
			    (some #'(lambda (other-type)
				      (super-type-p other-type first-type))
				  new-types))
		  (push first-type new-types))))
	  types)
    (sort new-types #'string< :key #'type-reference-name)))

(defclass collect-throws-visitor ()
  ((throws :initform (list) :accessor throws)))

(defmethod visit ((e try-statement) (visitor collect-throws-visitor))
  ;;First, the form:
  (let ((old-throws (throws visitor))
	(handled-throws (handled-throws e)))
    (setf (throws visitor) (list))
    (visit (try-statement-form e) visitor)
    (let ((new-throws (throws visitor)))
      ;;remove all those exceptions that are handled by the try stratement
      (setf (throws visitor)
	    (union (remove-if #'(lambda (new-throw)
				  (some #'(lambda (handled-throw)
					    (super-type-p handled-throw new-throw))
					handled-throws))
			      new-throws)
		   old-throws
		   :test #'equal-type-p))))
  ;;Now, add all throws in the handlers:
  (visit (try-statement-handlers e) visitor))

(defmethod visit :after ((e method-call-expression) (visitor collect-throws-visitor))
  (unless (or (anonymous-class-allocation-expression-p e)
	      (next-method-call-expression-p e))
    (setf (throws visitor)
	  (union (method-declaration-throws-list (strict-find-declaration e))
		 (throws visitor)
		 :test #'equal-type-p))))

(defmethod visit :after ((e throw-statement) (visitor collect-throws-visitor))
  (setf (throws visitor)
	(adjoin (get-type (throw-statement-argument e))
		(throws visitor)
		:test #'equal-type-p)))

(defparameter *computing-throws-stack* (list))

(defun infer-method-throws (meth-decl)
  (if (member meth-decl *computing-throws-stack*)
    (list)
    (let ((*computing-throws-stack* (cons meth-decl *computing-throws-stack*)))
      (let ((visitor (make-instance 'collect-throws-visitor)))
	(visit meth-decl visitor)
	(let ((explicit-throws (type-reference-list-elements (method-declaration-declared-throws meth-decl))))
	  (let ((checked-throws
		 (mapcar #'(lambda (type)
			     (with-parent (meth-decl)
					  (copy-type type)))
			 (checked-exceptions (set-difference (throws visitor) explicit-throws :test (complement #'super-type-p))))))
	    (if (endp checked-throws)
	      explicit-throws
	      (with-linj-syntax ()
		(warn "Method ~S throws ~{~/pp/~^, ~}" (method-declaration-name meth-decl) checked-throws)
		(type-union (union explicit-throws checked-throws :test #'equal-type-p))))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun linj2undoc-java-directory (&rest args)
  (let ((*type-body-declarations-order*
	 '(("// constants" :constants)
	   ("// slots" :slots)
	   ("// constructors" :constructors)
	   ("// member classes" :member-classes)
	   ("// finalizers" :finalizers)
	   ("// accessors" :accessors)
	   ("// methods" :methods)
	   ("// key methods" :key-methods)
	   ("// trace methods" :tracing-methods)
	   ("// static blocks" :static-blocks)))
	(*write-category-comment* nil))
    (apply #'linj2java-directory args)))