mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
010b159f56
* module/ice-9/boot-9.scm: * module/ice-9/deprecated.scm (has-suffix?): Deprecate. * test-suite/guile-test: * benchmark-suite/guile-benchmark: Fix uses of deprecated has-suffix?.
403 lines
13 KiB
Scheme
403 lines
13 KiB
Scheme
;;;; Copyright (C) 2003, 2005, 2006, 2009, 2010 Free Software Foundation, Inc.
|
||
;;;;
|
||
;;;; This library is free software; you can redistribute it and/or
|
||
;;;; modify it under the terms of the GNU Lesser General Public
|
||
;;;; License as published by the Free Software Foundation; either
|
||
;;;; version 3 of the License, or (at your option) any later version.
|
||
;;;;
|
||
;;;; This library 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
|
||
;;;; Lesser General Public License for more details.
|
||
;;;;
|
||
;;;; You should have received a copy of the GNU Lesser General Public
|
||
;;;; License along with this library; if not, write to the Free Software
|
||
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
||
;;;;
|
||
|
||
(define-module (ice-9 deprecated)
|
||
#:export (substring-move-left! substring-move-right!
|
||
dynamic-maybe-call dynamic-maybe-link
|
||
try-module-linked try-module-dynamic-link
|
||
list* feature? eval-case unmemoize-expr
|
||
$asinh
|
||
$acosh
|
||
$atanh
|
||
$sqrt
|
||
$abs
|
||
$exp
|
||
$log
|
||
$sin
|
||
$cos
|
||
$tan
|
||
$asin
|
||
$acos
|
||
$atan
|
||
$sinh
|
||
$cosh
|
||
$tanh
|
||
closure?
|
||
%nil
|
||
@bind
|
||
error-catching-loop
|
||
error-catching-repl
|
||
scm-style-repl
|
||
apply-to-args
|
||
has-suffix?)
|
||
|
||
#:replace (module-ref-submodule module-define-submodule!))
|
||
|
||
|
||
;;;; Deprecated definitions.
|
||
|
||
(define substring-move-left! substring-move!)
|
||
(define substring-move-right! substring-move!)
|
||
|
||
|
||
;; This method of dynamically linking Guile Extensions is deprecated.
|
||
;; Use `load-extension' explicitly 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)))
|
||
|
||
|
||
(define (list* . args)
|
||
(issue-deprecation-warning "'list*' is deprecated. Use 'cons*' instead.")
|
||
(apply cons* args))
|
||
|
||
(define (feature? sym)
|
||
(issue-deprecation-warning
|
||
"`feature?' is deprecated. Use `provided?' instead.")
|
||
(provided? sym))
|
||
|
||
(define-macro (eval-case . clauses)
|
||
(issue-deprecation-warning
|
||
"`eval-case' is deprecated. Use `eval-when' instead.")
|
||
;; Practically speaking, eval-case only had load-toplevel and else as
|
||
;; conditions.
|
||
(cond
|
||
((assoc-ref clauses '(load-toplevel))
|
||
=> (lambda (exps)
|
||
;; the *unspecified so that non-toplevel definitions will be
|
||
;; caught
|
||
`(begin *unspecified* . ,exps)))
|
||
((assoc-ref clauses 'else)
|
||
=> (lambda (exps)
|
||
`(begin *unspecified* . ,exps)))
|
||
(else
|
||
`(begin))))
|
||
|
||
;; The strange prototype system for uniform arrays has been
|
||
;; deprecated.
|
||
(read-hash-extend
|
||
#\y
|
||
(lambda (c port)
|
||
(issue-deprecation-warning
|
||
"The `#y' bitvector syntax is deprecated. Use `#*' instead.")
|
||
(let ((x (read port)))
|
||
(cond
|
||
((list? x)
|
||
(list->bitvector
|
||
(map (lambda (x)
|
||
(cond ((zero? x) #f)
|
||
((eqv? x 1) #t)
|
||
(else (error "invalid #y element" x))))
|
||
x)))
|
||
(else
|
||
(error "#y needs to be followed by a list" x))))))
|
||
|
||
(define (unmemoize-expr . args)
|
||
(issue-deprecation-warning
|
||
"`unmemoize-expr' is deprecated. Use `unmemoize-expression' instead.")
|
||
(apply unmemoize-expression args))
|
||
|
||
(define ($asinh z) (asinh z))
|
||
(define ($acosh z) (acosh z))
|
||
(define ($atanh z) (atanh z))
|
||
(define ($sqrt z) (sqrt z))
|
||
(define ($abs z) (abs z))
|
||
(define ($exp z) (exp z))
|
||
(define ($log z) (log z))
|
||
(define ($sin z) (sin z))
|
||
(define ($cos z) (cos z))
|
||
(define ($tan z) (tan z))
|
||
(define ($asin z) (asin z))
|
||
(define ($acos z) (acos z))
|
||
(define ($atan z) (atan z))
|
||
(define ($sinh z) (sinh z))
|
||
(define ($cosh z) (cosh z))
|
||
(define ($tanh z) (tanh z))
|
||
|
||
(define (closure? x)
|
||
(issue-deprecation-warning
|
||
"`closure?' is deprecated. Use `procedure?' instead.")
|
||
(procedure? x))
|
||
|
||
(define %nil #nil)
|
||
|
||
;;; @bind is used by the old elisp code as a dynamic scoping mechanism.
|
||
;;; Please let the Guile developers know if you are using this macro.
|
||
;;;
|
||
(define-syntax @bind
|
||
(lambda (x)
|
||
(define (bound-member id ids)
|
||
(cond ((null? ids) #f)
|
||
((bound-identifier=? id (car ids)) #t)
|
||
((bound-member (car ids) (cdr ids)))))
|
||
|
||
(issue-deprecation-warning
|
||
"`@bind' is deprecated. Use `with-fluids' instead.")
|
||
|
||
(syntax-case x ()
|
||
((_ () b0 b1 ...)
|
||
#'(let () b0 b1 ...))
|
||
((_ ((id val) ...) b0 b1 ...)
|
||
(and-map identifier? #'(id ...))
|
||
(if (let lp ((ids #'(id ...)))
|
||
(cond ((null? ids) #f)
|
||
((bound-member (car ids) (cdr ids)) #t)
|
||
(else (lp (cdr ids)))))
|
||
(syntax-violation '@bind "duplicate bound identifier" x)
|
||
(with-syntax (((old-v ...) (generate-temporaries #'(id ...)))
|
||
((v ...) (generate-temporaries #'(id ...))))
|
||
#'(let ((old-v id) ...
|
||
(v val) ...)
|
||
(dynamic-wind
|
||
(lambda ()
|
||
(set! id v) ...)
|
||
(lambda () b0 b1 ...)
|
||
(lambda ()
|
||
(set! id old-v) ...)))))))))
|
||
|
||
(define (module-ref-submodule module name)
|
||
(or (hashq-ref (module-submodules module) name)
|
||
(and (module-submodule-binder module)
|
||
((module-submodule-binder module) module name))
|
||
(let ((var (module-local-variable module name)))
|
||
(and (variable-bound? var)
|
||
(module? (variable-ref var))
|
||
(begin
|
||
(warn "module" module "not in submodules table")
|
||
(variable-ref var))))))
|
||
|
||
(define (module-define-submodule! module name submodule)
|
||
(let ((var (module-local-variable module name)))
|
||
(if (and var (variable-bound? var) (not (module? (variable-ref var))))
|
||
(warn "defining module" module ": not overriding local definition" var)
|
||
(module-define! module name submodule)))
|
||
(hashq-set! (module-submodules module) name submodule))
|
||
|
||
;; Define (%app) and (%app modules), and have (app) alias (%app). This
|
||
;; side-effects the-root-module, both to the submodules table and (through
|
||
;; module-define-submodule! above) the obarray.
|
||
;;
|
||
(let ((%app (make-module 31)))
|
||
(set-module-name! %app '(%app))
|
||
(module-define-submodule! the-root-module '%app %app)
|
||
(module-define-submodule! the-root-module 'app %app)
|
||
(module-define-submodule! %app 'modules (resolve-module '() #f)))
|
||
|
||
;; Allow code that poked %module-public-interface to keep on working.
|
||
;;
|
||
(set! module-public-interface
|
||
(let ((getter module-public-interface))
|
||
(lambda (mod)
|
||
(or (getter mod)
|
||
(cond
|
||
((and=> (module-local-variable mod '%module-public-interface)
|
||
variable-ref)
|
||
=> (lambda (iface)
|
||
(issue-deprecation-warning
|
||
"Setting a module's public interface via munging %module-public-interface is
|
||
deprecated. Use set-module-public-interface! instead.")
|
||
(set-module-public-interface! mod iface)
|
||
iface))
|
||
(else #f))))))
|
||
|
||
(set! set-module-public-interface!
|
||
(let ((setter set-module-public-interface!))
|
||
(lambda (mod iface)
|
||
(setter mod iface)
|
||
(module-define! mod '%module-public-interface iface))))
|
||
|
||
(define (error-catching-loop thunk)
|
||
(issue-deprecation-warning
|
||
"`error-catching-loop' in the default environment is deprecated.
|
||
Find it in the `(ice-9 scm-style-repl)' module instead.")
|
||
((@ (ice-9 scm-style-repl) error-catching-loop) thunk))
|
||
|
||
(define (error-catching-repl r e p)
|
||
(issue-deprecation-warning
|
||
"`error-catching-repl' in the default environment is deprecated.
|
||
Find it in the `(ice-9 scm-style-repl)' module instead.")
|
||
((@ (ice-9 scm-style-repl) error-catching-repl) r e p))
|
||
|
||
(define (scm-style-repl)
|
||
(issue-deprecation-warning
|
||
"`scm-style-repl' in the default environment is deprecated.
|
||
Find it in the `(ice-9 scm-style-repl)' module instead, or
|
||
better yet, use the repl from `(system repl repl)'.")
|
||
((@ (ice-9 scm-style-repl) scm-style-repl)))
|
||
|
||
|
||
;;; Apply-to-args had the following comment attached to it in boot-9, but it's
|
||
;;; wrong-headed: in the mentioned case, a point should either be a record or
|
||
;;; multiple values.
|
||
;;;
|
||
;;; apply-to-args is functionally redundant with apply and, worse,
|
||
;;; is less general than apply since it only takes two arguments.
|
||
;;;
|
||
;;; On the other hand, apply-to-args is a syntacticly convenient way to
|
||
;;; perform binding in many circumstances when the "let" family of
|
||
;;; of forms don't cut it. E.g.:
|
||
;;;
|
||
;;; (apply-to-args (return-3d-mouse-coords)
|
||
;;; (lambda (x y z)
|
||
;;; ...))
|
||
;;;
|
||
|
||
(define (apply-to-args args fn)
|
||
(issue-deprecation-warning
|
||
"`apply-to-args' is deprecated. Include a local copy in your program.")
|
||
(apply fn args))
|
||
|
||
(define (has-suffix? str suffix)
|
||
(issue-deprecation-warning
|
||
"`has-suffix?' is deprecated. Use `string-suffix?' instead (args reversed).")
|
||
(string-suffix? suffix str))
|