Import Upstream version 3a4upstream/3a4

1 files changed, 63 insertions, 51 deletions

diff --git a/guile.init b/guile.init
index 76f1f0e..9cf6ed4 100644
--- a/guile.init
+++ b/guile.init
@@ -6,7 +6,6 @@
 (if (string<? (version) "1.6")
     (define-module (ice-9 slib)))	; :no-backtrace
 (define slib-module (current-module))
-(define (defined? symbol) (module-defined? slib-module symbol))
 
 (define base:define define)
 (define define
@@ -59,6 +58,7 @@
 	  (and (defined? 'getenv) (getenv "SCHEME_LIBRARY_PATH"))
 	  ;; Use this path if your scheme does not support GETENV
 	  ;; or if SCHEME_LIBRARY_PATH is not set.
+	  "/usr/lib/slib/"
 	  (in-vicinity (implementation-vicinity) "slib/"))))
     (lambda () library-path)))
 
@@ -75,8 +75,6 @@
 		(string-append home "/")))
 	   (else home)))))
 ;@
-(define in-vicinity string-append)
-;@
 (define (user-vicinity)
   (case (software-type)
     ((vms)	"[.]")
@@ -144,9 +142,9 @@
 	  thunk
 	  (lambda () (exchange old))))))
 
-;;@ *FEATURES* is a list of symbols naming the (SLIB) features
+;;@ SLIB:FEATURES is a list of symbols naming the (SLIB) features
 ;;; initially supported by this implementation.
-(define *features*
+(define slib:features
   (append
       '(
 	source				;can load scheme source files
@@ -239,9 +237,7 @@
 
 	(if (defined? 'char-ready?)
 	    '(char-ready?)
-	    '())
-
-	*features*))
+	    '())))
 
 ;;; (OUTPUT-PORT-WIDTH <port>)
 (define (output-port-width . arg) 79)
@@ -261,13 +257,13 @@
 ;; "status:stop-sig" shouldn't arise here, since system shouldn't be
 ;; calling waitpid with WUNTRACED, but allow for it anyway, just in
 ;; case.
-(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)))))))
+(set! 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)))))))
 
 ;;; for line-i/o
 (use-modules (ice-9 popen))
@@ -279,13 +275,21 @@
 	       (status:term-sig status)
 	       (status:stop-sig status))
 	   (if (eof-object? line) "" line)))))
-
-(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)))))
+;; rdelim was loaded by default in guile 1.6, but not in 1.8
+;; load it to get read-line, read-line! and write-line,
+;; and re-export them for the benefit of loading this file from (ice-9 slib)
+(cond ((string>=? (scheme-implementation-version) "1.8")
+       (use-modules (ice-9 rdelim))
+       (re-export read-line)
+       (re-export read-line!)
+       (re-export write-line)))
+
+(set! delete-file
+      (let ((guile-core-delete-file delete-file))
+	(lambda (filename)
+	  (catch 'system-error
+		 (lambda () (guile-core-delete-file filename) #t)
+		 (lambda args #f)))))
 
 ;;; FORCE-OUTPUT flushes any pending output on optional arg output port
 ;;; use this definition if your system doesn't have such a procedure.
@@ -296,14 +300,13 @@
 
 (define (make-exchanger obj)
   (lambda (rep) (let ((old obj)) (set! obj rep) old)))
-(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)))))
-(define (port? obj) (or (input-port? obj) (output-port? obj)))
+(set! open-file
+      (let ((guile-core-open-file open-file))
+	(lambda (filename modes)
+	  (guile-core-open-file filename
+				(if (symbol? modes)
+				    (symbol->string modes)
+				    modes)))))
 (define (call-with-open-ports . ports)
   (define proc (car ports))
   (cond ((procedure? proc) (set! ports (cdr ports)))
@@ -314,6 +317,18 @@
     (for-each close-port ports)
     ans))
 
+(if (not (defined? 'browse-url))
+    ;; Nothing special to do for this, so straight from
+    ;; Template.scm.  Maybe "sensible-browser" for a debian
+    ;; system would be worth trying too (and would be good on a
+    ;; tty).
+    (define (browse-url url)
+      (define (try cmd end) (zero? (system (string-append cmd url end))))
+      (or (try "netscape-remote -remote 'openURL(" ")'")
+	  (try "netscape -remote 'openURL(" ")'")
+	  (try "netscape '" "'&")
+	  (try "netscape '" "'"))))
+
 ;;; "rationalize" adjunct procedures.
 ;;(define (find-ratio x e)
 ;;  (let ((rat (rationalize x e)))
@@ -323,14 +338,13 @@
 
 ;;; CHAR-CODE-LIMIT is one greater than the largest integer which can
 ;;; be returned by CHAR->INTEGER.
-;;(define char-code-limit 256)
+;; In Guile-1.8.0: (string>? (string #\000) (string #\200)) ==> #t
+(if (string=? (version) "1.8.0")
+    (define char-code-limit 128))
 
 ;;; MOST-POSITIVE-FIXNUM is used in modular.scm
 ;;(define most-positive-fixnum #x0FFFFFFF)
 
-;;; Return argument
-(define (identity x) x)
-
 ;;; SLIB:EVAL is single argument eval using the top-level (user) environment.
 (define slib:eval
   (if (string<? (scheme-implementation-version) "1.5")
@@ -475,7 +489,7 @@
 (define bitwise-xor logxor)
 (define bitwise-and logand)
 (define bitwise-not lognot)
-(define bit-count logcount)
+;;(define bit-count logcount)
 (define bit-set?   logbit?)
 (define any-bits-set? logtest)
 (define first-set-bit log2-binary-factors)
@@ -493,19 +507,24 @@
 		       (array-shape array)))))
 ;; DIMENSIONS->UNIFORM-ARRAY and list->uniform-array in Guile-1.6.4
 ;; cannot make empty arrays.
-(define (make-array 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))))))
+(set! 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)))))))
 (define create-array make-array)
 (define (make-uniform-wrapper prot)
   (if (string? prot) (set! prot (string->number prot)))
   (if prot
-      (lambda opt (if (null? opt)
-		      (list->uniform-array 1 prot (list prot))
-		      (list->uniform-array 0 prot opt)))
+      (if (string<? (version) "1.8")
+	  (lambda opt (if (null? opt)
+			  (list->uniform-array 1 prot (list prot))
+			  (list->uniform-array 0 prot opt)))
+	  (lambda opt (if (null? opt)
+			  (list->uniform-array 1 prot (list prot))
+			  (list->uniform-array 0 prot (car opt)))))
       vector))
 (define ac64 (make-uniform-wrapper "+i"))
 (define ac32 ac64)
@@ -586,16 +605,9 @@
 ;;; 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))
 
-;;; Guile has nil and t as self-sets
 (define t #t)
 (define nil #f)
 
-;;; Define these if your implementation's syntax can support it and if
-;;; they are not already defined.
-(define (1+ n) (+ n 1))
-(define (-1+ n) (+ n -1))
-(define 1- -1+)
-
 ;;; rev2-procedures
 (define <? <)
 (define <=? <=)