Commit | Line | Data |
---|---|---|
0ea72faa | 1 | ;;;; Copyright (C) 2003, 2005, 2006, 2009, 2010 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 | |
53befeb7 | 6 | ;;;; version 3 of the License, or (at your option) any later version. |
73be1d9e MV |
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 | ||
0ea72faa LC |
18 | (define-module (ice-9 deprecated) |
19 | #:export (substring-move-left! substring-move-right! | |
20 | dynamic-maybe-call dynamic-maybe-link | |
21 | try-module-linked try-module-dynamic-link | |
e63dda67 | 22 | list* feature? eval-case unmemoize-expr |
0ea72faa LC |
23 | $asinh |
24 | $acosh | |
25 | $atanh | |
26 | $sqrt | |
27 | $abs | |
28 | $exp | |
29 | $log | |
30 | $sin | |
31 | $cos | |
32 | $tan | |
33 | $asin | |
34 | $acos | |
35 | $atan | |
36 | $sinh | |
37 | $cosh | |
38 | $tanh | |
0abc2109 AW |
39 | closure? |
40 | %nil | |
03af6e09 | 41 | @bind |
4100dc5d | 42 | bad-throw |
b2e27da3 AW |
43 | error-catching-loop |
44 | error-catching-repl | |
0f509ab5 | 45 | scm-style-repl |
010b159f | 46 | apply-to-args |
0bbe199d | 47 | has-suffix? |
c3aaf3cf AW |
48 | scheme-file-suffix |
49 | get-option | |
50 | for-next-option | |
51 | display-usage-report | |
5c0450b2 | 52 | transform-usage-lambda |
40f17f1e AW |
53 | collect |
54 | assert-repl-silence | |
55 | assert-repl-print-unspecified | |
4f99a499 | 56 | assert-repl-verbosity |
9346b857 | 57 | set-repl-prompt! |
a29e5b63 | 58 | set-batch-mode?! |
38008a75 | 59 | repl |
fede5c89 | 60 | pre-unwind-handler-dispatch |
7034da24 | 61 | default-pre-unwind-handler |
d8158b83 AW |
62 | handle-system-error |
63 | stack-saved? | |
ec16eb78 | 64 | the-last-stack |
049ec202 AW |
65 | save-stack |
66 | named-module-use! | |
e2e2631d | 67 | top-repl |
d458073b AR |
68 | turn-on-debugging |
69 | read-hash-procedures)) | |
635a8b36 | 70 | |
0ea72faa | 71 | |
5d3af6f2 MV |
72 | ;;;; Deprecated definitions. |
73 | ||
5b943a3f MV |
74 | (define substring-move-left! substring-move!) |
75 | (define substring-move-right! substring-move!) | |
76 | ||
0ea72faa | 77 | \f |
5d3af6f2 | 78 | ;; This method of dynamically linking Guile Extensions is deprecated. |
877f06c3 | 79 | ;; Use `load-extension' explicitly from Scheme code instead. |
5d3af6f2 MV |
80 | |
81 | (define (split-c-module-name str) | |
82 | (let loop ((rev '()) | |
83 | (start 0) | |
84 | (pos 0) | |
85 | (end (string-length str))) | |
86 | (cond | |
87 | ((= pos end) | |
88 | (reverse (cons (string->symbol (substring str start pos)) rev))) | |
89 | ((eq? (string-ref str pos) #\space) | |
90 | (loop (cons (string->symbol (substring str start pos)) rev) | |
91 | (+ pos 1) | |
92 | (+ pos 1) | |
93 | end)) | |
94 | (else | |
95 | (loop rev start (+ pos 1) end))))) | |
96 | ||
97 | (define (convert-c-registered-modules dynobj) | |
98 | (let ((res (map (lambda (c) | |
99 | (list (split-c-module-name (car c)) (cdr c) dynobj)) | |
100 | (c-registered-modules)))) | |
101 | (c-clear-registered-modules) | |
102 | res)) | |
103 | ||
104 | (define registered-modules '()) | |
105 | ||
106 | (define (register-modules dynobj) | |
107 | (set! registered-modules | |
108 | (append! (convert-c-registered-modules dynobj) | |
109 | registered-modules))) | |
110 | ||
111 | (define (warn-autoload-deprecation modname) | |
112 | (issue-deprecation-warning | |
113 | "Autoloading of compiled code modules is deprecated." | |
114 | "Write a Scheme file instead that uses `load-extension'.") | |
115 | (issue-deprecation-warning | |
116 | (simple-format #f "(You just autoloaded module ~S.)" modname))) | |
117 | ||
118 | (define (init-dynamic-module modname) | |
119 | ;; Register any linked modules which have been registered on the C level | |
120 | (register-modules #f) | |
121 | (or-map (lambda (modinfo) | |
122 | (if (equal? (car modinfo) modname) | |
123 | (begin | |
124 | (warn-autoload-deprecation modname) | |
125 | (set! registered-modules (delq! modinfo registered-modules)) | |
126 | (let ((mod (resolve-module modname #f))) | |
127 | (save-module-excursion | |
128 | (lambda () | |
129 | (set-current-module mod) | |
130 | (set-module-public-interface! mod mod) | |
131 | (dynamic-call (cadr modinfo) (caddr modinfo)) | |
132 | )) | |
133 | #t)) | |
134 | #f)) | |
135 | registered-modules)) | |
136 | ||
137 | (define (dynamic-maybe-call name dynobj) | |
138 | (catch #t ; could use false-if-exception here | |
139 | (lambda () | |
140 | (dynamic-call name dynobj)) | |
141 | (lambda args | |
142 | #f))) | |
143 | ||
144 | (define (dynamic-maybe-link filename) | |
145 | (catch #t ; could use false-if-exception here | |
146 | (lambda () | |
147 | (dynamic-link filename)) | |
148 | (lambda args | |
149 | #f))) | |
150 | ||
151 | (define (find-and-link-dynamic-module module-name) | |
152 | (define (make-init-name mod-name) | |
153 | (string-append "scm_init" | |
154 | (list->string (map (lambda (c) | |
155 | (if (or (char-alphabetic? c) | |
156 | (char-numeric? c)) | |
157 | c | |
158 | #\_)) | |
159 | (string->list mod-name))) | |
160 | "_module")) | |
161 | ||
162 | ;; Put the subdirectory for this module in the car of SUBDIR-AND-LIBNAME, | |
163 | ;; and the `libname' (the name of the module prepended by `lib') in the cdr | |
164 | ;; field. For example, if MODULE-NAME is the list (inet tcp-ip udp), then | |
165 | ;; SUBDIR-AND-LIBNAME will be the pair ("inet/tcp-ip" . "libudp"). | |
166 | (let ((subdir-and-libname | |
167 | (let loop ((dirs "") | |
168 | (syms module-name)) | |
169 | (if (null? (cdr syms)) | |
170 | (cons dirs (string-append "lib" (symbol->string (car syms)))) | |
171 | (loop (string-append dirs (symbol->string (car syms)) "/") | |
172 | (cdr syms))))) | |
173 | (init (make-init-name (apply string-append | |
174 | (map (lambda (s) | |
175 | (string-append "_" | |
176 | (symbol->string s))) | |
177 | module-name))))) | |
178 | (let ((subdir (car subdir-and-libname)) | |
179 | (libname (cdr subdir-and-libname))) | |
180 | ||
181 | ;; Now look in each dir in %LOAD-PATH for `subdir/libfoo.la'. If that | |
182 | ;; file exists, fetch the dlname from that file and attempt to link | |
183 | ;; against it. If `subdir/libfoo.la' does not exist, or does not seem | |
184 | ;; to name any shared library, look for `subdir/libfoo.so' instead and | |
185 | ;; link against that. | |
186 | (let check-dirs ((dir-list %load-path)) | |
187 | (if (null? dir-list) | |
188 | #f | |
189 | (let* ((dir (in-vicinity (car dir-list) subdir)) | |
190 | (sharlib-full | |
191 | (or (try-using-libtool-name dir libname) | |
192 | (try-using-sharlib-name dir libname)))) | |
193 | (if (and sharlib-full (file-exists? sharlib-full)) | |
194 | (link-dynamic-module sharlib-full init) | |
195 | (check-dirs (cdr dir-list))))))))) | |
196 | ||
197 | (define (try-using-libtool-name libdir libname) | |
198 | (let ((libtool-filename (in-vicinity libdir | |
199 | (string-append libname ".la")))) | |
200 | (and (file-exists? libtool-filename) | |
201 | libtool-filename))) | |
202 | ||
203 | (define (try-using-sharlib-name libdir libname) | |
204 | (in-vicinity libdir (string-append libname ".so"))) | |
205 | ||
206 | (define (link-dynamic-module filename initname) | |
207 | ;; Register any linked modules which have been registered on the C level | |
208 | (register-modules #f) | |
209 | (let ((dynobj (dynamic-link filename))) | |
210 | (dynamic-call initname dynobj) | |
211 | (register-modules dynobj))) | |
212 | ||
213 | (define (try-module-linked module-name) | |
214 | (init-dynamic-module module-name)) | |
215 | ||
216 | (define (try-module-dynamic-link module-name) | |
217 | (and (find-and-link-dynamic-module module-name) | |
218 | (init-dynamic-module module-name))) | |
726571e0 | 219 | |
0ea72faa | 220 | \f |
726571e0 MV |
221 | (define (list* . args) |
222 | (issue-deprecation-warning "'list*' is deprecated. Use 'cons*' instead.") | |
223 | (apply cons* args)) | |
2042e178 | 224 | |
e63dda67 LC |
225 | (define (feature? sym) |
226 | (issue-deprecation-warning | |
227 | "`feature?' is deprecated. Use `provided?' instead.") | |
228 | (provided? sym)) | |
229 | ||
b15dea68 AW |
230 | (define-macro (eval-case . clauses) |
231 | (issue-deprecation-warning | |
232 | "`eval-case' is deprecated. Use `eval-when' instead.") | |
233 | ;; Practically speaking, eval-case only had load-toplevel and else as | |
234 | ;; conditions. | |
235 | (cond | |
236 | ((assoc-ref clauses '(load-toplevel)) | |
237 | => (lambda (exps) | |
238 | ;; the *unspecified so that non-toplevel definitions will be | |
239 | ;; caught | |
240 | `(begin *unspecified* . ,exps))) | |
241 | ((assoc-ref clauses 'else) | |
242 | => (lambda (exps) | |
243 | `(begin *unspecified* . ,exps))) | |
244 | (else | |
245 | `(begin)))) | |
10fab724 | 246 | |
0ea72faa LC |
247 | ;; The strange prototype system for uniform arrays has been |
248 | ;; deprecated. | |
10fab724 AW |
249 | (read-hash-extend |
250 | #\y | |
251 | (lambda (c port) | |
252 | (issue-deprecation-warning | |
5cc98776 | 253 | "The `#y' bytevector syntax is deprecated. Use `#s8' instead.") |
10fab724 AW |
254 | (let ((x (read port))) |
255 | (cond | |
5cc98776 AW |
256 | ((list? x) (list->s8vector x)) |
257 | (else (error "#y needs to be followed by a list" x)))))) | |
b7742c6b AW |
258 | |
259 | (define (unmemoize-expr . args) | |
260 | (issue-deprecation-warning | |
261 | "`unmemoize-expr' is deprecated. Use `unmemoize-expression' instead.") | |
262 | (apply unmemoize-expression args)) | |
ad79736c AW |
263 | |
264 | (define ($asinh z) (asinh z)) | |
265 | (define ($acosh z) (acosh z)) | |
266 | (define ($atanh z) (atanh z)) | |
267 | (define ($sqrt z) (sqrt z)) | |
268 | (define ($abs z) (abs z)) | |
269 | (define ($exp z) (exp z)) | |
270 | (define ($log z) (log z)) | |
271 | (define ($sin z) (sin z)) | |
272 | (define ($cos z) (cos z)) | |
273 | (define ($tan z) (tan z)) | |
274 | (define ($asin z) (asin z)) | |
275 | (define ($acos z) (acos z)) | |
276 | (define ($atan z) (atan z)) | |
277 | (define ($sinh z) (sinh z)) | |
278 | (define ($cosh z) (cosh z)) | |
279 | (define ($tanh z) (tanh z)) | |
0ea72faa | 280 | |
314b8716 AW |
281 | (define (closure? x) |
282 | (issue-deprecation-warning | |
283 | "`closure?' is deprecated. Use `procedure?' instead.") | |
284 | (procedure? x)) | |
cd038da5 AW |
285 | |
286 | (define %nil #nil) | |
0abc2109 AW |
287 | |
288 | ;;; @bind is used by the old elisp code as a dynamic scoping mechanism. | |
289 | ;;; Please let the Guile developers know if you are using this macro. | |
290 | ;;; | |
291 | (define-syntax @bind | |
292 | (lambda (x) | |
293 | (define (bound-member id ids) | |
294 | (cond ((null? ids) #f) | |
295 | ((bound-identifier=? id (car ids)) #t) | |
296 | ((bound-member (car ids) (cdr ids))))) | |
297 | ||
298 | (issue-deprecation-warning | |
299 | "`@bind' is deprecated. Use `with-fluids' instead.") | |
300 | ||
301 | (syntax-case x () | |
302 | ((_ () b0 b1 ...) | |
303 | #'(let () b0 b1 ...)) | |
304 | ((_ ((id val) ...) b0 b1 ...) | |
305 | (and-map identifier? #'(id ...)) | |
306 | (if (let lp ((ids #'(id ...))) | |
307 | (cond ((null? ids) #f) | |
308 | ((bound-member (car ids) (cdr ids)) #t) | |
309 | (else (lp (cdr ids))))) | |
310 | (syntax-violation '@bind "duplicate bound identifier" x) | |
311 | (with-syntax (((old-v ...) (generate-temporaries #'(id ...))) | |
312 | ((v ...) (generate-temporaries #'(id ...)))) | |
313 | #'(let ((old-v id) ... | |
314 | (v val) ...) | |
315 | (dynamic-wind | |
316 | (lambda () | |
317 | (set! id v) ...) | |
318 | (lambda () b0 b1 ...) | |
319 | (lambda () | |
320 | (set! id old-v) ...))))))))) | |
c9904ab0 | 321 | |
dcb68c09 AW |
322 | ;; There are deprecated definitions for module-ref-submodule and |
323 | ;; module-define-submodule! in boot-9.scm. | |
f6a5308b | 324 | |
635a8b36 AW |
325 | ;; Define (%app) and (%app modules), and have (app) alias (%app). This |
326 | ;; side-effects the-root-module, both to the submodules table and (through | |
327 | ;; module-define-submodule! above) the obarray. | |
328 | ;; | |
329 | (let ((%app (make-module 31))) | |
330 | (set-module-name! %app '(%app)) | |
331 | (module-define-submodule! the-root-module '%app %app) | |
332 | (module-define-submodule! the-root-module 'app %app) | |
333 | (module-define-submodule! %app 'modules (resolve-module '() #f))) | |
4e48b495 AW |
334 | |
335 | ;; Allow code that poked %module-public-interface to keep on working. | |
336 | ;; | |
337 | (set! module-public-interface | |
338 | (let ((getter module-public-interface)) | |
339 | (lambda (mod) | |
340 | (or (getter mod) | |
341 | (cond | |
342 | ((and=> (module-local-variable mod '%module-public-interface) | |
343 | variable-ref) | |
344 | => (lambda (iface) | |
345 | (issue-deprecation-warning | |
346 | "Setting a module's public interface via munging %module-public-interface is | |
347 | deprecated. Use set-module-public-interface! instead.") | |
348 | (set-module-public-interface! mod iface) | |
349 | iface)) | |
350 | (else #f)))))) | |
351 | ||
352 | (set! set-module-public-interface! | |
353 | (let ((setter set-module-public-interface!)) | |
354 | (lambda (mod iface) | |
355 | (setter mod iface) | |
356 | (module-define! mod '%module-public-interface iface)))) | |
03af6e09 | 357 | |
4100dc5d AW |
358 | (define (bad-throw key . args) |
359 | (issue-deprecation-warning | |
360 | "`bad-throw' in the default environment is deprecated. | |
361 | Find it in the `(ice-9 scm-style-repl)' module instead.") | |
362 | (apply (@ (ice-9 scm-style-repl) bad-throw) key args)) | |
363 | ||
4ae3d5aa AW |
364 | (define (error-catching-loop thunk) |
365 | (issue-deprecation-warning | |
b2e27da3 AW |
366 | "`error-catching-loop' in the default environment is deprecated. |
367 | Find it in the `(ice-9 scm-style-repl)' module instead.") | |
368 | ((@ (ice-9 scm-style-repl) error-catching-loop) thunk)) | |
4ae3d5aa AW |
369 | |
370 | (define (error-catching-repl r e p) | |
371 | (issue-deprecation-warning | |
b2e27da3 AW |
372 | "`error-catching-repl' in the default environment is deprecated. |
373 | Find it in the `(ice-9 scm-style-repl)' module instead.") | |
374 | ((@ (ice-9 scm-style-repl) error-catching-repl) r e p)) | |
4ae3d5aa | 375 | |
03af6e09 AW |
376 | (define (scm-style-repl) |
377 | (issue-deprecation-warning | |
b2e27da3 AW |
378 | "`scm-style-repl' in the default environment is deprecated. |
379 | Find it in the `(ice-9 scm-style-repl)' module instead, or | |
380 | better yet, use the repl from `(system repl repl)'.") | |
381 | ((@ (ice-9 scm-style-repl) scm-style-repl))) | |
0f509ab5 AW |
382 | |
383 | ||
384 | ;;; Apply-to-args had the following comment attached to it in boot-9, but it's | |
385 | ;;; wrong-headed: in the mentioned case, a point should either be a record or | |
386 | ;;; multiple values. | |
387 | ;;; | |
388 | ;;; apply-to-args is functionally redundant with apply and, worse, | |
389 | ;;; is less general than apply since it only takes two arguments. | |
390 | ;;; | |
391 | ;;; On the other hand, apply-to-args is a syntacticly convenient way to | |
392 | ;;; perform binding in many circumstances when the "let" family of | |
393 | ;;; of forms don't cut it. E.g.: | |
394 | ;;; | |
395 | ;;; (apply-to-args (return-3d-mouse-coords) | |
396 | ;;; (lambda (x y z) | |
397 | ;;; ...)) | |
398 | ;;; | |
399 | ||
400 | (define (apply-to-args args fn) | |
401 | (issue-deprecation-warning | |
402 | "`apply-to-args' is deprecated. Include a local copy in your program.") | |
403 | (apply fn args)) | |
010b159f AW |
404 | |
405 | (define (has-suffix? str suffix) | |
406 | (issue-deprecation-warning | |
407 | "`has-suffix?' is deprecated. Use `string-suffix?' instead (args reversed).") | |
408 | (string-suffix? suffix str)) | |
0bbe199d AW |
409 | |
410 | (define scheme-file-suffix | |
411 | (lambda () | |
412 | (issue-deprecation-warning | |
413 | "`scheme-file-suffix' is deprecated. Use `%load-extensions' instead.") | |
414 | ".scm")) | |
c3aaf3cf AW |
415 | |
416 | \f | |
417 | ||
418 | ;;; {Command Line Options} | |
419 | ;;; | |
420 | ||
421 | (define (get-option argv kw-opts kw-args return) | |
422 | (issue-deprecation-warning | |
423 | "`get-option' is deprecated. Use `(ice-9 getopt-long)' instead.") | |
424 | (cond | |
425 | ((null? argv) | |
426 | (return #f #f argv)) | |
427 | ||
428 | ((or (not (eq? #\- (string-ref (car argv) 0))) | |
429 | (eq? (string-length (car argv)) 1)) | |
430 | (return 'normal-arg (car argv) (cdr argv))) | |
431 | ||
432 | ((eq? #\- (string-ref (car argv) 1)) | |
433 | (let* ((kw-arg-pos (or (string-index (car argv) #\=) | |
434 | (string-length (car argv)))) | |
435 | (kw (symbol->keyword (substring (car argv) 2 kw-arg-pos))) | |
436 | (kw-opt? (member kw kw-opts)) | |
437 | (kw-arg? (member kw kw-args)) | |
438 | (arg (or (and (not (eq? kw-arg-pos (string-length (car argv)))) | |
439 | (substring (car argv) | |
440 | (+ kw-arg-pos 1) | |
441 | (string-length (car argv)))) | |
442 | (and kw-arg? | |
443 | (begin (set! argv (cdr argv)) (car argv)))))) | |
444 | (if (or kw-opt? kw-arg?) | |
445 | (return kw arg (cdr argv)) | |
446 | (return 'usage-error kw (cdr argv))))) | |
447 | ||
448 | (else | |
449 | (let* ((char (substring (car argv) 1 2)) | |
450 | (kw (symbol->keyword char))) | |
451 | (cond | |
452 | ||
453 | ((member kw kw-opts) | |
454 | (let* ((rest-car (substring (car argv) 2 (string-length (car argv)))) | |
455 | (new-argv (if (= 0 (string-length rest-car)) | |
456 | (cdr argv) | |
457 | (cons (string-append "-" rest-car) (cdr argv))))) | |
458 | (return kw #f new-argv))) | |
459 | ||
460 | ((member kw kw-args) | |
461 | (let* ((rest-car (substring (car argv) 2 (string-length (car argv)))) | |
462 | (arg (if (= 0 (string-length rest-car)) | |
463 | (cadr argv) | |
464 | rest-car)) | |
465 | (new-argv (if (= 0 (string-length rest-car)) | |
466 | (cddr argv) | |
467 | (cdr argv)))) | |
468 | (return kw arg new-argv))) | |
469 | ||
470 | (else (return 'usage-error kw argv))))))) | |
471 | ||
472 | (define (for-next-option proc argv kw-opts kw-args) | |
473 | (issue-deprecation-warning | |
474 | "`for-next-option' is deprecated. Use `(ice-9 getopt-long)' instead.") | |
475 | (let loop ((argv argv)) | |
476 | (get-option argv kw-opts kw-args | |
477 | (lambda (opt opt-arg argv) | |
478 | (and opt (proc opt opt-arg argv loop)))))) | |
479 | ||
480 | (define (display-usage-report kw-desc) | |
481 | (issue-deprecation-warning | |
482 | "`display-usage-report' is deprecated. Use `(ice-9 getopt-long)' instead.") | |
483 | (for-each | |
484 | (lambda (kw) | |
485 | (or (eq? (car kw) #t) | |
486 | (eq? (car kw) 'else) | |
487 | (let* ((opt-desc kw) | |
488 | (help (cadr opt-desc)) | |
489 | (opts (car opt-desc)) | |
490 | (opts-proper (if (string? (car opts)) (cdr opts) opts)) | |
491 | (arg-name (if (string? (car opts)) | |
492 | (string-append "<" (car opts) ">") | |
493 | "")) | |
494 | (left-part (string-append | |
495 | (with-output-to-string | |
496 | (lambda () | |
497 | (map (lambda (x) (display (keyword->symbol x)) (display " ")) | |
498 | opts-proper))) | |
499 | arg-name)) | |
500 | (middle-part (if (and (< (string-length left-part) 30) | |
501 | (< (string-length help) 40)) | |
502 | (make-string (- 30 (string-length left-part)) #\ ) | |
503 | "\n\t"))) | |
504 | (display left-part) | |
505 | (display middle-part) | |
506 | (display help) | |
507 | (newline)))) | |
508 | kw-desc)) | |
509 | ||
510 | (define (transform-usage-lambda cases) | |
511 | (issue-deprecation-warning | |
512 | "`display-usage-report' is deprecated. Use `(ice-9 getopt-long)' instead.") | |
513 | (let* ((raw-usage (delq! 'else (map car cases))) | |
514 | (usage-sans-specials (map (lambda (x) | |
515 | (or (and (not (list? x)) x) | |
516 | (and (symbol? (car x)) #t) | |
517 | (and (boolean? (car x)) #t) | |
518 | x)) | |
519 | raw-usage)) | |
520 | (usage-desc (delq! #t usage-sans-specials)) | |
521 | (kw-desc (map car usage-desc)) | |
522 | (kw-opts (apply append (map (lambda (x) (and (not (string? (car x))) x)) kw-desc))) | |
523 | (kw-args (apply append (map (lambda (x) (and (string? (car x)) (cdr x))) kw-desc))) | |
524 | (transmogrified-cases (map (lambda (case) | |
525 | (cons (let ((opts (car case))) | |
526 | (if (or (boolean? opts) (eq? 'else opts)) | |
527 | opts | |
528 | (cond | |
529 | ((symbol? (car opts)) opts) | |
530 | ((boolean? (car opts)) opts) | |
531 | ((string? (caar opts)) (cdar opts)) | |
532 | (else (car opts))))) | |
533 | (cdr case))) | |
534 | cases))) | |
535 | `(let ((%display-usage (lambda () (display-usage-report ',usage-desc)))) | |
536 | (lambda (%argv) | |
537 | (let %next-arg ((%argv %argv)) | |
538 | (get-option %argv | |
539 | ',kw-opts | |
540 | ',kw-args | |
541 | (lambda (%opt %arg %new-argv) | |
542 | (case %opt | |
543 | ,@ transmogrified-cases)))))))) | |
5c0450b2 AW |
544 | |
545 | \f | |
546 | ||
547 | ;;; {collect} | |
548 | ;;; | |
549 | ;;; Similar to `begin' but returns a list of the results of all constituent | |
550 | ;;; forms instead of the result of the last form. | |
551 | ;;; | |
552 | ||
553 | (define-syntax collect | |
554 | (lambda (x) | |
555 | (issue-deprecation-warning | |
556 | "`collect' is deprecated. Define it yourself.") | |
557 | (syntax-case x () | |
558 | ((_) #''()) | |
559 | ((_ x x* ...) | |
1772145c AW |
560 | #'(let ((val x)) |
561 | (cons val (collect x* ...))))))) | |
40f17f1e AW |
562 | |
563 | ||
564 | \f | |
565 | ||
566 | (define (assert-repl-silence v) | |
567 | (issue-deprecation-warning | |
568 | "`assert-repl-silence' has moved to `(ice-9 scm-style-repl)'.") | |
569 | ((@ (ice-9 scm-style-repl) assert-repl-silence) v)) | |
570 | ||
571 | (define (assert-repl-print-unspecified v) | |
572 | (issue-deprecation-warning | |
573 | "`assert-repl-print-unspecified' has moved to `(ice-9 scm-style-repl)'.") | |
574 | ((@ (ice-9 scm-style-repl) assert-repl-print-unspecified) v)) | |
575 | ||
576 | (define (assert-repl-verbosity v) | |
577 | (issue-deprecation-warning | |
578 | "`assert-repl-verbosity' has moved to `(ice-9 scm-style-repl)'.") | |
579 | ((@ (ice-9 scm-style-repl) assert-repl-verbosity) v)) | |
4f99a499 AW |
580 | |
581 | (define (set-repl-prompt! v) | |
582 | (issue-deprecation-warning | |
583 | "`set-repl-prompt!' is deprecated. Use `repl-default-prompt-set!' from | |
584 | the `(system repl common)' module.") | |
f4b879e0 AW |
585 | ;; Avoid @, as when bootstrapping it will cause the (system repl common) |
586 | ;; module to be loaded at expansion time, which eventually loads srfi-1, but | |
587 | ;; that fails due to an unbuilt supporting lib... grrrrrrrrr. | |
588 | ((module-ref (resolve-interface '(system repl common)) | |
589 | 'repl-default-prompt-set!) | |
590 | v)) | |
9346b857 AW |
591 | |
592 | (define (set-batch-mode?! arg) | |
593 | (cond | |
594 | (arg | |
595 | (issue-deprecation-warning | |
596 | "`set-batch-mode?!' is deprecated. Use `ensure-batch-mode!' instead.") | |
597 | (ensure-batch-mode!)) | |
598 | (else | |
599 | (issue-deprecation-warning | |
600 | "`set-batch-mode?!' with an argument of `#f' is deprecated. Use the | |
652f48c0 | 601 | `*repl-stack*' fluid instead.") |
9346b857 | 602 | #t))) |
a29e5b63 AW |
603 | |
604 | (define (repl read evaler print) | |
605 | (issue-deprecation-warning | |
606 | "`repl' is deprecated. Define it yourself.") | |
607 | (let loop ((source (read (current-input-port)))) | |
608 | (print (evaler source)) | |
609 | (loop (read (current-input-port))))) | |
38008a75 AW |
610 | |
611 | (define (pre-unwind-handler-dispatch key . args) | |
612 | (issue-deprecation-warning | |
613 | "`pre-unwind-handler-dispatch' is deprecated. Use | |
fede5c89 AW |
614 | `default-pre-unwind-handler' from `(ice-9 scm-style-repl)' directly.") |
615 | (apply (@ (ice-9 scm-style-repl) default-pre-unwind-handler) key args)) | |
616 | ||
617 | (define (default-pre-unwind-handler key . args) | |
618 | (issue-deprecation-warning | |
619 | "`default-pre-unwind-handler' is deprecated. Use it from | |
620 | `(ice-9 scm-style-repl)' if you need it.") | |
621 | (apply (@ (ice-9 scm-style-repl) default-pre-unwind-handler) key args)) | |
7034da24 AW |
622 | |
623 | (define (handle-system-error key . args) | |
624 | (issue-deprecation-warning | |
625 | "`handle-system-error' is deprecated. Use it from | |
626 | `(ice-9 scm-style-repl)' if you need it.") | |
627 | (apply (@ (ice-9 scm-style-repl) handle-system-error) key args)) | |
d8158b83 AW |
628 | |
629 | (define-syntax stack-saved? | |
630 | (make-variable-transformer | |
631 | (lambda (x) | |
632 | (issue-deprecation-warning | |
633 | "`stack-saved?' is deprecated. Use it from | |
634 | `(ice-9 save-stack)' if you need it.") | |
635 | (syntax-case x (set!) | |
636 | ((set! id val) | |
637 | (identifier? #'id) | |
638 | #'(set! (@ (ice-9 save-stack) stack-saved?) val)) | |
639 | (id | |
640 | (identifier? #'id) | |
641 | #'(@ (ice-9 save-stack) stack-saved?)))))) | |
642 | ||
ec16eb78 AW |
643 | (define-syntax the-last-stack |
644 | (lambda (x) | |
645 | (issue-deprecation-warning | |
646 | "`the-last-stack' is deprecated. Use it from `(ice-9 save-stack)' | |
647 | if you need it.") | |
648 | (syntax-case x () | |
649 | (id | |
650 | (identifier? #'id) | |
651 | #'(@ (ice-9 save-stack) the-last-stack))))) | |
652 | ||
d8158b83 AW |
653 | (define (save-stack . args) |
654 | (issue-deprecation-warning | |
655 | "`save-stack' is deprecated. Use it from `(ice-9 save-stack)' if you need | |
656 | it.") | |
657 | (apply (@ (ice-9 save-stack) save-stack) args)) | |
049ec202 AW |
658 | |
659 | (define (named-module-use! user usee) | |
660 | (issue-deprecation-warning | |
661 | "`named-module-use!' is deprecated. Define it yourself if you need it.") | |
662 | (module-use! (resolve-module user) (resolve-interface usee))) | |
663 | ||
ff87b2bd AW |
664 | (define (top-repl) |
665 | (issue-deprecation-warning | |
666 | "`top-repl' has moved to the `(ice-9 top-repl)' module.") | |
667 | ((module-ref (resolve-module '(ice-9 top-repl)) 'top-repl))) | |
3932bdb3 AW |
668 | |
669 | (set! debug-enable | |
670 | (let ((debug-enable debug-enable)) | |
671 | (lambda opts | |
672 | (if (memq 'debug opts) | |
673 | (begin | |
674 | (issue-deprecation-warning | |
675 | "`(debug-enable 'debug)' is obsolete and has no effect." | |
676 | "Remove it from your code.") | |
677 | (apply debug-enable (delq 'debug opts))) | |
678 | (apply debug-enable opts))))) | |
e2e2631d AW |
679 | |
680 | (define (turn-on-debugging) | |
681 | (issue-deprecation-warning | |
682 | "`(turn-on-debugging)' is obsolete and usually has no effect." | |
683 | "Debugging capabilities are present by default.") | |
684 | (debug-enable 'backtrace) | |
685 | (read-enable 'positions)) | |
d458073b AR |
686 | |
687 | (define (read-hash-procedures-warning) | |
688 | (issue-deprecation-warning | |
689 | "`read-hash-procedures' is deprecated." | |
690 | "Use the fluid `%read-hash-procedures' instead.")) | |
691 | ||
692 | (define-syntax read-hash-procedures | |
693 | (identifier-syntax | |
694 | (_ | |
695 | (begin (read-hash-procedures-warning) | |
696 | (fluid-ref %read-hash-procedures))) | |
697 | ((set! _ expr) | |
698 | (begin (read-hash-procedures-warning) | |
699 | (fluid-set! %read-hash-procedures expr))))) |