summaryrefslogtreecommitdiffstats
path: root/chez.init
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:26 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:26 -0800
commitf24b9140d6f74804d5599ec225717d38ca443813 (patch)
tree0da952f1a5a7c0eacfc05c296766523e32c05fe2 /chez.init
parent8ffbc2df0fde83082610149d24e594c1cd879f4a (diff)
downloadslib-f24b9140d6f74804d5599ec225717d38ca443813.tar.gz
slib-f24b9140d6f74804d5599ec225717d38ca443813.zip
Import Upstream version 2c0upstream/2c0
Diffstat (limited to 'chez.init')
-rw-r--r--chez.init453
1 files changed, 291 insertions, 162 deletions
diff --git a/chez.init b/chez.init
index a91cce3..b158304 100644
--- a/chez.init
+++ b/chez.init
@@ -1,6 +1,7 @@
-;"chez.init" Initialization file for SLIB for Chez Scheme -*-scheme-*-
+;"chez.init" Initialization file for SLIB for Chez Scheme 5.0c -*-scheme-*-
; Copyright (C) 1993 dorai@cs.rice.edu (Dorai Sitaram)
-; Copyright (C) 1991, 1992, 1993 Aubrey Jaffer.
+; Copyright (C) 1991, 1992, 1993, 1994, 1997 Aubrey Jaffer.
+; Adapted to version 5.0c by stone@math.grin.edu (John David Stone) 1997
;
;Permission to copy this software, to redistribute it, and to use it
;for any purpose is granted, subject to the following restrictions and
@@ -18,68 +19,180 @@
;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.
+;; The SOFTWARE-TYPE procedure returns a symbol indicating the generic
+;; operating system type. UNIX, VMS, MACOS, AMIGA and MS-DOS are
+;; supported.
-(define (software-type) 'UNIX)
+(define software-type
+ (lambda () 'unix))
-(define (scheme-implementation-type) 'Chez)
+;; The SCHEME-IMPLEMENTATION-TYPE procedure returns a symbol denoting the
+;; Scheme implementation that loads this file.
-;;; (scheme-implementation-version) should return a string describing
-;;; the version the scheme implementation loading this file.
+(define scheme-implementation-type
+ (lambda () 'chez))
-(define (scheme-implementation-version) "?")
+;; The SCHEME-IMPLEMENTATION-VERSION procedure returns a string describing
+;; the version of the Scheme implementation that loads this file.
+
+(define scheme-implementation-version
+ (lambda () "5.0c"))
+
+;; The IMPLEMENTATION-VICINITY procedure returns a string giving the
+;; pathname of the directory that includes any auxiliary files used by this
+;; Scheme implementation.
(define implementation-vicinity
- (lambda () "/usr/local/lib/scheme/"))
+ (lambda () "/usr/local/chez/5.0c/"))
+
+;; The GETENV returns the value of a shell environment variable.
+
+;; In some implementations of Chez Scheme, this can be done with foreign
+;; procedures. However, I [JDS] am using the HP version, which does not
+;; support them, so a different approach is needed.
+;;
+;; Here's the version that doesn't work on HPs:
+;;
+;; (provide-foreign-entries '("getenv"))
+;;
+;; (define getenv
+;; (foreign-procedure "getenv"
+;; (string) string))
+;;
+;; And here's a version that parses the value out of the output of the
+;; /bin/env command:
+
+(define getenv
+ (lambda (env-var)
+ (let ((env-port (car (process "exec /bin/env")))
+ (read-line
+ (lambda (source)
+ (let ((next (peek-char source)))
+ (if (eof-object? next)
+ next
+ (let loop ((ch (read-char source))
+ (so-far '()))
+ (if (or (eof-object? ch)
+ (char=? ch #\newline))
+ (apply string (reverse so-far))
+ (loop (read-char source) (cons ch so-far))))))))
+ (position-of-copula
+ (lambda (str)
+ (let ((len (string-length str)))
+ (do ((position 0 (+ position 1)))
+ ((or (= position len)
+ (char=? (string-ref str position) #\=))
+ position))))))
+ (let loop ((equation (read-line env-port)))
+ (if (eof-object? equation)
+ #f
+ (let ((break (position-of-copula equation))
+ (len (string-length equation)))
+ (if (string=? (substring equation 0 break) env-var)
+ (if (= break len)
+ ""
+ (substring equation (+ break 1) len))
+ (loop (read-line env-port)))))))))
+
+;; The LIBRARY-VICINITY procedure returns the pathname of the directory
+;; where Scheme library functions reside.
+
+(define library-vicinity
+ (let ((library-path (or (getenv "SCHEME_LIBRARY_PATH")
+ "/usr/local/lib/slib/")))
+ (lambda () library-path)))
-;; library-vicinity is moved below the defination of getenv
+;;; (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)))
+
+;; The OUTPUT-PORT-WIDTH procedure returns the number of graphic characters
+;; that can reliably be displayed on one line of the standard output port.
+
+(define output-port-width
+ (lambda arg
+ (let ((env-width-string (getenv "COLUMNS")))
+ (if (and env-width-string
+ (let loop ((remaining (string-length env-width-string)))
+ (or (zero? remaining)
+ (let ((next (- remaining 1)))
+ (and (char-numeric? (string-ref env-width-string
+ next))
+ (loop next))))))
+ (- (string->number env-width-string) 1)
+ 79))))
+
+;; The OUTPUT-PORT-HEIGHT procedure returns the number of lines of text
+;; that can reliably be displayed simultaneously in the standard output
+;; port.
+
+(define output-port-height
+ (lambda arg
+ (let ((env-height-string (getenv "LINES")))
+ (if (and env-height-string
+ (let loop ((remaining (string-length env-height-string)))
+ (or (zero? remaining)
+ (let ((next (- remaining 1)))
+ (and (char-numeric? (string-ref env-height-string
+ next))
+ (loop next))))))
+ (string->number env-height-string)
+ 24))))
+
+;; *FEATURES* is a list of symbols describing features of this
+;; implementation; SLIB procedures sometimes consult this list to figure
+;; out whether to attempt some incompletely standard operation.
(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
+ '(source ; Chez Scheme can load Scheme source files, with the
+ ; command (slib:load-source "filename") -- see below.
+
+ compiled ; Chez Scheme can also load compiled Scheme files, with the
+ ; command (slib:load-compiled "filename") -- see below.
+
+ char-ready? delay dynamic-wind eval 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 string-port system transcript values with-file))
+
+;; Version 5.0c has R4RS macros, but not defmacro.
+
+(define *defmacros*
+ (list (cons 'defmacro
+ (lambda (name parms . body)
+ `(set! *defmacros* (cons (cons ',name (lambda ,parms ,@body))
+ *defmacros*))))))
+(define (defmacro? m) (and (assq m *defmacros*) #t))
+
+(define (macroexpand-1 e)
+ (if (pair? e) (let ((a (car e)))
+ (cond ((symbol? a) (set! a (assq a *defmacros*))
+ (if a (apply (cdr a) (cdr e)) e))
+ (else e)))
+ e))
+
+(define (macroexpand e)
+ (if (pair? e) (let ((a (car e)))
+ (cond ((symbol? a)
+ (set! a (assq a *defmacros*))
+ (if a (macroexpand (apply (cdr a) (cdr e))) e))
+ (else e)))
+ e))
+
+(define base:eval eval)
+(define (defmacro:eval x) (base:eval (defmacro:expand* x)))
+(define (defmacro:expand* x)
+ (require 'defmacroexpand) (apply defmacro:expand* x '()))
+
+;; Chez's sorting routines take parameters in the order opposite to SLIB's.
+;; The following definitions override the predefined procedures with the
+;; parameters-reversed versions.
+
(define chez:sort sort)
(define chez:sort! sort!)
(define chez:merge merge)
@@ -98,82 +211,106 @@
(lambda (s1 s2 p)
(chez:merge! p s1 s2)))
-;RENAME-FILE
+;; 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))))))
+
+;; Chez's NIL variable is bound to '(); SLIB's is bound to #F.
+
+(define nil #f)
+
+;; SLIB provides identifiers for the TAB (ASCII 9) and FORM-FEED (ASCII 12)
+;; characters.
+
+(define slib:tab #\tab)
+(define slib:form-feed #\page)
+
+;; The following definitions implement a few widely useful procedures that
+;; Chez Scheme does not provide or provides under a different name.
+
+;; The RENAME-FILE procedure constructs and executes a Unix mv command to
+;; change the name of a file.
+
(define rename-file
(lambda (src dst)
(system (string-append "mv " src " " dst))))
-;OUTPUT-PORT-WIDTH
-(define output-port-width (lambda arg 79))
+;; The CURRENT-ERROR-PORT procedure returns a port to which error
+;; messages are to be displayed; this is the original standard output
+;; port (even if the program subsequently changes the current output port
+;; somehow).
-;;; (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.
+;; SLIB provides its own version of the ERROR procedure.
+
+(define slib:error
+ (lambda args
+ (let ((port (current-error-port)))
+ (display "Error: " port)
+ (for-each (lambda (x) (display x port)) args)
+ (error #f ""))))
+
+;; The TMPNAM procedure constructs and returns a temporary file name,
+;; presumably unique and not a duplicate of one already existing.
+
(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))
+ (lambda ()
+ (set! cntr (+ 1 cntr))
+ (let ((tmp (string-append "slib_" (number->string cntr))))
+ (if (file-exists? tmp) (tmpnam) tmp)))))
-(define library-vicinity
- (let ((library-path (or (getenv "SCHEME_LIBRARY_PATH")
- "/usr/local/lib/slib/")))
- (lambda () library-path)))
+;; The FORCE-OUTPUT requires buffered output that has been written to a
+;; port to be transferred all the way out to its ultimate destination.
-;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)
+;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string
+;; port versions of CALL-WITH-INPUT-FILE and CALL-WITH-OUTPUT-FILE.
-;Chez's MOST-POSITIVE-FIXNUM is a thunk rather than a number
-(if (procedure? most-positive-fixnum)
- (set! most-positive-fixnum (most-positive-fixnum)))
+(define call-with-output-string
+ (lambda (f)
+ (let ((outsp (open-output-string)))
+ (f outsp)
+ (let ((s (get-output-string outsp)))
+ (close-output-port outsp)
+ s))))
-;;; Return argument
-(define (identity x) x)
+(define call-with-input-string
+ (lambda (s f)
+ (let* ((insp (open-input-string s))
+ (res (f insp)))
+ (close-input-port insp)
+ res)))
-(define slib:eval eval)
+;; CHAR-CODE-LIMIT is the number of characters in the character set; only
+;; non-negative integers less than CHAR-CODE-LIMIT are eligible as
+;; arguments to INTEGER->CHAR.
+
+(define char-code-limit 256)
+
+;; Chez's MOST-POSITIVE-FIXNUM is a thunk rather than a number.
-(define-macro! defmacro z `(define-macro! ,@z))
+(if (procedure? most-positive-fixnum)
+ (set! most-positive-fixnum (most-positive-fixnum)))
-(define (defmacro? m) (get m '*expander*))
+;; The IDENTITY procedure returns its argument without change.
-(define macroexpand-1 eps-expand-once)
+(define identity
+ (lambda (x) x))
-(define (macroexpand e)
- (if (pair? e) (let ((a (car e)))
- (if (and (symbol? a) (getprop a '*expander*))
- (macroexpand (expand-once e))
- e))
- e))
+;; The GENTEMP procedure generates unused symbols and marks them as
+;; belonging to the SLIB package.
(define gentemp
(let ((*gensym-counter* -1))
@@ -182,54 +319,45 @@
(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)
+;; The IN-VICINITY procedure is simply STRING-APPEND, conventionally used
+;; to attach a directory pathname to the name of a file that is expected to
+;; be in that directory.
-(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 in-vicinity string-append)
-(define slib:error
- (lambda args
- (let ((port (current-error-port)))
- (display "Error: " port)
- (for-each (lambda (x) (display x port)) args)
- (error #f ""))))
+;; For backward compatability, the SCHEME-FILE-SUFFIX procedure is defined
+;; to return the string ".scm". Note, however, that ".ss" is a common Chez
+;; file suffix.
-(define slib:tab #\tab)
-(define slib:form-feed #\page)
+(define scheme-file-suffix
+ (lambda () ".scm"))
-;Chez's nil variable is bound to '() rather than #f
+;; SLIB appropriates Chez Scheme's EVAL procedure.
-(define nil #f)
+(define slib:eval eval)
+(define macro:eval slib:eval)
-(define in-vicinity string-append)
+(define slib:eval-load
+ (lambda (<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))))))
+
+;; SLIB:EXIT is the implementation procedure that exits, or returns
+;; if exiting is not supported.
-;;; 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)])))
+ (let ((arg (call-with-current-continuation identity)))
+ (cond ((procedure? arg) arg)
+ (arg (exit))
+ (else (exit 1)))))
(define slib:exit
(lambda args
@@ -239,28 +367,29 @@
((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")
+;; The SLIB:LOAD-SOURCE procedure, given a string argument, should attach
+;; the appropriate file suffix to the string and load the file named
+;; by the resulting string.
-;;; (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
+ (lambda (f)
+ (load (string-append f (scheme-file-suffix)))))
-(define (slib:load-source f) (load (string-append f (scheme-file-suffix))))
+;;; defmacro:load and macro:load also need the default 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.
+;; The SLIB:LOAD-COMPILED procedure, given a string argument, finds and
+;; loads the file, assumed to have been compiled.
(define slib:load-compiled load)
-;;; At this point SLIB:LOAD must be able to load SLIB files.
+;; SLIB:LOAD can now be defined to load SLIB files.
(define slib:load slib:load-source)
+;; Load the REQUIRE package.
+
(slib:load (in-vicinity (library-vicinity) "require"))
-;end chez.init
+
+;; end of chez.init