;;; chez.init -- SLIB initialization file for Chez Scheme, version 5.0c

;; Copyright (C) 1993 dorai@cs.rice.edu (Dorai Sitaram)
;; Copyright (C) 1991, 1992, 1993, 1994, 1997 Aubrey Jaffer

;; Adapted to version 5.0c by stone@math.grin.edu (John David Stone)
;; April 29 - May 1, 1997

;; -------------------------------------------------------------------------
;; Permission to copy this software, to redistribute it, and to use it for
;; any purpose is granted, subject to the following restrictions and
;; understandings.

;; 1.  Any copy made of this software must include this copyright notice in
;;     full. 

;; 2.  I have made no warrantee or representation that the operation of
;;     this software will be error-free, and I am under no obligation to
;;     provide any services, by way of maintenance, update, or otherwise. 

;; 3.  In conjunction with products arising from the use of this material,
;;     there shall be no use of my name in any advertising, promotional,
;;     or sales literature without prior written consent in each case.
;; -------------------------------------------------------------------------

;; (The first-person pronouns in the preceding notice apparently refer
;; to Aubrey Jaffer.)

;; This initialization file supplies definitions for variables that are
;; used elsewhere in the SLIB library but are either not predefined by Chez
;; Scheme or are defined differently.  It also causes the REQUIRE package
;; from the SLIB library to be loaded.

;; We begin with some procedures that provide information about the
;; Scheme implementation that is being used and the environment in which
;; it is running.

;; The SOFTWARE-TYPE procedure returns a symbol indicating the generic
;; operating system type.  UNIX, VMS, MACOS, AMIGA and MS-DOS are
;; supported.

