(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);")))

(defun new-proclaimed-argd (args return);FIXME room for more, but F_NARG_WIDTH = 6
  (do* ((type (f-type return) (f-type (pop args)))
	(i 0 (+ 2 i))
	(ans type (logior ans (ash type i))))
       ((or (>= i 14) (null args)) (the (unsigned-byte 15) ans))))
