;s4.ss
;SLaTeX v. 2.3
;Making dialect meet R4RS spec
;(includes optimizing for Chez 4.0a+)
;(c) Dorai Sitaram, Rice U., 1991, 1994

(extract-if (chez)
  (eval-when (compile load eval)
    (if (bound? 'optimize-level) 'skip ;else code only for old Chezs
      (let ((cwif call-with-input-file)
	    (cwof call-with-output-file))
	(set! call-with-input-file
	  (lambda (f p)
	    (cwif f (lambda (pt)
		      (p pt)
		      (close-input-port pt)))))
	(set! call-with-output-file
	  (lambda (f p)
	    (cwof f (lambda (pt)
		      (p pt)
		      (close-output-port pt)))))))))

(extract-if (chez)
  (if (bound? 'optimize-level) (optimize-level 3)))

'(extract-if (chez)
   (eval-when (compile load eval)
     (if (bound? 'waiter-prompt-and-read)
	 (begin
	   (waiter-prompt-and-read
	     (lambda (n)
	       (read (console-input-port))))
	   '(waiter-write (lambda (x) 'void))))))

(extract-if (cl)
  (do-all-symbols (x)
    (cond ((boundp x) 'void)
	  ((macro-function x) 'void)
	  ((special-form-p x) 'void)
	  ((fboundp x)
	   (setf (symbol-value x) (symbol-function x))))))

(extract-if (cl)
  (define boolean?
    (lambda (b)
      (or (eq b t) (eq b nil))))

  (define list?
    ;not quite listp
    (lambda (s)
      (cond ((null s) t)
	    ((consp s) (list? (cdr s)))
	    (else nil))))

  (define memq
    (lambda (x s)
      (cl/member x s :test (function eq))))

  (define member
    (lambda (x s)
      (cl/member x s :test (function equal))))

  (define assq
    (lambda (x s)
      (cl/assoc x s :test (function eq))))

  (define assoc
    (lambda (x s)
      (cl/assoc x s :test (function equal))))

  (define number->string
    (lambda (n &optional b)
      (if b (write-to-string n :base b)
	  (write-to-string n))))

  (define string->number
    (lambda (s &optional b)
      (if b (let ((*read-base* b))
	      (with-input-from-string (p s)
		(let ((n (cl/read p)))
		  (if (numberp n) n nil))))
	  (with-input-from-string (p s)
	    (let ((n (cl/read p)))
	      (if (numberp n) n  nil))))))

  (define char-whitespace?
    (lambda (c)
      (or (char= c #\space) (char= c #\tab)
	(not (graphic-char-p c)))))

  (define make-string
    (lambda (n &optional c)
      (cl/make-string n :initial-element
       (if c c #\space))))

  (define string
    (lambda (&rest z)
      (concatenate 'string z)))

  (define string-append
    (lambda (&rest z)
      (apply concatenate 'string z)))

  (define string->list
    (lambda (s)
      (concatenate 'list s)))

  (define list->string
    (lambda (s)
      (concatenate 'string s)))

  (define make-vector
    (lambda (n &optional x)
      (make-array (list n) :initial-element x)))

  (define vector->list
    (lambda (v)
      (concatenate 'vector v)))

  (define list->vector
    (lambda (s)
      (concatenate 'vector s)))

  (define procedure?
    (lambda (x)
      (cond ((symbolp x) nil)
	    ;some CLs' functionp gives t on symbols!
	    ((functionp x) t)
	    (t nil))))

  (define call-with-input-file
    (lambda (f pr)
      (with-open-file (inp f :direction :input)
	(funcall pr inp))))

  (define call-with-output-file
    (lambda (f pr)
      (with-open-file (outp f :direction :output)
	(funcall pr outp))))

  (define current-input-port
    (lambda ()
      *standard-input*))

  (define current-output-port
    (lambda ()
      *standard-output*))

  (define open-input-file
    (lambda (f)
      (open f :direction :input)))

  (define open-output-file
    (lambda (f)
      (open f :direction :output)))

  (define read
    (lambda (&optional p)
      (cl/read p nil :eof-object)))

  (define read-char
    (lambda (&optional p)
      (cl/read-char p nil :eof-object)))

  (define peek-char
    (lambda (&optional p)
      (cl/peek-char nil p nil :eof-object)))

  (define eof-object?
    (lambda (v)
      (eq v :eof-object)))

  )