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