From 5bea21e81ed516440e34e480f2c33ca41aa8c597 Mon Sep 17 00:00:00 2001 From: Bryan Newbold Date: Mon, 20 Feb 2017 00:05:36 -0800 Subject: Import Upstream version 3a4 --- guile.init | 114 ++++++++++++++++++++++++++++++++++--------------------------- 1 file changed, 63 insertions(+), 51 deletions(-) (limited to 'guile.init') diff --git a/guile.init b/guile.init index 76f1f0e..9cf6ed4 100644 --- a/guile.init +++ b/guile.init @@ -6,7 +6,6 @@ (if (string) (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 (stringUNIFORM-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 (stringuniform-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