From mboxrd@z Thu Jan 1 00:00:00 1970 Path: main.gmane.org!not-for-mail From: Kevin Ryde Newsgroups: gmane.lisp.guile.devel Subject: slib more stuff Date: Mon, 09 Aug 2004 11:18:09 +1000 Sender: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Message-ID: <87u0vd2jou.fsf@zip.com.au> NNTP-Posting-Host: deer.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: sea.gmane.org 1092014357 25343 80.91.224.253 (9 Aug 2004 01:19:17 GMT) X-Complaints-To: usenet@sea.gmane.org NNTP-Posting-Date: Mon, 9 Aug 2004 01:19:17 +0000 (UTC) Original-X-From: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Mon Aug 09 03:19:05 2004 Return-path: Original-Received: from lists.gnu.org ([199.232.76.165]) by deer.gmane.org with esmtp (Exim 3.35 #1 (Debian)) id 1Btyob-0006qc-00 for ; Mon, 09 Aug 2004 03:19:05 +0200 Original-Received: from localhost ([127.0.0.1] helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.33) id 1BtysI-0003of-9D for guile-devel@m.gmane.org; Sun, 08 Aug 2004 21:22:54 -0400 Original-Received: from mailman by lists.gnu.org with tmda-scanned (Exim 4.33) id 1Btys9-0003oa-Gj for guile-devel@gnu.org; Sun, 08 Aug 2004 21:22:45 -0400 Original-Received: from exim by lists.gnu.org with spam-scanned (Exim 4.33) id 1Btys7-0003mt-PV for guile-devel@gnu.org; Sun, 08 Aug 2004 21:22:45 -0400 Original-Received: from [199.232.76.173] (helo=monty-python.gnu.org) by lists.gnu.org with esmtp (Exim 4.33) id 1Btys7-0003mn-MF for guile-devel@gnu.org; Sun, 08 Aug 2004 21:22:43 -0400 Original-Received: from [61.8.0.84] (helo=mailout1.pacific.net.au) by monty-python.gnu.org with esmtp (Exim 4.34) id 1Btyo4-0005Wo-H1 for guile-devel@gnu.org; Sun, 08 Aug 2004 21:18:33 -0400 Original-Received: from mailproxy1.pacific.net.au (mailproxy1.pacific.net.au [61.8.0.86]) by mailout1.pacific.net.au (8.12.3/8.12.3/Debian-6.6) with ESMTP id i791IS4u025958 for ; Mon, 9 Aug 2004 11:18:28 +1000 Original-Received: from localhost (ppp297D.dyn.pacific.net.au [61.8.41.125]) by mailproxy1.pacific.net.au (8.12.3/8.12.3/Debian-6.6) with ESMTP id i791IP2B023525 for ; Mon, 9 Aug 2004 11:18:25 +1000 Original-Received: from gg by localhost with local (Exim 3.36 #1 (Debian)) id 1Btynk-0000wJ-00; Mon, 09 Aug 2004 11:18:12 +1000 Original-To: guile-devel@gnu.org Mail-Copies-To: never User-Agent: Gnus/5.110003 (No Gnus v0.3) Emacs/21.3 (gnu/linux) X-BeenThere: guile-devel@gnu.org X-Mailman-Version: 2.1.5 Precedence: list List-Id: "Developers list for Guile, the GNU extensibility library" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Xref: main.gmane.org gmane.lisp.guile.devel:3916 X-Report-Spam: http://spam.gmane.org/gmane.lisp.guile.devel:3916 --=-=-= 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::). --=-=-= Content-Disposition: attachment; filename=slib.scm.misc.diff --- 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) @@ -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} ;;; --=-=-= Content-Disposition: attachment; filename=slib.test ;;;; 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? >=?))) ;; ;; 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))))))))) --=-=-= Content-Type: text/plain; charset="us-ascii" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit Content-Disposition: inline _______________________________________________ Guile-devel mailing list Guile-devel@gnu.org http://lists.gnu.org/mailman/listinfo/guile-devel --=-=-=--