slib more stuff

[Kevin Ryde <user42@zip.com.au>]

[-- Attachment #1: Type: text/plain, Size: 1952 bytes --]

I made some changes to ice-9 slib,

        * slib.scm (*features*): Remove array and array-for-each, core
        definitions are insufficient for latest slib.
        (t, nil): New constants slib says are supposed to exist.
        (call-with-open-ports, browse-url): New functions for latest slib.
        Implementations taken from Template.scm (public domain).
        (open-file): Extend core definition to accept symbols for the mode,
        required by latest slib.
        (delete-file): Replace core definition with version returning #t/#f as
        per slib spec.
        (system): Mark as #:replace to suppress override warning, use new
        style "(@ (guile) system)" to call core function.

This will be for 1.6 too, because otherwise slib 3a1 is fairly broken.
Just need to adapt the open-file and delete-file implementations to 1.6.

Words in the manual about the overridden bits:


   Note that the following Guile core functions are overridden by
`(ice-9 slib)', to implement SLIB specified semantics.

`delete-file'
     Returns `#t' for success or `#f' for failure (*note Input/Output:
     (slib)Input/Output.), as opposed to the Guile core version
     unspecified for success and throwing an error for failure (*note
     File System::).

`provided?'
     Accepts a feature specification containing `and' and `or' forms
     combining symbols (*note Feature: (slib)Feature.), as opposed to
     the Guile core taking only plain symbols (*note Feature
     Manipulation::).

`open-file'
     Takes a symbol `r', `rb', `w' or `wb' for the open mode (*note
     Input/Output: (slib)Input/Output.), as opposed to the Guile core
     version taking a string (*note File Ports::).

`system'
     Returns a plain exit code 0 to 255 (*note System Interface:
     (slib)System Interface.), as opposed to the Guile core version
     returning a wait status that must be examined with
     `status:exit-val' etc (*note Processes::).



[-- Attachment #2: slib.scm.misc.diff --]
[-- Type: text/plain, Size: 5516 bytes --]

--- slib.scm.~1.43.~	2004-06-15 08:54:56.000000000 +1000
+++ slib.scm	2004-08-09 11:14:14.000000000 +1000
@@ -29,7 +29,7 @@
 	   logical:bit-extract logical:integer-expt logical:ipow-by-squaring
 	   slib:eval-load slib:tab slib:form-feed difftime offset-time
 	   software-type)
-  :replace (provide provided?)
+  :replace (delete-file open-file provide provided? system)
   :no-backtrace)
 
 \f
@@ -135,6 +135,8 @@
 ;	trace				;has macros: TRACE and UNTRACE
 ;	compiler			;has (COMPILER)
 ;	ed				;(ED) is editor
