summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--ice-9/Makefile.am2
-rw-r--r--ice-9/deprecated.scm185
2 files changed, 186 insertions, 1 deletions
diff --git a/ice-9/Makefile.am b/ice-9/Makefile.am
index 13adb5897..e1c1cca6c 100644
--- a/ice-9/Makefile.am
+++ b/ice-9/Makefile.am
@@ -35,7 +35,7 @@ ice9_sources = \
streams.scm string-fun.scm syncase.scm threads.scm \
buffered-input.scm time.scm history.scm channel.scm \
pretty-print.scm ftw.scm gap-buffer.scm occam-channel.scm \
- weak-vector.scm
+ weak-vector.scm deprecated.scm
subpkgdatadir = $(pkgdatadir)/${GUILE_EFFECTIVE_VERSION}/ice-9
subpkgdata_DATA = $(ice9_sources)
diff --git a/ice-9/deprecated.scm b/ice-9/deprecated.scm
new file mode 100644
index 000000000..3f1b14846
--- /dev/null
+++ b/ice-9/deprecated.scm
@@ -0,0 +1,185 @@
+;;;; Copyright (C) 2003 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;; Boston, MA 02111-1307 USA
+;;;;
+;;;; As a special exception, the Free Software Foundation gives permission
+;;;; for additional uses of the text contained in its release of GUILE.
+;;;;
+;;;; The exception is that, if you link the GUILE library with other files
+;;;; to produce an executable, this does not by itself cause the
+;;;; resulting executable to be covered by the GNU General Public License.
+;;;; Your use of that executable is in no way restricted on account of
+;;;; linking the GUILE library code into it.
+;;;;
+;;;; This exception does not however invalidate any other reasons why
+;;;; the executable file might be covered by the GNU General Public License.
+;;;;
+;;;; This exception applies only to the code released by the
+;;;; Free Software Foundation under the name GUILE. If you copy
+;;;; code from other Free Software Foundation releases into a copy of
+;;;; GUILE, as the General Public License permits, the exception does
+;;;; not apply to the code that you add in this way. To avoid misleading
+;;;; anyone as to the status of such modified files, you must delete
+;;;; this exception notice from them.
+;;;;
+;;;; If you write modifications of your own for GUILE, it is your choice
+;;;; whether to permit this exception to apply to your modifications.
+;;;; If you do not wish that, delete this exception notice.
+;;;;
+
+;;;; Deprecated definitions.
+
+;; This method of dynamically linking Guile Extensions is deprecated.
+;; Use `load-extension' explicitely from Scheme code instead.
+
+(define (split-c-module-name str)
+ (let loop ((rev '())
+ (start 0)
+ (pos 0)
+ (end (string-length str)))
+ (cond
+ ((= pos end)
+ (reverse (cons (string->symbol (substring str start pos)) rev)))
+ ((eq? (string-ref str pos) #\space)
+ (loop (cons (string->symbol (substring str start pos)) rev)
+ (+ pos 1)
+ (+ pos 1)
+ end))
+ (else
+ (loop rev start (+ pos 1) end)))))
+
+(define (convert-c-registered-modules dynobj)
+ (let ((res (map (lambda (c)
+ (list (split-c-module-name (car c)) (cdr c) dynobj))
+ (c-registered-modules))))
+ (c-clear-registered-modules)
+ res))
+
+(define registered-modules '())
+
+(define (register-modules dynobj)
+ (set! registered-modules
+ (append! (convert-c-registered-modules dynobj)
+ registered-modules)))
+
+(define (warn-autoload-deprecation modname)
+ (issue-deprecation-warning
+ "Autoloading of compiled code modules is deprecated."
+ "Write a Scheme file instead that uses `load-extension'.")
+ (issue-deprecation-warning
+ (simple-format #f "(You just autoloaded module ~S.)" modname)))
+
+(define (init-dynamic-module modname)
+ ;; Register any linked modules which have been registered on the C level
+ (register-modules #f)
+ (or-map (lambda (modinfo)
+ (if (equal? (car modinfo) modname)
+ (begin
+ (warn-autoload-deprecation modname)
+ (set! registered-modules (delq! modinfo registered-modules))
+ (let ((mod (resolve-module modname #f)))
+ (save-module-excursion
+ (lambda ()
+ (set-current-module mod)
+ (set-module-public-interface! mod mod)
+ (dynamic-call (cadr modinfo) (caddr modinfo))
+ ))
+ #t))
+ #f))
+ registered-modules))
+
+(define (dynamic-maybe-call name dynobj)
+ (catch #t ; could use false-if-exception here
+ (lambda ()
+ (dynamic-call name dynobj))
+ (lambda args
+ #f)))
+
+(define (dynamic-maybe-link filename)
+ (catch #t ; could use false-if-exception here
+ (lambda ()
+ (dynamic-link filename))
+ (lambda args
+ #f)))
+
+(define (find-and-link-dynamic-module module-name)
+ (define (make-init-name mod-name)
+ (string-append "scm_init"
+ (list->string (map (lambda (c)
+ (if (or (char-alphabetic? c)
+ (char-numeric? c))
+ c
+ #\_))
+ (string->list mod-name)))
+ "_module"))
+
+ ;; Put the subdirectory for this module in the car of SUBDIR-AND-LIBNAME,
+ ;; and the `libname' (the name of the module prepended by `lib') in the cdr
+ ;; field. For example, if MODULE-NAME is the list (inet tcp-ip udp), then
+ ;; SUBDIR-AND-LIBNAME will be the pair ("inet/tcp-ip" . "libudp").
+ (let ((subdir-and-libname
+ (let loop ((dirs "")
+ (syms module-name))
+ (if (null? (cdr syms))
+ (cons dirs (string-append "lib" (symbol->string (car syms))))
+ (loop (string-append dirs (symbol->string (car syms)) "/")
+ (cdr syms)))))
+ (init (make-init-name (apply string-append
+ (map (lambda (s)
+ (string-append "_"
+ (symbol->string s)))
+ module-name)))))
+ (let ((subdir (car subdir-and-libname))
+ (libname (cdr subdir-and-libname)))
+
+ ;; Now look in each dir in %LOAD-PATH for `subdir/libfoo.la'. If that
+ ;; file exists, fetch the dlname from that file and attempt to link
+ ;; against it. If `subdir/libfoo.la' does not exist, or does not seem
+ ;; to name any shared library, look for `subdir/libfoo.so' instead and
+ ;; link against that.
+ (let check-dirs ((dir-list %load-path))
+ (if (null? dir-list)
+ #f
+ (let* ((dir (in-vicinity (car dir-list) subdir))
+ (sharlib-full
+ (or (try-using-libtool-name dir libname)
+ (try-using-sharlib-name dir libname))))
+ (if (and sharlib-full (file-exists? sharlib-full))
+ (link-dynamic-module sharlib-full init)
+ (check-dirs (cdr dir-list)))))))))
+
+(define (try-using-libtool-name libdir libname)
+ (let ((libtool-filename (in-vicinity libdir
+ (string-append libname ".la"))))
+ (and (file-exists? libtool-filename)
+ libtool-filename)))
+
+(define (try-using-sharlib-name libdir libname)
+ (in-vicinity libdir (string-append libname ".so")))
+
+(define (link-dynamic-module filename initname)
+ ;; Register any linked modules which have been registered on the C level
+ (register-modules #f)
+ (let ((dynobj (dynamic-link filename)))
+ (dynamic-call initname dynobj)
+ (register-modules dynobj)))
+
+(define (try-module-linked module-name)
+ (init-dynamic-module module-name))
+
+(define (try-module-dynamic-link module-name)
+ (and (find-and-link-dynamic-module module-name)
+ (init-dynamic-module module-name)))