Import Upstream version 3a3upstream/3a3

1 files changed, 59 insertions, 51 deletions

diff --git a/guile.init b/guile.init
index a488998..76f1f0e 100644
--- a/guile.init
+++ b/guile.init
@@ -45,9 +45,9 @@
 ;;; the directory where any auxillary files to your Scheme
 ;;; implementation reside.
 (define implementation-vicinity
-  (let* ((path (or (%search-load-path "slib/require.scm")
-		   (error "Could not find slib/require.scm in " %load-path)))
-	 (vic (substring path 0 (- (string-length path) 16))))
+  (let* ((path (or (%search-load-path "ice-9/q.scm")
+		   (error "Could not find ice-9/q.scm in " %load-path)))
+	 (vic (substring path 0 (- (string-length path) 11))))
     (lambda () vic)))
 
 ;;; (library-vicinity) should be defined to be the pathname of the
@@ -66,7 +66,7 @@
 ;;; directory, the directory which typically contains files which
 ;;; customize a computer environment for a user.
 (define (home-vicinity)
-  (let ((home (getenv "HOME")))
+  (let ((home (and (defined? 'getenv) (getenv "HOME"))))
     (and home
 	 (case (software-type)
 	   ((unix coherent ms-dos)	;V7 unix has a / on HOME
@@ -79,7 +79,7 @@
 ;@
 (define (user-vicinity)
   (case (software-type)
-    ((VMS)	"[.]")
+    ((vms)	"[.]")
     (else	"")))
 ;@
 (define vicinity:suffix?
@@ -111,7 +111,7 @@
 ;@
 (define sub-vicinity
   (case (software-type)
-    ((VMS) (lambda
+    ((vms) (lambda
 	       (vic name)
 	     (let ((l (string-length vic)))
 	       (if (or (zero? (string-length vic))
@@ -121,10 +121,10 @@
 				  "." name "]")))))
     (else (let ((*vicinity-suffix*
 		 (case (software-type)
-		   ((NOSVE) ".")
-		   ((MACOS THINKC) ":")
-		   ((MS-DOS WINDOWS ATARIST OS/2) "\\")
-		   ((UNIX COHERENT PLAN9 AMIGA) "/"))))
+		   ((nosve) ".")
+		   ((macos thinkc) ":")
+		   ((ms-dos windows atarist os/2) "\\")
+		   ((unix coherent plan9 amiga) "/"))))
 	    (lambda (vic name)
 	      (string-append vic name *vicinity-suffix*))))))
 ;@
@@ -190,6 +190,7 @@
 					;STRING-NULL?, APPEND!, 1+,
 					;-1+, <?, <=?, =?, >?, >=?
 ;;;	object-hash			;has OBJECT-HASH
+	hash				;HASH, HASHV, HASHQ
 
 	full-continuation		;can return multiple times
 ;;;	ieee-floating-point		;conforms to IEEE Standard 754-1985
@@ -206,6 +207,7 @@
 ;;;	record				;has user defined data structures
 	string-port			;has CALL-WITH-INPUT-STRING and
 					;CALL-WITH-OUTPUT-STRING
+	line-i/o
 ;;;	sort
 ;;;	pretty-print
 ;;;	object->string
@@ -213,7 +215,7 @@
 ;;;	trace				;has macros: TRACE and UNTRACE
 ;;;	compiler			;has (COMPILER)
 ;;;	ed				;(ED) is editor
-;;;	system				;posix (system <string>)
+	system				;posix (system <string>)
 ;;;	getenv				;posix (getenv <string>)
 ;;;	program-arguments		;returns list of strings (argv)
 ;;;	current-time			;returns time in seconds since 1/1/1970
@@ -223,6 +225,8 @@
 	logical
 	random				;Random numbers
 
+	array
+	array-for-each
 	)
 
 	(if (defined? 'getenv)
@@ -233,22 +237,10 @@
 	    '(current-time)
 	    '())
 
-	(if (defined? 'system)
-	    '(system)
-	    '())
-
-	(if (defined? 'array?)
-	    '(array)
-	    '())
-
 	(if (defined? 'char-ready?)
 	    '(char-ready?)
 	    '())
 
-	(if (defined? 'array-for-each)
-	    '(array-for-each)
-	    '())
-
 	*features*))
 
 ;;; (OUTPUT-PORT-WIDTH <port>)
@@ -277,16 +269,17 @@
 	  (+ 128 (or (status:term-sig st)
 		     (status:stop-sig st)))))))
 
-;;; (TMPNAM) makes a temporary file name.
-;;(define tmpnam (let ((cntr 100))
-;;		 (lambda () (set! cntr (+ 1 cntr))
-;;			 (string-append "slib_" (number->string cntr)))))
-
-;;; (FILE-EXISTS? <string>)
-;;(define (file-exists? f) #f)
+;;; for line-i/o
+(use-modules (ice-9 popen))
+(define (system->line command . tmp)
+  (let ((ipip (open-input-pipe command)))
+    (define line (read-line ipip))
+    (let ((status (close-pipe ipip)))
+      (and (or (eqv? 0 (status:exit-val status))
+	       (status:term-sig status)
+	       (status:stop-sig status))
+	   (if (eof-object? line) "" line)))))
 
-;;; (DELETE-FILE <string>)
-;;(define (delete-file f) #f)
 (define delete-file
   (let ((guile-core-delete-file delete-file))
     (lambda (filename)
@@ -354,29 +347,44 @@
 ;;; Here for backward compatability
 ;;(define scheme-file-suffix
 ;;  (let ((suffix (case (software-type)
-;;		  ((NOSVE) "_scm")
+;;		  ((nosve) "_scm")
 ;;		  (else ".scm"))))
 ;;    (lambda () suffix)))
 
-(define (guile:wrap-case-insensitive proc)
-  (lambda args
-    (save-module-excursion
-     (lambda ()
-       (set-current-module slib-module)
-       (let ((old (read-options)))
-	 (dynamic-wind
-	     (lambda () (read-enable 'case-insensitive))
-	     (lambda () (apply proc args))
-	     (lambda () (read-options old))))))))
+;;; (define (guile:wrap-case-insensitive proc)
+;;;   (lambda args
+;;;     (save-module-excursion
+;;;      (lambda ()
+;;;        (set-current-module slib-module)
+;;;        (let ((old (read-options)))
+;;; 	 (dynamic-wind
+;;; 	     (lambda () (read-enable 'case-insensitive))
+;;; 	     (lambda () (apply proc args))
+;;; 	     (lambda () (read-options old))))))))
 
-(define read (guile:wrap-case-insensitive read))
+;;; (define read (guile:wrap-case-insensitive read))
 
 ;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever
 ;;; suffix all the module files in SLIB have.  See feature 'SOURCE.
-(define slib:load
-  (let ((load-file (guile:wrap-case-insensitive load)))
-    (lambda (<pathname>)
-      (load-file (string-append <pathname> (scheme-file-suffix))))))
+;;; (define slib:load
+;;;   (let ((load-file (guile:wrap-case-insensitive load)))
+;;;     (lambda (<pathname>)
+;;;       (load-file (string-append <pathname> (scheme-file-suffix))))))
+(define (slib:load-helper loader)
+  (lambda (name)
+    (save-module-excursion
+     (lambda ()
+       (set-current-module slib-module)
+       (let ((errinfo (catch 'system-error
+			     (lambda () (loader name) #f)
+			     (lambda args args))))
+	 (if (and errinfo
+		  (catch 'system-error
+			 (lambda () (loader (string-append name ".scm")) #f)
+			 (lambda args args)))
+	     (apply throw errinfo)))))))
+(define slib:load (slib:load-helper load))
+(define slib:load-from-path (slib:load-helper load-from-path))
 
 (define slib:load-source slib:load)
 
@@ -524,9 +532,9 @@
 (define A:floR32b ar32)
 (define A:floR16b ar32)
 ;; decimal flonums
-(define A:flor128d ar64)
-(define A:flor64d ar64)
-(define A:flor32d ar32)
+(define A:floR128d ar64)
+(define A:floR64d ar64)
+(define A:floR32d ar32)
 ;; fixnums
 (define A:fixZ64b as64)
 (define A:fixZ32b as32)