From 1e9a86d92c40700dba5bc511705eac4fa2086e24 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Tue, 10 Aug 2004 00:44:08 +0000 Subject: [PATCH] (*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. (slib:exit, slib:error, slib:warn, slib:eval, slib:eval-load, slib:tab, slib:form-feed, slib:load-source, output-port-width, output-port-height, difftime, offset-time): Export these, they're meant to be public. --- ice-9/slib.scm | 110 ++++++++++++++++++++++++++++++++++++++++--------- 1 file changed, 90 insertions(+), 20 deletions(-) diff --git a/ice-9/slib.scm b/ice-9/slib.scm index bcdf66ae7..1c928d287 100644 --- a/ice-9/slib.scm +++ b/ice-9/slib.scm @@ -71,10 +71,10 @@ -(define slib:exit quit) -(define slib:error error) -(define slib:warn warn) -(define slib:eval (lambda (x) (eval x slib-module))) +(define-public slib:exit quit) +(define-public slib:error error) +(define-public slib:warn warn) +(define-public slib:eval (lambda (x) (eval x slib-module))) (define defmacro:eval (lambda (x) (eval x (interaction-environment)))) (define logical:logand logand) (define logical:logior logior) @@ -86,9 +86,9 @@ (define logical:bit-extract bit-extract) (define logical:integer-expt integer-expt) (define logical:ipow-by-squaring ipow-by-squaring) -(define slib:eval-load eval-load) -(define slib:tab #\tab) -(define slib:form-feed #\page) +(define-public slib:eval-load eval-load) +(define-public slib:tab #\tab) +(define-public slib:form-feed #\page) (define slib-module (current-module)) @@ -128,18 +128,10 @@ '(system) '()) - (if (defined? 'array?) - '(array) - '()) - (if (defined? 'char-ready?) '(char-ready?) '()) - (if (defined? 'array-for-each) - '(array-for-each) - '()) - (if (and (string->number "0.0") (inexact? (string->number "0.0"))) '(inexact) '()) @@ -162,6 +154,36 @@ '())))) +;; 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 ;;; doesn't expect this function to search a path, so I expect to get @@ -189,7 +211,7 @@ (lambda args args))) (apply throw errinfo)))))) -(define slib:load-source slib:load) +(define-public slib:load-source slib:load) (define defmacro:load slib:load) (define slib-parent-dir @@ -208,10 +230,58 @@ (define (scheme-implementation-type) 'guile) (define (scheme-implementation-version) "") -(define (output-port-width . arg) 80) -(define (output-port-height . arg) 24) +;; 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) + +(define-public (output-port-width . arg) 80) +(define-public (output-port-height . arg) 24) (define (identity x) x) +;; 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 + (let ((guile-core-open-file open-file)) + (lambda (filename modes) + (if (symbol? modes) + (set! modes (symbol->string modes))) + (guile-core-open-file filename modes)))) + +;; returning #t/#f instead of throwing an error for failure +(define-public delete-file + (let ((guile-core-delete-file delete-file)) + (lambda (filename) + (catch 'system-error + (lambda () (guile-core-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 '" "'"))) + ;;; {Random numbers} ;;; (define (make-random-state . args) @@ -254,8 +324,8 @@ ;;; {Time} ;;; -(define difftime -) -(define offset-time +) +(define-public difftime -) +(define-public offset-time +) (define %system-define define)