;;;; 	Copyright (C) 1995 Free Software Foundation, Inc.
;;;; 
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2, or (at your option)
;;;; any later version.
;;;; 
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;; 
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING.  If not, write to
;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
;;;; 


(require 'match-slib)

;;; A compiler back-end for a C-like language, targetting
;;; the Java-like bytecode engine in Guile.
;;;



;;; {Syntax Trees for Functions}
;;; 
;;; (fn  type name 
;;;      ((type arg) (type arg)...) 
;;;      ((type local) (type local)...)
;;;      (stmt stmt...)
;;;      source-pos__opt)
;;; 
;;; (struct type ((type field) ...) source-pos__opt)


(define (make-cfn type name args locals stmts)
  (append! (list 'cfn type name args locals) stmts))

(define (cfn-type cfn) (cadr cfn))
(define (cfn-name cfn) (caddr cfn))
(define (cfn-args cfn) (cadddr cfn))
(define (cfn-locals cfn) (car (cddddr cfn)))
(define (cfn-statments cfn) (cadr (cddddr cfn)))
(define (cfn-source-pos cfn)
  (and (pair? (cddr (cddddr cfn)))
       (caddr (cddddr cfn))))


;;; {Symbol Tables}
;;;

(define (make-cfn-symbol-table) (make-table))

(define (cfn-find syms type symbol)
  (cond
   ((aref syms (cons type symbol)) => cdr)
   (else #f)))
(define (cfn-set! syms type symbol value)
  (aset! syms (cons type symbol) value))

(define (cfn-struct-type syms name)
  (cfn-find syms 'struct name))
(define (set-cfn-struct-type! syms name val)
  (cfn-set! syms 'struct name val))

(define (cfn-fn-source syms name)
  (cfn-find syms 'fn name))
(define (set-cfn-fn-source! syms name val)
  (cfn-set! syms 'fn name val))

(define (cfn-fn-bytecodes syms name)
  (cfn-find syms 'fn-bytecodes name))
(define (set-cfn-fn-bytecodes! syms name val)
  (cfn-set! syms 'fn-bytecodes name val))

(define (cfn-global-var syms name)
  (cfn-find syms 'global name))
(define (set-cfn-global-var! syms type name)
  (cfn-set! syms 'global name (list name type)))



;;; {Computing the Type of a Function from its Syntax Tree}
;;;

(define cfn-type-sigs
  '((int 	i)
    (float 	f)
    (scm	S)))

(define (cfn fn syms)
  (lambda rest
    (apply fn syms rest)))

(define (cfn-type-sig syms type)
  (cond
   ((assoc type cfn-type-sigs) => cadr)
   (else (cfn-struct-sig syms type))))

(define (cfn-fn-signature syms fn)
  (let* ((ret (cfn-type fn))
	 (args (cfn-args fn))
	 (arg-types (map cadr args))
	 (arg-sigs (map (cfn cfn-type-sig syms) arg-types))
	 (arg-string (apply string-append arg-sigs)))
    (string-append "(" arg-string ")" (cfn-type-sig syms ret))))
     


;;; {Temporary Entry Points into the Compiler}
;;;
(define (cfn-compile syms thing)
  (match thing
    (`(struct . ,_)
     (cfn-compile-struct syms thing))

    (`(cfn . ,_)
     (cfn-compile-fn syms thing))))

(define (cfn-compile-struct! syms defn)
  (if (cfn-struct-type syms name)
      (error 'multiply-defined-struct defn)
      (set-cfn-struct-type! syms defn)))

  
(define (cfn-compile-fn! syms defn)
  (if (cfn-fn-source syms (cfn-name defn))
      (error 'multiply-defined-function defn)
      (set-cfn-fn-source! syms (cfn-name defn) defn)))

(define (cfn-fn-bytecodes syms fn-name)
  (or (cfn-fn-bytecodes syms fn-name)
      (begin
	(set-cfn-fn-bytecodes!
	 syms fn-name
	 (cfn-compute-bytecodes syms
				(or (cfn-fn-source syms fn-name)
				    (error 'undefined-fn fn-name))))
	(cfn-fn-bytecodes syms fn-name))))
  
(define genlabel
  (let ((n -1))
    (lambda (root)
      (set! n (+ 1 n))
      (string->symbol (string-append root (number->string n))))))


;;; {The Heart of the Compiler}
;;
;; Overall, this function compiles one function.
;; It returns a list
;;   (contant-table fn-name fn-signature nlocals nstack bytecode)
;;

(define (cfn-compute-bytecodes syms fn)

  (define (appropriate-return type)
    (case type
      ((int) 'ireturn)
      ((float) 'freturn)
      ((void) 'vreturn)
      (else 'areturn)))

  (define (decl-locals locals)
    (define (decl-type type)
      (case type
	((int) 'ilocal)
	((float) 'flocal)
	((scm) 'alocal)
	(else 'alocal)))
    (let loop  ((x 0)
		(answer '())
		(locals locals))
      (if (null? locals)
	  answer
	  (loop (+ x 1)
		(cons `(decl ,(caar locals)
			     (,(decl-type (cadar locals)) ,x))
		      answer)
		(cdr locals)))))

  (define (find-variable sym)
    (or (assoc sym (cfn-locals fn))
	(assoc sym (cfn-args fn))
	(cfn-global-var syms sym)
	(error 'undefined-var sym)))
  
  ;; The expression compiler:
  ;;
  (define (compile-expression
	   syms fn max-depth so-far depth expr type return)


    (define (monop? op)
      (member op '(- ! ~)))

    (define (monop-inx op type)
      (cond
       ((assoc (list op type)
	       '(((- int) 	ineg)
		 ((- float) 	fneg)
		 ((- scm)	sneg)
		 ((~ int) 	ibitnot)
		 ((! int) 	icnot)
		 ((! scm) 	scnot)))
	=> cadr)
       (else (error 'illegal-type type expression))))

    (define (binop? op)
      (member op '(+ - * / ^ & | && ||)))

    (define (binop-inx op type)
      (cond
       ((assoc (list op type)
	       '(((+ int) 	iadd)
		 ((- int) 	isub)
		 ((* int) 	imul)
		 ((/ int) 	idiv)
		 ((% int)	imod)
		 ((&& int)	icand)
		 ((|| int)	icor)

		 ((+ float) 	fadd)
		 ((- float) 	fsub)
		 ((* float) 	fmul)
		 ((/ float) 	fdiv)
		 ((% float)	fmod)

		 ((+ scm) 	sadd)
		 ((- scm) 	ssub)
		 ((* scm) 	smul)
		 ((/ scm) 	sdiv)
		 ((% scm)	smod)
		 ((&& scm)	scand)
		 ((|| scm)	scor)

		 ((^ int) 	ixor)
		 ((& int) 	iand)
		 ((| int) 	ior)))
	=> cadr)
       (else (error 'illegal-type type expr))))

    (define cast-inxs
      '(((int float) i2f)
	((float int) f2i)
	((int void) drop)
	((float void) drop)

	((finish-these:

	((scm int) s2i)
	((scm float) s2f)
	((int scm) i2s)
	((float scm) f2s)))))

    (define (compile-cast from to so-far)
      (if (or (not to) (eq? from to))
	  so-far
	  (cond
	   ((assoc (list from to) cast-inxs)
	    => (lambda (inx)
		 `((,(cadr inx)) . ,so-far)))
	   (else (error 'illegal-implicit-cast from to expr)))))

    (define (stronger-type a b)
      (let* ((types '(scm float int)))
	(cond
	 ((member b (or (member a types) '()))  a)
	 ((member a (or (member b types) '()))  b)
	 (else (error 'illegal-type-combination a b expr)))))

    (define (compound? op) (member op '(+= -= *= /= %= &= |=)))

    (define (op-of-compound op)
      (string->symbol (substring op 0 (+ -1 (string-length op)))))

    (define (appropriate-dup type) 'dup)

    (match expr
      ((? number? n)
       (let ((n2 (case type
		   ((int) (inexact->exact n))
		   ((float) (exact->inexact n))
		   (else n))))
	 (return (cond
		  ((exact? n2) 'int)
		  (else 'float))
		 (max max-depth
		      (+ 1 depth))
		 `((load ,n2)
		   . ,so-far))))


      (((? compound? op) a b)
       (compile-expression
	syms fn max-depth so-far depth
	`(= ,a (,(op-of-compound op) ,a ,b))
	type return))

      ((? symbol? x)
       (let* ((var (find-variable x))
	      (var-type (cadr var))
	      (expr-type (or type var-type)))
	 (return expr-type
		 (max max-depth (+ 1 depth))
		 (compile-cast var-type expr-type
			       `((load ,x) . ,so-far)))))

      (`(= ,a ,b)
       (let* ((a-var (find-variable a))
	      (a-type (cadr a-var)))
	 (compile-expression
	  syms fn max-depth so-far depth b #f
	  (lambda (b-type max-depth new-code)
	    (let ((expr-type (or type a-type)))
	      (return expr-type
		      max-depth
		      (let ((storable (compile-cast b-type a-type new-code)))
			(if (eq? type 'void)
			    `((store ,a)
			      . ,storable)
			    (compile-cast
			     a-type type
			     `((store ,a)
			       (,(appropriate-dup a-type))
			       . ,storable))))))))))

      (((? monop? op) a)
       (compile-expression
	syms fn max-depth so-far depth a #f
	(lambda (a-type max-depth so-far)
	  (let ((expr-type (or type a-type)))
	    (return expr-type
		    max-depth
		    (compile-cast a-type type
				  `((,(monop-inx op a-type)) . ,so-far)))))))

      (((? binop? op) a b)
       (compile-expression
	syms fn max-depth '() depth a #f
	(lambda (a-type a-max-depth a-code)
	  (compile-expression
	   syms fn (max a-max-depth max-depth)
	   '() (+ 1 depth) b #f
	   (lambda (b-type b-max-depth b-code)
	     (let* ((op-type (stronger-type a-type b-type))
		    (expr-type (or type op-type)))
	       (return expr-type
		       b-max-depth
		       (compile-cast op-type expr-type
				     `((,(binop-inx op op-type))
				       . ,(append!
					 (compile-cast b-type op-type b-code)
					 (compile-cast a-type op-type a-code)
					 so-far))))))))))



      (else (error 'illegal-expression expr))))

    
  ;; The statement compiler
  ;;
  (define (compile-statements syms fn stmts break nstack so-far return)

    (if (null? stmts)
	(return nstack so-far)
	(let ((stmt (car stmts)))
	  (match stmt
	    (`(if ,pred ,cnsq ,anti)
	     (let ((anti-label (genlabel 'else))
		   (fi-label (genlabel 'fi)))
	       (compile-expression
		syms fn 0 so-far 0 pred 'int
		(lambda (expr-type this-nstack new-code)
		  (compile-statements
		   syms fn (list cnsq) break (max nstack this-nstack)
		   (cons `(ifeq ,anti-label)
			       new-code)
		   (lambda (this-nstack new-code)
		     (compile-statements
		      syms fn (list anti) break (max nstack this-nstack)
		      (cons anti-label
			    (cons `(goto ,fi-label)
				  new-code))
		      (lambda (this-nstack new-code)
			(compile-statements
			 syms fn (cdr stmts) break (max this-nstack nstack)
			 (cons fi-label new-code)
			 return)))))))))

	      

	    (`(for ,init ,test ,inc ,body)
	     (let ((test-label (genlabel 'for))
		   (continue-label (genlabel 'continue-label))
		   (break-label (genlabel 'break)))
	       (compile-expression
		syms fn 0 so-far 0 init 'void
		(lambda (ign this-nstack new-code)
		  (compile-expression
		   syms fn 0 (cons test-label new-code) 0 test 'int
		   (lambda (ign this-nstack new-code)
		     (compile-statements
		      syms fn (list body) break-label (max nstack this-nstack)
		      `((ifeq ,break-label)
			. ,new-code)
		      (lambda (this-nstack new-code)
			(compile-expression
			 syms fn 0
			 `(,continue-label . ,new-code)
			 0 inc 'void
			 (lambda (ign this-nstack new-code)
			   (compile-statements
			    syms fn (cdr stmts) break
			    (max nstack this-nstack)
			    `(,break-label
			      (goto ,test-label)
			      . ,new-code)
			    return)))))))))))
			 

	    (`(while ,test ,body)
	     (let ((test-label (genlabel 'while))
		   (break-label (genlabel 'break)))
	       (compile-expression
		syms fn 0 (cons test-label so-far) 0 test 'int
		(lambda (expr-type this-nstack new-code)
		  (compile-statements
		   syms fn (list body) break-label (max nstack this-nstack)
		   `((ifeq ,break-label)
		     . ,new-code)
		   (lambda (this-nstack new-code)
		     (compile-statements
		      syms fn (cdr stmts) break
		      (max nstack this-nstack)
		      `(,break-label
			(goto ,test-label)
			. ,new-code)
		      return)))))))

;;;	    (`(do ,body ,test) )
	      

	    (`(begin . ,body) 
	     (compile-statements syms fn (append! body (cdr stmts)) break
				 nstack so-far return))
	    
	    (`(return)
	     (if (not (eq? 'void (cfn-type fn)))
		 (error 'return-missing-expression fn)
		 (return this-nstack `((vreturn) . ,new-code))))

	    (`(return ,expression)
	     (if (not (null? (cdr stmts)))
		 (warning 'statements-after-return stmts))
	     (let ((type (cfn-type fn)))
	       (compile-expression syms fn 0 so-far 0 expression type
				   (lambda (expr-type this-nstack new-code)
				     (return (max this-nstack nstack)
					     (if (eq? type 'void)
						 new-code
						 (cons (list (appropriate-return type))
						       new-code)))))))

	    ( else
	      (compile-expression syms fn 0 so-far 0 (car stmts) 'void
				  (lambda (expr-type this-nstack new-code)
				    (compile-statements
				     syms fn (cdr stmts) break
				     (max nstack this-nstack) new-code return))))))))


  ;; Entry to the back-end:
  ;;
  (let* ((name (cfn-name fn))
	 (signature (cfn-fn-signature syms fn))
	 (constants (make-vector 1 #f))
	 (nlocals (+ (length (cfn-locals fn))
		     (length (cfn-args fn)))))

    (compile-statements
     syms fn (cfn-statments fn) #f 0 '()
     (lambda (nstack reversed-asm)
       (let* ((asm-body (reverse (cons '(halt) reversed-asm)))
	      (asm-header (decl-locals (append (cfn-args fn)
					       (cfn-locals fn))))
	      (asm (append! asm-header asm-body))
	      (bytes asm))
	 (list constants name signature nlocals nstack bytes))))))






;;; A mess of syntax trees for testing...
;;;

(define source '(fn int cross ((a int) (b int)) () ((= a b))))
(define source '(fn int cross ((a int) (b int)) () ((return (~ a)))))
(define source '(fn int cross ((a int) (b int) (c int) (d int)) () ((return (+ (* a d) (* b c))))))
(define source '(fn int cross ((a int) (b int) (c int) (d int))
		    ()
		    ((if a (return b) (return c)))))

(define source '(fn int cross ((a int) (b int) (c int) (d int))
		    ((z int))
		    ((while a (if z (return (+ d d)) (return b)))
		     (return b))))

(define source '(fn int loop ()
		    ((x int))
		    ((for x x x (return (+ x x)))
		     (return x))))
(define source '(fn int fib ((xp float))
		    ((tn2 int)
		     (tn1 int)
		     (tn int)
		     (x int))
		    ((= tn2 (= tn1 (= tn 1)))
		     (= x xp)
		     (for (= x (- x 2))
			  x
			  (-= x 1)

			  (begin
			    (= tn (+ tn2 tn1))
			    (= tn2 tn1)
			    (= tn1 tn)))
		     (return tn))))
(define source '(fn int fib ((x int))
		    ((tn2 int)
		     (tn1 int)
		     (tn int))
		    ((= tn2 (= tn1 (= tn 1)))
		     (for (= x (- x 2))
			  x
			  (-= x 1)

			  (begin
			    (= tn (+ tn2 tn1))
			    (= tn2 tn1)
			    (= tn1 tn)))
		     (return tn))))


;;; To compile one of those trees, try:
;;;
;;; (pp (cfn-compute-bytecodes (make-cfn-symbol-table) source))
;;;
