Commit | Line | Data |
---|---|---|
5d3af6f2 MV |
1 | ;;;; Copyright (C) 2003 Free Software Foundation, Inc. |
2 | ;;;; | |
73be1d9e MV |
3 | ;;;; This library is free software; you can redistribute it and/or |
4 | ;;;; modify it under the terms of the GNU Lesser General Public | |
5 | ;;;; License as published by the Free Software Foundation; either | |
6 | ;;;; version 2.1 of the License, or (at your option) any later version. | |
7 | ;;;; | |
8 | ;;;; This library is distributed in the hope that it will be useful, | |
5d3af6f2 | 9 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
73be1d9e MV |
10 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
11 | ;;;; Lesser General Public License for more details. | |
12 | ;;;; | |
13 | ;;;; You should have received a copy of the GNU Lesser General Public | |
14 | ;;;; License along with this library; if not, write to the Free Software | |
15 | ;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA | |
5d3af6f2 MV |
16 | ;;;; |
17 | ||
18 | ;;;; Deprecated definitions. | |
19 | ||
20 | ;; This method of dynamically linking Guile Extensions is deprecated. | |
21 | ;; Use `load-extension' explicitely from Scheme code instead. | |
22 | ||
23 | (define (split-c-module-name str) | |
24 | (let loop ((rev '()) | |
25 | (start 0) | |
26 | (pos 0) | |
27 | (end (string-length str))) | |
28 | (cond | |
29 | ((= pos end) | |
30 | (reverse (cons (string->symbol (substring str start pos)) rev))) | |
31 | ((eq? (string-ref str pos) #\space) | |
32 | (loop (cons (string->symbol (substring str start pos)) rev) | |
33 | (+ pos 1) | |
34 | (+ pos 1) | |
35 | end)) | |
36 | (else | |
37 | (loop rev start (+ pos 1) end))))) | |
38 | ||
39 | (define (convert-c-registered-modules dynobj) | |
40 | (let ((res (map (lambda (c) | |
41 | (list (split-c-module-name (car c)) (cdr c) dynobj)) | |
42 | (c-registered-modules)))) | |
43 | (c-clear-registered-modules) | |
44 | res)) | |
45 | ||
46 | (define registered-modules '()) | |
47 | ||
48 | (define (register-modules dynobj) | |
49 | (set! registered-modules | |
50 | (append! (convert-c-registered-modules dynobj) | |
51 | registered-modules))) | |
52 | ||
53 | (define (warn-autoload-deprecation modname) | |
54 | (issue-deprecation-warning | |
55 | "Autoloading of compiled code modules is deprecated." | |
56 | "Write a Scheme file instead that uses `load-extension'.") | |
57 | (issue-deprecation-warning | |
58 | (simple-format #f "(You just autoloaded module ~S.)" modname))) | |
59 | ||
60 | (define (init-dynamic-module modname) | |
61 | ;; Register any linked modules which have been registered on the C level | |
62 | (register-modules #f) | |
63 | (or-map (lambda (modinfo) | |
64 | (if (equal? (car modinfo) modname) | |
65 | (begin | |
66 | (warn-autoload-deprecation modname) | |
67 | (set! registered-modules (delq! modinfo registered-modules)) | |
68 | (let ((mod (resolve-module modname #f))) | |
69 | (save-module-excursion | |
70 | (lambda () | |
71 | (set-current-module mod) | |
72 | (set-module-public-interface! mod mod) | |
73 | (dynamic-call (cadr modinfo) (caddr modinfo)) | |
74 | )) | |
75 | #t)) | |
76 | #f)) | |
77 | registered-modules)) | |
78 | ||
79 | (define (dynamic-maybe-call name dynobj) | |
80 | (catch #t ; could use false-if-exception here | |
81 | (lambda () | |
82 | (dynamic-call name dynobj)) | |
83 | (lambda args | |
84 | #f))) | |
85 | ||
86 | (define (dynamic-maybe-link filename) | |
87 | (catch #t ; could use false-if-exception here | |
88 | (lambda () | |
89 | (dynamic-link filename)) | |
90 | (lambda args | |
91 | #f))) | |
92 | ||
93 | (define (find-and-link-dynamic-module module-name) | |
94 | (define (make-init-name mod-name) | |
95 | (string-append "scm_init" | |
96 | (list->string (map (lambda (c) | |
97 | (if (or (char-alphabetic? c) | |
98 | (char-numeric? c)) | |
99 | c | |
100 | #\_)) | |
101 | (string->list mod-name))) | |
102 | "_module")) | |
103 | ||
104 | ;; Put the subdirectory for this module in the car of SUBDIR-AND-LIBNAME, | |
105 | ;; and the `libname' (the name of the module prepended by `lib') in the cdr | |
106 | ;; field. For example, if MODULE-NAME is the list (inet tcp-ip udp), then | |
107 | ;; SUBDIR-AND-LIBNAME will be the pair ("inet/tcp-ip" . "libudp"). | |
108 | (let ((subdir-and-libname | |
109 | (let loop ((dirs "") | |
110 | (syms module-name)) | |
111 | (if (null? (cdr syms)) | |
112 | (cons dirs (string-append "lib" (symbol->string (car syms)))) | |
113 | (loop (string-append dirs (symbol->string (car syms)) "/") | |
114 | (cdr syms))))) | |
115 | (init (make-init-name (apply string-append | |
116 | (map (lambda (s) | |
117 | (string-append "_" | |
118 | (symbol->string s))) | |
119 | module-name))))) | |
120 | (let ((subdir (car subdir-and-libname)) | |
121 | (libname (cdr subdir-and-libname))) | |
122 | ||
123 | ;; Now look in each dir in %LOAD-PATH for `subdir/libfoo.la'. If that | |
124 | ;; file exists, fetch the dlname from that file and attempt to link | |
125 | ;; against it. If `subdir/libfoo.la' does not exist, or does not seem | |
126 | ;; to name any shared library, look for `subdir/libfoo.so' instead and | |
127 | ;; link against that. | |
128 | (let check-dirs ((dir-list %load-path)) | |
129 | (if (null? dir-list) | |
130 | #f | |
131 | (let* ((dir (in-vicinity (car dir-list) subdir)) | |
132 | (sharlib-full | |
133 | (or (try-using-libtool-name dir libname) | |
134 | (try-using-sharlib-name dir libname)))) | |
135 | (if (and sharlib-full (file-exists? sharlib-full)) | |
136 | (link-dynamic-module sharlib-full init) | |
137 | (check-dirs (cdr dir-list))))))))) | |
138 | ||
139 | (define (try-using-libtool-name libdir libname) | |
140 | (let ((libtool-filename (in-vicinity libdir | |
141 | (string-append libname ".la")))) | |
142 | (and (file-exists? libtool-filename) | |
143 | libtool-filename))) | |
144 | ||
145 | (define (try-using-sharlib-name libdir libname) | |
146 | (in-vicinity libdir (string-append libname ".so"))) | |
147 | ||
148 | (define (link-dynamic-module filename initname) | |
149 | ;; Register any linked modules which have been registered on the C level | |
150 | (register-modules #f) | |
151 | (let ((dynobj (dynamic-link filename))) | |
152 | (dynamic-call initname dynobj) | |
153 | (register-modules dynobj))) | |
154 | ||
155 | (define (try-module-linked module-name) | |
156 | (init-dynamic-module module-name)) | |
157 | ||
158 | (define (try-module-dynamic-link module-name) | |
159 | (and (find-and-link-dynamic-module module-name) | |
160 | (init-dynamic-module module-name))) |