summaryrefslogtreecommitdiffstats
path: root/guile.init
diff options
context:
space:
mode:
Diffstat (limited to 'guile.init')
-rw-r--r--guile.init164
1 files changed, 112 insertions, 52 deletions
diff --git a/guile.init b/guile.init
index 412a6b4..1ce1bd1 100644
--- a/guile.init
+++ b/guile.init
@@ -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/share/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"))