From 64f037d91e0c9296dcaef9a0ff3eb33b19a2ed34 Mon Sep 17 00:00:00 2001
From: Bryan Newbold <bnewbold@robocracy.org>
Date: Mon, 20 Feb 2017 00:05:38 -0800
Subject: Import Upstream version 3a5

---
 guile.init | 164 +++++++++++++++++++++++++++++++++++++++++--------------------
 1 file changed, 112 insertions(+), 52 deletions(-)

(limited to 'guile.init')

diff --git a/guile.init b/guile.init
index 9cf6ed4..e51381a 100644
--- a/guile.init
+++ b/guile.init
@@ -3,7 +3,7 @@
 ;;;
 ;;; This code is in the public domain.
 
-(if (string<? (version) "1.6")
+(if (not (and (string<=? "1.6" (version)) (string<? (version) "1.7")))
     (define-module (ice-9 slib)))	; :no-backtrace
 (define slib-module (current-module))
 
@@ -43,11 +43,13 @@
 ;;; (implementation-vicinity) should be defined to be the pathname of
 ;;; the directory where any auxillary files to your Scheme
 ;;; implementation reside.
-(define implementation-vicinity
-  (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)))
+;; (define implementation-vicinity
+;;   (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)))
+;;; Rob Browning says %site-dir exists since Guile-1.6
+(define implementation-vicinity %site-dir)
 
 ;;; (library-vicinity) should be defined to be the pathname of the
 ;;; directory where files of Scheme library functions reside.
