diff options
Diffstat (limited to 'require.scm')
| -rw-r--r-- | require.scm | 67 |
1 files changed, 33 insertions, 34 deletions
diff --git a/require.scm b/require.scm index ebaf49f..a578349 100644 --- a/require.scm +++ b/require.scm @@ -17,7 +17,7 @@ ;promotional, or sales literature without prior written consent in ;each case. -(define *SLIB-VERSION* "2c3") +(define *SLIB-VERSION* "2c7") ;;; Standardize msdos -> ms-dos. (define software-type @@ -31,44 +31,43 @@ (else ""))) (define *load-pathname* #f) -(define program-vicinity - (let ((*vicinity-suffix* +(define vicinity:suffix? + (let ((suffi (case (software-type) - ((AMIGA) '(#\: #\/)) + ((AMIGA) '(#\: #\/)) + ((MACOS THINKC) '(#\:)) ((MS-DOS WINDOWS ATARIST OS/2) '(#\\ #\/)) - ((MACOS THINKC) '(#\:)) - ((NOSVE) '(#\: #\.)) - ((UNIX COHERENT) '(#\/)) - ((VMS) '(#\: #\]))))) - (lambda () - (if *load-pathname* - (let loop ((i (- (string-length *load-pathname*) 1))) - (cond ((negative? i) "") - ((memv (string-ref *load-pathname* i) *vicinity-suffix*) - (substring *load-pathname* 0 (+ i 1))) - (else (loop (- i 1))))) - (slib:error "Not loading but called" 'program-vicinity))))) + ((NOSVE) '(#\: #\.)) + ((UNIX COHERENT) '(#\/)) + ((VMS) '(#\: #\]))))) + (lambda (chr) (memv chr suffi)))) +(define (program-vicinity) + (if *load-pathname* + (let loop ((i (- (string-length *load-pathname*) 1))) + (cond ((negative? i) "") + ((vicinity:suffix? (string-ref *load-pathname* i)) + (substring *load-pathname* 0 (+ i 1))) + (else (loop (- i 1))))) + (slib:error "Not loading but called" 'program-vicinity))) (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) ".") - ((UNIX COHERENT AMIGA) "/") - ((MACOS THINKC) ":") - ((MS-DOS WINDOWS ATARIST OS/2) "\\")))) - (lambda (vic name) - (string-append vic name *vicinity-suffix*)))))) + ((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 AMIGA) "/")))) + (lambda (vic name) + (string-append vic name *vicinity-suffix*)))))) (define (make-vicinity <pathname>) <pathname>) |