;;; LaHaShem HaAretz U'Mloah

;;; Stalin 0.10 - A global optimizing compiler for Scheme
;;; Copyright 1993, 1994, and 1995 University of Toronto. All rights reserved.
;;; Copyright 1996 Technion. All rights reserved.
;;; Copyright 1996 and 1997 University of Vermont. All rights reserved.
;;; Copyright 1997, 1998, 1999, 2000, and 2001 NEC Research Institute, Inc. All
;;; rights reserved.
;;; Copyright 2002 and 2003 Purdue University. All rights reserved.

;;; 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
;;; of the License, 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 program; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.

;;; written by:
;;;    Jeffrey Mark Siskind
;;;    NEC Research Institute, Inc.
;;;    4 Independence Way
;;;    Princeton NJ 08540-6620 USA
;;;    voice: 609/951-2705
;;;    FAX:   609/951-2483
;;;    Qobi@research.nj.nec.com
;;;    ftp://ftp.nj.nec.com/pub/qobi
;;;    http://www.neci.nj.nec.com/homepages/qobi

(import (chicken bitwise)
        (chicken platform)
        (chicken process-context)
        (only (chicken file) file-exists?)
        (chicken process))
(keyword-style #:none)
(case-sensitive #f)

(define c-sizeof-s2cuint (foreign-value "sizeof(C_word)" int))

;;; needs work: These are stubs for now.
(define (write-level) #f)
(define (write-pretty) #f)
(define (set-write-level! p?) ((lambda () #f)))
(define (set-write-pretty! p?) ((lambda () #f)))
(define (collect-all) ((lambda () #f)))
(define (collect-info) '(0))

(define flush-buffer flush-output)

(define (make-file-port stdio-file mode) stdio-file)

(define (port->stdio-file port) port)

(define (time-of-day) (panic "TIME-OF-DAY is not (yet) implemented"))

(define bit-not bitwise-not)

(define bit-and bitwise-and)

(define bit-or bitwise-ior)

;;; needs work: STDERR-PORT
(define (format destination format-string . arguments)
 (cond
  ((output-port? destination)
   (let ((twiddle? #f)
	 (n (- (string-length format-string) 1)))
    (unless (negative? n)
     (let loop ((i 0))
      (let ((char (string-ref format-string i)))
       (cond (twiddle?
	      (case char
	       ((#\a #\A)
		(when (null? arguments) (panic "Too few FORMAT arguments"))
		(display (car arguments) destination)
		(set! arguments (cdr arguments)))
	       ((#\s #\S)
		(when (null? arguments) (panic "Too few FORMAT arguments"))
		(write (car arguments) destination)
		(set! arguments (cdr arguments)))
	       ((#\~) (write-char #\~ destination))
	       ((#\%) (newline destination))
	       (else (panic "Improper FORMAT directive")))
	      (set! twiddle? #f))
	     ((char=? char #\~) (set! twiddle? #t))
	     (else (write-char char destination)))
       (cond ((< i n) (loop (+ i 1)))
	     ((not (null? arguments)) (panic "Too many FORMAT arguments"))
	     (twiddle? (panic "Twiddle at end of FORMAT string"))))))))
  ((eq? destination #t)
   (let ((twiddle? #f)
	 (n (- (string-length format-string) 1)))
    (unless (negative? n)
     (let loop ((i 0))
      (let ((char (string-ref format-string i)))
       (cond (twiddle?
	      (case char
	       ((#\a #\A)
		(when (null? arguments) (panic "Too few FORMAT arguments"))
		(display (car arguments))
		(set! arguments (cdr arguments)))
	       ((#\s #\S)
		(when (null? arguments) (panic "Too few FORMAT arguments"))
		(write (car arguments))
		(set! arguments (cdr arguments)))
	       ((#\~) (write-char #\~))
	       ((#\%) (newline))
	       (else (panic "Improper FORMAT directive")))
	      (set! twiddle? #f))
	     ((char=? char #\~) (set! twiddle? #t))
	     (else (write-char char)))
       (cond ((< i n) (loop (+ i 1)))
	     ((not (null? arguments)) (panic "Too many FORMAT arguments"))
	     (twiddle? (panic "Twiddle at end of FORMAT string"))))))))
  ((eq? destination #f)
   (let ((twiddle? #f)
	 (result '())
	 (n (- (string-length format-string) 1)))
    (define (write-to-result x)
     (cond ((null? x)
	    (set! result (cons #\( result))
	    (set! result (cons #\) result)))
	   ((eq? x #t)
	    (set! result (cons #\# result))
	    (set! result (cons #\T result)))
	   ((not x)
	    (set! result (cons #\# result))
	    (set! result (cons #\F result)))
	   ((char? x)
	    (set! result (cons #\# result))
	    (set! result (cons #\\ result))
	    ;; needs work: To handle other non printing characters.
	    (case x
	     ((#\newline)
	      (set! result (cons #\N result))
	      (set! result (cons #\e result))
	      (set! result (cons #\w result))
	      (set! result (cons #\l result))
	      (set! result (cons #\i result))
	      (set! result (cons #\n result))
	      (set! result (cons #\e result)))
	     ((#\space)
	      (set! result (cons #\S result))
	      (set! result (cons #\p result))
	      (set! result (cons #\a result))
	      (set! result (cons #\c result))
	      (set! result (cons #\e result)))
	     (else (set! result (cons x result)))))
	   ((number? x)
	    (for-each (lambda (c) (set! result (cons c result)))
		      (string->list (number->string x))))
	   ((input-port? x)
	    (set! result (cons #\# result))
	    (set! result (cons #\* result))
	    (set! result (cons #\I result))
	    (set! result (cons #\N result))
	    (set! result (cons #\P result))
	    (set! result (cons #\U result))
	    (set! result (cons #\T result))
	    (set! result (cons #\- result))
	    (set! result (cons #\P result))
	    (set! result (cons #\O result))
	    (set! result (cons #\R result))
	    (set! result (cons #\T result))
	    (set! result (cons #\* result)))
	   ((output-port? x)
	    (set! result (cons #\# result))
	    (set! result (cons #\* result))
	    (set! result (cons #\O result))
	    (set! result (cons #\U result))
	    (set! result (cons #\T result))
	    (set! result (cons #\P result))
	    (set! result (cons #\U result))
	    (set! result (cons #\T result))
	    (set! result (cons #\- result))
	    (set! result (cons #\P result))
	    (set! result (cons #\O result))
	    (set! result (cons #\R result))
	    (set! result (cons #\T result))
	    (set! result (cons #\* result)))
	   ((eof-object? x)
	    (set! result (cons #\# result))
	    (set! result (cons #\* result))
	    (set! result (cons #\E result))
	    (set! result (cons #\O result))
	    (set! result (cons #\F result))
	    (set! result (cons #\- result))
	    (set! result (cons #\O result))
	    (set! result (cons #\B result))
	    (set! result (cons #\J result))
	    (set! result (cons #\E result))
	    (set! result (cons #\C result))
	    (set! result (cons #\T result))
	    (set! result (cons #\* result)))
	   #;((pointer? x)
	    (set! result (cons #\# result))
	    (set! result (cons #\* result))
	    (set! result (cons #\P result))
	    (set! result (cons #\O result))
	    (set! result (cons #\I result))
	    (set! result (cons #\N result))
	    (set! result (cons #\T result))
	    (set! result (cons #\E result))
	    (set! result (cons #\R result))
	    (set! result (cons #\* result)))
	   ((symbol? x)
	    ;; needs work: Should slashify.
	    (let* ((x (symbol->string x))
		   (n (string-length x)))
	     (let loop ((i 0))
	      (when (< i n)
	       (set! result (cons (string-ref x i) result))
	       (loop (+ i 1))))))
	   ((procedure? x)
	    (set! result (cons #\# result))
	    (set! result (cons #\* result))
	    (set! result (cons #\P result))
	    (set! result (cons #\R result))
	    (set! result (cons #\O result))
	    (set! result (cons #\C result))
	    (set! result (cons #\E result))
	    (set! result (cons #\D result))
	    (set! result (cons #\U result))
	    (set! result (cons #\R result))
	    (set! result (cons #\E result))
	    (set! result (cons #\* result)))
	   ((string? x)
	    (set! result (cons #\" result))
	    (let ((n (string-length x)))
	     (let loop ((i 0))
	      (when (< i n)
	       (when (or (char=? (string-ref x i) #\\)
			 (char=? (string-ref x i) #\")
			 (set! result (cons #\\ result)))
		(set! result (cons (string-ref x i) result))
		(loop (+ i 1))))))
	    (set! result (cons #\" result)))
	   ((pair? x)
	    (set! result (cons #\( result))
	    (let loop ((x x))
	     (cond ((null? (cdr x))
		    (write-to-result (car x)))
		   ((pair? (cdr x))
		    (write-to-result (car x))
		    (set! result (cons #\space result))
		    (loop (cdr x)))
		   (else (write-to-result (car x))
			 (set! result (cons #\space result))
			 (write-to-result (cdr x)))))
	    (set! result (cons #\) result)))
	   ((vector? x)
	    (set! result (cons #\# result))
	    (set! result (cons #\( result))
	    (let ((n (vector-length x)))
	     (unless (zero? n)
	      (write-to-result (vector-ref x 0))
	      (let loop ((i 1))
	       (unless (= i n)
		(set! result (cons #\space result))
		(write-to-result (vector-ref x i))
		(loop (+ i 1))))))
	    (set! result (cons #\) result)))
	   (else (panic
		  "FORMAT with WRITE-methods is not (yet) implemented"))))
    (define (display-to-result x)
     (cond ((null? x)
	    (set! result (cons #\( result))
	    (set! result (cons #\) result)))
	   ((eq? x #t)
	    (set! result (cons #\# result))
	    (set! result (cons #\T result)))
	   ((not x)
	    (set! result (cons #\# result))
	    (set! result (cons #\F result)))
	   ((char? x)
	    (set! result (cons x result)))
	   ((number? x)
	    (for-each (lambda (c) (set! result (cons c result)))
		      (string->list (number->string x))))
	   ((input-port? x)
	    (set! result (cons #\# result))
	    (set! result (cons #\* result))
	    (set! result (cons #\I result))
	    (set! result (cons #\N result))
	    (set! result (cons #\P result))
	    (set! result (cons #\U result))
	    (set! result (cons #\T result))
	    (set! result (cons #\- result))
	    (set! result (cons #\P result))
	    (set! result (cons #\O result))
	    (set! result (cons #\R result))
	    (set! result (cons #\T result))
	    (set! result (cons #\* result)))
	   ((output-port? x)
	    (set! result (cons #\# result))
	    (set! result (cons #\* result))
	    (set! result (cons #\O result))
	    (set! result (cons #\U result))
	    (set! result (cons #\T result))
	    (set! result (cons #\P result))
	    (set! result (cons #\U result))
	    (set! result (cons #\T result))
	    (set! result (cons #\- result))
	    (set! result (cons #\P result))
	    (set! result (cons #\O result))
	    (set! result (cons #\R result))
	    (set! result (cons #\T result))
	    (set! result (cons #\* result)))
	   ((eof-object? x)
	    (set! result (cons #\# result))
	    (set! result (cons #\* result))
	    (set! result (cons #\E result))
	    (set! result (cons #\O result))
	    (set! result (cons #\F result))
	    (set! result (cons #\- result))
	    (set! result (cons #\O result))
	    (set! result (cons #\B result))
	    (set! result (cons #\J result))
	    (set! result (cons #\E result))
	    (set! result (cons #\C result))
	    (set! result (cons #\T result))
	    (set! result (cons #\* result)))
	   ((pointer? x)
	    (set! result (cons #\# result))
	    (set! result (cons #\* result))
	    (set! result (cons #\P result))
	    (set! result (cons #\O result))
	    (set! result (cons #\I result))
	    (set! result (cons #\N result))
	    (set! result (cons #\T result))
	    (set! result (cons #\E result))
	    (set! result (cons #\R result))
	    (set! result (cons #\* result)))
	   ((symbol? x)
	    (let* ((x (symbol->string x))
		   (n (string-length x)))
	     (let loop ((i 0))
	      (when (< i n)
	       (set! result (cons (string-ref x i) result))
	       (loop (+ i 1))))))
	   ((procedure? x)
	    (set! result (cons #\# result))
	    (set! result (cons #\* result))
	    (set! result (cons #\P result))
	    (set! result (cons #\R result))
	    (set! result (cons #\O result))
	    (set! result (cons #\C result))
	    (set! result (cons #\E result))
	    (set! result (cons #\D result))
	    (set! result (cons #\U result))
	    (set! result (cons #\R result))
	    (set! result (cons #\E result))
	    (set! result (cons #\* result)))
	   ((string? x)
	    (let ((n (string-length x)))
	     (let loop ((i 0))
	      (when (< i n)
	       (set! result (cons (string-ref x i) result))
	       (loop (+ i 1))))))
	   ((pair? x)
	    (set! result (cons #\( result))
	    (let loop ((x x))
	     (cond ((null? (cdr x))
		    (display-to-result (car x)))
		   ((pair? (cdr x))
		    (display-to-result (car x))
		    (set! result (cons #\space result))
		    (loop (cdr x)))
		   (else (display-to-result (car x))
			 (set! result (cons #\space result))
			 (display-to-result (cdr x)))))
	    (set! result (cons #\) result)))
	   ((vector? x)
	    (set! result (cons #\# result))
	    (set! result (cons #\( result))
	    (let ((n (vector-length x)))
	     (unless (zero? n)
	      (display-to-result (vector-ref x 0))
	      (let loop ((i 1))
	       (unless (= i n)
		(set! result (cons #\space result))
		(display-to-result (vector-ref x i))
		(loop (+ i 1))))))
	    (set! result (cons #\) result)))
	   (else (panic
		  "FORMAT with DISPLAY-methods is not (yet) implemented"))))
    (unless (negative? n)
     (let loop ((i 0))
      (let ((char (string-ref format-string i)))
       (cond (twiddle?
	      (case char
	       ((#\a #\A)
		(when (null? arguments) (panic "Too few FORMAT arguments"))
		(display-to-result (car arguments))
		(set! arguments (cdr arguments)))
	       ((#\s #\S)
		(when (null? arguments) (panic "Too few FORMAT arguments"))
		(write-to-result (car arguments))
		(set! arguments (cdr arguments)))
	       ((#\~) (set! result (cons #\~ result)))
	       ((#\%) (set! result (cons #\newline result)))
	       (else (panic "Improper FORMAT directive")))
	      (set! twiddle? #f))
	     ((char=? char #\~) (set! twiddle? #t))
	     (else (set! result (cons char result))))
       (cond ((< i n) (loop (+ i 1)))
	     ((not (null? arguments)) (panic "Too many FORMAT arguments"))
	     (twiddle? (panic "Twiddle at end of FORMAT string"))
	     (else (list->string (reverse result)))))))))
  (else (panic "Improper FORMAT destination"))))

(define panic error)

(define (pointer? x) #f)

(define (sublist list start end)	;Extension to R4RS.
  (if (zero? start)
      ;; needs work: To make tail recursive.
      (let loop ((list list) (k end))
	(if (zero? k) '() (cons (car list) (loop (cdr list) (- k 1)))))
      (sublist (cdr list) (- start 1) (- end 1))))


;;; Tam V'Nishlam Shevah L'El Borei Olam