(module saw_extratype
   (import type_type ast_var ast_node
	   type_typeof
	   type_env
	   module_module
	   tools_shape )
;   (export (saw-extratype v::global))
   (export (saw-extratypes l))
   (static (wide-class hook::type type::type)) )

;;
;; Change the types for extra-light procedures
;;    Can be done more cleanly by the cfa
;;
(define *changed-var* '())
(define *changed-node* '())
(define *more* #t)

(define (saw-extratypes l)
   (set! *changed-node* '())
   (set! *changed-var* '())
   (let fixpoint ( (more #t) )
      (when more
	 (set! *more* #f)
	 (for-each saw-typecheck l)
	 (fixpoint *more*) ))
   (for-each (lambda (v) (variable-type-set! v (hook-type (variable-type v))))
	     *changed-var* )
   (for-each (lambda (e) (node-type-set! e (hook-type (node-type e))))
	     *changed-node* ) )
   
;(define (saw-extratype v::global)
;   (saw-typecheck v)

(define (saw-typecheck v)
   (let ( (r (typecheck (sfun-body (global-value v)))) )
      ;; Change only private function return type
      (unless (eq? (global-import v) 'export)
	 (assign-type-var v r) )))

(define (assign-type-var v type)
   (when (and (hook? type) (not (hook? (variable-type v))))
      ;; CARE Do we check that the old type is procedure ?!
      (set! *more* #t)
      (variable-type-set! v type)
      (set! *changed-var* (cons v *changed-var*)) )
   type )

(define (assign-type e type)
   (when (and (hook? type) (not (hook? (node-type e))))
      ;; CARE Do we check that the old type is procedure ?!
      (set! *more* #t)
      (node-type-set! e type)
      (set! *changed-node* (cons e *changed-node*)) )
   type )

;;
(define-generic (typecheck e::node))

(define-method (typecheck e::atom)
   (typeof e) )

(define-method (typecheck e::var)
   (typeof e) )

(define-method (typecheck e::let-var)
   (with-access::let-var e (bindings body)
      (for-each (lambda (b) (assign-type-var (car b) (typecheck (cdr b))))
		bindings )
      (assign-type e (typecheck body)) ))

(define-method (typecheck e::setq)
   (with-access::setq e (var value)
      ;; CARE check (let ( (x (make-el-proc ..)) ) (set! x ??))
      (assign-type var (typecheck value)) ))

(define-method (typecheck e::sequence)
   (with-access::sequence e (nodes)
      (let walk ( (l nodes) (t (find-type 'unspecified)) )
	 (if (null? l)
	     (assign-type e t)
	     (walk (cdr l) (typecheck (car l))) ))))

(define-method (typecheck e::conditional)
   (with-access::conditional e (test true false)
      (typecheck test)
      (let ( (tt (typecheck true)) (tf (typecheck false)) )
	 ;; CARE What can I do to be right ?!
	 (cond
	    ((hook? tt)
	     (assign-type e tt) )
	    ((hook? tf)
	     (assign-type e tf) )
	    (else (typeof e)) ))))

(define-method (typecheck e::select)
   (with-access::select e (test clauses)
      (typecheck test)
	 ;; CARE What can I do to be right ?!
      (let walk ( (l clauses) (t (find-type 'unspecified)) )
	 (if (null? l)
	     (assign-type e t)
	     (walk (cdr l) (typecheck (cdar l))) ))))

(define-method (typecheck e::let-fun)
   (with-access::let-fun e (locals body)
      (for-each
       (lambda (v) (assign-type-var v (typecheck (sfun-body (local-value v)))))
       locals )
      (assign-type e (typecheck body)) ))

(define-method (typecheck e::app)
   (with-access::app e (fun args)
      (let ( (v (var-variable fun)) )
	 (check-args-params v args)
	 (if (local? v)
	     (assign-type e (variable-type v))
	     (let ( (id (global-id v)) (vect (find-type 'vector))
				       (obj (find-type 'obj)) )
		(define (change type)
		   (let ( (t (instantiate::type (init? #f))) )
		      (widen!::hook t (type type))
		      t ))
		(cond
		   ((eq? id 'make-el-procedure)
		    (if (not (eq? (node-type e) vect))
			(begin
			   (warning 'typecheck "Turning "
				    (shape (global-type v))
				    " into 'vector")
			   (global-type-set! v vect)
			   (change vect) )))
		   ((eq? id 'procedure-el-ref)
		    (set-car! (cfun-args-type (global-value v)) vect)
		    (typeof e) )
		   ((eq? id 'procedure-el-set!)
		    (set-car! (cfun-args-type (global-value v)) vect)
		    (typeof e) )
		   ((eq? id 'make-el-procedure-1)
		    (if (not (eq? (node-type e) obj))
			(begin
			   (warning 'typecheck "Turning "
				    (shape (global-type v))
				    " into 'obj")
			   (global-type-set! v obj)
			   ;; CARE Could we more precise ?
			   (change obj) )))
		   ((eq? id 'procedure-1-el-ref)
		    (set-car! (cfun-args-type (global-value v)) obj)
		    (typeof e) )
		   ((eq? id 'procedure-1-el-set!)
		    (set-car! (cfun-args-type (global-value v)) obj)
		    (typeof e) )
		   (else (assign-type e (variable-type v))) ))))))

(define (check-args-params v l)
   (if (local? v)
       (for-each typecheck l)
       (with-access::global v (module value)
	  ;; CARE Do we have to check that we have a private function ?
	  (if (and (eq? module *module*) (sfun? value))
	      (for-each (lambda (param  arg)
			   (assign-type-var param (typecheck arg)) )
			(sfun-args value)
			l )
	      (for-each typecheck l) ))))

(define (check-args-params.old v l)
   (if (local? v)
       (for-each typecheck l)
       (with-access::global v (module value)
	  ;; CARE Do we have to check that we have a private function ?
	  (if (and (eq? module *module*) (sfun? value))
	      (for-each (lambda (param  arg)
			   (let ( (ot (variable-type param))
				  (t (typecheck arg)) )
			      (assign-type-var param t)
			      (when (and (hook? t) (not (hook? ot)))
				 ;; We have to recheck this function
				 (saw-typecheck v) )))
			(sfun-args value)
			l )
	      (for-each typecheck l) ))))

(define-method (typecheck e::app-ly)
   (with-access::app-ly e (fun arg)
      (typecheck fun)
      (typecheck arg)
      (typeof e) ))
	  
(define-method (typecheck e::funcall)
   (with-access::funcall e (fun args strength)
      (if (eq? strength 'elight)
	  (assign-type e (check-args-params (var-variable fun) args))
	  (begin (typecheck fun)
		 (for-each typecheck args)
		 (typeof e) ))))

(define-method (typecheck e::extern)
   (with-access::extern e (expr*)
      (for-each (lambda (e) (typecheck e)) expr*)
      (typeof e) ))

(define-method (typecheck e::cast)
   (with-access::cast e (arg)
      (typecheck arg)
      (typeof e) ))

(define-method (typecheck e::set-ex-it)
   (with-access::set-ex-it e (var body)
      (typecheck body)
      (typeof e) ))

(define-method (typecheck e::jump-ex-it)
   (with-access::jump-ex-it e (exit value)
      (typecheck exit)
      (typecheck value)
      (typeof e) ))

(define-method (typecheck e::fail)
   (with-access::fail e (proc msg obj)
      (typecheck proc)
      (typecheck msg)
      (typecheck obj)
      (typeof e) ))

(define-method (typecheck e::make-box)
   (with-access::make-box e (value)
      (typecheck value)
      (typeof e) ))

(define-method (typecheck e::box-ref)
   (typeof e) )

(define-method (typecheck e::box-set!)
   (with-access::box-set! e (var value)
      (typecheck value)
      (typeof e) ))

      