(define software-type
  (lambda () 'unix))

;; The SCHEME-IMPLEMENTATION-TYPE procedure returns a symbol denoting the
;; Scheme implementation that loads this file.

(define scheme-implementation-type
  (lambda () 'chez))

;; The SCHEME-IMPLEMENTATION-VERSION procedure returns a string describing
;; the version of the Scheme implementation that loads this file.

(define scheme-implementation-version
  (lambda () "5.0c"))

;; The IMPLEMENTATION-VICINITY procedure returns a string giving the
;; pathname of the directory that includes any auxiliary files used by this
;; Scheme implementation.

(define implementation-vicinity
  (lambda () "/usr/local/chez/5.0c/"))

;; The GETENV returns the value of a shell environment variable.

;; In some implementations of Chez Scheme, this can be done with foreign
;; procedures.  However, I [JDS] am using the HP version, which does not
;; support them, so a different approach is needed.
;;
;; Here's the version that doesn't work on HPs:
;;
;; (provide-foreign-entries '("getenv"))
;; 
;; (define getenv
;;   (foreign-procedure "getenv"
;;     (string) string))
;;
;; And here's a version that parses the value out of the output of the
;; /bin/env command:

(define getenv
  (lambda (env-var)
    (let ((env-port (car (process "exec /bin/env")))
          (read-line
           (lambda (source)
             (let ((next (peek-char source)))
               (if (eof-object? next)
                   next
                   (let loop ((ch (read-char source))
                              (so-far '()))
                     (if (or (eof-object? ch)
                             (char=? ch #\newline))
                         (apply string (reverse so-far))
                         (loop (read-char source) (cons ch so-far))))))))
          (position-of-copula
           (lambda (str)
             (let ((len (string-length str)))
               (do ((position 0 (+ position 1)))
                   ((or (= position len)
                        (char=? (string-ref str position) #\=))
                    position))))))
      (let loop ((equation (read-line env-port)))
        (if (eof-object? equation)
            #f
            (let ((break (position-of-copula equation))
                  (len (string-length equation)))
              (if (string=? (substring equation 0 break) env-var)
                  (if (= break len)
                      ""
                      (substring equation (+ break 1) len))
                  (loop (read-line env-port)))))))))

;; The LIBRARY-VICINITY procedure returns the pathname of the directory
;; where Scheme library functions reside.

(define library-vicinity
  (let ((library-path (or (getenv "SCHEME_LIBRARY_PATH")
			  "/usr/local/lib/slib/")))
    (lambda () library-path)))

;; The OUTPUT-PORT-WIDTH procedure returns the number of graphic characters
;; that can reliably be displayed on one line of the standard output port.

(define output-port-width
  (lambda arg
    (let ((env-width-string (getenv "COLUMNS")))
      (if (and env-width-string
               (let loop ((remaining (string-length env-width-string)))
                 (or (zero? remaining)
                     (let ((next (- remaining 1)))
                       (and (char-numeric? (string-ref env-width-string
                                                       next))
                            (loop next))))))
          (- (string->number env-width-string) 1)
          79))))

;; The OUTPUT-PORT-HEIGHT procedure returns the number of lines of text
;; that can reliably be displayed simultaneously in the standard output
;; port.

(define output-port-height
  (lambda arg
    (let ((env-height-string (getenv "LINES")))
      (if (and env-height-string
               (let loop ((remaining (string-length env-height-string)))
                 (or (zero? remaining)
                     (let ((next (- remaining 1)))
                       (and (char-numeric? (string-ref env-height-string
                                                       next))
                            (loop next))))))
          (string->number env-height-string)
          24))))

;; *FEATURES* is a list of symbols describing features of this
;; implementation; SLIB procedures sometimes consult this list to figure
;; out whether to attempt some incompletely standard operation.

(define *features*
  '(source    ; Chez Scheme can load Scheme source files, with the
	      ;   command (slib:load-source "filename") -- see below.

    compiled  ; Chez Scheme can also load compiled Scheme files, with the
              ;   command (slib:load-compiled "filename") -- see below.

    char-ready? delay dynamic-wind fluid-let format full-continuation
    getenv ieee-p1178 macro multiarg/and- multiarg-apply pretty-print
    random random-inexact rationalize rev3-procedures rev3-report
    rev4-optional-procedures rev4-report sort string-port system
    transcript values with-file))

;; The following procedures connect SLIB's style of macro definition with
;; the primitives provided by Chez Scheme.

;; Apparently, in earlier versions of this init file, Chez's EXTEND-SYNTAX
;; form was used to create an R4RS DEFINE-SYNTAX.  Chez now supplies this
;; directly and seems to have discarded EXTEND-SYNTAX.

;; Earlier versions of this file also contained a number of other
;; definitions compensating for the absence of R4RS macros:

;; Here's what the old stuff looked like:
;;
;; (extend-syntax (define-syntax syntax-rules)
;;   ((define-syntax name (syntax-rules kwds . clauses))
;;    (extend-syntax (name . kwds) . clauses)))
;;
;; (define-syntax defined?
;;   (syntax-rules ()
;;     ((defined? x) (or (bound? 'x) (get 'x '*expander*)))))
;;
;; (define-macro! defmacro z `(define-macro! ,@z))
;; 
;; (define defmacro? 
;;   (lambda (m) (get m '*expander*)))
;;
;; (define macroexpand-1 eps-expand-once)
;;
;; (define macroexpand
;;   (lambda (e)
;;     (if (pair? e)
;;         (let ((a (car e)))
;;           (if (and (symbol? a)
;;                    (getprop a '*expander*))
;;               (macroexpand (expand-once e))
;;               e))
;;         e)))

;; In version 5.0c, R4RS macros can be used to implement the stuff that
;; SLIB requires:

(define *defmacros*
  (list (cons 'defmacro
              (lambda (name parms . body)
                `(set! *defmacros*
                       (cons (cons ',name (lambda ,parms ,@body))
                             *defmacros*))))))

(define defmacro?
  (lambda (m)
    (and (assq m *defmacros*) #t)))

(define macroexpand-1
  (lambda (e)
    (if (pair? e)
        (let ((a (car e)))
          (cond ((symbol? a) (set! a (assq a *defmacros*))
                             (if a (apply (cdr a) (cdr e)) e))
                (else e)))
        e)))

(define macroexpand
  (lambda (e)
    (if (pair? e)
        (let ((a (car e)))
          (cond ((symbol? a)
                 (set! a (assq a *defmacros*))
                 (if a (macroexpand (apply (cdr a) (cdr e))) e))
                (else e)))
        e)))

;; Chez's sorting routines take parameters in the order opposite to SLIB's.
;; The following definitions override the predefined procedures with the
;; parameters-reversed versions.

(define chez:sort sort)
(define chez:sort! sort!)
(define chez:merge merge)
(define chez:merge! merge!)

(define sort
  (lambda (s p)
    (chez:sort p s)))
(define sort!
  (lambda (s p)
    (chez:sort! p s)))
(define merge
  (lambda (s1 s2 p)
    (chez:merge p s1 s2)))
(define merge!
  (lambda (s1 s2 p)
    (chez:merge! p s1 s2)))

;; Chez's (FORMAT F . A) corresponds to SLIB's (FORMAT #F F . A)

(define chez:format format)

(define format
  (lambda (where how . args)
    (let ((str (apply chez:format how args)))
      (cond ((not where) str)
	    ((eq? where #t) (display str))
	    (else (display str where))))))

;; Chez's NIL variable is bound to '(); SLIB's is bound to #F.

(define nil #f)

;; The following definitions implement a few widely useful procedures that
;; Chez Scheme does not provide or provides under a different name.

;; SLIB provides identifiers for the TAB (ASCII 9) and FORM-FEED (ASCII 12)
;; characters.

(define slib:tab #\tab)
(define slib:form-feed #\page)

;; The RENAME-FILE procedure constructs and executes a Unix mv command to
;; change the name of a file.

(define rename-file
  (lambda (src dst)
    (system (string-append "mv " src " " dst))))

;; The CURRENT-ERROR-PORT procedure returns a port to which error
;; messages are to be displayed; this is the original standard output
;; port (even if the program subsequently changes the current output port
;; somehow).

(define current-error-port
  (let ((port (current-output-port)))
    (lambda () port)))

;; SLIB provides two versions of the ERROR procedure -- one to print
;; non-fatal advisory messages, the other for fatal errors.

(define slib:warn
  (lambda args
    (let ((port (current-error-port)))
      (display "Warn: " port)
      (for-each (lambda (x) (display x port)) args))))

(define slib:error
  (lambda args
    (let ((port (current-error-port)))
      (display "Error: " port)
      (for-each (lambda (x) (display x port)) args)
      (error #f ""))))

;; The TMPNAM procedure constructs and returns a temporary file name,
;; presumably unique and not a duplicate of one already existing.

(define tmpnam
  (let ((cntr 100))
    (lambda ()
      (set! cntr (+ 1 cntr))
      (let ((tmp (string-append "slib_" (number->string cntr))))
        (if (file-exists? tmp) (tmpnam) tmp)))))

;; The FORCE-OUTPUT requires buffered output that has been written to a
;; port to be transferred all the way out to its ultimate destination.

(define force-output flush-output)

;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string
;; port versions of CALL-WITH-INPUT-FILE and CALL-WITH-OUTPUT-FILE.

(define call-with-output-string
  (lambda (f)
    (let ((outsp (open-output-string)))
      (f outsp)
      (let ((s (get-output-string outsp)))
        (close-output-port outsp)
        s))))

(define call-with-input-string
  (lambda (s f)
    (let* ((insp (open-input-string s))
           (res (f insp)))
      (close-input-port insp)
      res)))

;; CHAR-CODE-LIMIT is the number of characters in the character set; only
;; non-negative integers less than CHAR-CODE-LIMIT are eligible as
;; arguments to INTEGER->CHAR.

(define char-code-limit 256)

;; Chez's MOST-POSITIVE-FIXNUM is a thunk rather than a number.

(if (procedure? most-positive-fixnum)
    (set! most-positive-fixnum (most-positive-fixnum)))

;; The IDENTITY procedure returns its argument without change.

(define identity 
  (lambda (x) x))

;; The GENTEMP procedure generates unused symbols and marks them as
;; belonging to the SLIB package.

(define gentemp
  (let ((*gensym-counter* -1))
    (lambda ()
      (set! *gensym-counter* (+ *gensym-counter* 1))
      (string->symbol
       (string-append "slib:G" (number->string *gensym-counter*))))))

;; The IN-VICINITY procedure is simply STRING-APPEND, conventionally used
;; to attach a directory pathname to the name of a file that is expected to
;; be in that directory.

(define in-vicinity string-append)

;; For backward compatability, the SCHEME-FILE-SUFFIX procedure is defined
;; to return the string ".scm".  Note, however, that ".ss" is a common Chez
;; file suffix.

(define scheme-file-suffix
  (lambda () ".scm"))

;; SLIB appropriates Chez Scheme's EVAL procedure.

(define slib:eval eval)

(define defmacro:eval slib:eval)
(define macro:eval slib:eval)

(define slib:eval-load
  (lambda (<pathname> evl)
    (if (not (file-exists? <pathname>))
        (set! <pathname> (string-append <pathname> (scheme-file-suffix))))
    (call-with-input-file <pathname>
      (lambda (port)
        (let ((old-load-pathname *load-pathname*))
          (set! *load-pathname* <pathname>)
          (do ((o (read port) (read port)))
              ((eof-object? o))
            (evl o))
          (set! *load-pathname* old-load-pathname))))))

;; SLIB:EXIT is the implementation procedure that exits, or returns
;; if exiting is not supported.

(define slib:chez:quit
  (let ((arg (call-with-current-continuation identity)))
    (cond ((procedure? arg) arg)
	  (arg (exit))
	  (else (exit 1)))))

(define slib:exit
  (lambda args
    (cond ((null? args) (slib:chez:quit #t))
	  ((eqv? #t (car args)) (slib:chez:quit #t))
	  ((eqv? #f (car args)) (slib:chez:quit #f))
	  ((zero? (car args)) (slib:chez:quit #t))
	  (else (slib:chez:quit #f)))))

;; The SLIB:LOAD-SOURCE procedure, given a string argument, should attach
;; the appropriate file suffix to the string and load the file named
;; by the resulting string.

(define slib:load-source
  (lambda (f)
    (load (string-append f (scheme-file-suffix)))))

;;; defmacro:load and macro:load also need the default suffix.

(define defmacro:load slib:load-source)
(define macro:load slib:load-source)

;; The SLIB:LOAD-COMPILED procedure, given a string argument, finds and
;; loads the file, assumed to have been compiled.

(define slib:load-compiled load)

;; SLIB:LOAD can now be defined to load SLIB files.

(define slib:load slib:load-source)

;; Load the REQUIRE package.

(slib:load (in-vicinity (library-vicinity) "require"))

;; end of chez.init