diff options
Diffstat (limited to 'DrScheme.init')
| -rw-r--r-- | DrScheme.init | 85 |
1 files changed, 84 insertions, 1 deletions
diff --git a/DrScheme.init b/DrScheme.init index 9942897..8cce2e9 100644 --- a/DrScheme.init +++ b/DrScheme.init @@ -3,6 +3,85 @@ ;;; ;;; 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)])) +;@ +(define in-vicinity string-append) +;@ +(define (user-vicinity) + (case (software-type) + ((VMS) "[.]") + (else ""))) + +(define *load-pathname* #f) +;@ +(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) + (if *load-pathname* + (pathname->vicinity *load-pathname*) + (slib:error 'program-vicinity " called; use slib:load to load"))) +;@ +(define sub-vicinity + (case (software-type) + ((VMS) (lambda + (vic name) + (let ((l (string-length vic))) + (if (or (zero? (string-length vic)) + (not (char=? #\] (string-ref vic (- l 1))))) + (string-append vic "[" name "]") + (string-append (substring vic 0 (- l 1)) + "." name "]"))))) + (else (let ((*vicinity-suffix* + (case (software-type) + ((NOSVE) ".") + ((MACOS THINKC) ":") + ((MS-DOS WINDOWS ATARIST OS/2) "\\") + ((UNIX COHERENT PLAN9 AMIGA) "/")))) + (lambda (vic name) + (string-append vic name *vicinity-suffix*)))))) +;@ +(define (make-vicinity <pathname>) <pathname>) +;@ +(define with-load-pathname + (let ((exchange + (lambda (new) + (let ((old *load-pathname*)) + (set! *load-pathname* new) + old)))) + (lambda (path thunk) + (let ((old #f)) + (dynamic-wind + (lambda () (set! old (exchange path))) + thunk + (lambda () (exchange old))))))) + (define (make-exchanger obj) (lambda (rep) (let ((old obj)) (set! obj rep) old))) (define (open-file filename modes) @@ -41,6 +120,9 @@ (eval '(require (lib "defmacro.ss"))) (slib:provide 'defmacro))) +(provide 'vicinity) +(provide 'srfi-59) + ;;;The rest corrects mistakes in ;;;/usr/local/lib/plt/collects/slibinit/init.ss: @@ -51,7 +133,8 @@ (let ((cep (current-error-port))) (if (provided? 'trace) (print-call-stack cep)) (display "Warn: " cep) - (for-each (lambda (x) (display #\ cep) (write x cep)) args)))) + (for-each (lambda (x) (display #\ cep) (write x cep)) args) + (newline cep)))) (define call-with-input-string (lambda (string thunk) |