#! /bin/sh
exec ../src/sizzle -s $0 $*
!#
;; scripts/compile.scm
;;
;; Copyright (C) 2000 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
;;
;; This 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 software 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 package; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.  

;; Simple pseudo-compiler for practicing Scheme

(use-modules (core pprint))

;;; Variable definitions =============================================

;;; These variables hold the names of some primitives needed for
;;; simplifying some expression types, such as `quasiquote' or `case'.
(define safe-name-memv '%%%memv%%%)
(define safe-name-make-promise '%%%make-promise%%%)
(define safe-name-cons '%%%cons%%%)
(define safe-name-list '%%%list%%%)
(define safe-name-list->vector '%%%list->vector%%%)
(define safe-name-append2 '%%%append2%%%)

;;; Helper functions =================================================

;;; Display a usage message for the program.
(define (help)
  (display "Usage: compile.scm [-h] [--help] FILE\n"))

;;; Simplifiaction code ==============================================

;;; The procedures in this section transform R5RS Scheme to a form
;;; where only the special forms `lambda', `begin', `if', `set!',
;;; `quote' and literal expressions, procedure applications and some
;;; calls to certain builtin primitives are left.

;;; Rewrite a `begin' expression so that nested begins are eliminated.
;;; Return a list with a head of `begin' and all statements from the
;;; original `begin' expression and the statements of embedded begins
;;; spliced in.
(define (flatten-begin expbegin)
  (cons 'begin
	(let loop ((l (cdr expbegin)) (flat '()))
	  (if (null? l)
	      flat
	      (let ((head (car l))
		    (queue (cdr l)))
		(if (and (pair? head) (eq? (car head) 'begin))
		    (loop (cdr head) (loop queue flat))
		    (cons head (loop queue flat))))))))

;;; Return a list of all defines at the beginning of the expression
;;; list `lexp'.  The returned pair has the list of defines in the car
;;; and the list of the remaining expressions in the cdr.
(define (extract-define lexp)
  (let ((head (car lexp))
	(rest (cdr lexp)))
    (if (and (pair? head) (eq? (car head) 'define))
	(let ((result (extract-define rest)))
	  (cons (cons head (car result)) (cdr result)))
	(cons '() lexp))))

;;; Simplify an expression body, like the body of a `begin' or
;;; `lambda' expression.
(define (simplify-body form)
  (let* ((flatbody (flatten-begin form))
	 (result (extract-define (cdr flatbody)))
	 (rawdefines (car result))
	 (exps (map simplify (cdr result)))
	 (defines (map simplify rawdefines))
	 (decls (map cdr defines))
	 (body `(begin ,@exps)))
    (if (null? decls)
	body
	(simplify `(letrec ,decls ,body)))))

;; Simplify the `begin' form `expr'.
(define (simplify-begin expr)
  (simplify-body expr))

;; Simplify the define form (define (foo bar) #t) to
;; (define foo (lambda (bar) #t))
(define (simplify-convenience-define form)
  `(define ,(caadr form)
     (lambda ,(cdadr form) ,@(cddr form))))

;; Simplify all expression of the define form `form'.
(define (simplify-define form)
  (let ((expr (simplify (caddr form))))
    `(define ,(cadr form) ,expr)))

;; Simplify all expression of the lambda form `form'.
(define (simplify-lambda form)
  (let ((body (simplify-body (cons 'begin (cddr form)))))
    `(lambda ,(cadr form) ,body)))

;; Simplify all expression of the named let form `form'.
(define (simplify-named-let form)
  (let ((proc-name (cadr form))
	(formals (map car (caddr form)))
	(inits (map cadr (caddr form)))
	(body (simplify-body (cons 'begin (cdddr form)))))
    (list 'letrec (list (list proc-name
			      (list 'lambda formals body)))
	  (cons proc-name inits))))
	
;; Simplify all expression of the normal let form `form'.
(define (simplify-normal-let form)
  (let ((formals (map car (cadr form)))
	(inits (map (lambda (x) (simplify (cadr x))) (cadr form)))
	(body (simplify-body (cons 'begin (cddr form)))))
    (cons (list 'lambda formals body) inits)))
;    (cons (append (list 'lambda formals) body) inits)))
	
;; Simplify all expression of the let form `form'.
(define (simplify-let form)
  (cond ((and (> (length form) 1)
	      (symbol? (cadr form)))
	 (simplify (simplify-named-let form)))
	(else 
	 (simplify-normal-let form))))
	
;; Simplify all expression of the letrec form `form'.
;; The expression
;;   (letrec ((x 1) (y 2)) (+ x y))
;; is transformed to
;;   (let ((x #f) (y #f)) (begin (set! x 1) (set! y 2) (+ x y)))
;; and then simplified further.
(define (simplify-letrec form)
  (let ((formals (map car (cadr form)))
	(inits (map (lambda (x) (simplify (cadr x))) (cadr form))))
    (let ((sets (let loop ((formals formals) (inits inits))
		  (if (null? formals)
		      '()
		      (cons (list 'set! (car formals) (car inits))
			    (loop (cdr formals) (cdr inits))))))
	  (body (simplify-body (cons 'begin (cddr form)))))
      (simplify `(let ,(map (lambda (x) (list x #f)) formals)
		   ,@sets ,body)))))
	
;; Simplify all expression of the let* form `form'.
(define (simplify-let* form)
  (let ((formals (map car (cadr form)))
	(inits (map (lambda (x) (simplify (cadr x))) (cadr form)))
	(body (simplify-body (cons 'begin (cddr form)))))
    (let loop ((formals formals) (inits inits))
      (if (null? formals)
	  body
	  (simplify (list 'let (cons (list (car formals)
					   (car inits))
				     '())
			  (loop (cdr formals) (cdr inits))))))))
	
;; Simplify all expression of the if form `form'.
(define (simplify-if form)
  `(if ,@(map simplify (cdr form))))

;; Simplify all expression of the set! form `form'.
(define (simplify-set! form)
  `(set! ,(cadr form) ,(simplify (caddr form))))

;; Simplify all expression of the force form `form'.
(define (simplify-force form)
  (list (cadr form)))

;; Simplify all expression of the and form `form'.
(define (simplify-and form)
  (cond ((null? (cdr form))
	 #t)
	((null? (cddr form))
	 (cadr form))
	(else
	 (simplify `(if ,(cadr form) (and ,@(cddr form)) #f)))))

;; Simplify all expression of the or form `form'.
(define (simplify-or form)
  (cond ((null? (cdr form))
	 #f)
	((null? (cddr form))
	 (cadr form))
	(else
	 (let* ((e-hd (cadr form))
		(e-tl (cddr form))
		(tmp (gensym)))
	   (simplify `(let ((,tmp ,e-hd))
			(if ,tmp
			    ,tmp
			    (or ,@e-tl))))))))

(define (simplify-cond form)
  (if (null? (cdr form))
      #f
      (let* ((clause (cadr form))
	     (others (cddr form))
	     (newcond (simplify (cons 'cond others))))
	(cond ((eq? (car clause) 'else)
	       (simplify (cons 'begin (cdr clause))))
	      ((null? (cdr clause))
	       (simplify (list 'or (car clause) newcond)))
	      ((eq? (cadr clause) '=>)
	       (let* ((test (car clause))
		      (recipient (caddr clause))
		      (tmp (gensym)))
		 (simplify `(let ((,tmp ,test))
			      (if ,tmp
				  (,recipient ,tmp)
				  ,newcond)))))
	      (else
	       (let* ((test (car clause))
		      (actions (cdr clause))
		      (conseq (cons 'begin actions)))
		 (simplify `(if ,test ,conseq ,newcond))))))))

(define (simplify-case form)
  (let* ((tmp-key (gensym))
	 (trans-test
	  (lambda (test)
	    (if (eq? test 'else) 'else `(,safe-name-memv ,tmp-key ',test))))
	 (key (cadr form))
	 (clauses (cddr form))
	 (tests (map car clauses))
	 (expr-lists (map cdr clauses))
	 (memv-tests (map trans-test tests))
	 (cond-clauses (map cons memv-tests expr-lists)))
    (simplify `(let ((,tmp-key ,key)) (cond ,@cond-clauses)))))

(define (simplify-do form)
  (let* ((normalize-step (lambda (v sf)
			   (if (null? sf) v (car sf))))
	 (bindings (cadr form))
	 (testnsequence (caddr form))
	 (commands (cdddr form))
	 (vars (map car bindings))
	 (inits (map cadr bindings))
	 (steps-fac (map cddr bindings))
	 (steps (map normalize-step vars steps-fac))
	 (test (car testnsequence))
	 (sequence (cdr testnsequence))
	 (loop-var (gensym))
	 (loop-call (cons loop-var steps))
	 (loop-bindings (map list vars inits)))
    (simplify `(let ,loop-var ,loop-bindings
		    (if ,test
			(begin
			  (if #f #f)
			  ,@sequence)
			(begin
			  ,@commands
			  ,loop-call))))))

(define (simplify-delay form)
    (let ((delexp (cadr form)))
      `(,safe-name-make-promise (lambda () ,delexp))))

(define (detect-unquote exp level)
  (cond ((vector? exp)
	 (let loop ((pos (- (vector-length exp) 1)))
	   (cond ((< pos 0)
		  #f)
		 ((detect-unquote (vector-ref exp pos) level)
		  #t)
		 (else
		  (loop (- pos 1))))))
	((pair? exp)
	 (let ((head (car exp)))
	   (cond ((eq? head 'quasiquote)
		  (detect-unquote (cadr exp) (+ level 1)))
		 ((or (eq? head 'unquote) (eq? head 'unquote-splicing))
		  (if (= level 1)
		      #t
		      (detect-unquote (cadr exp) (- level 1))))
		 (else
		  (or (detect-unquote head level)
		      (detect-unquote (cdr exp) level))))))
	(else
	 #f)))

(define (simplify-quasiquote form)
  (let loop ((exp (cadr form)) (level 1))
    (cond ((not (detect-unquote exp level))
	   (list 'quote exp))
	  ((vector? exp)
	     (list safe-name-list->vector
		   (loop (vector->list exp) level)))
	    ((pair? exp)
	     (let ((head (car exp)))
	       (cond ((eq? head 'quasiquote)
		      (list safe-name-list
			    ''quasiquote
			    (loop (cadr exp) (+ level 1))))
		     ((eq? head 'unquote)
		      (if (= level 1)
			  (cadr exp)
			  (list safe-name-list
				''unquote
				(loop (cadr exp) (- level 1)))))
		     ((and (pair? head)
			   (eq? (car head) 'unquote-splicing)
		           (= level 1))
		      (if (null? (cdr exp))
			  (cadr head)
			  (list safe-name-append2
				(cadr head)
				(loop (cdr exp) level))))
		     ((eq? head 'unquote-splicing)
		      (list safe-name-list
			    ''unquote-splicing
			    (loop (cadr exp) (- level 1))))
		     (else
		      (list safe-name-cons
			    (loop (car exp) level)
			    (loop (cdr exp) level)))))))))

;; Simplify the procedure applications or special form `form'.
(define (simplify-form form)
  (cond ((and (eq? (car form) 'define)
	      (> (length form) 1)
	      (pair? (cadr form)))
	 (simplify (simplify-convenience-define form)))
	((and (eq? (car form) 'define)
	      (= (length form) 3)
	      (symbol? (cadr form)))
	 (simplify-define form))
	((eq? (car form) 'begin)
	 (simplify-begin form))
	((eq? (car form) 'lambda)
	 (simplify-lambda form))
	((eq? (car form) 'let)
	 (simplify-let form))
	((eq? (car form) 'letrec)
	 (simplify-letrec form))
	((eq? (car form) 'let*)
	 (simplify-let* form))
	((eq? (car form) 'if)
	 (simplify-if form))
	((eq? (car form) 'set!)
	 (simplify-set! form))
	((eq? (car form) 'force)
	 (simplify-force form))
	((eq? (car form) 'and)
	 (simplify-and form))
	((eq? (car form) 'or)
	 (simplify-or form))
	((eq? (car form) 'delay)
	 (simplify-delay form))
	((eq? (car form) 'cond)
	 (simplify-cond form))
	((eq? (car form) 'case)
	 (simplify-case form))
	((eq? (car form) 'do)
	 (simplify-do form))
	((eq? (car form) 'quasiquote)
	 (simplify-quasiquote form))
	((eq? (car form) 'quote)
	 form)
	(else (map simplify form))))

;; Simplify the expression `expr'.  
(define (simplify expr)
  (cond ((pair? expr)
	 (simplify-form expr))
	(else expr)))

;;; Code generation ==================================================

;; Get a new, unique label number. 
(define gen-label
  (let ((label-no 0))
    (lambda ()
      (set! label-no (+ label-no 1))
      label-no)))

(define literal-list '())
(define literal-count 0)

(define (emit-literal lit)
  (let ((l (assq lit literal-list)))
    (if l
	(cdr l)
	(begin
	  (set! literal-list (cons (cons lit literal-count) literal-list))
	  (let ((lc literal-count))
	    (set! literal-count (+ literal-count 1))
	    lc)))))

(define (literal-vector)
  (list->vector (map (lambda (x) (car x)) (reverse literal-list))))

(define code-list '())

(define (reset-emitter)
  (set! literal-list '())
  (set! literal-count 0)
  (set! code-list '()))

(define (emit-op code . ops)
  (set! code-list (cons (cons code ops) code-list)))

;; Convert a formal lambda argument list to a proper list of symbols,
;; like this:
;; (bla fasel . fomp) => (bla fasel fomp)
(define (make-symbol-list lst)
  (cond ((null? lst)
	 '())
	((pair? lst)
	 (cons (car lst) (make-symbol-list (cdr lst))))
	(else
	 (cons lst '()))))

(define (translate-lambda-body formals expr env)
  (let loop ((formals formals) (varnum 0))
    (if (null? formals)
	#t
	(if (pair? formals)
	    (loop (cdr formals) (+ varnum 1))
	    (emit-op '%make-list varnum))))
  (translate-block expr env #t)
  (emit-op '%restore-continuation))

(define (translate-if expr env tail?)
  (let ((end-label (gen-label))
	(else-label (gen-label)))
    (translate (cadr expr) env #f)
    (emit-op '%jump-if-false else-label)
    (translate (caddr expr) env tail?)
;    (if (pair? (cdddr expr))
;	(emit-op '%jump end-label))
    (emit-op '%jump end-label)
    (emit-op '%label else-label)
;    (if (pair? (cdddr expr))
;	(begin
;	  (translate (cadddr expr) env tail?)
;	  (emit-op '%label end-label)))))
    (if (pair? (cdddr expr))
	(translate (cadddr expr) env tail?)
	(emit-op '%push-unspecified))
    (emit-op '%label end-label)))

(define (translate-form expr env tail?)
  (cond ((eq? (car expr) 'define)
	 #t)
	((eq? (car expr) 'set!)
	 (translate (caddr expr) env tail?)
	 (emit-op '%store-global (cadr expr)))
	((eq? (car expr) 'begin)
	 (translate-block (cdr expr) env tail?))
	((eq? (car expr) 'quote)
	 (translate-constant (cadr expr) env tail?))
	((eq? (car expr) 'lambda)
	 (let ((lab (gen-label))
	       (old-code-list code-list)
	       (old-literal-list literal-list)
	       (old-literal-count literal-count)
	       (new-env (cons (make-symbol-list (cadr expr)) env)))
;	   (write-line new-env)
	   (reset-emitter)
	   (translate-lambda-body (cadr expr) (cddr expr) new-env)

	   (set! code-list (reverse code-list))
	   (emit-op '%install-literals (literal-vector))
	   (emit-op '%label lab)
	   (emit-op '%source-code expr)
	   (emit-op '%comment)
	   (write-code-list code-list)
	   (set! code-list old-code-list)
	   (set! literal-list old-literal-list)
	   (set! literal-count old-literal-count)
	   (emit-op '%make-closure lab)))
	((eq? (car expr) 'if)
	 (translate-if expr env tail?))
	(else
	 (for-each (lambda (x) (translate x env #f)) (cdr expr))
	 (translate (car expr) env #f)
	 (if (not tail?)
	     (emit-op '%save-continuation))
	 (emit-op '%call (- (length expr) 1)))))

(define (translate-constant expr env tail?)
  (cond ((or (number? expr) (char? expr) (boolean? expr))
	 (emit-op '%push-immediate expr))
	(else
	 (emit-op '%push-literal (emit-literal expr)))))

;; Compile a reference to the variable `expr'.  If `expr' is found in
;; the environment chain `env', a local variable reference is emitted,
;; otherwise, a symbol reference.
(define (translate-reference expr env tail?)
  (let loop0 ((env env) (ofs 0))
    (cond ((null? env)
	   (emit-op '%push-global expr))
	  (else (let loop1 ((vars (car env)) (slot 0))
		  (cond ((null? vars)
			 (loop0 (cdr env) (+ ofs 1)))
			((eq? (car vars) expr)
			 (emit-op '%push-local ofs slot))
			(else
			 (loop1 (cdr vars) (+ slot 1)))))))))
		

;; Compile an expression `expr'.  `env' is the environment chain in
;; which symbols are looked up, `tail?' is a boolean telling whether
;; the expression is in tail position.
(define (translate expr env tail?)
  (cond ((pair? expr)
	 (translate-form expr env tail?))
	((symbol? expr)
	 (translate-reference expr env tail?))
;	 (if tail?
;	     (emit-op '%restore-continuation)))
	(else
	 (translate-constant expr env tail?))))
;	 (if tail?
;	     (emit-op '%restore-continuation)))))

;; Compile a sequence of expressions in the list `exprs'.  `env' is
;; used for symbol lookups and `tail?' tells whether the sequence of
;; expressions is in tail position.
(define (translate-block exprs env tail?)
  (let loop ((exprs exprs) (popcnt 0))
    (cond ((null? exprs) #t)
	  ((null? (cdr exprs))
	   (if (> popcnt 0)
		(emit-op '%pop popcnt)
		#t)
	   (translate (car exprs) env tail?))
	  (else
	   (translate (car exprs) env #f)
	   (loop (cdr exprs) (+ popcnt 1))))))
	
(define (translate-definition expr env)
  (translate (caddr expr) env #f)
  (emit-op '%store-global (cadr expr)))
      

(define (translate-definitions exprs env)
  (for-each (lambda (x) (translate-definition x env)) exprs)
  (emit-op '%pop (length exprs)))

;; Extract all toplevel definitions from the code list `code'.
(define (toplevel-definitions code)
  (cond
   ((null? code) '())
   ((and (pair? code) (pair? (car code)) (eq? (caar code) 'define))
    (cons (list 'define-global (cadar code) (caddar code))
	  (toplevel-definitions (cdr code))))
   (else
    (toplevel-definitions (cdr code)))))

;; Extract the toplevel statements from the code list `code'.
(define (toplevel-statements code)
  (cond
   ((null? code) '())
   ((and (pair? code) (pair? (car code)) (eq? (caar code) 'define))
    (toplevel-statements (cdr code)))
   (else
    (cons (car code) (toplevel-statements (cdr code))))))

;; Simplify the code list `code'.
(define (simplify-code code)
  (map simplify code))

;; Wrap the initialization statements into a global procedure called
;; `main, which receives the command line options in the parameter
;; `%command-line%'.
(define (wrap-init-code statements)
  (list
   (list 'define-global 'main
	 (append (list 'lambda '(%command-line%)) statements))))

;; Read all forms from the port `in-port' and return them in a list.
(define (read-file in-port filename)
  (let loop ((expr (read in-port)) (code '()))
    (cond ((eof-object? expr) 
	   (reverse! code))
	  (else (loop (read in-port) (cons expr code))))))

;; Write the initialization code to standard output.
(define (write-init-code code)
  (write-line "; Init code")
  (for-each (lambda (x) (write x) (newline)) code)
  (newline))

;; Write all toplevel definitions to standard output.
(define (write-toplevel-definitions defs)
  (write-line "; Toplevel definitions")
  (for-each (lambda (x) (write x) (newline)) defs)
  (newline))

;; Write all toplevel definitions to standard output.
(define (write-toplevel-statements defs)
  (write-line "; Toplevel statements")
  (for-each (lambda (x) (write x) (newline)) defs)
  (newline))

(define (write-literals)
  (write-line "; Literal vector")
  (write (literal-vector))
  (newline)
  (newline))

(define (write-code-list code)
  (for-each
   (lambda (op)
     (cond ((eq? (car op) '%label)
	    (display "@l")
	    (display (cadr op))
	    (display ":"))
	   ((eq? (car op) '%comment)
	    (display " ")
	    (for-each (lambda (x) (write x) (display #\space)) (cdr op)))
	   ((eq? (car op) '%source-code)
	    (display " ")
	    (for-each (lambda (x) (pretty-print x)) (cdr op)))
	   ((memq (car op) '(%jump %jump-if-false))
	    (display "  ")
	    (display (car op))
	    (display " @l")
	    (display (cadr op)))
	   (else
	    (display "  ")
	    (for-each (lambda (x) (write x) (display #\space)) op)))
     (newline))
   code))

;; Compile the data available on the input port `in-port'.  Use
;; `filename' for error messages.
(define (compile in-port filename)
  (let* ((start-label (gen-label))
	 (code (read-file in-port filename))
	 (simplified-code (simplify-code code))
	 (definitions (toplevel-definitions simplified-code))
	 (statements (toplevel-statements simplified-code))
	 (init-code (wrap-init-code statements)))
    (with-output-to-file (string-append filename ".pre")
      (lambda ()
	(display "; -*-scheme-*-

(define %%%cons%%% cons)
(define %%%list%%% list)
(define %%%memv%%% memv)
(define %%%append2%%% append)

")
	(for-each 
	   pretty-print
	   simplified-code)))
    (write-line ";;; Generated by compile.scm -- do not edit!  -*-scheme-*-\n")
;    (write-toplevel-definitions definitions)
;    (write-toplevel-statements statements)
    (emit-op '%comment '======================================================================)
    (emit-op '%comment 'compilation 'unit 'entry 'point)
    (emit-op '%comment '======================================================================)
    (emit-op '%jump start-label)
    (emit-op '%comment)
    (write-code-list (reverse code-list))
    (reset-emitter)
    (emit-op '%comment)
    (emit-op '%comment '======================================================================)
    (emit-op '%comment 'install 'toplevel 'definitions)
    (emit-op '%comment '======================================================================)
    (translate-definitions definitions '())
    (emit-op '%comment)
    (emit-op '%comment '======================================================================)
    (emit-op '%comment 'toplevel 'statements)
    (emit-op '%comment '======================================================================)
    (translate-block statements '() #t)
    (emit-op '%restore-continuation)
    (set! code-list (reverse code-list))
    (emit-op '%install-literals (literal-vector))
    (emit-op '%label start-label)
    (emit-op '%comment '======================================================================)
    (emit-op '%comment 'main 'program)
    (emit-op '%comment '======================================================================)
    (write-code-list code-list)))

;; Check the command line and print the usage message if any of the
;; command line options `-h' or `--help' is given.  Otherwise, compile
;; every file on the command line.
(define (handle-command-line command-line)
  (cond ((or (< (length command-line) 2)
	     (member "-h" command-line)
	     (member "--help" command-line))
	 (help))
	(else 
	 (for-each (lambda (x) (compile (open-input-file x) x))
		   (cdr command-line)))))

;; Kick off the compiler.
(handle-command-line (command-line))

(pretty-print (gc-stats))
