diff options
Diffstat (limited to 'guile.init')
| -rw-r--r-- | guile.init | 114 |
1 files changed, 63 insertions, 51 deletions
@@ -6,7 +6,6 @@ (if (string<? (version) "1.6") (define-module (ice-9 slib))) ; :no-backtrace (define slib-module (current-module)) -(define (defined? symbol) (module-defined? slib-module symbol)) (define base:define define) (define define @@ -59,6 +58,7 @@ (and (defined? 'getenv) (getenv "SCHEME_LIBRARY_PATH")) ;; Use this path if your scheme does not support GETENV ;; or if SCHEME_LIBRARY_PATH is not set. + "/usr/lib/slib/" (in-vicinity (implementation-vicinity) "slib/")))) (lambda () library-path))) @@ -75,8 +75,6 @@ (string-append home "/"))) (else home))))) ;@ -(define in-vicinity string-append) -;@ (define (user-vicinity) (case (software-type) ((vms) "[.]") @@ -144,9 +142,9 @@ thunk (lambda () (exchange old)))))) -;;@ *FEATURES* is a list of symbols naming the (SLIB) features +;;@ SLIB:FEATURES is a list of symbols naming the (SLIB) features ;;; initially supported by this implementation. -(define *features* +(define slib:features (append '( source ;can load scheme source files @@ -239,9 +237,7 @@ (if (defined? 'char-ready?) '(char-ready?) - '()) - - *features*)) + '()))) ;;; (OUTPUT-PORT-WIDTH <port>) (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 (string<? (scheme-implementation-version) "1.5") @@ -475,7 +489,7 @@ (define bitwise-xor logxor) (define bitwise-and logand) (define bitwise-not lognot) -(define bit-count logcount) +;;(define bit-count logcount) (define bit-set? logbit?) (define any-bits-set? logtest) (define first-set-bit log2-binary-factors) @@ -493,19 +507,24 @@ (array-shape array))))) ;; DIMENSIONS->UNIFORM-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 (string<? (version) "1.8") + (lambda opt (if (null? opt) + (list->uniform-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 <? <) (define <=? <=) |