@@ -56,6 +58,10 @@
 	 (or
 	  ;; Use this getenv if your implementation supports it.
 	  (and (defined? 'getenv) (getenv "SCHEME_LIBRARY_PATH"))
+	  ;; Rob Browning sent this; I'm not sure its a good idea.
+          ;; See if we can find slib/guile.init (cf. implementation-vicinity).
+          (let ((path (%search-load-path "slib/guile.init")))
+            (and path (substring path 0 (- (string-length path) 10))))
 	  ;; Use this path if your scheme does not support GETENV
 	  ;; or if SCHEME_LIBRARY_PATH is not set.
 	  "/usr/lib/slib/"
@@ -239,6 +245,14 @@
 	    '(char-ready?)
 	    '())))
 
+;;@ (FILE-POSITION <port> . <k>)
+(define (file-position port . args)
+  (if (null? args)
+      (ftell port)
+      (seek port (car args) SEEK_SET)))
+(if (string>=? (scheme-implementation-version) "1.8")
+    (module-replace! (current-module) '(file-position)))
+
 ;;; (OUTPUT-PORT-WIDTH <port>)
 (define (output-port-width . arg) 79)
 
@@ -257,13 +271,17 @@
 ;; "status:stop-sig" shouldn't arise here, since system shouldn't be
 ;; calling waitpid with WUNTRACED, but allow for it anyway, just in
 ;; case.
-(set! system
+(define system
       (let ((guile-core-system system))
 	(lambda (str)
 	  (define st (guile-core-system str))
 	  (or (status:exit-val st)
 	      (+ 128 (or (status:term-sig st)
 			 (status:stop-sig st)))))))
+;; This has to be done after the definition so that the original
+;; binding will still be visible during the definition.
+(if (string>=? (scheme-implementation-version) "1.8")
+    (module-replace! (current-module) '(system)))
 
 ;;; for line-i/o
 (use-modules (ice-9 popen))
@@ -284,12 +302,16 @@
        (re-export read-line!)
        (re-export write-line)))
 
-(set! delete-file
+(define delete-file
       (let ((guile-core-delete-file delete-file))
 	(lambda (filename)
 	  (catch 'system-error
 		 (lambda () (guile-core-delete-file filename) #t)
 		 (lambda args #f)))))
+;; This has to be done after the definition so that the original
+;; binding will still be visible during the definition.
+(if (string>=? (scheme-implementation-version) "1.8")
+    (module-replace! (current-module) '(delete-file)))
 
 ;;; FORCE-OUTPUT flushes any pending output on optional arg output port
 ;;; use this definition if your system doesn't have such a procedure.
@@ -300,13 +322,18 @@
 
 (define (make-exchanger obj)
   (lambda (rep) (let ((old obj)) (set! obj rep) old)))
-(set! open-file
+(define open-file
       (let ((guile-core-open-file open-file))
 	(lambda (filename modes)
 	  (guile-core-open-file filename
 				(if (symbol? modes)
 				    (symbol->string modes)
 				    modes)))))
+;; This has to be done after the definition so that the original
+;; binding will still be visible during the definition.
+(if (string>=? (scheme-implementation-version) "1.8")
+    (module-replace! (current-module) '(open-file)))
+
 (define (call-with-open-ports . ports)
   (define proc (car ports))
   (cond ((procedure? proc) (set! ports (cdr ports)))
@@ -358,48 +385,52 @@
 ;;; return if exiting not supported.
 (define slib:exit quit)
 
-;;; Here for backward compatability
-;;(define scheme-file-suffix
-;;  (let ((suffix (case (software-type)
-;;		  ((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 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-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))
-
+(cond ((string>=? (scheme-implementation-version) "1.8")
+       (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))
+       )
+      (else
+       ;;Here for backward compatability
+       (define scheme-file-suffix
+	 (let ((suffix (case (software-type)
+			 ((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 read (guile:wrap-case-insensitive read))
+
+       (define slib:load
+	 (let ((load-file (guile:wrap-case-insensitive load)))
+	   (lambda (<pathname>)
+	     (load-file (string-append <pathname> (scheme-file-suffix))))))
+       ))
+
+;;;(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-source slib:load)
 
 ;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced
@@ -412,6 +443,15 @@
 
 (define (defmacro:expand* x)
   (require 'defmacroexpand) (apply defmacro:expand* x '()))
+;@
+(define gentemp
+  (let ((*gensym-counter* -1))
+    (lambda ()
+      (set! *gensym-counter* (+ *gensym-counter* 1))
+      (string->symbol
+       (string-append "slib:G" (number->string *gensym-counter*))))))
+(if (string>=? (scheme-implementation-version) "1.8")
+    (module-replace! (current-module) '(gentemp)))
 
 ;;; If your implementation provides R4RS macros:
 (define macro:eval slib:eval)
@@ -507,13 +547,18 @@
 		       (array-shape array)))))
 ;; DIMENSIONS->UNIFORM-ARRAY and list->uniform-array in Guile-1.6.4
 ;; cannot make empty arrays.
-(set! make-array
+(define make-array
       (lambda (prot . args)
 	(if (array-null? prot)
 	    (dimensions->uniform-array args (array-prototype prot))
 	    (dimensions->uniform-array args (array-prototype prot)
 				       (apply array-ref prot
 					      (map car (array-shape prot)))))))
+;; This has to be done after the definition so that the original
+;; binding will still be visible during the definition.
+(if (string>=? (scheme-implementation-version) "1.8")
+    (module-replace! (current-module) '(make-array)))
+
 (define create-array make-array)
 (define (make-uniform-wrapper prot)
   (if (string? prot) (set! prot (string->number prot)))
@@ -602,6 +647,18 @@
 (if (not (defined? 'random:chunk))
     (define (random:chunk sta) (random 256 sta)))
 
+;;; workaround for Guile 1.6.7 bug
+(cond ((or (array? 'guile) (array? '(1 6 7)))
+       (define array?
+	 (let ((old-array? array?))
+	   (lambda (obj)
+	     (and (old-array? obj)
+		  (not (or (list? obj)
+			   (symbol? obj)
+			   (record? obj)))))))
+       (if (string>=? (scheme-implementation-version) "1.8")
+	   (module-replace! (current-module) '(array?)))))
+
 ;;; Support for older versions of Scheme.  Not enough code for its own file.
 ;;(define (last-pair l) (if (pair? (cdr l)) (last-pair (cdr l)) l))
 
@@ -615,4 +672,7 @@
 (define >? >)
 (define >=? >=)
 
+(if (string>=? (scheme-implementation-version) "1.8")
+    (module-replace! (current-module) '(provide provided?)))
+
 (slib:load (in-vicinity (library-vicinity) "require"))
-- 
cgit v1.2.3