Import Upstream version 2a6upstream/2a6

1 files changed, 266 insertions, 0 deletions

diff --git a/chez.init b/chez.init
new file mode 100644
index 0000000..a91cce3
--- /dev/null
+++ b/chez.init
@@ -0,0 +1,266 @@
+;"chez.init" Initialization file for SLIB for Chez Scheme	-*-scheme-*-
+; Copyright (C) 1993 dorai@cs.rice.edu (Dorai Sitaram)
+; Copyright (C) 1991, 1992, 1993 Aubrey Jaffer.
+;
+;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.
+
+;;; (software-type) should be set to the generic operating system type.
+;;; UNIX, VMS, MACOS, AMIGA and MS-DOS are supported.
+
+(define (software-type) 'UNIX)
+
+(define (scheme-implementation-type) 'Chez)
+
+;;; (scheme-implementation-version) should return a string describing
+;;; the version the scheme implementation loading this file.
+
+(define (scheme-implementation-version) "?")
+
+(define implementation-vicinity
+  (lambda () "/usr/local/lib/scheme/"))
+
+;; library-vicinity is moved below the defination of getenv
+
+(define *features*
+  '(
+    source				;can load scheme source files
+					;(slib:load-source "filename")
+    compiled				;can load compiled files
+					;(slib:load-compiled "filename")
+    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
+    system
+    transcript
+    with-file
+    string-port
+    ))
+
+;R4RS define-syntax in terms of Chez's extend-syntax.
+;Caveat: no let-syntax
+
+(extend-syntax (define-syntax syntax-rules)
+  ((define-syntax name (syntax-rules kwds . clauses))
+   (extend-syntax (name . kwds) . clauses)))
+
+;DEFINED?
+(define-syntax defined?
+  (syntax-rules ()
+    ((defined? x) (or (bound? 'x) (get 'x '*expander*)))))
+
+;Chez's sort routines have the opposite parameter order to Slib's
+(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)))
+
+;RENAME-FILE
+(define rename-file
+  (lambda (src dst)
+    (system (string-append "mv " src " " dst))))
+
+;OUTPUT-PORT-WIDTH
+(define output-port-width (lambda arg 79))
+
+;;; (OUTPUT-PORT-HEIGHT <port>)
+(define (output-port-height . arg) 24)
+
+;;; (CURRENT-ERROR-PORT)
+(define current-error-port
+  (let ((port (current-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)))))
+
+;GETENV
+(provide-foreign-entries '("getenv"))
+(define getenv
+  (foreign-procedure "getenv"
+    (string) string))
+
+(define library-vicinity
+  (let ((library-path (or (getenv "SCHEME_LIBRARY_PATH")
+			  "/usr/local/lib/slib/")))
+    (lambda () library-path)))
+
+;FORCE-OUTPUT
+(define force-output flush-output)
+
+;;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string
+;;; port versions of CALL-WITH-*PUT-FILE.
+(define (call-with-output-string f)
+  (let ((outsp (open-output-string)))
+    (f outsp)
+    (let ((s (get-output-string outsp)))
+      (close-output-port outsp)
+      s)))
+
+(define (call-with-input-string s f)
+  (let* ((insp (open-input-string s))
+	 (res (f insp)))
+    (close-input-port insp)
+    res))
+
+;CHAR-CODE-LIMIT
+(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)))
+
+;;; Return argument
+(define (identity x) x)
+
+(define slib:eval eval)
+
+(define-macro! defmacro z `(define-macro! ,@z))
+
+(define (defmacro? m) (get m '*expander*))
+
+(define macroexpand-1 eps-expand-once)
+
+(define (macroexpand e)
+  (if (pair? e) (let ((a (car e)))
+		  (if (and (symbol? a) (getprop a '*expander*))
+		      (macroexpand (expand-once 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 macro: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)))))
+
+;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))))))
+
+(define slib:error
+  (lambda args
+    (let ((port (current-error-port)))
+      (display "Error: " port)
+      (for-each (lambda (x) (display x port)) args)
+      (error #f ""))))
+
+(define slib:tab #\tab)
+(define slib:form-feed #\page)
+
+;Chez's nil variable is bound to '() rather than #f
+
+(define nil #f)
+
+(define in-vicinity string-append)
+
+;;; Define SLIB:EXIT to be the implementation procedure to exit or
+;;; return if exitting not supported.
+(define slib:chez:quit
+  (let ([arg (call-with-current-continuation (lambda (x) x))])
+    (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)))))
+
+;;; Here for backward compatability
+;Note however that ".ss" is a common Chez file suffix
+(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) (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)
+
+;;; (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"))
+;end chez.init