#!/usr/local/bin/calypso
; genthunk.l
;
; a stand-alone program for creating C thunks for calypso
;

(defun generate-temp-variable (index type)
  (cond ((= 'string type)
	 (fpatom fd "\tchar\t*a" index ", abuf" index "[1024];\n")
	 )
	((or (= 'intp type) (= 'int type))
	 (fpatom fd "\tint\ta" index ";\n")
	 )
	((or (= 'floatp type) (= 'float type))
	 (fpatom fd "\tdouble\ta" index ";\n")
	 )
	((or (= 'list type))
	 (fpatom fd "\tstruct dotted\t*a" index ";\n")
	 )
	(t (error (spatom "generate-thunk: bad type " type)))
	)
  )

(defun generate-type-check (index type)
  (cond ((= 'string type)
	 (fformat fd
		  "\tif (!stringp (arg%v) && !symbolp (arg%v)) {\n"
		  index index)
	 (fformat fd
		  "\t\terror (\"%a: non-string %%v\", arg%v);\n"
		  function-name
		  index)
	 (fformat fd "\t\treturn nil;\n")
	 (fformat fd "\t}\n");
	 (fformat fd "\ta%v = iCstring (itemtostring (arg%v));\n" index index);
	 )
	((or (= 'intp type) (= 'int type))
	 (fformat fd "\tif (nump (arg%v))\n" index)
	 (fformat fd "\t\ta%v = itemtonum (arg%v);\n" index index)
	 (fformat fd "\telse if (floatpp (arg%v))\n" index)
	 (fformat fd "\t\ta%v = (int) *itemtofloatp (arg%v);\n" index index)
	 (fformat fd "\telse {\n")
	 (fformat fd
		  "\t\terror (\"%a: non-number %%v\", arg%v);\n"
		  function-name
		  index)
	 (fformat fd "\t\treturn nil;\n")
	 (fformat fd "\t}\n");
	 )
	((or (= 'floatp type) (= 'float type))
	 (fformat fd "\tif (nump (arg%v))\n" index)
	 (fformat fd "\t\ta%v = (double) itemtonum (arg%v);\n" index index)
	 (fformat fd "\telse if (floatpp (arg%v))\n")
	 (fformat fd "\t\ta%v = *itemtofloatp (arg%v);\n" index index)
	 (fformat fd "\telse {\n")
	 (fformat fd
		  "\t\terror (\"%a: non-number %%v\", arg%v);\n"
		  function-name
		  index)
	 (fformat fd "\t\treturn nil;\n")
	 (fformat fd "\t}\n");
	 )
	((= 'list type)
	 (fpatom fd "\tif (nilp (arg" index "))\n"
	 	 "\t\ta" index " = nil;\n"
	 	 "\telse if (listp (arg" index "))\n"
		 "\t\ta" index " = itemtolist (arg" index ");\n"
		 "\telse {\n"
		 "\t\terror (\"" function-name
		 ": non-list %v\", sprint (arg"
		 index "));\n"
		 "\t\treturn nil;\n"
		 "\t}\n"
		 )
	 )
	)
  )
       
(defun generate-return-decl (type)
  (cond ((= 'string type)
	 (fpatom fd "\tchar\t*ret;\n")
	 )
	((or (= 'int type)
	     (= 'boolean type)
	     )
	 (fpatom fd "\tint\tret;\n")
	 )
	((= 'float type)
	 (fpatom fd "\tdouble\tret, *retp;\n")
	 )
	((= 'list type)
	 (fpatom fd "\tstruct dotted\t*ret;\n")
	 )
	((= 'boolean type)
	 (fpatom fd "\tint\tret;\n")
	 )
	((= 'void type)
	 )
	(t (error (spatom "generate-thunk: bad type " type)))
	)
  )

(defun generate-extern-decl (type name)
  (cond ((or (= 'int type)
	     (= 'boolean type)
	     )
	 t)
	(t
  	 (fpatom fd "#ifndef " name "\n")
  	 (cond ((= 'string type)
	 	(fpatom fd "\tchar\t*" name "();\n")
	 	)
	       ((= 'float type)
	 	(fpatom fd "\tdouble\t" name "();\n")
	 	)
	       ((= 'list type)
		(fpatom fd "\tstruct dotted\t*" name "();\n")
		)
	       )
  	 (fpatom fd "#endif\n")
	 )
	)
  )

(defun generate-return-value (type)
  (cond ((= 'string type)
	 (fpatom fd "stringtoitem (iStrcpy (ret))")
	 )
	((= 'int type)
	 (fpatom fd "intRet (ret)")
	 )
	((= 'boolean type)
	 (fpatom fd "ret ? symboltoitem (true) : nil")
	 )
	((= 'float type)
	 (fpatom fd "doubleRet (ret)")
	 )
	((= 'void type)
	 (fpatom fd "symboltoitem (true)")
	 )
	((= 'list type)
	 (fpatom fd "ret ? listtoitem (ret) : nil")
	 )
	)
  )

(defun generate-thunk (proto-type fd)
  (let ((return-type (car proto-type))
	(function-name (cadr proto-type))
	(args (cddr proto-type))
	(arg-count (length (cddr proto-type)))
	(string-args 0)
	(i))
    (fpatom fd "lispval\nlisp_" (get-name function-name) " (")
    (setq i 0)
    (while (< i arg-count)
	   (if (not (string? (nth i args))) then
	       (fpatom fd "arg" i)
	       (++ i)
	       (cond ((< i arg-count) (fpatom fd ", ")))
	    else
	       (++ i)
	       (++ string-args)
	       )
	   )
    (fpatom fd ")\n")
    (if (< string-args arg-count) then
    	   (setq i 0)
    	   (fpatom fd "lispval ")
    	   (while (< i arg-count)
		  (if (not (string? (nth i args)))
	   	      (fpatom fd "arg" i)
	   	      (++ i)
	   	      (cond ((< i arg-count) (fpatom fd ", "))
		 	    (t (fpatom fd ";\n"))
		 	    )
		   else
		      (++ i)
		      )
	   	  )
	)
    (fpatom fd "{\n"
	   )
    (generate-return-decl return-type)
    (generate-extern-decl return-type (get-name function-name))
    (setq i 0)
    (while (< i arg-count)
	   (if (not (string? (nth i args))) then
	       (generate-temp-variable i (nth i args))
	       )
	   (++ i)
	   )
    (fpatom fd "\n")
    (setq i 0)
    (while (< i arg-count)
	   (if (not (string? (nth i args))) then
	       (generate-type-check i (nth i args))
	       )
	   (++ i)
	   )
    (cond ((= 'void return-type)
    	   (fformat fd "\t")
	   )
	  (t
    	   (fformat fd "\tret = ")
	   )
	  )
    (fformat fd "%v (" function-name)
    (setq i 0)
    (while (< i arg-count)
	   (if (string? (nth i args)) then
	       (fpatom fd (nth i args))
	    elseif (or (= 'floatp (nth i args)) (= 'intp (nth i args))) then
	       (fformat fd "&a%v" i)
	    else
	       (fformat fd "a%v" i)
	       )
	   (setq i (1+ i))
	   (cond ((< i arg-count) (fpatom fd ", ")))
	   )
    (fpatom fd ");\n")
    (fpatom fd "\treturn ")
    (generate-return-value return-type)
    (fpatom fd ";\n" "}\n\n")
    (fformat fd "struct builtin LISP%v = { \"%v\", lisp_%s, LAMBDA, %v };\n\n"
	     function-name
	     (cond (adjust-name
		    (adjust-name function-name)
		    )
		   (t (sprint function-name))
		   )
	     function-name
	     (- arg-count string-args)
	     )
    t
    )
  )

(defun make-thunks (in-fd out-fd)
  (fpatom out-fd "/* lisp thunks for c routines */\n"
	  "# include <local/calypso.h>\n\n"
	  )
  (setq adjust-name nil)
  (while (setq proto-type (fread in-fd))
	 (cond ((string? proto-type) (fpatom out-fd proto-type))
	       ((= (car proto-type) 'eval)
		(eval (cadr proto-type))
		)
	       (t
		(generate-thunk proto-type out-fd)
		)
	       )
	 )
  t
  )

(if argv then
    (while argv
	   (let ((in-fd (fopen (car argv) "r")))
	     (make-thunks in-fd stdout)
	     (fclose in-fd)
	     )
	   (setq argv (cdr argv))
	   )
 else
    (make-thunks stdin stdout)
    )
(exit 0)
