(setq compile-debug-mode nil compfile-optimize nil)

(comment "compile and revert")

(macro compile (args) `(compile-0 ',args))

(defun compile-0 (args)
  (lets ((file (c:tempfile)) (hf (string-append file ".h"))
	 (cf (string-append file ".c")) (of (string-append file ".o"))
	 (hstream (outopen (stream hf))) (cstream (outopen (stream cf)))
	 (readtable compile-readtable)
	 (compiled-funcs) (compiling-funcs) (compfile-optimize)
	 (ncodepieces 1)
	 (fix-flag)
         (nliterals 0) (literals)
	 (current-fn '*toplevel*)
	 (current-cfn)
	 (codes) (sp 0))

    (c:compile-start hf hstream cstream)
    (mapc args (function (lambda (x) (c:gen (compile-1 x cstream hstream)))))
    (c:gen (copy '(return nil)))
    (c:dump-c current-fn (c:make-begin codes) cstream)
    (c:compile-end hf cf of t t)
    compiled-funcs))

(defun compile-1 (fn cs hs)
  (cond ((not (symbolp fn)) (c:warn "illegal function name" fn) nil)
	((not (definedp fn)) (c:warn "undefined function" fn) nil)
	((atom (getd fn)) (c:warn "definition is an atom" fn) nil) 
	(t (catch 'compile-error (compile-2 fn cs hs)))))

(defun compile-2 (fn cs hs)
   (match (putprop fn (getd fn) 'original-definition)
      (('lambda formals . body)
       (c:compile-function fn formals body hs cs)
       (c:make-code (c:post-incr ncodepieces) nil nil))
      (('macro 'lambda formals . body)
       (c:compile-macro fn formals body hs cs)
       (c:make-code (c:post-incr ncodepieces) nil nil))
      (def (c:warn (cond ((codep def) "definition is a code-piece")
                         (t "illegal definition"))
                   fn))))

(macro revert (args) `(mapc ',args (function revert*)))

(defun revert* (fn)
   (cond ((get fn 'original-definition) (putd fn (get fn 'original-definition)))
	 (t (c:warn "can't revert" fn))))

(comment "compfile")

(defun compfile (lf of (compopt 0) (printopt)) 
   (or (symbolp lf) (stringp lf) (c:error "not a file name" lf))
   (or (symbolp of) (stringp of) (c:error "not a file name" of))
   (setq lf(string lf) of(string of))
   (lets ((file (c:tempfile)) (hf (string-append file ".h"))
	  (cf (string-append file ".c"))
	  (lstream (inopen (stream (string lf))))
	  (hstream (outopen (stream hf)))
	  (cstream (outopen (stream cf)))
	  (readtable compile-readtable)
	  (compiled-funcs) (compiling-funcs)
	  (compfile-optimize (0= compopt)) (ncodepieces 1)
	  (fixflag))
    (cond ((= compopt 0)
	   (compfile-0 lstream hstream cstream hf cf of printopt))
          ((= compopt 1)
	   (compfile-1 lstream hstream cstream hf cf of printopt))
          ((= compopt 2)
	   (compfile-2 lstream hstream cstream hf cf of printopt)))))

(defun compfile-0 (ls hs cs hf cf of popt)
   (c:readfile ls)
   (inopen ls)
   (c:compile-start hf hs cs)
   (lets ((err:end-of-file (function (lambda (x (y)) (throw 'eof))))
	  (form)
          (nliterals 0) (literals)
	  (current-fn '*toplevel*)
	  (current-cfn)
	  (codes) (special-vars) (local-vars)
	  (sp 0) (cvars) (ivars) (tcheck-var (c:get-cvar))
	  (prog-tags) (catch-tags))
    (catch 'eof 
      (loop (catch 'compile-error
	    (setq form (read ls))
	    (match form
	       (('declare . rest))
	       (('compile-end) (close ls) (throw 'eof))
	       (form (format "compiling /s/n" form)
	  	     (c:gen-form form nil nil))))))
    (c:gen (copy '(return nil)))
    (c:dump-c current-fn
	      (c:make-block (nconc cvars (c:int-ivar ivars)) codes)
	      cs)
    (c:compile-end hf cf of nil nil)
    nil))

(comment "shitauke")

(defun c:compile-function (fn formals body hs cs)
   (lets ((name (or fn (gensym "func"))) (nliterals 1)
	  (literals `((,name . 0))) (minarg 0) (maxarg 0)
	  (info (cond (fn 'INFO_FUNC) (t 'INFO_NONE))))
    (c:dump-c name (c:lambda formals body name) cs)
    (c:dump-literal current-cfn literals hs)
    (c:dump-codeinfo current-cfn info nliterals maxarg minarg hs)
    (push name compiled-funcs)))

(defun c:compile-macro (fn formals body hs cs)
   (lets ((name (or fn (gensym "macro"))) (nliterals 1)
	  (literals `((,name . 0))) (minarg 0) (maxarg 0)
	  (info (cond (fn 'INFO_MACRO) (t 'INFO_NONE))))
    (c:dump-c name (c:lambda formals body name) cs)
    (c:dump-literal current-cfn literals hs)
    (c:dump-codeinfo current-cfn info nliterals maxarg minarg hs)
    (push name compiled-funcs)))

(defun c:compile-prop (fn formals body sym name hs cs)
   (lets ((nliterals 2) (literals `((,name . 1) (,sym . 0)))
	  (minarg 0) (maxarg 0) (compfile-optimize))
    (c:dump-c fn (c:lambda formals body fn) cs)
    (c:dump-literal current-cfn literals hs)
    (c:dump-codeinfo current-cfn 'INFO_PROP nliterals maxarg minarg hs)
    (push fn compiled-funcs)))

(defun c:tempfile nil (string-append "/tmp/uti" (number-image (getpid))))

(defun c:compile-start (hf hs cs)
   (c:dump-include hs)
   (lets ((standard-output cs)) (format "#include ""/c""/n" hf)))

(defun c:compile-end (hf cf of rmo load)
   (lets ((com (c:make-command cf of)))
    (c:dump-literal current-cfn literals hstream)
    (c:dump-codeinfo current-cfn 'INFO_NONE nliterals 0 0 hstream)
    (setq compiled-funcs (nreverse compiled-funcs))
    (cond (compiled-funcs
           (c:dump-infoarray `(,current-fn . ,compiled-funcs) hstream)
           (c:dump-initfunc (make-base-name of) hstream)
           (close hstream)
           (close cstream)
           (and compile-debug-mode (princ com) (terpri)) 
	   (and com (<> (call com) 0) (c:error "c-compile error" com))
           (and load (system-code-load of)))
	  (t (close hstream) (close cstream)))
    (or compile-debug-mode
	(call (cond (rmo (string-append "rm " of " " cf " " hf))
		    (t (string-append "rm " cf " " hf)))))))

(defun c:readfile (ls)
   (lets ((err:end-of-file (function (lambda (x (y)) (throw 'readfile)))) (x))
    (catch 'readfile
      (loop
	(setq x (read ls))
	(and (consp x)
	     (consp (cdr x))
	     (memq (car x) '(defun defmacro macro))
	     (c:funcname (second x)))))))

(defun c:dump-include ((standard-output standard-output))
   (format "#include <setjmp.h>/n")
   (format "#include <constdef.h>/n")
   (format "#include <defvar.h>/n")
   (format "#include <cmpdef.h>/n")
   (format "extern WORD make_codepiece2();/n")
   (format "#define make_code(n,fp) make_codepiece2(inf_array[n], fp)/n"))

(defun c:dump-literal (cfn lt (standard-output standard-output))
   (format "static char /c_literal[] = """ cfn)
   (mapc (nreverse lt)
	 (function (lambda (x) (c:dump-instring (car x)) (princ " "))))
   (format """;/n"))

(defun c:dump-instring (x)
   (cond ((symbolp x) (c:dump-symbol x))
	 ((stringp x) (c:dump-string x))
	 ((numberp x) (prin1 x))
	 ((vectorp x) (c:dump-vector x))
	 ((atom x) (c:warn "illegal object to dump" x))
	 (t (c:dump-cons x))))

(defun c:dump-symbol (sym)
   (lets ((m (string-search-char "\" sym)))
    (cond (m (and (<> (logor 128 (vref readtable (sref sym 0))) 0) (princ "/"))
	     (do ((i 0 (1+ i)) (str (string sym)) (c))
		 ((= i (string-length sym)))
                 (setq c (sref str i))
		 (cond ((= c (character "\")) (princ "\\")) (t (tyo c)))))
          (t (prin1 sym)))))

(defun c:dump-string (str)
   (princ "\""")
   (do ((i 0 (1+ i)) (c))
       ((= i (string-length str)))
       (setq c (sref str i))
       (cond ((= c (character """")) (princ "\""\"""))
	     ((= c (character "\")) (princ "\\"))
	     (t (tyo c))))
   (princ "\"""))

(defun c:dump-vector (v)
   (princ "#")
   (do ((i 0 (1+ i)) (l))
       ((= i (vector-length v))
	(cond ((null l) (princ "()")) (t (c:dump-cons (nreverse l)))))
       (push (vref v i) l)))

(defun c:dump-cons (x)
   (princ "(")
   (lets ((l (last x)))
    (map x
	(function
	  (lambda (y) (c:dump-instring (car y))
		      (or (eq y l) (princ " ")))))
    (and (cdr l) (princ " . ") (c:dump-instring (cdr l))))
   (princ ")"))

(defun c:dump-codeinfo (cfn p n maxarg minarg (standard-output standard-output))
    (format "static WORD /c_cf();/n" cfn)
    (format "static struct code_inf /c_info = {/n" cfn)
    (format "	/s, /s, /s, /s, /c_cf, /c_literal/n};/n"
       p n maxarg minarg cfn cfn)))

(defun c:dump-infoarray (fl (standard-output standard-output))
   (format "static struct code_inf *inf_array[] = {/n")
   (do ((l fl (cdr l)) (i 0))
       ((null l) (format "(struct code_inf *) 0/n};/n")) 
       (and (0= i) (tyo 9))
       (format "&/c_info, " (c:funcname (car l)))
       (cond ((= (incr i 1) 5) (terpri) (setq i 0)))))

(defun c:dump-initfunc (cfn (standard-output standard-output))
   (format "WORD init_code_/c(fp)/n" (translate cfn c-chartable))
   (format "WORD *fp;/n")
   (format "{/n	WORD rval;/n")
   (comment format "	printf(""enter initfunc\n"");/n")
   (format "	rval = make_code(0, fp);/n")
   (format "	rval = funcall(rval, 0, fp);/n")
   (format "	return(rval);/n}/n"))

