--- slib/guile.init.dpkg-dist 2010-05-06 08:20:58.000000000 +0200 +++ slib/guile.init 2012-10-22 00:06:21.457707670 +0200 @@ -7,11 +7,29 @@ (define-module (ice-9 slib))) ; :no-backtrace (define slib-module (current-module)) -(define base:define define) -(define define - (procedure->memoizing-macro - (lambda (exp env) - (cons (if (= 1 (length env)) 'define-public 'base:define) (cdr exp))))) +;;(define base:define define) +;; The following line should work for all version >= 1.6 +(local-define '(base:define) (local-ref '(define))) +(cond-expand + (guile-2 + (define-syntax define + (let* ((syntax-object-wrap (lambda (s) (vector-ref s 2))) + (wrap-subst cdr) + (syntax-toplevel? + (lambda (s) + (null? (cdr (wrap-subst (syntax-object-wrap s))))))) + (lambda (x) + (syntax-case x () + ((_ f0 f1 ...) + (syntax-toplevel? #'f0) + (syntax (define-public f0 f1 ...))) + ((_ f0 f1 ...) + (syntax (base:define f0 f1 ...)))))))) + (guile + (define define + (procedure->memoizing-macro + (lambda (exp env) + (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)) @@ -274,12 +292,13 @@ ;; calling waitpid with WUNTRACED, but allow for it anyway, just in ;; case. (define system - (let ((guile-core-system system)) + (let ((guile-core-system (nested-ref the-root-module '(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") @@ -305,7 +324,7 @@ (re-export write-line))) (define delete-file - (let ((guile-core-delete-file delete-file)) + (let ((guile-core-delete-file (nested-ref the-root-module '(delete-file)))) (lambda (filename) (catch 'system-error (lambda () (guile-core-delete-file filename) #t) @@ -325,7 +344,7 @@ (define (make-exchanger obj) (lambda (rep) (let ((old obj)) (set! obj rep) old))) (define open-file - (let ((guile-core-open-file open-file)) + (let ((guile-core-open-file (nested-ref the-root-module '(open-file)))) (lambda (filename modes) (guile-core-open-file filename (if (symbol? modes) @@ -346,17 +365,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) - (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 '" "'")))) +;; 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) @@ -369,7 +387,7 @@ ;;; 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)) + (set! char-code-limit 128)) ;;; MOST-POSITIVE-FIXNUM is used in modular.scm ;;(define most-positive-fixnum #x0FFFFFFF) @@ -386,49 +404,55 @@ ;;; return if exiting not supported. (define slib:exit quit) +(define slib:load #f) +(define slib:load-from-path #f) +(define read #f) (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)) + (let ((slib:load-helper + (lambda (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))))))))) + (set! slib:load (slib:load-helper load)) + (set! slib:load-from-path (slib:load-helper load-from-path))) + (set! read (nested-ref the-root-module '(read))) ) (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 () - (load-file (string-append (scheme-file-suffix)))))) - )) + (let ((scheme-file-suffix + (let ((suffix (case (software-type) + ((nosve) "_scm") + (else ".scm")))) + (lambda () suffix))) + (guile:wrap-case-insensitive + (lambda (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)))))))))) + + (set! read + (guile:wrap-case-insensitive + (nested-ref the-root-module '(read)))) + + (set! slib:load + (let ((load-file (guile:wrap-case-insensitive load))) + (lambda () + (load-file (string-append (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. @@ -645,20 +669,24 @@ (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))) +;;(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?))))) +(base:define array? #f) +(let ((guile-core-array? (nested-ref the-root-module '(array?)))) + (cond ((or (guile-core-array? 'guile) (guile-core-array? '(1 6 7))) + (set! array? + (lambda (obj) + (and (guile-core-array? obj) + (not (or (list? obj) + (symbol? obj) + (record? obj)))))) + (export array?) + (if (string>=? (scheme-implementation-version) "1.8") + (module-replace! (current-module) '(array?)))) + (else + (set! array? guile-core-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))