(in-package :compiler)

(defun c-key-rep (key)
  (ecase key
    ((:object :char :int :long :float :double :fixnum :void) (string-downcase key))
    (:string "char *")
    (:ustring "unsigned char *")))

(defmacro defentry (n args c &optional (lt t)
		      &aux (tsyms (load-time-value
				   (mapl (lambda (x) (setf (car x) (gensym "DEFENTRY")))
					 (make-list call-arguments-limit)))))
  (let* ((cp (consp c))
	 (st (and cp (eq (car c) 'static)))
	 (c (if st (cdr c) c))
	 (m (if cp (cadr c) c))
	 (m (if (symbolp m) (string-downcase m) m))
	 (rt (intern (symbol-name (if cp (car c) lt)) 'keyword))
	 (tps (mapcar (lambda (x) (intern (string (if (consp x) (car x) x)) 'keyword)) args))
	 (decl (reduce (lambda (y x)
			 (strcat y (if (> (length y) 0) "," "")
				 (c-key-rep x)))
		       tps :initial-value ""))
	 (decl (concatenate 'string (c-key-rep rt) " " m "(" decl ");"))
	 (decl (if st "" decl))
	 (syms (mapcar (lambda (x) (declare (ignore x)) (pop tsyms)) args)))
  `(defun ,n ,syms 
     (declare (optimize (safety 2)))
     ,@(mapcar (lambda (x y) `(check-type ,x ,(get y 'lisp-type))) syms tps)
     (lit ,(if (eq rt :void) :object rt)
	  "({" ,decl 
	  ,@(when (eq rt :void) `("("))
	  ,m "("
	  ,@(mapcon (lambda (x y z) `((,(car z) ,(car y))
				      ,(if (cdr x) (if (consp (car x)) "+" ",") ""))) args syms tps)
	  ")"
	  ,@(when (eq rt :void) `(",Cnil)"))
	  ";})"))))

(defun fm-to-string (form)
  (typecase form
;    (null "Cnil")
;    (true "Ct")
    ((cons (eql vv) t) (fm-to-string (cadr form)))
    ((cons (member char-value fixnum-value character-value) t) (fm-to-string (caddr form)))
    ((eql most-negative-fixnum)  #.(string-concatenate "(" (write-to-string (1+ most-negative-fixnum)) "- 1)"))
    (fixnum (format nil "~a" form)); string character
    (float (format nil "~10,,,,,,'eG" form))
    ((complex float)
     (string-concatenate "(" (fm-to-string (realpart form)) " + I * " (fm-to-string (imagpart form)) ")"))))

(when (eql 32 (si::heap-report))
  (setq compiler::*cmpinclude-string* (compiler::mysub compiler::*cmpinclude-string* "void *alloca(unsigned long);" "void *alloca(unsigned);")))


(defconstant +max-typed-args+ (let ((x (cdr (tp-bnds (cadr (si::sig 'c-function-argd))))))
				(if (typep x 'fixnum) (1- (truncate (integer-length x) 2)) 0)))

(defun new-proclaimed-argd (args return)
  (do* ((type (f-type return) (f-type (pop args)))
	(i 0 (+ 2 i))
	(ans type (logior ans (ash type i))))
       ((or (>= i #.(ash (1+ +max-typed-args+) 1)) (null args))
	(the (unsigned-byte #.(1+ (ash (1+ +max-typed-args+) 1))) ans))))

(defun wt-requireds (requireds arg-types &optional first narg &aux (i -1))
  (declare (ignore arg-types))
  (flet ((wt (x) (wt x) (let ((*compiler-output1* *compiler-output2*)) (wt x))))
	(dolist (v requireds (wt (if narg ",...)" ")")))
	  (setq narg (or narg (is-narg-var v)))
	  (let* ((gt (global-type-bump (if (< (incf i) +max-typed-args+) (var-type v) t)))
		 (cvar (cs-push gt t)))
	    (when first (wt ","))
	    (setq first t)
	    (setf (var-loc v) cvar)
	    (wt *volatile*)
	    (wt (register v))
	    (wt (rep-type gt))
	    (wt "V")
	    (wt cvar)))))



(defun t3defun-local-entry (fname cfun lambda-expr sp inline-info
				  &aux specials *reg-clv* (requireds (caaddr lambda-expr)) nargs (i -1))
  (do ((vl requireds (cdr vl))
       (types (cadr inline-info) (cdr types)))
      ((endp vl))
      (cond ((eq (var-kind (car vl)) 'special)
	     (push (cons (car vl) (var-loc (car vl))) specials))
	    ((var-cb (car vl)) (push (list (eq 'clb (var-loc (car vl))) (car vl)) *reg-clv*))
;	    ((var-cb (car vl)) (push (car vl) *reg-clv*))
	    ((setf (var-kind (car vl))
		   (or (when (< (incf i) +max-typed-args+)
			 (car (member (promoted-c-type (var-type (car vl))) +c-local-arg-types+)))
		       'object))))
      (setf (var-loc (car vl)) (cs-push (var-type (car vl)) t)))
  (when (is-narg-le lambda-expr)
    (setq nargs (car (last requireds)))
    (setf (var-register nargs) 0))
  (let* ((s (function-string fname))
	 (g (when (stringp cfun) (char= #\G (char cfun 0)))))
    (wt-comment (strcat (if g "global" "local") " entry for function ") s))
  (wt-h "static " (declaration-type (rep-type (caddr inline-info))) (c-function-name "LI" cfun fname) "(")
  (wt-nl1 "static " (declaration-type (rep-type (caddr inline-info))) (c-function-name "LI" cfun fname) "(")
  (wt-requireds requireds (cadr inline-info) nil nargs)
  (wt-h ";")
  (let* ((cm *reservation-cmacro*))
	 ;; (tri (tail-recursion-info fname nil lambda-expr))
	 ;; (*unwind-exit* (if tri (cons 'tail-recursion-mark *unwind-exit*) *unwind-exit*)))
    (wt-nl1 "{	")
    (wt " VMB" cm " VMS" cm " VMV" cm)
    (when nargs (wt-nl "va_list ap;")(wt-nl "va_start(ap,V" (var-loc nargs) ");"))

    (when sp (wt-nl "bds_check;"))
    (when *compiler-push-events* (wt-nl "ihs_check;"))
;    (dolist (v clv) (setf (var-ref v) (list 'cvar (var-loc v))) (c2bind v))
    (dolist (v specials)
      (setq *bds-used* t)
      (wt-nl "bds_bind(" (vv-str (cdr v)) "," `(gen-loc :object (cvar ,(var-loc (car v)))) ");")
      (push 'bds-bind *unwind-exit*)
      (setf (var-kind (car v)) 'SPECIAL)
      (setf (var-loc (car v)) (cdr v)))
    (let ((*mv-var* (mv-var lambda-expr)))
      (c2expr (caddr (cddr lambda-expr)))
      (wt-V*-macros cm (caddr inline-info)))
    
    
;;; Make sure to return object if necessary
;    (if (equal "object " (rep-type (caddr inline-info))) (wt-nl "return Cnil;"))

    (when nargs (wt-nl "va_end(ap);"))
    (wt-nl1 "}")))
