guile18/ice-9/deprecated.scm

   1 ;;;; Copyright (C) 2003, 2005, 2006 Free Software Foundation, Inc.
   2 ;;;;
   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,
   9 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  16 ;;;;
  17
  18 ;;;; Deprecated definitions.
  19
  20 (define substring-move-left! substring-move!)
  21 (define substring-move-right! substring-move!)
  22
  23 ;; This method of dynamically linking Guile Extensions is deprecated.
  24 ;; Use `load-extension' explicitly 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)))
 164
 165 (define (list* . args)
 166   (issue-deprecation-warning "'list*' is deprecated.  Use 'cons*' instead.")
 167   (apply cons* args))
 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
 176 (define (make-uniform-array prot . bounds)
 177   (dimensions->uniform-array bounds prot))
 178
 179 (define (list->uniform-vector prot lst)
 180   (list->uniform-array 1 prot lst))