diff options
Diffstat (limited to 'guile.init')
| -rw-r--r-- | guile.init | 164 |
1 files changed, 112 insertions, 52 deletions
@@ -3,7 +3,7 @@ ;;; ;;; This code is in the public domain. -(if (string<? (version) "1.6") +(if (not (and (string<=? "1.6" (version)) (string<? (version) "1.7"))) (define-module (ice-9 slib))) ; :no-backtrace (define slib-module (current-module)) @@ -43,11 +43,13 @@ ;;; (implementation-vicinity) should be defined to be the pathname of ;;; the directory where any auxillary files to your Scheme ;;; implementation reside. -(define implementation-vicinity - (let* ((path (or (%search-load-path "ice-9/q.scm") - (error "Could not find ice-9/q.scm in " %load-path))) - (vic (substring path 0 (- (string-length path) 11)))) - (lambda () vic))) +;; (define implementation-vicinity +;; (let* ((path (or (%search-load-path "ice-9/q.scm") +;; (error "Could not find ice-9/q.scm in " %load-path))) +;; (vic (substring path 0 (- (string-length path) 11)))) +;; (lambda () vic))) +;;; Rob Browning says %site-dir exists since Guile-1.6 +(define implementation-vicinity %site-dir) ;;; (library-vicinity) should be defined to be the pathname of the ;;; directory where files of Scheme library functions reside. @@ -56,6 +58,10 @@ (or ;; Use this getenv if your implementation supports it. (and (defined? 'getenv) (getenv "SCHEME_LIBRARY_PATH")) + ;; Rob Browning sent this; I'm not sure its a good idea. + ;; See if we can find slib/guile.init (cf. implementation-vicinity). + (let ((path (%search-load-path "slib/guile.init"))) + (and path (substring path 0 (- (string-length path) 10)))) ;; Use this path if your scheme does not support GETENV ;; or if SCHEME_LIBRARY_PATH is not set. "/usr/lib/slib/" @@ -239,6 +245,14 @@ '(char-ready?) '()))) +;;@ (FILE-POSITION <port> . <k>) +(define (file-position port . args) + (if (null? args) + (ftell port) + (seek port (car args) SEEK_SET))) +(if (string>=? (scheme-implementation-version) "1.8") + (module-replace! (current-module) '(file-position))) + ;;; (OUTPUT-PORT-WIDTH <port>) (define (output-port-width . arg) 79) @@ -257,13 +271,17 @@ ;; "status:stop-sig" shouldn't arise here, since system shouldn't be ;; calling waitpid with WUNTRACED, but allow for it anyway, just in ;; case. -(set! system +(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))))))) +;; This has to be done after the definition so that the original +;; binding will still be visible during the definition. +(if (string>=? (scheme-implementation-version) "1.8") + (module-replace! (current-module) '(system))) ;;; for line-i/o (use-modules (ice-9 popen)) @@ -284,12 +302,16 @@ (re-export read-line!) (re-export write-line))) -(set! delete-file +(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))))) +;; This has to be done after the definition so that the original +;; binding will still be visible during the definition. +(if (string>=? (scheme-implementation-version) "1.8") + (module-replace! (current-module) '(delete-file))) ;;; FORCE-OUTPUT flushes any pending output on optional arg output port ;;; use this definition if your system doesn't have such a procedure. @@ -300,13 +322,18 @@ (define (make-exchanger obj) (lambda (rep) (let ((old obj)) (set! obj rep) old))) -(set! open-file +(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))))) +;; This has to be done after the definition so that the original +;; binding will still be visible during the definition. +(if (string>=? (scheme-implementation-version) "1.8") + (module-replace! (current-module) '(open-file))) + (define (call-with-open-ports . ports) (define proc (car ports)) (cond ((procedure? proc) (set! ports (cdr ports))) @@ -358,48 +385,52 @@ ;;; return if exiting not supported. (define slib:exit quit) -;;; Here for backward compatability -;;(define scheme-file-suffix -;; (let ((suffix (case (software-type) -;; ((nosve) "_scm") -;; (else ".scm")))) -;; (lambda () suffix))) - -;;; (define (guile:wrap-case-insensitive proc) -;;; (lambda args -;;; (save-module-excursion -;;; (lambda () -;;; (set-current-module slib-module) -;;; (let ((old (read-options))) -;;; (dynamic-wind -;;; (lambda () (read-enable 'case-insensitive)) -;;; (lambda () (apply proc args)) -;;; (lambda () (read-options old)))))))) - -;;; (define read (guile:wrap-case-insensitive read)) - -;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever -;;; suffix all the module files in SLIB have. See feature 'SOURCE. -;;; (define slib:load -;;; (let ((load-file (guile:wrap-case-insensitive load))) -;;; (lambda (<pathname>) -;;; (load-file (string-append <pathname> (scheme-file-suffix)))))) -(define (slib:load-helper loader) - (lambda (name) - (save-module-excursion - (lambda () - (set-current-module slib-module) - (let ((errinfo (catch 'system-error - (lambda () (loader name) #f) - (lambda args args)))) - (if (and errinfo - (catch 'system-error - (lambda () (loader (string-append name ".scm")) #f) - (lambda args args))) - (apply throw errinfo))))))) -(define slib:load (slib:load-helper load)) -(define slib:load-from-path (slib:load-helper load-from-path)) - +(cond ((string>=? (scheme-implementation-version) "1.8") + (define (slib:load-helper loader) + (lambda (name) + (save-module-excursion + (lambda () + (set-current-module slib-module) + (let ((errinfo (catch 'system-error + (lambda () (loader name) #f) + (lambda args args)))) + (if (and errinfo + (catch 'system-error + (lambda () (loader (string-append name ".scm")) #f) + (lambda args args))) + (apply throw errinfo))))))) + (define slib:load (slib:load-helper load)) + (define slib:load-from-path (slib:load-helper load-from-path)) + ) + (else + ;;Here for backward compatability + (define scheme-file-suffix + (let ((suffix (case (software-type) + ((nosve) "_scm") + (else ".scm")))) + (lambda () suffix))) + + (define (guile:wrap-case-insensitive proc) + (lambda args + (save-module-excursion + (lambda () + (set-current-module slib-module) + (let ((old (read-options))) + (dynamic-wind + (lambda () (read-enable 'case-insensitive)) + (lambda () (apply proc args)) + (lambda () (read-options old)))))))) + + (define read (guile:wrap-case-insensitive read)) + + (define slib:load + (let ((load-file (guile:wrap-case-insensitive load))) + (lambda (<pathname>) + (load-file (string-append <pathname> (scheme-file-suffix)))))) + )) + +;;;(SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever +;;;suffix all the module files in SLIB have. See feature 'SOURCE. (define slib:load-source slib:load) ;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced @@ -412,6 +443,15 @@ (define (defmacro:expand* x) (require 'defmacroexpand) (apply defmacro:expand* x '())) +;@ +(define gentemp + (let ((*gensym-counter* -1)) + (lambda () + (set! *gensym-counter* (+ *gensym-counter* 1)) + (string->symbol + (string-append "slib:G" (number->string *gensym-counter*)))))) +(if (string>=? (scheme-implementation-version) "1.8") + (module-replace! (current-module) '(gentemp))) ;;; If your implementation provides R4RS macros: (define macro:eval slib:eval) @@ -507,13 +547,18 @@ (array-shape array))))) ;; DIMENSIONS->UNIFORM-ARRAY and list->uniform-array in Guile-1.6.4 ;; cannot make empty arrays. -(set! make-array +(define 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))))))) +;; This has to be done after the definition so that the original +;; binding will still be visible during the definition. +(if (string>=? (scheme-implementation-version) "1.8") + (module-replace! (current-module) '(make-array))) + (define create-array make-array) (define (make-uniform-wrapper prot) (if (string? prot) (set! prot (string->number prot))) @@ -602,6 +647,18 @@ (if (not (defined? 'random:chunk)) (define (random:chunk sta) (random 256 sta))) +;;; workaround for Guile 1.6.7 bug +(cond ((or (array? 'guile) (array? '(1 6 7))) + (define array? + (let ((old-array? array?)) + (lambda (obj) + (and (old-array? obj) + (not (or (list? obj) + (symbol? obj) + (record? obj))))))) + (if (string>=? (scheme-implementation-version) "1.8") + (module-replace! (current-module) '(array?))))) + ;;; 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)) @@ -615,4 +672,7 @@ (define >? >) (define >=? >=) +(if (string>=? (scheme-implementation-version) "1.8") + (module-replace! (current-module) '(provide provided?))) + (slib:load (in-vicinity (library-vicinity) "require")) |