module/ice-9/deprecated.scm

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