;;; "pscheme.init" SLIB init file for Pocket Scheme	-*-scheme-*-
;;; Author: Ben Goetter <goetter@mazama.net>
;;;   last revised for 1.1.0 on 16 October 2000
;;; Initial work for 0.2.3 by Robert Goldman (goldman@htc.honeywell.com)
;;; SLIB orig Author: Aubrey Jaffer (jaffer@ai.mit.edu)
;;;
;;; This code is in the public domain.

; best fit for Windows CE?
(define (software-type) 'MS-DOS)

(define (scheme-implementation-type) 'Pocket-Scheme)
(define (scheme-implementation-version)
  (let ((v (version)))
    (string-append
      (number->string (car v)) "."
      (number->string (cadr v)) "."
      (number->string (caddr v)))))
(define (scheme-implementation-home-page) "http://www.mazama.net/scheme/pscheme.htm")


(define in-vicinity string-append)

(define (implementation-vicinity) "\\Program Files\\Pocket Scheme\\")
(define (library-vicinity) (in-vicinity (implementation-vicinity) "slib\\"))
(define (home-vicinity)	"\\My Documents\\")

;(define (implementation-vicinity) "D:\\SRC\\PSCHEME\\BUILD\\TARGET\\X86\\NT\\DBG\\")
;(define (library-vicinity) "D:\\SRC\\SLIB\\")
;(define (home-vicinity) "D:\\SRC\\PSCHEME\\")

(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
; Undef this to get the SLIB TRACE macros
;	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

	))

;;; (OUTPUT-PORT-WIDTH <port>)
;;; (OUTPUT-PORT-HEIGHT <port>)
;; $BUGBUG completely bogus values.
(define (output-port-width . arg) 79)
(define (output-port-height . arg) 12)

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

;;; (FILE-EXISTS? <string>)
(define (file-exists? f)
 (with-handlers (((lambda (x) #t) (lambda (x) #f)))
  (close-input-port (open-input-file f))
  #t))

;; pscheme: current-error-port, delete-file, force-output already defined

;;; CHAR-CODE-LIMIT is one greater than the largest integer which can
;;; be returned by CHAR->INTEGER.
;(define char-code-limit
; (with-handlers (
;  ((lambda (x) #t) (lambda (x) 256))
;                )
;  (integer->char 65535)
;  65536))
;;; Currently there are only three clients of this symbol.
;;; Following observations relate to PScheme 0.3.5, JACAL 1a9, SLIB 2c5.
;;; JACAL: crashes when set to 65536.
;;; make-crc: extremely inefficient when set to 65536, spending forever in init
;;; precedence-parse: ignores any setting in excess of 256
;;; So we patch it to 256.
(define char-code-limit 256)

;;; MOST-POSITIVE-FIXNUM is used in modular.scm
;;; This is the most positive immediate-value fixnum in PScheme.
(define most-positive-fixnum #x07FFFFFF)

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

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

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

; Define defmacro in terms of our define-macro
(define-macro (defmacro name args . body)
 `(define-macro (,name ,@args) ,@body))

; following defns removed in 0.6.3 while I rethink macro support
;(define defmacro? macro?)
;(define macroexpand expand-macro)
;(define macroexpand-1 expand-macro-1)

(define gentemp gensym)

(define base:eval slib:eval)
(define defmacro:eval slib:eval)

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

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

;;; Define an error procedure for the library
(define slib:error error)

;;; As announced by feature string-port
(define (call-with-output-string t)
 (let* ((p (open-output-string))
        (r (t p))
        (s (get-output-string p)))
  (close-output-port p)
  s))

(define (call-with-input-string s t)
 (let* ((p (open-input-string s))
        (r (t p)))
  (close-input-port p)
  r))

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

;;; Support for older versions of Scheme.  Not enough code for its own file.
(define (last-pair l) (if (pair? (cdr l)) (last-pair (cdr l)) l))
(define t #t)
(define nil #f)

;;; Define these if your implementation's syntax can support it and if
;;; they are not already defined.

(define (1+ n) (+ n 1))
(define (-1+ n) (+ n -1))
(define 1- -1+)

;;; Define SLIB:EXIT to be the implementation procedure to exit or
;;; return if exitting not supported.
(define slib:exit exit)

;;; Here for backward compatability
(define scheme-file-suffix
  (let ((suffix (case (software-type)
		  ((NOSVE) "_scm")
		  (else ".scm"))))
    (lambda () suffix)))

;;; (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 f)
 (if (not (file-exists? f))
  (set! f (string-append f (scheme-file-suffix))))
 (load f))

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

;;; Pscheme and SLIB both define REQUIRE, so dispatch on argument type.
;;; The SLIB REQUIRE does accept strings, though this facility seems never to be used.
(define pscheme:require require)
(slib:load (in-vicinity (library-vicinity) "require"))
(define slib:require require)
(define (require x)
 (if (string? x) (pscheme:require x) (slib:require x)))