Import Upstream version 2c7upstream/2c7

1 files changed, 202 insertions, 0 deletions

diff --git a/pscheme.init b/pscheme.init
new file mode 100644
index 0000000..dfa05a8
--- /dev/null
+++ b/pscheme.init
@@ -0,0 +1,202 @@
+;;; "pscheme.init" -*-scheme-*-

+;;; SLIB init file for Pocket Scheme

+;;; SLIB orig Author: Aubrey Jaffer (jaffer@ai.mit.edu)

+;;; Author: Ben Goetter <goetter@angrygraycat.com>

+;;; Initial work for 0.2.3 by Robert Goldman (goldman@htc.honeywell.com)

+;;;

+;;; This code is in the public domain.

+

+; best fit for Windows CE?

+(define (software-type) 'MS-DOS)

+

+(define (scheme-implementation-type) 'PocketScheme)

+(define (scheme-implementation-version) "0.3.6")

+

+(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 *features*

+  '(source

+    rev4-report

+    ieee-p1178

+    rev4-optional-procedures

+    multiarg/and-

+    multiarg-apply

+    with-file

+    char-ready?

+    defmacro

+    delay

+    eval

+    dynamic-wind

+    full-continuation

+    ;;trace				; Comment out for SLIB TRACE macros

+    system

+    string-port

+    ))

+

+;;; (OUTPUT-PORT-WIDTH <port>)

+(define (output-port-width . arg) 79)

+

+;;; (OUTPUT-PORT-HEIGHT <port>)

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

+  (let ((file #f))

+    (with-handlers (((lambda (x) #t) (lambda (x) #f)))

+		   (set! file (open-input-file f))

+		   (close-input-port file)

+		   #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.

+;;; The secondary representation extends fixnum values to 0xffffffff.

+(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 gentemp

+  (let ((*gensym-counter* -1))

+    (lambda ()

+      (set! *gensym-counter* (+ *gensym-counter* 1))

+      (string->symbol

+       (string-append "slib:G" (number->string *gensym-counter*))))))

+

+(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 . k)

+  (error 

+   (cond

+    ((= (length k) 0) '())

+    ((= (length k) 1) (car k))

+    ((provided? 'string-port)

+     (call-with-output-string

+      (lambda (out)

+	(let ((add-space #f))

+	  (map

+	   (lambda (arg)

+	     (if add-space (write-char #\space out) (set! add-space #t))

+	     (display arg out))

+	   k)))))

+    (else (car k)))))

+

+;;; For the benefit of slib:error above, 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) ".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 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)

+

+;;; Hold onto pscheme native version

+(define pscheme:require require)

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