diff options
Diffstat (limited to 'chez.init')
| -rw-r--r-- | chez.init | 453 |
1 files changed, 291 insertions, 162 deletions
@@ -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 |