guile/module/slib/pscheme.init

;;; "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
	rev4-report
	ieee-p1178
	rev4-optional-procedures
	multiarg/and-
	multiarg-apply
	with-file
	char-ready?
	defmacro
        rationalize
	delay
	eval
	dynamic-wind
	full-continuation
; Undef this to get the SLIB TRACE macros
;	trace
	system
        string-port
	))


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