+
+	;; core definitions compatible, plus `make-random-state' below
 	random
 	)
 
@@ -150,20 +152,41 @@
 	    '(system)
 	    '())
 
-	(if (defined? 'array?)
-	    '(array)
-	    '())
-
 	(if (defined? 'char-ready?)
 	    '(char-ready?)
 	    '())
 
-	(if (defined? 'array-for-each)
-	    '(array-for-each)
-	    '())
-
 	*features*))
 
+;; The array module specified by slib 3a1 is not the same as what guile
+;; provides, so we must remove `array' from the features list.
+;;
+;; The main difference is `create-array' which is similar to
+;; `make-uniform-array', but the `Ac64' etc prototype procedures incorporate
+;; an initial fill element into the prototype.
+;;
+;; Believe the array-for-each module will need to be taken from slib when
+;; the array module is taken from there, since what the array module creates
+;; won't be understood by the guile functions.  So remove `array-for-each'
+;; from the features list too.
+;;
+;; Also, slib 3a1 array-for-each specifies an `array-map' which is not in
+;; guile (but could be implemented quite easily).
+;;
+;; ENHANCE-ME: It'd be nice to implement what's necessary, since the guile
+;; functions should be more efficient than the implementation in slib.
+;;
+;; FIXME: Since the *features* variable is shared by slib and the guile
+;; core, removing these feature symbols has the unhappy effect of making it
+;; look like they aren't in the core either.  Let's assume that arrays have
+;; been present unconditionally long enough that no guile-specific code will
+;; bother to test.  An alternative would be to make a new separate
+;; *features* variable which the slib stuff operated on, leaving the core
+;; mechanism alone.  That might be a good thing anyway.
+;;
+(set! *features* (delq 'array          *features*))
+(set! *features* (delq 'array-for-each *features*))
+
 
 ;;; FIXME: Because uers want require to search the path, this uses
 ;;; load-from-path, which probably isn't a hot idea.  slib
@@ -216,9 +239,55 @@
 (define (scheme-implementation-home-page)
   "http://www.gnu.org/software/guile/guile.html")
 
+;; legacy from r3rs, but slib says all implementations provide these
+;; ("Legacy" section of the "Miscellany" node in the manual)
+(define-public t   #t)
+(define-public nil #f)
+
+;; ENHANCE-ME: Could call ioctl TIOCGWINSZ to get the size of a tty (see
+;; "man 4 tty_ioctl" on a GNU/Linux system), on systems with that.
 (define (output-port-width . arg) 80)
 (define (output-port-height . arg) 24)
 
+;; slib 3a1 and up, straight from Template.scm
+(define-public (call-with-open-ports . ports)
+  (define proc (car ports))
+  (cond ((procedure? proc) (set! ports (cdr ports)))
+	(else (set! ports (reverse ports))
+	      (set! proc (car ports))
+	      (set! ports (reverse (cdr ports)))))
+  (let ((ans (apply proc ports)))
+    (for-each close-port ports)
+    ans))
+
+;; slib (version 3a1) requires open-file accept a symbol r, rb, w or wb for
+;; MODES, so extend the guile core open-file accordingly.
+;;
+;; slib (version 3a1) also calls open-file with strings "rb" or "wb", not
+;; sure if that's intentional, but in any case this extension continues to
+;; accept strings to make that work.
+;;
+(define-public (open-file filename modes)
+  (if (symbol? modes)
+      (set! modes (symbol->string modes)))
+  ((@ (guile) open-file) filename modes))
+
+;; returning #t/#f instead of throwing an error for failure
+(define-public (delete-file filename)
+  (catch 'system-error
+    (lambda () ((@ (guile) delete-file) filename) #t)
+    (lambda args #f)))
+
+;; 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-public (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 '" "'")))
+
 ;;; {array-for-each}
 (define (array-indexes ra)
   (let ((ra0 (apply make-array '() (array-shape ra))))
@@ -248,7 +317,6 @@
 
 ;;; {system}
 ;;;
-
 ;; If the program run is killed by a signal, the shell normally gives an
 ;; exit code of 128+signum.  If the shell itself is killed by a signal then
 ;; we do the same 128+signum here.
@@ -256,15 +324,13 @@
 ;; "stop-sig" shouldn't arise here, since system shouldn't be calling
 ;; waitpid with WUNTRACED, but allow for it anyway, just in case.
 ;;
-(if (defined? 'system)
-    (begin
-      (define guile-core-system system)
-      (define-public system
-	(lambda (str)
-	  (let ((st (guile-core-system str)))
-	    (or (status:exit-val st)
-		(+ 128 (or (status:term-sig st)
-			   (status:stop-sig st)))))))))
+(if (memq 'system *features*)
+    (define-public system
+      (lambda (str)
+	(let ((st ((@ (guile) system) str)))
+	  (or (status:exit-val st)
+	      (+ 128 (or (status:term-sig st)
+			 (status:stop-sig st))))))))
 
 ;;; {Time}
 ;;;

[-- Attachment #3: slib.test --]
[-- Type: text/plain, Size: 3617 bytes --]

;;;; slib.test --- Test suite for Guile's SLIB glue. -*- scheme -*-
;;;;
;;;; Copyright 2003, 2004 Free Software Foundation, Inc.
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2, or (at your option)
;;;; any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING.  If not, write to
;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
;;;; Boston, MA 02111-1307 USA

;; These tests are run only if slib is available.  slib will need to be
;; installed (or linked) under the configured guile $prefix.
;;
(if (catch #t
      (lambda () (resolve-module '(ice-9 slib)))
      (lambda args #f))
    (begin

      (define-module (test-suite test-ice-9-slib)
	#:duplicates (last)  ;; avoid warnings about various replacements
	#:use-module (test-suite lib)
	#:use-module (ice-9 slib))

      ;;
      ;; delete-file
      ;;

      ;; in guile 1.6.4 and earlier delete-file didn't match the slib spec
      (with-test-prefix "delete-file"
	(pass-if "non existant file"
	  (eq? #f (delete-file "nosuchfile")))
	(pass-if "existing file"
	  (call-with-output-file "slibtest.tmp" noop)
	  (eq? #t (delete-file "slibtest.tmp"))))

      ;;
      ;; browse-url
      ;;

      (with-test-prefix "browse-url"
	(pass-if (procedure? browse-url)))

      ;;
      ;; call-with-open-ports
      ;;

      (with-test-prefix "call-with-open-ports"
	(pass-if (procedure? call-with-open-ports))
	
	(pass-if "close on return"
	  (let ((port (open-input-file "/dev/null")))
	    (call-with-open-ports port (lambda (port) #f))
	    (port-closed? port))))

      ;;
      ;; nil
      ;;

      ;; in guile 1.6.4 and earlier this was missing
      (with-test-prefix "nil"
	(pass-if (eq? #f nil)))

      ;;
      ;; open-file
      ;;

      ;; this style open-file is only a requirement in slib 3a1 and up, but
      ;; we provide it always
      (with-test-prefix "open-file"
	(pass-if (port? (open-file "/dev/null" 'r)))
	(pass-if (port? (open-file "/dev/null" 'rb)))
	(pass-if (port? (open-file "/dev/null" 'w)))
	(pass-if (port? (open-file "/dev/null" 'wb))))

      ;;
      ;; rev2-procedures
      ;;

      ;; in guile 1.6.4 the 'rev2-procedures feature we defined claimed
      ;; these existed, but they didn't
      (with-test-prefix "rev2-procedures"
	(require 'rev2-procedures)
	(pass-if (procedure? -1+))
	(pass-if (procedure? <?))
	(pass-if (procedure? <=?))
	(pass-if (procedure? =?))
	(pass-if (procedure? >?))
	(pass-if (procedure? >=?)))

      ;;
      ;; system
      ;;

      ;; in guile 1.6.4 and earlier system didn't match the slib spec
      (with-test-prefix "system"
	(pass-if (= 0 (system "exit 0")))
	(pass-if (= 1 (system "exit 1")))
	(pass-if (= 99 (system "exit 99"))))

      ;;
      ;; t
      ;;

      ;; in guile 1.6.4 and earlier this was missing
      (with-test-prefix "t"
	(pass-if (eq? #t t)))

      (require 'array)
      (with-test-prefix "array"

	;;
	;; create-array
	;;

	;; create-array isn't in old slib, but when it exists it should work
	(if (defined? 'create-array)
	    (with-test-prefix "create-array"
	      (pass-if (array? (create-array (As32 0) '(0 1)))))))))

[-- Attachment #4: Type: text/plain, Size: 143 bytes --]

_______________________________________________
Guile-devel mailing list
Guile-devel@gnu.org
http://lists.gnu.org/mailman/listinfo/guile-devel