summaryrefslogtreecommitdiffstats
path: root/DrScheme.init
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:31 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:31 -0800
commit5145dd3aa0c02c9fc496d1432fc4410674206e1d (patch)
tree540afc30c51da085f5bd8ec3f4c89f6496e7900d /DrScheme.init
parent8466d8cfa486fb30d1755c4261b781135083787b (diff)
downloadslib-5145dd3aa0c02c9fc496d1432fc4410674206e1d.tar.gz
slib-5145dd3aa0c02c9fc496d1432fc4410674206e1d.zip
Import Upstream version 3a2upstream/3a2
Diffstat (limited to 'DrScheme.init')
-rw-r--r--DrScheme.init85
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)