Index: slib.scm
===================================================================
RCS file: /cvsroot/guile/guile/guile-core/ice-9/slib.scm,v
retrieving revision 1.46
diff -r1.46 slib.scm
73a74,145
> ;;; (software-type) should be set to the generic operating system type.
> ;;; UNIX, VMS, MACOS, AMIGA and MS-DOS are supported.
> (define software-type
>   (if (string<? (version) "1.6")
>       (lambda () 'UNIX)
>       (lambda () 'unix)))
> 
> (define (user-vicinity)
>   (case (software-type)
>     ((vms)	"[.]")
>     (else	"")))
> 
> (define vicinity:suffix?
>   (let ((suffi
> 	 (case (software-type)
> 	   ((amiga)				'(#\: #\/))
> 	   ((macos thinkc)			'(#\:))
> 	   ((ms-dos windows atarist os/2)	'(#\\ #\/))
> 	   ((nosve)				'(#\: #\.))
> 	   ((unix coherent plan9)		'(#\/))
> 	   ((vms)				'(#\: #\]))
> 	   (else
> 	    (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)
>   (define clp (current-load-port))
>   (if clp
>       (pathname->vicinity (port-filename clp))
>       (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 with-load-pathname
>   (let ((exchange
> 	 (lambda (new)
> 	   (let ((old program-vicinity))
> 	     (set! program-vicinity new)
> 	     old))))
>     (lambda (path thunk)
>       (define old #f)
>       (define vic (pathname->vicinity path))
>       (dynamic-wind
> 	  (lambda () (set! old (exchange (lambda () vic))))
> 	  thunk
> 	  (lambda () (exchange old))))))
> 
204a277,278
> (define slib:features *features*)
>