;;;"mitscheme.init" Initialization for SLIB for MITScheme        -*-scheme-*-
;;; Author: Aubrey Jaffer
;;;
;;; This code is in the public domain.

;;; Make this part of your ~/.scheme.init file.

(define getenv get-environment-variable)

;;; (software-type) should be set to the generic operating system type.
(define (software-type) (if (getenv "HOMEDRIVE") 'MS-DOS 'UNIX))

;;; (scheme-implementation-type) should return the name of the scheme
;;; implementation loading this file.

(define (scheme-implementation-type) 'MITScheme)

;;; (scheme-implementation-home-page) should return a (string) URI
;;; (Uniform Resource Identifier) for this scheme implementation's home
;;; page; or false if there isn't one.

(define (scheme-implementation-home-page)
  "http://swissnet.ai.mit.edu/scheme-home.html")

;;; (scheme-implementation-version) should return a string describing
;;; the version the scheme implementation loading this file.

(define (scheme-implementation-version)
  (let* ((str (with-output-to-string identify-world))
	 (beg (+ (string-search-forward "Release " str) 8))
	 (rst (substring str beg (string-length str)))
	 (end (string-find-next-char-in-set
	       rst
	       (predicate->char-set char-whitespace?))))
    (substring rst 0 end)))

;;; (implementation-vicinity) should be defined to be the pathname of
;;; the directory where any auxillary files to your Scheme
;;; implementation reside.

(define (implementation-vicinity)
  (case (software-type)
    ((MS-DOS)	"c:\\scheme\\")
    ((UNIX)	 "/usr/local/lib/mit-scheme/")
    ((VMS)	"scheme$src:")))

;;; (library-vicinity) should be defined to be the pathname of the
;;; directory where files of Scheme library functions reside.

(define library-vicinity
  (let ((library-path
	 (or (getenv "SCHEME_LIBRARY_PATH")
	     ;; Use this path if your scheme does not support GETENV.
	     (case (software-type)
	       ((MS-DOS) "c:\\slib\\")
	       ((UNIX) "/usr/local/lib/slib/")
	       ((VMS) "lib$scheme:")
	       (else "")))))
    (lambda () library-path)))

;;; (home-vicinity) should return the vicinity of the user's HOME
;;; directory, the directory which typically contains files which
;;; customize a computer environment for a user.

(define home-vicinity
  (let ((home-path (getenv "HOME")))
    (lambda () home-path)))

;;; *features* should be set to a list of symbols describing features
;;; of this implementation.  See Template.scm for the list of feature
;;; names.

(define *features*
      '(
	source				;can load scheme source files
					;(slib:load-source "filename")
	compiled			;can load compiled files
					;(slib:load-compiled "filename")

		       ;; Scheme report features

	rev5-report			;conforms to
	eval				;R5RS two-argument eval
	values				;R5RS multiple values
	dynamic-wind			;R5RS dynamic-wind
	macro				;R5RS high level macros
	delay				;has DELAY and FORCE
	multiarg-apply			;APPLY can take more than 2 args.
	char-ready?
	rationalize
	rev4-optional-procedures	;LIST-TAIL, STRING->LIST,
					;LIST->STRING, STRING-COPY,
					;STRING-FILL!, LIST->VECTOR,
					;VECTOR->LIST, and VECTOR-FILL!

	rev4-report			;conforms to

	ieee-p1178			;conforms to

;	rev3-report			;conforms to

	rev2-procedures			;SUBSTRING-MOVE-LEFT!,
					;SUBSTRING-MOVE-RIGHT!,
					;SUBSTRING-FILL!,
					;STRING-NULL?, APPEND!, 1+,
					;-1+, <?, <=?, =?, >?, >=?
	object-hash			;has OBJECT-HASH

	multiarg/and-			;/ and - can take more than 2 args.
	with-file			;has WITH-INPUT-FROM-FILE and
					;WITH-OUTPUT-FROM-FILE
	transcript			;TRANSCRIPT-ON and TRANSCRIPT-OFF
	ieee-floating-point		;conforms to IEEE Standard 754-1985
					;IEEE Standard for Binary
					;Floating-Point Arithmetic.
	full-continuation		;can return multiple times

			;; Other common features

;	srfi				;srfi-0, COND-EXPAND finds all srfi-*
	sicp				;runs code from Structure and
					;Interpretation of Computer
					;Programs by Abelson and Sussman.
	defmacro			;has Common Lisp DEFMACRO
	record				;has user defined data structures
	string-port			;has CALL-WITH-INPUT-STRING and
					;CALL-WITH-OUTPUT-STRING
;	sort
	pretty-print
	object->string
;	format				;Common-lisp output formatting
	trace				;has macros: TRACE and UNTRACE
	compiler			;has (COMPILER)
;	ed				;(ED) is editor
	system				;posix (system <string>)
	getenv				;posix (getenv <string>)
;	program-arguments		;returns list of strings (argv)
	current-time			;returns time in seconds since 1/1/1970

		  ;; Implementation Specific features

	queue
	Xwindows
	))

