From 5145dd3aa0c02c9fc496d1432fc4410674206e1d Mon Sep 17 00:00:00 2001
From: Bryan Newbold <bnewbold@robocracy.org>
Date: Mon, 20 Feb 2017 00:05:31 -0800
Subject: Import Upstream version 3a2

---
 require.scm | 97 ++++++++++++++++++-------------------------------------------
 1 file changed, 28 insertions(+), 69 deletions(-)

(limited to 'require.scm')

diff --git a/require.scm b/require.scm
index a11cbf5..ec97d7a 100644
--- a/require.scm
+++ b/require.scm
@@ -1,5 +1,5 @@
 ;;;; Implementation of VICINITY and MODULES for Scheme
-;Copyright (C) 1991, 1992, 1993, 1994, 1997, 2002, 2003 Aubrey Jaffer
+;Copyright (C) 1991, 1992, 1993, 1994, 1997, 2002, 2003, 2005 Aubrey Jaffer
 ;
 ;Permission to copy this software, to modify it, to redistribute it,
 ;to distribute modified versions, and to use it for any purpose is
@@ -17,69 +17,7 @@
 ;promotional, or sales literature without prior written consent in
 ;each case.
 ;@
-(define *SLIB-VERSION* "3a1")
-;@
-(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)				'(#\: #\])))))
-    (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 (slib:pathnameize-load *old-load*)
-  (lambda (<pathname> . extra)
-    (let ((old-load-pathname *load-pathname*))
-      (set! *load-pathname* <pathname>)
-      (apply *old-load* (cons <pathname> extra))
-      (set! *load-pathname* old-load-pathname))))
-
-(set! slib:load-source
-      (slib:pathnameize-load slib:load-source))
-(set! slib:load
-      (slib:pathnameize-load slib:load))
+(define *SLIB-VERSION* "3a2")
 
 ;;;; MODULES
 ;@
@@ -183,7 +121,8 @@
   (feval expression))
 ;@
 (define (provided? expression)
-  (define feature-list (cons (software-type) *features*))
+  (define feature-list (cons (scheme-implementation-type)
+			     (cons (software-type) *features*)))
   (define (provided? expression)
     (if (memq expression feature-list) #t
 	(and *catalog*
@@ -242,7 +181,6 @@
 (define require:provided? provided?)
 (define require:require require)
 
-(slib:provide 'vicinity)
 (if (and (string->number "0.0") (inexact? (string->number "0.0")))
     (slib:provide 'inexact))
 (if (rational? (string->number "1/19")) (slib:provide 'rational))
@@ -253,6 +191,7 @@
 
 (cond
  ((slib:provided? 'srfi)
+  (slib:provide 'srfi-59)
   (do ((idx 0 (+ 1 idx))
        (srfis (symbol->string 'srfi-)))
       ((> idx 100))
@@ -260,11 +199,33 @@
       (if (slib:eval `(cond-expand (,srfi #t) (else #f)))
 	  (slib:provide srfi))))))
 
+(define (slib:pathnameize-load *old-load*)
+  (lambda (<pathname> . extra)
+    (with-load-pathname <pathname>
+      (lambda ()
+	(apply *old-load* (cons <pathname> extra))))))
+
+(set! slib:load-source
+      (slib:pathnameize-load slib:load-source))
+(set! slib:load
+      (slib:pathnameize-load slib:load))
+
+;@
+(define (slib:eval-load <pathname> evl)
+  (if (not (file-exists? <pathname>))
+      (set! <pathname> (string-append <pathname> (scheme-file-suffix))))
+  (call-with-input-file <pathname>
+    (lambda (port)
+      (with-load-pathname <pathname>
+	(lambda ()
+	  (do ((o (read port) (read port)))
+	      ((eof-object? o))
+	    (evl o)))))))
+
 (define report:print
   (lambda args
     (for-each (lambda (x) (write x) (display #\ )) args)
     (newline)))
-
 ;@
 (define slib:report
   (let ((slib:report (lambda () (slib:report-version) (slib:report-locations))))
@@ -295,8 +256,6 @@
       (report:print '(IMPLEMENTATION-VICINITY) 'is (implementation-vicinity))
       (report:print '(LIBRARY-VICINITY) 'is (library-vicinity))
       (report:print '(SCHEME-FILE-SUFFIX) 'is (scheme-file-suffix))
-      (cond (*load-pathname*
-	     (report:print '*LOAD-PATHNAME* 'is *load-pathname*)))
       (let* ((i (+ -1 5)))
 	(cond ((eq? (car features) (car *features*)))
 	      (else (report:print 'loaded '*FEATURES* ':) (display slib:tab)))
-- 
cgit v1.2.3