Commit | Line | Data |
---|---|---|
1443643f | 1 | ;;;; Copyright (C) 2003, 2005, 2006 Free Software Foundation, Inc. |
5d3af6f2 | 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 | |
92205699 | 15 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA |
5d3af6f2 MV |
16 | ;;;; |
17 | ||
18 | ;;;; Deprecated definitions. | |
19 | ||
5b943a3f MV |
20 | (define substring-move-left! substring-move!) |
21 | (define substring-move-right! substring-move!) | |
22 | ||
5d3af6f2 MV |
23 | ;; This method of dynamically linking Guile Extensions is deprecated. |
24 | ;; Use `load-extension' explicitely from Scheme code instead. | |
25 | ||
26 | (define (split-c-module-name str) | |
27 | (let loop ((rev '()) | |
28 | (start 0) | |
29 | (pos 0) | |
30 | (end (string-length str))) | |
31 | (cond | |
32 | ((= pos end) | |
33 | (reverse (cons (string->symbol (substring str start pos)) rev))) | |
34 | ((eq? (string-ref str pos) #\space) | |
35 | (loop (cons (string->symbol (substring str start pos)) rev) | |
36 | (+ pos 1) | |
37 | (+ pos 1) | |
38 | end)) | |
39 | (else | |
40 | (loop rev start (+ pos 1) end))))) | |
41 | ||
42 | (define (convert-c-registered-modules dynobj) | |
43 | (let ((res (map (lambda (c) | |
44 | (list (split-c-module-name (car c)) (cdr c) dynobj)) | |
45 | (c-registered-modules)))) | |
46 | (c-clear-registered-modules) | |
47 | res)) | |
48 | ||
49 | (define registered-modules '()) | |
50 | ||
51 | (define (register-modules dynobj) | |
52 | (set! registered-modules | |
53 | (append! (convert-c-registered-modules dynobj) | |
54 | registered-modules))) | |
55 | ||
56 | (define (warn-autoload-deprecation modname) | |
57 | (issue-deprecation-warning | |
58 | "Autoloading of compiled code modules is deprecated." | |
59 | "Write a Scheme file instead that uses `load-extension'.") | |
60 | (issue-deprecation-warning | |
61 | (simple-format #f "(You just autoloaded module ~S.)" modname))) | |
62 | ||
63 | (define (init-dynamic-module modname) | |
64 | ;; Register any linked modules which have been registered on the C level | |
65 | (register-modules #f) | |
66 | (or-map (lambda (modinfo) | |
67 | (if (equal? (car modinfo) modname) | |
68 | (begin | |
69 | (warn-autoload-deprecation modname) | |
70 | (set! registered-modules (delq! modinfo registered-modules)) | |
71 | (let ((mod (resolve-module modname #f))) | |
72 | (save-module-excursion | |
73 | (lambda () | |
74 | (set-current-module mod) | |
75 | (set-module-public-interface! mod mod) | |
76 | (dynamic-call (cadr modinfo) (caddr modinfo)) | |
77 | )) | |
78 | #t)) | |
79 | #f)) | |
80 | registered-modules)) | |
81 | ||
82 | (define (dynamic-maybe-call name dynobj) | |
83 | (catch #t ; could use false-if-exception here | |
84 | (lambda () | |
85 | (dynamic-call name dynobj)) | |
86 | (lambda args | |
87 | #f))) | |
88 | ||
89 | (define (dynamic-maybe-link filename) | |
90 | (catch #t ; could use false-if-exception here | |
91 | (lambda () | |
92 | (dynamic-link filename)) | |
93 | (lambda args | |
94 | #f))) | |
95 | ||
96 | (define (find-and-link-dynamic-module module-name) | |
97 | (define (make-init-name mod-name) | |
98 | (string-append "scm_init" | |
99 | (list->string (map (lambda (c) | |
100 | (if (or (char-alphabetic? c) | |
101 | (char-numeric? c)) | |
102 | c | |
103 | #\_)) | |
104 | (string->list mod-name))) | |
105 | "_module")) | |
106 | ||
107 | ;; Put the subdirectory for this module in the car of SUBDIR-AND-LIBNAME, | |
108 | ;; and the `libname' (the name of the module prepended by `lib') in the cdr | |
109 | ;; field. For example, if MODULE-NAME is the list (inet tcp-ip udp), then | |
110 | ;; SUBDIR-AND-LIBNAME will be the pair ("inet/tcp-ip" . "libudp"). | |
111 | (let ((subdir-and-libname | |
112 | (let loop ((dirs "") | |
113 | (syms module-name)) | |
114 | (if (null? (cdr syms)) | |
115 | (cons dirs (string-append "lib" (symbol->string (car syms)))) | |
116 | (loop (string-append dirs (symbol->string (car syms)) "/") | |
117 | (cdr syms))))) | |
118 | (init (make-init-name (apply string-append | |
119 | (map (lambda (s) | |
120 | (string-append "_" | |
121 | (symbol->string s))) | |
122 | module-name))))) | |
123 | (let ((subdir (car subdir-and-libname)) | |
124 | (libname (cdr subdir-and-libname))) | |
125 | ||
126 | ;; Now look in each dir in %LOAD-PATH for `subdir/libfoo.la'. If that | |
127 | ;; file exists, fetch the dlname from that file and attempt to link | |
128 | ;; against it. If `subdir/libfoo.la' does not exist, or does not seem | |
129 | ;; to name any shared library, look for `subdir/libfoo.so' instead and | |
130 | ;; link against that. | |
131 | (let check-dirs ((dir-list %load-path)) | |
132 | (if (null? dir-list) | |
133 | #f | |
134 | (let* ((dir (in-vicinity (car dir-list) subdir)) | |
135 | (sharlib-full | |
136 | (or (try-using-libtool-name dir libname) | |
137 | (try-using-sharlib-name dir libname)))) | |
138 | (if (and sharlib-full (file-exists? sharlib-full)) | |
139 | (link-dynamic-module sharlib-full init) | |
140 | (check-dirs (cdr dir-list))))))))) | |
141 | ||
142 | (define (try-using-libtool-name libdir libname) | |
143 | (let ((libtool-filename (in-vicinity libdir | |
144 | (string-append libname ".la")))) | |
145 | (and (file-exists? libtool-filename) | |
146 | libtool-filename))) | |
147 | ||
148 | (define (try-using-sharlib-name libdir libname) | |
149 | (in-vicinity libdir (string-append libname ".so"))) | |
150 | ||
151 | (define (link-dynamic-module filename initname) | |
152 | ;; Register any linked modules which have been registered on the C level | |
153 | (register-modules #f) | |
154 | (let ((dynobj (dynamic-link filename))) | |
155 | (dynamic-call initname dynobj) | |
156 | (register-modules dynobj))) | |
157 | ||
158 | (define (try-module-linked module-name) | |
159 | (init-dynamic-module module-name)) | |
160 | ||
161 | (define (try-module-dynamic-link module-name) | |
162 | (and (find-and-link-dynamic-module module-name) | |
163 | (init-dynamic-module module-name))) | |
726571e0 MV |
164 | |
165 | (define (list* . args) | |
166 | (issue-deprecation-warning "'list*' is deprecated. Use 'cons*' instead.") | |
167 | (apply cons* args)) | |
2042e178 MV |
168 | |
169 | ;; The strange prototype system for uniform arrays has been | |
170 | ;; deprecated. | |
171 | ||
172 | (define uniform-vector-fill! array-fill!) | |
173 | ||
174 | (define make-uniform-vector dimensions->uniform-array) | |
175 | ||
1d314ec2 | 176 | (define (make-uniform-array prot . bounds) |
1aaa1c17 | 177 | (dimensions->uniform-array bounds prot)) |
2042e178 MV |
178 | |
179 | (define (list->uniform-vector prot lst) | |
180 | (list->uniform-array 1 prot lst)) | |
b15dea68 AW |
181 | |
182 | (define-macro (eval-case . clauses) | |
183 | (issue-deprecation-warning | |
184 | "`eval-case' is deprecated. Use `eval-when' instead.") | |
185 | ;; Practically speaking, eval-case only had load-toplevel and else as | |
186 | ;; conditions. | |
187 | (cond | |
188 | ((assoc-ref clauses '(load-toplevel)) | |
189 | => (lambda (exps) | |
190 | ;; the *unspecified so that non-toplevel definitions will be | |
191 | ;; caught | |
192 | `(begin *unspecified* . ,exps))) | |
193 | ((assoc-ref clauses 'else) | |
194 | => (lambda (exps) | |
195 | `(begin *unspecified* . ,exps))) | |
196 | (else | |
197 | `(begin)))) |