diff options
Diffstat (limited to 'guile.init')
| -rwxr-xr-x[-rw-r--r--] | guile.init | 392 |
1 files changed, 308 insertions, 84 deletions
diff --git a/guile.init b/guile.init index 1b59833..a728e33 100644..100755 --- a/guile.init +++ b/guile.init @@ -3,8 +3,166 @@ ;;; ;;; This code is in the public domain. -(if (not (and (string<=? "1.6" (version)) (string<? (version) "1.8.3"))) - (define-module (ice-9 slib))) ; :no-backtrace +(cond-expand + (guile-2 + (include "guile-2.init")) + (else + +(cond + ((and (string<=? "1.6" (version)) (string<? (version) "1.8.3"))) + ((string>=? (version) "1.8.6") + (define-module (ice-9 slib) + :export + ( + <=? + <? + =? + >=? + >? + A:bool + A:fixN16b + A:fixN32b + A:fixN64b + A:fixN8b + A:fixZ16b + A:fixZ32b + A:fixZ64b + A:fixZ8b + A:floC128b + A:floC16b + A:floC32b + A:floC64b + A:floR128b + A:floR128d + A:floR16b + A:floR32b + A:floR32d + A:floR64b + A:floR64d + a:bool + a:fixn16b + a:fixn32b + a:fixn64b + a:fixn8b + a:fixz16b + a:fixz32b + a:fixz64b + a:fixz8b + a:floc128b + a:floc16b + a:floc32b + a:floc64b + a:flor128b + a:flor128d + a:flor16b + a:flor32b + a:flor32d + a:flor64b + a:flor64d + any-bits-set? + arithmetic-shift + array-indexes + array-null? + array:copy! + ;; ac32 + ;; ac64 + ;; ar32 + ;; ar64 + ;; as16 + ;; as32 + ;; as64 + ;; as8 + ;; at1 + ;; au16 + ;; au32 + ;; au64 + ;; au8 + bit-field + bit-reverse + bit-set? + bitwise-and + bitwise-if + bitwise-ior + bitwise-merge + bitwise-not + bitwise-xor + booleans->integer + browse-url + call-with-open-ports + copy-bit + copy-bit-field + create-array + ;;define + defmacro:eval + defmacro:expand* + defmacro:load + ;;delete-file + difftime + ;;file-position + first-set-bit + gentemp + home-vicinity + implementation-vicinity + integer->list + library-vicinity + list->array + list->integer + log2-binary-factors + logical:ash + logical:bit-extract + logical:integer-expt + logical:integer-length + ;;logical:ipow-by-squaring + logical:logand + logical:logcount + logical:logior + logical:lognot + logical:logxor + macro:eval + macro:load + make-array + make-exchanger + make-random-state + ;;make-uniform-wrapper + make-vicinity + ;; nil + offset-time + ;;open-file + output-port-height + output-port-width + pathname->vicinity + program-vicinity + random:chunk + reverse-bit-field + rotate-bit-field + scheme-implementation-home-page + scheme-implementation-type + scheme-implementation-version + ;; slib-module + slib:error + slib:eval + slib:eval-load + slib:exit + ;; slib:features + slib:form-feed + slib:load + slib:load-compiled + slib:load-source + slib:tab + slib:warn + software-type + sub-vicinity + ;;system + system->line + ;; t + user-vicinity + vector->array + ;; vicinity:suffix? + ;; with-load-pathname + ) + :no-backtrace)) + (else + (define-module (ice-9 slib)))) (define slib-module (current-module)) (define base:define define) @@ -14,10 +172,10 @@ (cons (if (= 1 (length env)) 'define-public 'base:define) (cdr exp))))) ;;; Hack to make syncase macros work in the slib module -(if (nested-ref the-root-module '(app modules ice-9 syncase)) - (set-object-property! (module-local-variable (current-module) 'define) - '*sc-expander* - '(define))) + (if (nested-ref the-root-module '(app modules ice-9 syncase)) + (set-object-property! (module-local-variable (current-module) 'define) + '*sc-expander* + '(define))) ;;; (software-type) should be set to the generic operating system type. ;;; UNIX, VMS, MACOS, AMIGA and MS-DOS are supported. @@ -49,11 +207,14 @@ ;; (vic (substring path 0 (- (string-length path) 11)))) ;; (lambda () vic))) ;; -;;; Rob Browning says %site-dir exists since Guile-1.6 +;;; Rob Browning says %site-dir exists since Guile-1.6. But Thomas +;;; Bushnell points out that %site-dir mashes the slibcat for all +;;; versions together. %library-dir (also since Guile-1.6) is the +;;; versioned directory. (define implementation-vicinity (cond ((and (defined? 'getenv) (getenv "GUILE_IMPLEMENTATION_PATH")) => (lambda (path) (lambda () path))) - (else %site-dir))) + (else %library-dir))) ;;; (library-vicinity) should be defined to be the pathname of the ;;; directory where files of Scheme library functions reside. @@ -63,13 +224,12 @@ ;; 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)))) + ;; 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/" - (in-vicinity (implementation-vicinity) "slib/")))) + "/usr/share/slib/"))) (lambda () library-path))) ;;; (home-vicinity) should return the vicinity of the user's HOME @@ -214,7 +374,7 @@ ;; Other common features -;;; srfi-0 ;srfi-0, COND-EXPAND finds all srfi-* + srfi-0 ;srfi-0, COND-EXPAND finds all srfi-* ;;; sicp ;runs code from Structure and ;Interpretation of Computer ;Programs by Abelson and Sussman. @@ -271,12 +431,12 @@ ;; 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))))))) + (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") @@ -343,17 +503,16 @@ (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) +;; 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 '" "'")))) + (try "netscape '" "'"))) ;;; "rationalize" adjunct procedures. ;;(define (find-ratio x e) @@ -365,8 +524,13 @@ ;;; CHAR-CODE-LIMIT is one greater than the largest integer which can ;;; be returned by CHAR->INTEGER. ;; In Guile-1.8.0: (string>? (string #\000) (string #\200)) ==> #t -(if (string=? (version) "1.8.0") - (define char-code-limit 128)) +(define char-code-limit + (if (string=? (version) "1.8.0") + 128 + char-code-limit)) +(if (string>=? (scheme-implementation-version) "1.8") + (module-replace! (current-module) '(char-code-limit))) + ;;; MOST-POSITIVE-FIXNUM is used in modular.scm ;;(define most-positive-fixnum #x0FFFFFFF) @@ -383,49 +547,54 @@ ;;; return if exiting not supported. (define slib:exit quit) -(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))) +;; for (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))))))) + +;; for (string<? (scheme-implementation-version) "1.8") +(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)))))))) +;;Here for backward compatability +(define scheme-file-suffix + (if (string>=? (scheme-implementation-version) "1.8") + scheme-file-suffix + (let ((suffix (case (software-type) + ((nosve) "_scm") + (else ".scm")))) + (lambda () suffix)))) +(define read + (if (string>=? (scheme-implementation-version) "1.8") + read + (guile:wrap-case-insensitive read))) +(if (string>=? (scheme-implementation-version) "1.8") + (module-replace! (current-module) '(scheme-file-suffix read))) + +(define slib:load + (if (string>=? (scheme-implementation-version) "1.8") + (slib:load-helper load) + (let ((load-file (guile:wrap-case-insensitive load))) (lambda (<pathname>) - (load-file (string-append <pathname> (scheme-file-suffix)))))) - )) + (load-file (string-append <pathname> (scheme-file-suffix))))))) +;;(define slib:load-from-path (slib:load-helper load-from-path)) ;;;(SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever ;;;suffix all the module files in SLIB have. See feature 'SOURCE. @@ -557,6 +726,58 @@ (if (string>=? (scheme-implementation-version) "1.8") (module-replace! (current-module) '(make-array))) +(define (list->array rank proto lst) + (define dimensions + (do ((shp '() (cons (length row) shp)) + (row lst (car lst)) + (rnk (+ -1 rank) (+ -1 rnk))) + ((negative? rnk) (reverse shp)))) + (let ((nra (apply make-array proto dimensions))) + (define (l2ra dims idxs row) + (cond ((null? dims) + (apply array-set! nra row (reverse idxs))) + ((if (not (eqv? (car dims) (length row))) + (slib:error 'list->array + 'non-rectangular 'array dims dimensions)) + (do ((idx 0 (+ 1 idx)) + (row row (cdr row))) + ((>= idx (car dims))) + (l2ra (cdr dims) (cons idx idxs) (car row)))))) + (l2ra dimensions '() lst) + nra)) +(if (string>=? (scheme-implementation-version) "1.8") + (module-replace! (current-module) '(list->array))) + +(define (vector->array vect prototype . dimensions) + (define vdx (vector-length vect)) + (if (not (eqv? vdx (apply * dimensions))) + (slib:error 'vector->array vdx '<> (cons '* dimensions))) + (let ((ra (apply make-array prototype dimensions))) + (define (v2ra dims idxs) + (cond ((null? dims) + (set! vdx (+ -1 vdx)) + (apply array-set! ra (vector-ref vect vdx) (reverse idxs))) + (else + (do ((idx (+ -1 (car dims)) (+ -1 idx))) + ((negative? idx) vect) + (v2ra (cdr dims) (cons idx idxs)))))) + (v2ra dimensions '()) + ra)) +(define (array->vector ra) + (define dims (array-dimensions ra)) + (let* ((vdx (apply * dims)) + (vect (make-vector vdx))) + (define (ra2v dims idxs) + (if (null? dims) + (let ((val (apply array-ref ra (reverse idxs)))) + (set! vdx (+ -1 vdx)) + (vector-set! vect vdx val)) + (do ((idx (+ -1 (car dims)) (+ -1 idx))) + ((negative? idx) vect) + (ra2v (cdr dims) (cons idx idxs))))) + (ra2v dims '()) + vect)) + (define create-array make-array) (define (make-uniform-wrapper prot) (if (string? prot) (set! prot (string->number prot))) @@ -642,20 +863,21 @@ (require 'object->string) (set! seed (object->limited-string seed 50))))) (seed->random-state seed))) -(if (not (defined? 'random:chunk)) - (define (random:chunk sta) (random 256 sta))) +(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?))))) +(define array? + (if (or (array? 'guile) (array? '(1 6 7))) + (let ((old-array? array?)) + (lambda (obj) + (and (old-array? obj) + (not (or (list? obj) + (symbol? obj) + (record? obj)))))) + array?)) +(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)) @@ -670,7 +892,9 @@ (define >? >) (define >=? >=) +(slib:load (in-vicinity (library-vicinity) "require")) + (if (string>=? (scheme-implementation-version) "1.8") (module-replace! (current-module) '(provide provided?))) -(slib:load (in-vicinity (library-vicinity) "require")) +)) ;; end of cond-expand clause for Guile < 2.0 |