* slib more stuff
@ 2004-08-09 1:18 Kevin Ryde
0 siblings, 0 replies; only message in thread
From: Kevin Ryde @ 2004-08-09 1:18 UTC (permalink / raw)
[-- 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
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2004-08-09 1:18 UTC | newest]
Thread overview: (only message) (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2004-08-09 1:18 slib more stuff Kevin Ryde
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).