;; lisp2c.lsp -- feeble attempt at Lisp-to-C translator/compiler
;; (c) 1997 Will Ware  
;; GNU General Public License

;; This assumes a C library of Common Lisp functions which doesn't yet exist.
;; Code produced by this translator is pretty illegible, so run it thru
;; 'indent' or another C pretty-printer. The translation process is not
;; complete or automatic by any means, you *will* need to hand-edit the
;; resulting C code. This thing has been tried on only a little bit of Lisp
;; code, and will probably break on almost anything else, but hey, it's free.
;; This code is provided "as is". Good luck, you're on your own.

(defconstant object-prefix "OBJECT ")  ;; "OBJ*" ? "CONS*" ???

(defconstant scarey-list
  '(do dolist mapcar defstruct))  ;; add more things here to prevent horror

(defvar pending-stuff "")

(defun locals-list (x)
  (cond ((null x) "")
	((atom x) "???")
	((atom (car x))
	 (format nil "~a~a;~%~a"
		 object-prefix
		 (clean-name (car x))
		 (locals-list (cdr x))))
	(t
	 (format nil "~a~a = ~a;~%~a"
		 object-prefix
		 (clean-name (caar x))
		 (expression (cadar x))
		 (locals-list (cdr x))))))

(defun arg-list (x iflag)
  (cond ((null x) "")
	((atom x) "???")
	((null (cdr x)) (concatenate
			 'string
			 (if iflag object-prefix "")
			 (expression (car x))))
	(t (concatenate
	    'string
	    (if iflag object-prefix "")
	    (expression (car x))
	    ", "
	    (arg-list (cdr x) iflag)))))

(defun statement-list (x)
  (cond ((null x) "")
	((atom x) "/*?????*/ ;")
	(t (format nil "~a~%~a"
		   (statement (car x) nil)
		   (statement-list (cdr x))))))

(defun clean-name (str)
  (cond ((eq str "+") "add")
	((eq str "-") "subtract")
	((eq str "*") "multiply")
	((eq str "/") "divide")
	((eq str "<") "less_than")
	((eq str ">") "greater_than")
	((eq str "=") "numerical_equal")
	((eq str "<=") "less_than_or_equal")
	((eq str ">=") "greater_than_or_equal")
	(t (if (not (stringp str))
	       (setf str (format nil "~a" str)))
	   (do ((i 0 (1+ i)) c)
	       ((= i (length str)) str)
	       (setf c (char-downcase (char str i)))
	       (if (eq c #\-) (setf c #\_))
	       (setf (char str i) c)))))

(defun hack-if (x)
  (format nil "if (~a) {~%~a}~a"		 
	  (expression (cadr x))
	  (statement (caddr x) nil)
	  (if (cdddr x)
	      (format nil "else {~%~a}"
		      (statement (cadddr x) nil))
	    "")))

(defun hack-cond (x)
  (do ((L (cdr x) (cdr L)) (z ""))
      ((null L) z)
      (setf z
	    (concatenate 'string z
			 (format nil "~a{~%~a}~a"
				 (if (not (eq (caar L) t))
				     (format nil "if (~a) "
					     (expression (caar L)))
				   "")
				 (statement-list (cdar L))
				 (if (cdr L) "else " ""))))))

(defun hack-case (x)
  (concatenate
   'string
   "switch ("
   (expression (cadr x))
   (format nil ") {~%")
   (do ((L (cddr x) (cdr L)) (z ""))
       ((null L) z)
       (cond ((eq (caar L) 'else)
	      (setf z (concatenate 'string z
				   (format nil "default: ~a break"
					   (statement-list (cdar L))))))
	     ((atom (caar L))
	      (setf z (concatenate 'string z
				   (format nil "case ~a: ~a break;~%"
					   (expression (caar L))
					   (statement-list (cdar L))))))
	     ((eq (caaar L) 'quote)
	      (setf z (concatenate 'string z
				   (format nil "case ~a: ~a break;~%"
					   (expression (cadaar L))
					   (statement-list (cdar L))))))
	     (t
	      (dolist
	       (g (caar L))
	       (setf z
		     (concatenate 'string z
				  (format nil "case ~a: "
					  (expression g)))))
	      (setf z
		    (concatenate 'string z
				 (statement-list (cdar L)))))))
   "}"))

(defun put-pending (s)
  (setf pending-stuff
	(concatenate 'string pending-stuff s)))

(defun build-function (name args body)
  (format nil "~a~a (~a) {~%~a}"
	  object-prefix
	  name
	  (arg-list args t)
	  body))

(defvar aux-func-name nil)

(defun build-auxiliary-function (args body)
  (setf aux-func-name (format nil "aux_~a" (gensym)))
  (build-function aux-func-name args body))

(defun expression (x)
  (cond ((null x) "NIL")
	((numberp x) (format nil "~a" x))
	((stringp x) (format nil "~s" x))
	((eq x t) "TRUE")
	((atom x) (clean-name (format nil "~a" x)))

	((eq (car x) 'null)
	 (format nil "NULLP(~a)"
		 (expression (cadr x))))

	((eq (car x) 'atom)
	 (format nil "ATOMP(~a)"
		 (expression (cadr x))))

	((eq (car x) 'listp)
	 (format nil "LISTP(~a)"
		 (expression (cadr x))))

	((eq (car x) '1+)
	 (format nil "(~a) + 1" (expression (cadr x))))

	((eq (car x) '1-)
	 (format nil "(~a) - 1" (expression (cadr x))))

	((eq (car x) 'quote)
	 (if (atom (cadr x))
	     (expression (cadr x))
	   (format nil "~s" (cadr x))))

	((eq (car x) 'format)
	 (cond ((eq (cadr x) t)
		(expression (cons 'printf (cddr x))))
	       ((eq (cadr x) nil)
		(expression (cons 'sprintf (cons 'tempstr (cddr x)))))
	       (t
		(expression (cons 'fprintf (cdr x))))))

	((eq (car x) 'nth)
	 (format nil "~a[~a]"
		 (expression (caddr x))
		 (expression (cadr x))))

	((eq (car x) 'cond)
	 (hack-cond x))

	((eq (car x) 'if)
	 (put-pending
	  (build-auxiliary-function (list (cadr x)) (hack-if x)))
	 (format nil "~a(~a)" aux-func-name (clean-name (cadr x))))

	((eq (car x) 'case)
	 (put-pending
	  (build-auxiliary-function (list (cadr x)) (hack-case x)))
	 (format nil "~a(~a)" aux-func-name (clean-name (cadr x))))

        ((or (eq (car x) 'let)
             (eq (car x) 'let*))
         (format nil "{~%~a~a}"
                 (locals-list (cadr x))
                 (statement-list (cddr x))))

	((eq (car x) 'labels)
	 (dolist (y (cadr x))
		 (setf
		  pending-stuff
		  (concatenate
		   'string
		   pending-stuff
		   (format nil "~a~a (~a) {~%~a}"
			   object-prefix
			   (clean-name (car y))
			   (arg-list (cadr y) t)
			   (statement-list (cddr y))))))
	 (statement-list (cddr x)))

	((member (car x) scarey-list)
	 (format nil "SCAREY_STUFF /* ~s */ " (car x)))

	(t
	 (format nil "~a(~a)"
		 (clean-name (car x))
		 (arg-list (cdr x) nil)))))

(defun statement (x top-level)
  (cond ((null x) (format nil "return NIL;"))
	((numberp x) (format nil "return ~a;" x))
	((stringp x) (format nil "return ~s;" x))
	((eq x t) "return TRUE;")
	((atom x) (clean-name (format nil "return ~a;" x)))

	((eq (car x) 'if)
	 (hack-if x))

	((or (eq (car x) 'setf)
	     (eq (car x) 'setq)
	     (eq (car x) 'defvar))
	 (format nil "~a~a = ~a;"
		 (if top-level object-prefix "")
		 (clean-name (cadr x))
		 (expression (caddr x))))

	((eq (car x) 'defconstant)
	 (format nil "#define ~a ~a"
		 (clean-name (cadr x))
		 (expression (caddr x))))

	((eq (car x) 'defun)
	 (build-function (clean-name (cadr x))
			 (caddr x)
			 (statement-list (cdddr x))))

	;; don't even try to understand Common Lisp macros
	((eq (car x) 'defmacro)
	 (format nil "/* ~s */" x))

	((eq (car x) 'dotimes)
	 (let ((var (clean-name (caadr x))))
	   (format nil
		   "for (~a = 0; ~a < ~a; ~a++) {~%~a}"
		   var var (expression (cadadr x)) var
		   (statement-list (cddr x)))))

	((eq (car x) 'load)
	 (format nil "#include ~s" (cadr x)))

	(t
	 (format nil "~a;"
		 (expression x)))))

(defun lisp2c (inname outname)
  (let ((inf (open (make-pathname :name inname)))
	(outf (open (make-pathname :name outname)
		    :direction :output
		    :if-exists :supersede)))
    (do ((x (read inf nil 'eof) (read inf nil 'eof)))
	((eq x 'eof))
	(format outf "~a~%" (statement x t))
	(if (> (length pending-stuff) 0)
	    (let ()
	      (format outf "~a~%" pending-stuff)
	      (setf pending-stuff ""))))
    (close inf)
    (close outf)))