(define writeln
  (lambda args
    (let loop ((args args))
      (if (null? args)
	  (newline)
	  (begin (display (car args))
	         (loop (cdr args)))))))

(define proc? procedure?)


(define scheme-type 'chez)
(collect-trip-bytes 4000000)
(generate-inspector-information #t)

(remprop 'match '*expander*)     ;;; Not used -- conflicts with balance

(extend-syntax (alias)
  ([alias sym1 sym2]
   [extend-syntax (sym1)
     ([sym1 . args]
      [sym2 . args])]))

;;; 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 "fx-fix.s")

(define fixnum? (lambda (x) (and (integer? x) (>= x -32768) (<= x 32767))))
(define bignum? (lambda (x) (and (integer? x)
				 (or (< x -32768) (> x 32767)))))

;(load "profile.s")
(load "opc2.s")
(load "asm2.s")
(load "asm-let.s")
(load "pass1v33.s")
(load "pass2v6.s")
(load "passpv4.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?
  (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 reset-times
  (lambda ()
    (set! p1-total (make-vector 6 0))
    (set! p2-total (make-vector 6 0))
    (set! asm2-total (make-vector 6 0))))
(reset-times)

(define add-vecs
  (letrec ((do-add            ;;; Add v2 to v1, returning v1
	    (lambda (v1 v2)
	      (let loop ((i 0))
		(if (< i (vector-length v1))
		    (begin
		      (vector-set! v1 i (+ (vector-ref v1 i)
					   (vector-ref v2 i)))
		      (loop (add1 i)))
		    v1)))))
    (lambda (total . vec*)
      (let loop ((vec* vec*))
	(if (null? vec*)
	    total
	    (begin
	      (do-add total (car vec*))
	      (loop (cdr vec*))))))))

(define sub-vecs
  (lambda (v1 v2)
    (let loop ((i 0))
      (if (< i (vector-length v1))
	  (begin
	    (vector-set! v1 i (- (vector-ref v1 i)
				 (vector-ref v2 i)))
	    (loop (add1 i)))
	  v1))))

(define show-stats
  (lambda (name vec)
    (newline)(newline)
    (writeln "statistics for " name)
    (writeln "total cpu time    : " (vector-ref vec 0) "ms")
    (writeln "total wall time   : " (vector-ref vec 1) "ms")
    (writeln "total memory used : " (vector-ref vec 2) "bytes")
    (writeln "number of gcs     : " (vector-ref vec 3))
    (writeln "total gc time     : " (vector-ref vec 4) "ms")
    (writeln "total cpu - gc    : " (vector-ref vec 5) "ms")))

(define show-all-stats
  (lambda ()
    (show-stats 'pass1 p1-total)
    (show-stats 'pass2-including-asm1 p2-total)
    (show-stats 'asm2  asm2-total)))

(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)))

(define show-stats
  (lambda ()
(writeln "*immed-atomic-cnt: " *immed-atomic-cnt)
(writeln "*immed-cnt: " *immed-cnt)
(writeln "*id-cnt: " *id-cnt)
(writeln "*close-cnt: " *close-cnt)
(writeln "*let-cnt: " *let-cnt)
(writeln "*llet-cnt: " *llet-cnt)
(writeln "*begin-cnt: " *begin-cnt)
(writeln "*if-cnt: " *if-cnt)
(writeln "*set!-cnt: " *set!-cnt)
(writeln "*or-cnt: " *or-cnt)
(writeln "*and-cnt: " *and-cnt)
(writeln "*recursive-cnt: " *recursive-cnt)
(writeln "*tail-cnt: " *tail-cnt)
(writeln "*bco-call-cnt: " *bco-call-cnt)
(writeln "*loop-call-cnt: " *loop-call-cnt)
(writeln "*inline-cnt: " *inline-cnt)))