Import Upstream version 3a2upstream/3a2

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)