(define current-time current-file-time)
(define difftime -)
(define offset-time +)

;;; (OUTPUT-PORT-WIDTH <port>)
(define output-port-width output-port/x-size)

;;; (OUTPUT-PORT-HEIGHT <port>)
(define (output-port-height . arg) 24)

;;; (CURRENT-ERROR-PORT)
(define current-error-port
  (let ((port console-output-port))
    (lambda () port)))

;;; (TMPNAM) makes a temporary file name.
(define tmpnam
  (let ((cntr 100))
    (lambda () (set! cntr (+ 1 cntr))
	    (let ((tmp (string-append "slib_" (number->string cntr))))
	      (if (file-exists? tmp) (tmpnam) tmp)))))

;;; FORCE-OUTPUT flushes any pending output on optional arg output port.
(define force-output flush-output)
;;; MITScheme 7.2 is missing flush-output.  Use this instead
;(define (force-output . arg) #t)

;;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string
;;; port versions of CALL-WITH-*PUT-FILE.
(define (call-with-output-string proc)
  (let ((co (current-output-port)))
    (with-output-to-string
      (lambda ()
	(let ((port (current-output-port)))
	  (with-output-to-port co
	    (lambda () (proc port))))))))

(define (call-with-input-string string proc)
  (let ((ci (current-input-port)))
    (with-input-from-string string
      (lambda ()
	(let ((port (current-input-port)))
	  (with-input-from-port ci
	    (lambda () (proc port))))))))

(define object->string write-to-string)
(define object->limited-string write-to-string)

;;; "rationalize" adjunct procedures.
(define (find-ratio x e)
  (let ((rat (rationalize x e)))
    (list (numerator rat) (denominator rat))))
(define (find-ratio-between x y)
  (find-ratio (/ (+ x y) 2) (/ (- x y) 2)))

;;; CHAR-CODE-LIMIT is one greater than the largest integer which can
;;; be returned by CHAR->INTEGER.  It is defined incorrectly (65536)
;;; by MITScheme version 8.0.
(define char-code-limit 256)

;;; MOST-POSITIVE-FIXNUM is used in modular.scm
(define most-positive-fixnum #x03FFFFFF)

;;; Return argument
(define (identity x) x)

;;; SLIB:EVAL is single argument eval using the top-level (user) environment.
;(define (slib:eval form) (eval form (repl/environment (nearest-repl))))
(define (slib:eval form) (eval form user-initial-environment))

(define *macros* '(defmacro))
(define (defmacro? m) (and (memq m *macros*) #t))

(syntax-table-define system-global-syntax-table 'defmacro
  (macro defmacargs
    (let ((macname (car defmacargs)) (macargs (cadr defmacargs))
				     (macbdy (cddr defmacargs)))
      `(begin
	 (set! *macros* (cons ',macname *macros*))
	 (syntax-table-define system-global-syntax-table ',macname
	   (macro ,macargs ,@macbdy))))))

(define (macroexpand-1 e)
  (if (pair? e) (let ((a (car e)))
		  (if (and (symbol? a) (defmacro? a))
		      (apply (syntax-table-ref system-global-syntax-table a)
			     (cdr e))
		      e))
      e))

(define (macroexpand e)
  (if (pair? e) (let ((a (car e)))
		  (if (and (symbol? a) (defmacro? a))
		      (macroexpand
		       (apply (syntax-table-ref system-global-syntax-table a)
			      (cdr e)))
		      e))
      e))

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

(define defmacro:eval slib:eval)
(define defmacro:load load)
;;; If your implementation provides R4RS macros:
;(define macro:eval slib:eval)
;(define macro:load load)

(define (slib:eval-load <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)))))

(define record-modifier record-updater)	;some versions need this?

(define slib:warn
  (lambda args
    (let ((cep (current-error-port)))
      (if (provided? 'trace) (print-call-stack cep))
      (display "Warn: " cep)
      (for-each (lambda (x) (display x cep)) args))))

;; define an error procedure for the library
(define (slib:error . args)
  (if (provided? 'trace) (print-call-stack (current-error-port)))
  (apply error-procedure (append args (list (the-environment)))))

;; define these as appropriate for your system.
(define slib:tab (integer->char 9))
(define slib:form-feed (integer->char 12))

(define in-vicinity string-append)

;;; Define SLIB:EXIT to be the implementation procedure to exit or
;;; return if exitting not supported.
(define slib:exit
  (lambda args
    (cond ((null? args) (exit))
	  ((eqv? #t (car args)) (exit))
	  ((and (number? (car args)) (integer? (car args))) (exit (car args)))
	  (else (exit 1)))))

;;; Here for backward compatability

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

;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever
;;; suffix all the module files in SLIB have.  See feature 'SOURCE.

(define slib:load-source load)

;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced
;;; by compiling "foo.scm" if this implementation can compile files.
;;; See feature 'COMPILED.

(define slib:load-compiled load)

;;; At this point SLIB:LOAD must be able to load SLIB files.

(define slib:load slib:load-source)

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