#!/bin/sh
type;exec guile -l $0 -e "(ctax-repl *stdin*)"
;;; -*-scheme-*- tells emacs this is a scheme file.

;;;; 	Copyright (C) 1994, 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.
;;;; 



;; Easier to type:
;;
(define pp (lambda args (apply pretty-print args)))

;; Especially good for debugging -- wrap this 
;; around a form.  E.g.:
;;      (+ x <some-exp>) => (+ x (pk 'buggy-exp-val <some-exp>))
;;
(define (pk tag val)
  (pp (list tag val))
  val)

;;; {Warnings and Errors.}
;;;

;; Crudely warn about semantic errors in the source program 
;; (e.g. ``statements after return'').
;;
(define (warning v)
  (pp (list 'warning v)))
      

;;; {Entry Points}
;;;

;; repl
(define (ctax-repl port)
  (synthetic-repl ctax-prompt ctax-read ctax-eval pp port))


(define (ctax-repl-thunk)
  (ctax-prompt)
  (pp (ctax-eval (ctax-read)))
  (ctax-repl-thunk))

;; Prompter
;;
(define (ctax-prompt) (display "ctax> ") (force-output))

;; Parse one ctax command from a port.
;;
(define (ctax-read) (ctax-parse (lambda () (string (read-char)))))

;; Evaluate a parsed form.
;;
(define (ctax-eval tree)  (eval (ctax-transl-command tree)))


;; Parse and translate a string, pretty-print the answer
;;
(define (ctax-translation string)
  (let ((tree (ctax-tree string)))
    (ctax-transl-command tree)))




;; Return a parse tree for the argument string
;;
(define (ctax-tree string)
  (ctax-parse (lambda ()
		(let ((answer string))
		  (set! string #f)
		  answer))))

;; Translate a tree returned from ctax parse.  The tree
;; is either a stand-alone statement or a definition.
;;
(define (ctax-transl-command tree)
  (cond
   ((and (pair? tree)
	 (eq? 'ctax:define (car tree)))
    (ctax-transl-definition tree))

   ((and (pair? tree)
	 (eq? 'ctax:SCM (car tree)))
    (cons 'begin
	  (map (lambda (v)
		 `(define ,v ,(ctax-transl-expression (caddr tree))))
	       (cadr tree))))

   (#t
    (ctax-transl-top-level-statement tree))))


;;; {The Translator}
;;;

;; Return a Scheme form that is equivalent to a
;; top-level ctax statement.  We compile the statement
;; as if it were the body of a parameterless, anonymous function, 
;; and then construct an application of that function.
;;
(define (ctax-transl-top-level-statement tree)
  `((lambda ()
      ,(ctax-transl-function-defining-statement tree))))
    
;; Defines translate to defines.
;;
(define (ctax-transl-definition tree)
  (let ((iens (cadr tree))
	(formals (caddr tree))
	(doc (cadddr tree))
	(interaction (car (cddddr tree)))
	(body (cadr (cddddr tree))))
    `(define ,(cons iens formals)
       ,(ctax-transl-function-defining-statement body))))

;;
(define (ctax-transl-definition-procedure tree)
  (let ((iens (cadr tree))
	(formals (caddr tree))
	(doc (cadddr tree))
	(interaction (car (cddddr tree)))
	(body (cadr (cddddr tree))))
    `(lambda ,formals
       ,(ctax-transl-function-defining-statement body))))


;; A statement that is the body of a function definition
;; is translated by this procedure.  The gist is that the statement
;; is translated as usual, but that we might have to provide
;; some bindings for free labels like `break' or `fi'.
;;
(define (ctax-transl-function-defining-statement tree)
  (ctax-transl-statement
   tree
   #f
   #f
   (lambda (translation free-attribs)
     (cond
      ((member free-attribs '(() (return))) translation)
      ((member free-attribs '((break) (fi)))
       `(let ((,(car free-attribs) (lambda (x) x)))
	  ,translation))
      (t (error (list 'internal-error-bad-attributes free-attribs)))))))


;; Translate a statement
;;
;; The arguments are 

;;     tree -- a ctax syntax tree to translate

;;     following -- the name of a label to which to pass the value
;;                  of this statement.  #f if the statment should just
;;                  return it's value.

;;                  For example, the two branches of a conditional are
;;                  (normally) translated with following set to 'fi,
;;                  and that label is given to the statements that
;;                  follow the conditional.

;;                  Some care is taken to not introduce labels
;;                  unecessarily.  For example, if a conditional is
;;                  being compiled with following set to 'break
;;                  (indicating an enclosing while loop), then it
;;                  won't introduce a 'fi label.  Instead, the two
;;                  branches will also have following set to 'break.
;;                  This optimization is a kind of goto compression.

;;     exits-ok? -- #f unless the statement is enclosed in a loop.
;;                  Only if this is not false can the statement be `break'
;;                  or `continue'

;;     return -- the return continuation. Takes two arguments.
;;
;;               The first argument is the Scheme form which is the
;;               translation.

;;               The second is a list of flags describing the translation.
;;               In this implementation, the flags are either '() or a
;;               one element list.

;;               The flags can be:

;;                   '(return)  -- the statement is a return statement.

;;                   '(fi) -- the statement passes its value to the
;;                            label `fi'.  Presumably the statement
;;                            was a conditional.

;;                   '(break) -- the statement passes its label to the
;;                               label `break'.  The statement was
;;                               some form of loop (while, for or do).
;;


(define (ctax-transl-statement tree following exits-ok? return)

  (let ((statement-type (ctax-tree-type tree)))
    (case statement-type

      ;; Compound statements.
      ;;
      ;; In the simplest case, a ctax block turns into just a Scheme
      ;; block:
      ;;
      ;;   { a; b; c; }    =>   (begin [a] [b] [c])
      ;;
      ;; That case is handled by translating a to [a], and then
      ;; making (conceptually):
      ;;
      ;;        (begin [a] (begin [{b; c;}]))
      ;;
      ;; To actually build such a scheme form, we use ctax-make-begin!
      ;; which flattens nested begin forms.
      ;;
      ;; In a more complicated case, the first statment might be
      ;; a loop or conditional.  In that case, the rest of the
      ;; statements have to be labeled:
      ;;
      ;;      { if (a) b; else return c;  d; }
      ;;    =>
      ;;      (let ((fi (lambda (return) [d])))
      ;;         (if (ctax-test [a])
      ;;            (fi [b])
      ;;            c))
      ;;
      ;; Note that this translation isn't hygenic: it mixes some
      ;; compiler generated identifiers ("fi" and "return") in with
      ;; the identifiers of the source program.  We get away with that
      ;; by making the labels illegal ctax identifiers.  Slightly more
      ;; sophisticated translations could be hygenic but there is no
      ;; need so long as the compiler can allocate a few variable
      ;; names to itself.
      ;;
      
      
      ((ctax:begin)

       (let* ((formals (cadr tree))
	      (body (cddr tree))
	      (first-stmt (car body))
	      (rest-stmts (cdr body)))

	 (if (null? rest-stmts)

	     ;; If a compound statement only contains one element,
	     ;; just translate that element.
	     ;;
	     (ctax-transl-statement
	      (car body)
	      following
	      exits-ok?
	      (lambda (only-tree only-labels)
		(return
		 ;; Even though the block has only one statement, it
		 ;; may have some local variables.
		 ;;
		 (if (null? formals)
		     only-tree
		     (ctax-enclose-with-formals formals only-tree))
		 only-labels)))


	     ;; Truly compound statemts
	     ;;
	     ;; Start by translating the first statement...
	     ;;
	     (ctax-transl-statement
	      first-stmt

	      ;; We are in the middle of a block, so the first statement
	      ;; is followed directly by other statements.  Therefore,
	      ;; it should just return its value normally:
	      ;;
	      #f

	      ;; It is only ok for the first statement to be a break
	      ;; or continue if it was ok for this whole block to have
	      ;; been a break or continue:
	      ;;
	      exits-ok?

	      (lambda (first-tree first-attribs)
		;; A big dispatch on the attributes of the first
		;; statement:
		;;
		(cond
		 ;; If the first statement was simple enough, then there
		 ;; are no free labels to resolve
		 ;;
		 ((null? first-attribs)
		  ;; Just put the statement in a scheme block with the
		  ;; rest of the statements.  First, contruct a ctax block
		  ;; containing only the rest of this block, and compile
		  ;; that:
		  ;;
		  (ctax-transl-statement
		   (cons 'ctax:begin (cons '() rest-stmts))

		   ;; The subblock containing all statements after the
		   ;; first is followed by whatever follows the block
		   ;; we're working on.
		   ;;
		   following

		   ;; Again, this is inherited:
		   ;;
		   exits-ok?

		   (lambda (rest-tree rest-attribs)
		     ;; This function has the compiled first
		     ;; statement, and the compiled rest of the block.
		     ;;
		     (let ((block-denot
			    (ctax-make-begin! (list first-tree rest-tree))))
		       (return
			(if (null? formals)
			    block-denot
			    (ctax-enclose-with-formals formals block-denot))
			;; The attributes of the tail of the block
			;; become the attributes of the whole block:
			;;
			rest-attribs)))))


		 ;; If the first statement was a return statement,
		 ;; then ignore the remaining statements and consider 
		 ;; this whole block a return statement.
		 ;;
		 ((equal? '(return) first-attribs)
		  (warning 'statements-after-return)
		  (return first-tree '(return)))

		 ;; If the first statement was a conditional or loop,
		 ;; provide the appropriate label for the rest of the block:
		 ;;
		 ((member first-attribs '((fi) (break)))
		  (ctax-transl-statement
		   ;; Compile the rest of the block.
		   ;;
		   (cons 'ctax:begin (cons '() rest-stmts))

		   ;; The rest of the block inherits the whole
		   ;; block's follow.
		   ;;
		   following

		   ;; Inherit whether we are in a loop:
		   ;;
		   exits-ok?

		   (lambda (rest-tree rest-attribs)
		     ;; Label the rest of the block `fi' or `break'
		     ;; so that the first statement can terminate using
		     ;; branches to that label.
		     ;;
		     (let ((block-denot `(let ((,(car first-attribs)
						(lambda (return) ,rest-tree)))
					   ,first-tree)))
		       (return
			(if (null? formals)
			    block-denot
			    (ctax-enclose-with-formals formals
						       block-denot))

			rest-attribs)))))

		 (t (list 'goof
			  first-attribs
			  first-tree))))))))

      ;; Return statements simply denote their expression's denotation.
      ;; This is different from an expression statement.  An expression
      ;; statement denotes its expression's denotation but wrapped in a
      ;; call to the label implied by `follow'.
      ;;
      ((ctax:return)
       (return (ctax-transl-expression (cadr tree)) '(return)))
      

      ((ctax:if)
       (let* ((pred (cadr tree))
	      (consequent (caddr tree))
	      (anticons (cadddr tree))

	      (tail-label  (or following 'fi))

	      ;; Translate the predicate trivially...
	      ;;
	      (pred-denot `(ctax:test ,(ctax-transl-expression pred))))
	 
	 (ctax-transl-statement
	  consequent
	  tail-label
	  exits-ok?	
	  (lambda (cons-denot cons-labels)
	    (ctax-transl-statement
	     anticons
	     tail-label
	     exits-ok?
	     (lambda (anticons-denot anticons-labels)
	       (return
		`(if ,pred-denot
		     ,cons-denot
		     ,anticons-denot)
		(if following
		    #f
		    '(fi)))))))))

      ((ctax:while ctax:do)
       (let* ((pred (cadr tree))
	      (body (caddr tree))
	      (pred-denot `(ctax:test ,(ctax-transl-expression pred)))
	      (tail-label (or following 'break)))

	 (ctax-transl-statement
	  body
	  'continue
	  #t
	  (lambda (body-denot body-labels)
	    (return
	     
	     (let ((w/continue
		    `(letrec ((continue
			       (lambda (return)
				 (if ,pred-denot
				     ,body-denot
				     (break return)))))
		       ;; Does one execution of the body always
		       ;; precede the first evaluation of the predicate?
		       ;;
		       ,(if (eq? statement-type 'ctax:do)
			    body-denot
			    '(continue #f)))))

	       ;; If there is a `following' label, then that
	       ;; label is where calls to `break' should go.
	       ;;
	       (if following
		   `(let ((break ,following))
		      ,w/continue)
		   w/continue))

	     
	     ;; If there is no following label, then 
	     ;; the caller has to provide an appropriate
	     ;; binding for `break'.
	     ;;
	     (if following
		 #f
		 '(break)))))))


      ;; For loops are simply rewritten in the way you'd expect.
      ((ctax:for)
       (let* ((init (cadr tree))
	      (pred (caddr tree))
	      (increment (cadddr tree))
	      (body (car (cddddr tree)))
	      (new-body `(ctax:begin
			  ()
			  ,body
			  ,increment))
	      (new-loop `(ctax:while ,pred
				     ,new-body))
	      (easier-form `(ctax:begin
			     ()
			     ,init
			     ,new-loop)))

	 (ctax-transl-statement easier-form following exits-ok? return)))

      ((ctax:break) (return '(break #f) '(break)))

      ((ctax:continue) (return '(continue #f) '(continue)))

      ;; Expressions:
      (else
       (let ((exp-denot (ctax-transl-expression tree)))
	 (return
	  (if following
	      (list following exp-denot)
	      exp-denot)
	  '()))))))


;; Translate an expression.  This is trivial because flow of control
;; is not an issue.  For simplicity, we presume a ctax run-time with 
;; function names that match the symbols used as syntactic identifiers.
;;

(define (ctax-transl-expression tree)
  (case (ctax-tree-type tree)
    ;; Expressions:
    ((ctax:comma)
     (ctax-make-begin! (map ctax-transl-expression (cdr tree))))
     

    ((ctax:constant) tree)

    ((ctax:variable) tree)

    ((ctax:neg ctax:log-neg ctax:pos ctax:bit-neg)
     (cons (car tree)
	   (map ctax-transl-expression (cdr tree))))

    ((ctax:assign)
     (let* ((dest (cadr tree))
	    (val (caddr tree))
	    (dest-denot (ctax-transl-expression dest))
	    (val-denot (ctax-transl-expression val)))
       (ctax-make-assignment dest-denot val-denot)))
       
    ((ctax:times ctax:div ctax:mod ctax:plus ctax:minus ctax:lshift
		 ctax:rshift ctax:eq ctax:ne ctax:le ctax:ge
		 ctax:lt ctax:gt ctax:bit-and ctax:bit-xor ctax:bit-or
		 ctax:log-and ctax:log-or ctax:if-exp)
     (cons (car tree)
	   (map ctax-transl-expression (cdr tree))))

    ((ctax:apply)
     (map ctax-transl-expression (cons (cadr tree) (caddr tree))))

    (else (error (list 'internal-error tree)))))

  

;; Return a symbol describing a parse tree.
;;
(define (ctax-tree-type tree)
  (cond
   ((pair? tree) (car tree))
   ((memq tree '(ctax:break ctax:continue)) tree)
   ((symbol? tree) 'ctax:variable)
   (t 'ctax:constant)))


;; When building up scheme forms like (begin...), collapse
;; nested begin forms destructively.
;;
(define (ctax-make-begin! expressions)

  (define (is-begin form)
    (and (pair? form) (eq? (car form) 'begin)))

  (define (build-list! dest exps)
    (cond
     ((null? exps)
      (set-cdr! dest '()))
     ((is-begin (car exps))
      (set-cdr! dest (cdar exps))
      (build-list! (last-pair dest) (cdr exps)))
     (t
      (set-cdr! dest (cons (car exps) '()))
      (build-list! (cdr dest) (cdr exps)))))

  (let ((answer (cons 'begin '#f)))
    (build-list! answer expressions)
    answer))


;; Assignment translates trivially
;;
(define (ctax-make-assignment dest val)
  `(set! ,dest ,val))



(define (ctax-enclose-with-formals formals scheme-form)
  (define (formal->let-binding formal)
    (let* ((var-names (cadr formal))
	   (first-var (car var-names))
	   (init-expression (caddr formal)))
      (cons (list first-var
		  (ctax-transl-expression init-expression))
	    (map (lambda (var-name)
		   (list var-name first-var))
		 (cdr var-names)))))

  (define (formals-list->let-bindings list)
    (if (null? list)
	'()
	(append (formal->let-binding (car list))
		(formals-list->let-bindings (cdr list)))))

  `(let* ,(formals-list->let-bindings formals)
     ,scheme-form))


(define (ctax-enclose-with-formals formals scheme-form)
  (define (formal->sets formal)
    (if (eq? (car formal) 'ctax:define)
	`((set! ,(cadr formal)
		,(ctax-transl-definition-procedure formal)))
	(let ((var-names (cadr formal))
	      (init-expression (caddr formal)))
	  (let loop ((answer '())
		     (val init-expression)
		     (vars var-names))
	    (if (null? vars)
		(reverse answer)
		(loop (cons `(set! ,(car vars) ,val) answer)
		      (car vars)
		      (cdr vars)))))))

  (define (formals-list->sets list)
    (if (null? list)
	'()
	(append! (formal->sets (car list))
		 (formals-list->sets (cdr list)))))

  (define (formal-decls f)
    (if (eq? (car f) 'ctax:define)
	(cons (list (cadr f) 0) '())
	(map (lambda (v) (list v 0)) (cadr f))))

  `(let ,(apply append! (map formal-decls formals))
     (begin ,@(formals-list->sets formals))
     ,scheme-form))



(define (ctax:test val)
  (and val (not (eq? 0 val))))

(defmacro ctax:eq (a b) `(eq? ,a ,b))
(defmacro ctax:ne (a b) `(not (eq? ,a ,b)))
(defmacro ctax:le (a b) `(<= ,a ,b))
(defmacro ctax:ge (a b) `(>= ,a ,b))
(defmacro ctax:lt (a b) `(< ,a ,b))
(defmacro ctax:gt (a b) `(> ,a ,b))

(defmacro ctax:minus (a b) `(- ,a ,b))
(defmacro ctax:plus (a b) `(+ ,a ,b))
(defmacro ctax:times (a b) `(* ,a ,b))
(defmacro ctax:div (a b) `(/ ,a ,b))
(defmacro ctax:mod (a b) `(mod ,a ,b))

(defmacro ctax:neg (a) `(- ,a))
(defmacro ctax:pos (a) a)

(define (ctax:log-neg a) (if (or (not a) (eq? 0 a)) 1 0))

(defmacro ctax:lshift (a b) `(ash ,a ,b))
(defmacro ctax:rshift (a b) `(ash ,a (- ,b))) 
(defmacro ctax:bit-neg (a) `(lognot ,a))
(defmacro ctax:bit-and (a b) `(logand ,a ,b))
(defmacro ctax:bit-xor (a b) `(logxor ,a ,b))
(defmacro ctax:bit-or (a b) `(logor ,a ,b))

(defmacro ctax:log-and subforms
  `(and ,@subforms))
(defmacro ctax:log-or subforms
  `(or ,@subforms))
(defmacro ctax:if-exp subforms `(if ,@subforms))
(defmacro (false) #f)

(define argv *argv*)

(provide 'ctax)




