(define scheme-type 's88)

;;; This implementation of case uses memq instead of memv. This is MUCH faster
;;; because memq is a BCO and eq? is inlined.
;(let ((get-pred
;	(lambda (k)
;	  (cond ((symbol? k) 'eq?)
;		((fixnum? k) 'eq?)
;		((number? k) '=)
;		((char? k)   'eq?)
;		((boolean? k) 'eq?)
;		((null? k)   'eq?)
;		(else (error 'case "Invalid matching element: ~s" k))))))
;(extend-syntax (case else)
;  ((case (fun x ...) m ...)
;   (with ((g (gensym)))
;      (let ((g (fun x ...))) (case g m ...))))
;  ((case v) #f)
;  ((case v (else e1 e2 ...)) (begin e1 e2 ...))
;  ((case v ((k) e1 e2 ...) m ...)
;   (with ((predicate (get-pred 'k)))
;     (if (predicate v 'k)
;	 (begin e1 e2 ...)
;	 (case v m ...))))
;  ((case v ((k1 k2) e1 e2 ...) m ...)
;   (with ((p1 (get-pred 'k1))
;	  (p2 (get-pred 'k2)))
;     (if (or (p1 v 'k1) (p2 v 'k2)) 
;	 (begin e1 e2 ...)
;	 (case v m ...))))
;  ((case v ((k1 k2 ...) e1 e2 ...) m ...)
;   (with ((junk (unless 
;		 (andmap (lambda (x)(or (symbol? x)(char? x)(fixnum? x)))
;			 '(k1 k2 ...))
;		 (error 'case "lists must be memq-recognizeable"))))
;      (if (memq v '(k1 k2 ...)) (begin e1 e2 ...) (case v m ...))))
;  ((case v (k e1 e2 ...) m ...)
;   (with ((predicate (get-pred 'k)))
;     (if (predicate v 'k) (begin e1 e2 ...) (case v m ...))))))

(alias mkc list)
(alias make-label gensym)

(load "opc2.s")
(writeln "opc2.s")
(load "asm2.s")
(writeln "asm2.s")
(load "asm-let.s")
(writeln "asm-let.s")
(load "passpv4.s")
(writeln "passpv4.s")
(load "pass1v33.s")
(writeln "pass1v33.s")
(load "pass2v6.s")
(writeln "pass2v6.s")
;(load "expandf.s")
;(load "expd.chz")
(load "syntax.ss")
(load "make.s")
(load "records.ss")

(set! inline? #t)

;;; Bco? defined here for chez.
(define body-code-object? (lambda (x) (bco? x)))
;(define body-code-object?
;  (let
;    ((objs
;         ;;; gc.ss
;       '(cons box make-string explode gensym runtime fxruntime %gc 
;
;         ;;; glist2.ss
;	 memq  set-car! set-cdr! length length-chk list? reverse reverse!
;	 list list* list-ref %list-tail assq 
;	 ; Inlined: car cdr caar cadr cdar cddr 
;	 ;          caaar caadr cadar caddr cdaar cdadr cddar cdddr
;	 ;          caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
;	 ;          cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
;
;	 ;;; pwrite.s
;	 %write 
;
;	 ;;; Pwrite.ss
;	 get-cursor set-cursor key-ready?  %current-drive %set-drive
;         current-directory set-directory %freesp %1st-semi slashify %exec
;
;	 ;;; g3.ss
;         + - * negative? positive? remainder quotient = even? odd? >>
;	 explode-bn number?
;
;	 ;;; numc.ss
;	 exact->inexact inexact->exact number->string
;
;	 ;;; qport.ss
;	 current-input-port current-output-port open-input-file
;	 open-output-file open-extend-file file-exists? 
;	 open-input-string open-output-string close-input-port
;	 close-output-port read-char peek-char write-char write-string
;	 input-port? output-port? 
;
;	 ;;; vect.ss
;	 vector-length make-vector vector vector-ref vector-set! vector->list
;	 list->vector
;	        
;	 ;;; cvect2.ss
;	 %make-code-vector asm-p1-string %code-vector-ref
;	 %code-vector-set! list->cvector
;
;	 ;;; edit.ss
;	 edit
;	 )))
;    (lambda (x)
;      (memq x objs))))

(define timeit #f)

(define cf
  (let ((dest (void)))
  (lambda files
    (unless (>= (length files) 2)
	    (error 'compile-file "Wrong number of arguments ~s" files))
    (writeln "compiling: " files)
    (let ((source
	   (let src-loop ((files files))
	     (if (null? (cdr files))
		 (begin (set! dest (car files))
			())
		 (let* ((ip (open-input-file (car files)))
			(e (let loop ((e (read ip)))
			     (if (eof-object? e)
				 (begin (close-input-port ip)
					())
				 (cons e (loop (read ip)))))))
		   (append! e (src-loop (cdr files))))))))
      (p2 (p1 (cons 'begin source)))
      (write-code dest))
    #t)))