diff options
Diffstat (limited to 'mzscheme.init')
| -rw-r--r-- | mzscheme.init | 431 |
1 files changed, 431 insertions, 0 deletions
diff --git a/mzscheme.init b/mzscheme.init new file mode 100644 index 0000000..db6b3b9 --- /dev/null +++ b/mzscheme.init @@ -0,0 +1,431 @@ +;;;"mzscheme.init" Initialization for SLIB for mzscheme -*-scheme-*- +;;; This code is in the public domain. + +;;@ (software-type) should be set to the generic operating system type. +;;; unix, vms, macos, amiga and ms-dos are supported. +(define (software-type) + (case (system-type) + [(unix macosx) 'unix] + [(windows) 'ms-dos] + [(macos) 'macos] + [else (system-type)])) + +;;@ (scheme-implementation-type) should return the name of the scheme +;;; implementation loading this file. +(define (scheme-implementation-type) '|MzScheme|) + +;;@ (scheme-implementation-home-page) should return a (string) URI +;;; (Uniform Resource Identifier) for this scheme implementation's home +;;; page; or false if there isn't one. +(define (scheme-implementation-home-page) "http://www.plt-scheme.org/") + +;;@ (scheme-implementation-version) should return a string describing +;;; the version the scheme implementation loading this file. +(define scheme-implementation-version version) + +;;@ (implementation-vicinity) should be defined to be the pathname of +;;; the directory where any auxillary files to your Scheme +;;; implementation reside. +(define implementation-vicinity + (let ([path + (or (getenv "MZSCHEME_IMPLEMENTATION_PATH") + (getenv "PLTHOME") + (with-handlers ([void (lambda (x) #f)]) + (let ([p (collection-path "mzlib")]) + (let*-values ([(base name dir?) (split-path p)] + [(base name dir?) (split-path base)]) + (and (path? base) (path->string base))))) + (case (system-type) + ((unix macosx) "/usr/local/lib/plt") + ((windows) "C:\\Program Files\\PLT") + ((macos) "My Disk:plt:")))]) + (lambda () path))) + +;;@ (library-vicinity) should be defined to be the pathname of the +;;; directory where files of Scheme library functions reside. +(define library-vicinity + (let ((library-path + (or + ;; Use this getenv if your implementation supports it. + (getenv "SCHEME_LIBRARY_PATH") + ;; Try an slib collection first + (with-handlers ([void (lambda (x) #f)]) + (path->string (collection-path "slib"))) + ;; look for slib in a few common places + (ormap (lambda (dir) + (and (directory-exists? dir) dir)) + '("/usr/local/lib/slib/" + "/usr/share/slib/" + ;; this is for RH/Fedora that uses umb-scheme for slib + ;;"/usr/share/umb-scheme/slib" + )) + (error 'slib-init + "can't find SCHEME_LIBRARY_PATH environment variable, \"slib\" collection, or a system slib directory")))) + (lambda () library-path))) + +;;@ (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) + (path->string (find-system-path 'home-dir))) +;@ +(define in-vicinity + (lambda args + (path->string + (let loop ([args args]) + (cond + [(null? (cdr args)) (car args)] + [(string=? "" (car args)) (loop (cdr args))] + [else (let ([v (loop (cdr args))]) + (build-path (car args) v))]))))) +;@ +(define (user-vicinity) + (path->string (build-path 'same))) +;@ +(define vicinity:suffix? + (let ((suffi + (case (software-type) + ((amiga) '(#\: #\/)) + ((macos thinkc) '(#\:)) + ((ms-dos windows atarist os/2) '(#\\ #\/)) + ((nosve) '(#\: #\.)) + ((unix coherent plan9) '(#\/)) + ((vms) '(#\: #\])) + (else + (slib:warn "require.scm" 'unknown 'software-type (software-type)) + "/")))) + (lambda (chr) (and (memv chr suffi) #t)))) +;@ +(define (pathname->vicinity pathname) + (let loop ((i (- (string-length pathname) 1))) + (cond ((negative? i) "") + ((vicinity:suffix? (string-ref pathname i)) + (substring pathname 0 (+ i 1))) + (else (loop (- i 1)))))) +;@ +(define (program-vicinity) + (path->string + (or (current-load-relative-directory) + (current-directory)))) +;@ +(define sub-vicinity + (lambda (vic name) + (path->string (build-path vic name)))) +;@ +(define (make-vicinity <pathname>) <pathname>) +;@ +(define with-load-pathname + (lambda (a thunk) (thunk))) + +;;; slib:features should be set to a list of symbols describing +;;; features of this implementation. Suggestions for features are: + +(define slib:features + '( + source ;can load scheme source files + ;(slib:load-source "filename") + compiled ;can load compiled files + ;(slib:load-compiled "filename") + rev4-report ;conforms to +;;; rev3-report ;conforms to +;;; ieee-p1178 ;conforms to +;;; srfi-0 ;srfi-0, COND-EXPAND finds all srfi-* +;;; sicp ;runs code from Structure and + ;Interpretation of Computer + ;Programs by Abelson and Sussman. + rev4-optional-procedures ;LIST-TAIL, STRING->LIST, + ;LIST->STRING, STRING-COPY, + ;STRING-FILL!, LIST->VECTOR, + ;VECTOR->LIST, and VECTOR-FILL! +;;; rev2-procedures ;SUBSTRING-MOVE-LEFT!, + ;SUBSTRING-MOVE-RIGHT!, + ;SUBSTRING-FILL!, + ;STRING-NULL?, APPEND!, 1+, + ;-1+, <?, <=?, =?, >?, >=? + multiarg/and- ;/ and - can take more than 2 args. + multiarg-apply ;APPLY can take more than 2 args. + rationalize + delay ;has DELAY and FORCE + with-file ;has WITH-INPUT-FROM-FILE and + ;WITH-OUTPUT-FROM-FILE + string-port ;has CALL-WITH-INPUT-STRING and + ;CALL-WITH-OUTPUT-STRING +;;; transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF + char-ready? + macro ;has R4RS high level macros + syntax-case ;has syntax-case macros + defmacro ;has Common Lisp DEFMACRO + eval ;SLIB:EVAL is single argument eval +;;; record ;has user defined data structures + values ;proposed multiple values + dynamic-wind ;proposed dynamic-wind + ieee-floating-point ;conforms to + full-continuation ;can return multiple times +;;; object-hash ;has OBJECT-HASH + +;;; sort +;;; queue ;queues + pretty-print +;;; object->string + format ;plt/collects/srfi/28.ss says in core +;;; trace ;has macros: TRACE and UNTRACE +;;; compiler ;has (COMPILER) +;;; ed ;(ED) is editor + system ;posix (system <string>) + getenv ;posix (getenv <string>) + program-arguments ;returns list of strings (argv) +;;; Xwindows ;X support +;;; curses ;screen management package +;;; termcap ;terminal description package +;;; terminfo ;sysV terminal description + fluid-let + srfi-59 + srfi-96 + vicinity + current-time ;returns time in seconds since 1/1/1970 + )) +;@ +(define (program-arguments) + (cons (symbol->string (scheme-implementation-type)) + (vector->list (current-command-line-arguments)))) + +(require (lib "pretty.ss")) +(unless (memq (system-type) '(unix beos)) + (namespace-require '(lib "date.ss"))) +;@ +(define current-time + ;; Gives time since 1/1/1970 ... + ;; ... GMT for Unix, Windows, and Mac OS X. + ;; ... local time for Mac OS. + (if (memq (system-type) '(unix macosx windows)) + current-seconds + (let ([zero (find-seconds 0 0 0 1 1 1970)]) + (lambda () + (- (current-seconds) zero))))) + +;;@ (OUTPUT-PORT-WIDTH <port>) +(define (output-port-width . arg) 79) + +;;@ (OUTPUT-PORT-HEIGHT <port>) +(define (output-port-height . arg) 24) + +;;; (CURRENT-ERROR-PORT) +;; Already in MzScheme + +;;@ (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>) +;; Already in MzScheme + +;;; (DELETE-FILE <string>) +;; Already in MzScheme + +;;@ FORCE-OUTPUT flushes any pending output on optional arg output port +;;; use this definition if your system doesn't have such a procedure. +(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-input-string + (lambda (string thunk) + (parameterize ((current-input-port (open-input-string string))) + (thunk (current-input-port))))) +(define call-with-output-string + (lambda (receiver) + (let ((sp (open-output-string))) + (receiver sp) + (get-output-string sp)))) + +;;; "rationalize" adjunct procedures. +(define (find-ratio x e) + (let ((rat (rationalize x e))) + (list (numerator rat) (denominator rat)))) +(define (find-ratio-between x y) + (find-ratio (/ (+ x y) 2) (/ (- x y) 2))) + +;;@ CHAR-CODE-LIMIT is one greater than the largest integer which can +;;; be returned by CHAR->INTEGER. +(define char-code-limit 256) + +;;@ MOST-POSITIVE-FIXNUM is used in modular.scm +(define most-positive-fixnum #x3FFFFFFF) ; 30 bits on 32-bit machines +; (define most-positive-fixnum #x3FFFFFFFFFFFFFFF) ; 62 bits on 64-bit machines + +;;@ Return argument +(define (identity x) x) + +;;@ SLIB:EVAL is single argument eval using the top-level (user) environment. +(define slib:eval eval) + +(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 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 x) (base:eval (defmacro:expand* x))) +(define (defmacro:expand* x) + (slib:require 'defmacroexpand) (apply defmacro:expand* x '())) +;@ +(define (defmacro:load <pathname>) + (slib:eval-load <pathname> defmacro:eval)) +;@ +(define slib:warn + (lambda args + (let ((cep (current-error-port))) + (if (provided? 'trace) (print-call-stack cep)) + (display "Warn: " cep) + (for-each (lambda (x) (display #\space cep) (write x cep)) args) + (newline cep)))) + +;;@ define an error procedure for the library +(define slib:error + (let ((error error)) + (lambda args + (let ((cep (current-error-port))) + (if (provided? 'trace) (print-call-stack cep)) + (apply error "Error:" args))))) +;@ +(define (make-exchanger obj) + (lambda (rep) (let ((old obj)) (set! obj rep) old))) +;@ +(define (open-file filename modes) + (case modes + ((r rb) (open-input-file filename)) + ((w wb) (open-output-file filename)) + (else (slib:error 'open-file 'mode? modes)))) +;;(define (port? obj) (or (input-port? obj) (output-port? obj))) +;@ +(define (call-with-open-ports . ports) + (define proc (car ports)) + (cond ((procedure? proc) (set! ports (cdr ports))) + (else (set! ports (reverse ports)) + (set! proc (car ports)) + (set! ports (reverse (cdr ports))))) + (let ((ans (apply proc ports))) + (for-each close-port ports) + ans)) +;@ +(define (close-port port) + (cond ((input-port? port) + (close-input-port port) + (if (output-port? port) (close-output-port port))) + ((output-port? port) (close-output-port port)) + (else (slib:error 'close-port 'port? port)))) +;@ +(define (browse-url url) + (define (try cmd end) (zero? (system (string-append cmd url end)))) + (or (try "netscape-remote -remote 'openURL(" ")'") + (try "netscape -remote 'openURL(" ")'") + (try "netscape '" "'&") + (try "netscape '" "'"))) + +;;@ 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+ add1) +(define -1+ sub1) +(define 1- -1+) + +;;@ Define SLIB:EXIT to be the implementation procedure to exit or +;;; return if exiting 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))) + +(define (ensure-path-string p) + (if (path? p) (path->string p) p)) + +;;@ (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 (ensure-path-string f) ".scm"))) + +;;@ (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 f) + (cond ((string? f) + (load (string-append (ensure-path-string f) ".zo"))) + ((and (pair? f) (eq? 'lib (car f))) + (eval `(require ,f))) + (slib:error 'slib:load-compiled 'bad 'argument f))) + +;;@ At this point SLIB:LOAD must be able to load SLIB files. +(define slib:load slib:load-source) + +;;; If your implementation provides R4RS macros: +(define macro:eval slib:eval) +(define macro:load slib:load-source) + +;;; If your implementation provides syntax-case macros: +(define syncase:eval slib:eval) +(define syncase:load slib:load-source) + +(require (rename mzscheme mz:require require)) + +(slib:load (in-vicinity (library-vicinity) "require")) + +;;; Hack `require' to work with both SLIB and MzScheme: +(define-syntax (require stx) + (syntax-case stx (quote) + [_ + (identifier? stx) + #'slib:require] + [(_ (quote something)) + #'(slib:require (quote something))] + [(_ req ...) + (if (eq? 'top-level (syntax-local-context)) + #'(mz:require req ...) + #'(slib:require req ...))])) + +;;; Previously loaded "/usr/local/lib/plt/collects/slibinit/init.ss" +(cond ((string<? (version) "200") + (require-library "init.ss" "slibinit")) + (else + ;;(load (build-path (collection-path "slibinit") "init.ss")) + (eval '(require (lib "defmacro.ss"))))) |