module/ice-9/deprecated.scm

   1 ;;;; Copyright (C) 2003, 2005, 2006, 2009, 2010, 2011, 2012, 2013 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             $expt
  30             $log
  31             $sin
  32             $cos
  33             $tan
  34             $asin
  35             $acos
  36             $atan
  37             $sinh
  38             $cosh
  39             $tanh
  40             closure?
  41             %nil
  42             @bind
  43             bad-throw
  44             error-catching-loop
  45             error-catching-repl
  46             scm-style-repl
  47             apply-to-args
  48             has-suffix?
  49             scheme-file-suffix
  50             get-option
  51             for-next-option
  52             display-usage-report
  53             transform-usage-lambda
  54             collect
  55             assert-repl-silence
  56             assert-repl-print-unspecified
  57             assert-repl-verbosity
  58             set-repl-prompt!
  59             set-batch-mode?!
  60             repl
  61             pre-unwind-handler-dispatch
  62             default-pre-unwind-handler
  63             handle-system-error
  64             stack-saved?
  65             the-last-stack
  66             save-stack
  67             named-module-use!
  68             top-repl
  69             turn-on-debugging
  70             read-hash-procedures
  71             process-define-module
  72             fluid-let-syntax
  73             set-system-module!
  74             char-code-limit
  75             generalized-vector?
  76             generalized-vector-length
  77             generalized-vector-ref
  78             generalized-vector-set!
  79             generalized-vector->list))
  80
  81
  82 ;;;; Deprecated definitions.
  83
  84 (define substring-move-left!
  85   (lambda args
  86     (issue-deprecation-warning
  87      "`substring-move-left!' is deprecated.  Use `substring-move!' instead.")
  88     (apply substring-move! args)))
  89 (define substring-move-right!
  90   (lambda args
  91     (issue-deprecation-warning
  92      "`substring-move-right!' is deprecated.  Use `substring-move!' instead.")
  93     (apply substring-move! args)))
  94
  95
  96 \f
  97 ;; This method of dynamically linking Guile Extensions is deprecated.
  98 ;; Use `load-extension' explicitly from Scheme code instead.
  99
 100 (define (split-c-module-name str)
 101   (let loop ((rev '())
 102              (start 0)
 103              (pos 0)
 104              (end (string-length str)))
 105     (cond
 106      ((= pos end)
 107       (reverse (cons (string->symbol (substring str start pos)) rev)))
 108      ((eq? (string-ref str pos) #\space)
 109       (loop (cons (string->symbol (substring str start pos)) rev)
 110             (+ pos 1)
 111             (+ pos 1)
 112             end))
 113      (else
 114       (loop rev start (+ pos 1) end)))))
 115
 116 (define (convert-c-registered-modules dynobj)
 117   (let ((res (map (lambda (c)
 118                     (list (split-c-module-name (car c)) (cdr c) dynobj))
 119                   (c-registered-modules))))
 120     (c-clear-registered-modules)
 121     res))
 122
 123 (define registered-modules '())
 124
 125 (define (register-modules dynobj)
 126   (set! registered-modules
 127         (append! (convert-c-registered-modules dynobj)
 128                  registered-modules)))
 129
 130 (define (warn-autoload-deprecation modname)
 131   (issue-deprecation-warning
 132    "Autoloading of compiled code modules is deprecated."
 133    "Write a Scheme file instead that uses `load-extension'.")
 134   (issue-deprecation-warning
 135    (simple-format #f "(You just autoloaded module ~S.)" modname)))
 136
 137 (define (init-dynamic-module modname)
 138   ;; Register any linked modules which have been registered on the C level
 139   (register-modules #f)
 140   (or-map (lambda (modinfo)
 141             (if (equal? (car modinfo) modname)
 142                 (begin
 143                   (warn-autoload-deprecation modname)
 144                   (set! registered-modules (delq! modinfo registered-modules))
 145                   (let ((mod (resolve-module modname #f)))
 146                     (save-module-excursion
 147                      (lambda ()
 148                        (set-current-module mod)
 149                        (set-module-public-interface! mod mod)
 150                        (dynamic-call (cadr modinfo) (caddr modinfo))
 151                        ))
 152                     #t))
 153                 #f))
 154           registered-modules))
 155
 156 (define (dynamic-maybe-call name dynobj)
 157   (issue-deprecation-warning
 158    "`dynamic-maybe-call' is deprecated.  "
 159    "Wrap `dynamic-call' in a `false-if-exception' yourself.")
 160   (false-if-exception (dynamic-call name dynobj)))
 161
 162
 163 (define (dynamic-maybe-link filename)
 164   (issue-deprecation-warning
 165    "`dynamic-maybe-link' is deprecated.  "
 166    "Wrap `dynamic-link' in a `false-if-exception' yourself.")
 167   (false-if-exception (dynamic-link filename)))
 168
 169 (define (find-and-link-dynamic-module module-name)
 170   (define (make-init-name mod-name)
 171     (string-append "scm_init"
 172                    (list->string (map (lambda (c)
 173                                         (if (or (char-alphabetic? c)
 174                                                 (char-numeric? c))
 175                                             c
 176                                             #\_))
 177                                       (string->list mod-name)))
 178                    "_module"))
 179
 180   ;; Put the subdirectory for this module in the car of SUBDIR-AND-LIBNAME,
 181   ;; and the `libname' (the name of the module prepended by `lib') in the cdr
 182   ;; field.  For example, if MODULE-NAME is the list (inet tcp-ip udp), then
 183   ;; SUBDIR-AND-LIBNAME will be the pair ("inet/tcp-ip" . "libudp").
 184   (let ((subdir-and-libname
 185          (let loop ((dirs "")
 186                     (syms module-name))
 187            (if (null? (cdr syms))
 188                (cons dirs (string-append "lib" (symbol->string (car syms))))
 189                (loop (string-append dirs (symbol->string (car syms)) "/")
 190                      (cdr syms)))))
 191         (init (make-init-name (apply string-append
 192                                      (map (lambda (s)
 193                                             (string-append "_"
 194                                                            (symbol->string s)))
 195                                           module-name)))))
 196     (let ((subdir (car subdir-and-libname))
 197           (libname (cdr subdir-and-libname)))
 198
 199       ;; Now look in each dir in %LOAD-PATH for `subdir/libfoo.la'.  If that
 200       ;; file exists, fetch the dlname from that file and attempt to link
 201       ;; against it.  If `subdir/libfoo.la' does not exist, or does not seem
 202       ;; to name any shared library, look for `subdir/libfoo.so' instead and
 203       ;; link against that.
 204       (let check-dirs ((dir-list %load-path))
 205         (if (null? dir-list)
 206             #f
 207             (let* ((dir (in-vicinity (car dir-list) subdir))
 208                    (sharlib-full
 209                     (or (try-using-libtool-name dir libname)
 210                         (try-using-sharlib-name dir libname))))
 211               (if (and sharlib-full (file-exists? sharlib-full))
 212                   (link-dynamic-module sharlib-full init)
 213                   (check-dirs (cdr dir-list)))))))))
 214
 215 (define (try-using-libtool-name libdir libname)
 216   (let ((libtool-filename (in-vicinity libdir
 217                                        (string-append libname ".la"))))
 218     (and (file-exists? libtool-filename)
 219          libtool-filename)))
 220
 221 (define (try-using-sharlib-name libdir libname)
 222   (in-vicinity libdir (string-append libname ".so")))
 223
 224 (define (link-dynamic-module filename initname)
 225   ;; Register any linked modules which have been registered on the C level
 226   (register-modules #f)
 227   (let ((dynobj (dynamic-link filename)))
 228     (dynamic-call initname dynobj)
 229     (register-modules dynobj)))
 230
 231 (define (try-module-linked module-name)
 232   (issue-deprecation-warning
 233    "`try-module-linked' is deprecated."
 234    "See the manual for how more on C extensions.")
 235   (init-dynamic-module module-name))
 236
 237 (define (try-module-dynamic-link module-name)
 238   (issue-deprecation-warning
 239    "`try-module-dynamic-link' is deprecated."
 240    "See the manual for how more on C extensions.")
 241   (and (find-and-link-dynamic-module module-name)
 242        (init-dynamic-module module-name)))
 243
 244 \f
 245 (define (list* . args)
 246   (issue-deprecation-warning "'list*' is deprecated.  Use 'cons*' instead.")
 247   (apply cons* args))
 248
 249 (define (feature? sym)
 250   (issue-deprecation-warning
 251    "`feature?' is deprecated.  Use `provided?' instead.")
 252   (provided? sym))
 253
 254 (define-macro (eval-case . clauses)
 255   (issue-deprecation-warning
 256    "`eval-case' is deprecated.  Use `eval-when' instead.")
 257   ;; Practically speaking, eval-case only had load-toplevel and else as
 258   ;; conditions.
 259   (cond
 260    ((assoc-ref clauses '(load-toplevel))
 261     => (lambda (exps)
 262          ;; the *unspecified so that non-toplevel definitions will be
 263          ;; caught
 264          `(begin *unspecified* . ,exps)))
 265    ((assoc-ref clauses 'else)
 266     => (lambda (exps)
 267          `(begin *unspecified* . ,exps)))
 268    (else
 269     `(begin))))
 270
 271 ;; The strange prototype system for uniform arrays has been
 272 ;; deprecated.
 273 (read-hash-extend
 274  #\y
 275  (lambda (c port)
 276    (issue-deprecation-warning
 277     "The `#y' bytevector syntax is deprecated.  Use `#s8' instead.")
 278    (let ((x (read port)))
 279      (cond
 280       ((list? x) (list->s8vector x))
 281       (else (error "#y needs to be followed by a list" x))))))
 282
 283 (define (unmemoize-expr . args)
 284   (issue-deprecation-warning
 285    "`unmemoize-expr' is deprecated. Use `unmemoize-expression' instead.")
 286   (apply unmemoize-expression args))
 287
 288 (define ($asinh z)
 289   (issue-deprecation-warning
 290    "`$asinh' is deprecated.  Use `asinh' instead.")
 291   (asinh z))
 292 (define ($acosh z)
 293   (issue-deprecation-warning
 294    "`$acosh' is deprecated.  Use `acosh' instead.")
 295   (acosh z))
 296 (define ($atanh z)
 297   (issue-deprecation-warning
 298    "`$atanh' is deprecated.  Use `atanh' instead.")
 299   (atanh z))
 300 (define ($sqrt z)
 301   (issue-deprecation-warning
 302    "`$sqrt' is deprecated.  Use `sqrt' instead.")
 303   (sqrt z))
 304 (define ($abs z)
 305   (issue-deprecation-warning
 306    "`$abs' is deprecated.  Use `abs' instead.")
 307   (abs z))
 308 (define ($exp z)
 309   (issue-deprecation-warning
 310    "`$exp' is deprecated.  Use `exp' instead.")
 311   (exp z))
 312 (define ($expt z1 z2)
 313   (issue-deprecation-warning
 314    "`$expt' is deprecated.  Use `expt' instead.")
 315   (expt z1 z2))
 316 (define ($log z)
 317   (issue-deprecation-warning
 318    "`$log' is deprecated.  Use `log' instead.")
 319   (log z))
 320 (define ($sin z)
 321   (issue-deprecation-warning
 322    "`$sin' is deprecated.  Use `sin' instead.")
 323   (sin z))
 324 (define ($cos z)
 325   (issue-deprecation-warning
 326    "`$cos' is deprecated.  Use `cos' instead.")
 327   (cos z))
 328 (define ($tan z)
 329   (issue-deprecation-warning
 330    "`$tan' is deprecated.  Use `tan' instead.")
 331   (tan z))
 332 (define ($asin z)
 333   (issue-deprecation-warning
 334    "`$asin' is deprecated.  Use `asin' instead.")
 335   (asin z))
 336 (define ($acos z)
 337   (issue-deprecation-warning
 338    "`$acos' is deprecated.  Use `acos' instead.")
 339   (acos z))
 340 (define ($atan z)
 341   (issue-deprecation-warning
 342    "`$atan' is deprecated.  Use `atan' instead.")
 343   (atan z))
 344 (define ($sinh z)
 345   (issue-deprecation-warning
 346    "`$sinh' is deprecated.  Use `sinh' instead.")
 347   (sinh z))
 348 (define ($cosh z)
 349   (issue-deprecation-warning
 350    "`$cosh' is deprecated.  Use `cosh' instead.")
 351   (cosh z))
 352 (define ($tanh z)
 353   (issue-deprecation-warning
 354    "`$tanh' is deprecated.  Use `tanh' instead.")
 355   (tanh z))
 356
 357 (define (closure? x)
 358   (issue-deprecation-warning
 359    "`closure?' is deprecated. Use `procedure?' instead.")
 360   (procedure? x))
 361
 362 (define %nil #nil)
 363
 364 ;;; @bind is used by the old elisp code as a dynamic scoping mechanism.
 365 ;;; Please let the Guile developers know if you are using this macro.
 366 ;;;
 367 (define-syntax @bind
 368   (lambda (x)
 369     (define (bound-member id ids)
 370       (cond ((null? ids) #f)
 371             ((bound-identifier=? id (car ids)) #t)
 372             ((bound-member (car ids) (cdr ids)))))
 373
 374     (issue-deprecation-warning
 375      "`@bind' is deprecated. Use `with-fluids' instead.")
 376
 377     (syntax-case x ()
 378       ((_ () b0 b1 ...)
 379        #'(let () b0 b1 ...))
 380       ((_ ((id val) ...) b0 b1 ...)
 381        (and-map identifier? #'(id ...))
 382        (if (let lp ((ids #'(id ...)))
 383              (cond ((null? ids) #f)
 384                    ((bound-member (car ids) (cdr ids)) #t)
 385                    (else (lp (cdr ids)))))
 386            (syntax-violation '@bind "duplicate bound identifier" x)
 387            (with-syntax (((old-v ...) (generate-temporaries #'(id ...)))
 388                          ((v ...) (generate-temporaries #'(id ...))))
 389              #'(let ((old-v id) ...
 390                      (v val) ...)
 391                  (dynamic-wind
 392                    (lambda ()
 393                      (set! id v) ...)
 394                    (lambda () b0 b1 ...)
 395                    (lambda ()
 396                      (set! id old-v) ...)))))))))
 397
 398 ;; There are deprecated definitions for module-ref-submodule and
 399 ;; module-define-submodule! in boot-9.scm.
 400
 401 ;; Define (%app) and (%app modules), and have (app) alias (%app). This
 402 ;; side-effects the-root-module, both to the submodules table and (through
 403 ;; module-define-submodule! above) the obarray.
 404 ;;
 405 (let ((%app (make-module 31)))
 406   (set-module-name! %app '(%app))
 407   (module-define-submodule! the-root-module '%app %app)
 408   (module-define-submodule! the-root-module 'app %app)
 409   (module-define-submodule! %app 'modules (resolve-module '() #f)))
 410
 411 ;; Allow code that poked %module-public-interface to keep on working.
 412 ;;
 413 (set! module-public-interface
 414       (let ((getter module-public-interface))
 415         (lambda (mod)
 416           (or (getter mod)
 417               (cond
 418                ((and=> (module-local-variable mod '%module-public-interface)
 419                        variable-ref)
 420                 => (lambda (iface)
 421                      (issue-deprecation-warning
 422 "Setting a module's public interface via munging %module-public-interface is
 423 deprecated. Use set-module-public-interface! instead.")
 424                      (set-module-public-interface! mod iface)
 425                      iface))
 426                (else #f))))))
 427
 428 (set! set-module-public-interface!
 429       (let ((setter set-module-public-interface!))
 430         (lambda (mod iface)
 431           (setter mod iface)
 432           (module-define! mod '%module-public-interface iface))))
 433
 434 (define (bad-throw key . args)
 435   (issue-deprecation-warning
 436    "`bad-throw' in the default environment is deprecated.
 437 Find it in the `(ice-9 scm-style-repl)' module instead.")
 438   (apply (@ (ice-9 scm-style-repl) bad-throw) key args))
 439
 440 (define (error-catching-loop thunk)
 441   (issue-deprecation-warning
 442    "`error-catching-loop' in the default environment is deprecated.
 443 Find it in the `(ice-9 scm-style-repl)' module instead.")
 444   ((@ (ice-9 scm-style-repl) error-catching-loop) thunk))
 445
 446 (define (error-catching-repl r e p)
 447   (issue-deprecation-warning
 448    "`error-catching-repl' in the default environment is deprecated.
 449 Find it in the `(ice-9 scm-style-repl)' module instead.")
 450   ((@ (ice-9 scm-style-repl) error-catching-repl) r e p))
 451
 452 (define (scm-style-repl)
 453   (issue-deprecation-warning
 454    "`scm-style-repl' in the default environment is deprecated.
 455 Find it in the `(ice-9 scm-style-repl)' module instead, or
 456 better yet, use the repl from `(system repl repl)'.")
 457   ((@ (ice-9 scm-style-repl) scm-style-repl)))
 458
 459
 460 ;;; Apply-to-args had the following comment attached to it in boot-9, but it's
 461 ;;; wrong-headed: in the mentioned case, a point should either be a record or
 462 ;;; multiple values.
 463 ;;;
 464 ;;; apply-to-args is functionally redundant with apply and, worse,
 465 ;;; is less general than apply since it only takes two arguments.
 466 ;;;
 467 ;;; On the other hand, apply-to-args is a syntacticly convenient way to
 468 ;;; perform binding in many circumstances when the "let" family of
 469 ;;; of forms don't cut it.  E.g.:
 470 ;;;
 471 ;;;     (apply-to-args (return-3d-mouse-coords)
 472 ;;;       (lambda (x y z)
 473 ;;;             ...))
 474 ;;;
 475
 476 (define (apply-to-args args fn)
 477   (issue-deprecation-warning
 478    "`apply-to-args' is deprecated. Include a local copy in your program.")
 479   (apply fn args))
 480
 481 (define (has-suffix? str suffix)
 482   (issue-deprecation-warning
 483    "`has-suffix?' is deprecated. Use `string-suffix?' instead (args reversed).")
 484   (string-suffix? suffix str))
 485
 486 (define scheme-file-suffix
 487   (lambda ()
 488     (issue-deprecation-warning
 489      "`scheme-file-suffix' is deprecated. Use `%load-extensions' instead.")
 490     ".scm"))
 491
 492 \f
 493
 494 ;;; {Command Line Options}
 495 ;;;
 496
 497 (define (get-option argv kw-opts kw-args return)
 498   (issue-deprecation-warning
 499    "`get-option' is deprecated. Use `(ice-9 getopt-long)' instead.")
 500   (cond
 501    ((null? argv)
 502     (return #f #f argv))
 503
 504    ((or (not (eq? #\- (string-ref (car argv) 0)))
 505         (eq? (string-length (car argv)) 1))
 506     (return 'normal-arg (car argv) (cdr argv)))
 507
 508    ((eq? #\- (string-ref (car argv) 1))
 509     (let* ((kw-arg-pos (or (string-index (car argv) #\=)
 510                            (string-length (car argv))))
 511            (kw (symbol->keyword (substring (car argv) 2 kw-arg-pos)))
 512            (kw-opt? (member kw kw-opts))
 513            (kw-arg? (member kw kw-args))
 514            (arg (or (and (not (eq? kw-arg-pos (string-length (car argv))))
 515                          (substring (car argv)
 516                                     (+ kw-arg-pos 1)
 517                                     (string-length (car argv))))
 518                     (and kw-arg?
 519                          (begin (set! argv (cdr argv)) (car argv))))))
 520       (if (or kw-opt? kw-arg?)
 521           (return kw arg (cdr argv))
 522           (return 'usage-error kw (cdr argv)))))
 523
 524    (else
 525     (let* ((char (substring (car argv) 1 2))
 526            (kw (symbol->keyword char)))
 527       (cond
 528
 529        ((member kw kw-opts)
 530         (let* ((rest-car (substring (car argv) 2 (string-length (car argv))))
 531                (new-argv (if (= 0 (string-length rest-car))
 532                              (cdr argv)
 533                              (cons (string-append "-" rest-car) (cdr argv)))))
 534           (return kw #f new-argv)))
 535
 536        ((member kw kw-args)
 537         (let* ((rest-car (substring (car argv) 2 (string-length (car argv))))
 538                (arg (if (= 0 (string-length rest-car))
 539                         (cadr argv)
 540                         rest-car))
 541                (new-argv (if (= 0 (string-length rest-car))
 542                              (cddr argv)
 543                              (cdr argv))))
 544           (return kw arg new-argv)))
 545
 546        (else (return 'usage-error kw argv)))))))
 547
 548 (define (for-next-option proc argv kw-opts kw-args)
 549   (issue-deprecation-warning
 550    "`for-next-option' is deprecated. Use `(ice-9 getopt-long)' instead.")
 551   (let loop ((argv argv))
 552     (get-option argv kw-opts kw-args
 553                 (lambda (opt opt-arg argv)
 554                   (and opt (proc opt opt-arg argv loop))))))
 555
 556 (define (display-usage-report kw-desc)
 557   (issue-deprecation-warning
 558    "`display-usage-report' is deprecated. Use `(ice-9 getopt-long)' instead.")
 559   (for-each
 560    (lambda (kw)
 561      (or (eq? (car kw) #t)
 562          (eq? (car kw) 'else)
 563          (let* ((opt-desc kw)
 564                 (help (cadr opt-desc))
 565                 (opts (car opt-desc))
 566                 (opts-proper (if (string? (car opts)) (cdr opts) opts))
 567                 (arg-name (if (string? (car opts))
 568                               (string-append "<" (car opts) ">")
 569                               ""))
 570                 (left-part (string-append
 571                             (with-output-to-string
 572                               (lambda ()
 573                                 (map (lambda (x) (display (keyword->symbol x)) (display " "))
 574                                      opts-proper)))
 575                             arg-name))
 576                 (middle-part (if (and (< (string-length left-part) 30)
 577                                       (< (string-length help) 40))
 578                                  (make-string (- 30 (string-length left-part)) #\ )
 579                                  "\n\t")))
 580            (display left-part)
 581            (display middle-part)
 582            (display help)
 583            (newline))))
 584    kw-desc))
 585
 586 (define (transform-usage-lambda cases)
 587   (issue-deprecation-warning
 588    "`display-usage-report' is deprecated. Use `(ice-9 getopt-long)' instead.")
 589   (let* ((raw-usage (delq! 'else (map car cases)))
 590          (usage-sans-specials (map (lambda (x)
 591                                     (or (and (not (list? x)) x)
 592                                         (and (symbol? (car x)) #t)
 593                                         (and (boolean? (car x)) #t)
 594                                         x))
 595                                   raw-usage))
 596          (usage-desc (delq! #t usage-sans-specials))
 597          (kw-desc (map car usage-desc))
 598          (kw-opts (apply append (map (lambda (x) (and (not (string? (car x))) x)) kw-desc)))
 599          (kw-args (apply append (map (lambda (x) (and (string? (car x)) (cdr x))) kw-desc)))
 600          (transmogrified-cases (map (lambda (case)
 601                                       (cons (let ((opts (car case)))
 602                                               (if (or (boolean? opts) (eq? 'else opts))
 603                                                   opts
 604                                                   (cond
 605                                                    ((symbol? (car opts))  opts)
 606                                                    ((boolean? (car opts)) opts)
 607                                                    ((string? (caar opts)) (cdar opts))
 608                                                    (else (car opts)))))
 609                                             (cdr case)))
 610                                     cases)))
 611     `(let ((%display-usage (lambda () (display-usage-report ',usage-desc))))
 612        (lambda (%argv)
 613          (let %next-arg ((%argv %argv))
 614            (get-option %argv
 615                        ',kw-opts
 616                        ',kw-args
 617                        (lambda (%opt %arg %new-argv)
 618                          (case %opt
 619                            ,@ transmogrified-cases))))))))
 620
 621 \f
 622
 623 ;;; {collect}
 624 ;;;
 625 ;;; Similar to `begin' but returns a list of the results of all constituent
 626 ;;; forms instead of the result of the last form.
 627 ;;;
 628
 629 (define-syntax collect
 630   (lambda (x)
 631     (issue-deprecation-warning
 632      "`collect' is deprecated. Define it yourself.")
 633     (syntax-case x ()
 634       ((_) #''())
 635       ((_ x x* ...)
 636        #'(let ((val x))
 637            (cons val (collect x* ...)))))))
 638
 639
 640 \f
 641
 642 (define (assert-repl-silence v)
 643   (issue-deprecation-warning
 644    "`assert-repl-silence' has moved to `(ice-9 scm-style-repl)'.")
 645   ((@ (ice-9 scm-style-repl) assert-repl-silence) v))
 646
 647 (define (assert-repl-print-unspecified v)
 648   (issue-deprecation-warning
 649    "`assert-repl-print-unspecified' has moved to `(ice-9 scm-style-repl)'.")
 650   ((@ (ice-9 scm-style-repl) assert-repl-print-unspecified) v))
 651
 652 (define (assert-repl-verbosity v)
 653   (issue-deprecation-warning
 654    "`assert-repl-verbosity' has moved to `(ice-9 scm-style-repl)'.")
 655   ((@ (ice-9 scm-style-repl) assert-repl-verbosity) v))
 656
 657 (define (set-repl-prompt! v)
 658   (issue-deprecation-warning
 659    "`set-repl-prompt!' is deprecated. Use `repl-default-prompt-set!' from
 660 the `(system repl common)' module.")
 661   ;; Avoid @, as when bootstrapping it will cause the (system repl common)
 662   ;; module to be loaded at expansion time, which eventually loads srfi-1, but
 663   ;; that fails due to an unbuilt supporting lib... grrrrrrrrr.
 664   ((module-ref (resolve-interface '(system repl common))
 665                'repl-default-prompt-set!)
 666    v))
 667
 668 (define (set-batch-mode?! arg)
 669   (cond
 670    (arg
 671     (issue-deprecation-warning
 672      "`set-batch-mode?!' is deprecated. Use `ensure-batch-mode!' instead.")
 673     (ensure-batch-mode!))
 674    (else
 675     (issue-deprecation-warning
 676      "`set-batch-mode?!' with an argument of `#f' is deprecated. Use the
 677 `*repl-stack*' fluid instead.")
 678     #t)))
 679
 680 (define (repl read evaler print)
 681   (issue-deprecation-warning
 682    "`repl' is deprecated. Define it yourself.")
 683   (let loop ((source (read (current-input-port))))
 684     (print (evaler source))
 685     (loop (read (current-input-port)))))
 686
 687 (define (pre-unwind-handler-dispatch key . args)
 688   (issue-deprecation-warning
 689    "`pre-unwind-handler-dispatch' is deprecated. Use
 690 `default-pre-unwind-handler' from `(ice-9 scm-style-repl)' directly.")
 691   (apply (@ (ice-9 scm-style-repl) default-pre-unwind-handler) key args))
 692
 693 (define (default-pre-unwind-handler key . args)
 694   (issue-deprecation-warning
 695    "`default-pre-unwind-handler' is deprecated. Use it from
 696 `(ice-9 scm-style-repl)' if you need it.")
 697   (apply (@ (ice-9 scm-style-repl) default-pre-unwind-handler) key args))
 698
 699 (define (handle-system-error key . args)
 700   (issue-deprecation-warning
 701    "`handle-system-error' is deprecated. Use it from
 702 `(ice-9 scm-style-repl)' if you need it.")
 703   (apply (@ (ice-9 scm-style-repl) handle-system-error) key args))
 704
 705 (define-syntax stack-saved?
 706   (make-variable-transformer
 707    (lambda (x)
 708      (issue-deprecation-warning
 709       "`stack-saved?' is deprecated. Use it from
 710 `(ice-9 save-stack)' if you need it.")
 711      (syntax-case x (set!)
 712        ((set! id val)
 713         (identifier? #'id)
 714         #'(set! (@ (ice-9 save-stack) stack-saved?) val))
 715        (id
 716         (identifier? #'id)
 717         #'(@ (ice-9 save-stack) stack-saved?))))))
 718
 719 (define-syntax the-last-stack
 720   (lambda (x)
 721     (issue-deprecation-warning
 722      "`the-last-stack' is deprecated. Use it from `(ice-9 save-stack)'
 723 if you need it.")
 724     (syntax-case x ()
 725       (id
 726        (identifier? #'id)
 727        #'(@ (ice-9 save-stack) the-last-stack)))))
 728
 729 (define (save-stack . args)
 730   (issue-deprecation-warning
 731    "`save-stack' is deprecated. Use it from `(ice-9 save-stack)' if you need
 732 it.")
 733   (apply (@ (ice-9 save-stack) save-stack) args))
 734
 735 (define (named-module-use! user usee)
 736   (issue-deprecation-warning
 737    "`named-module-use!' is deprecated. Define it yourself if you need it.")
 738   (module-use! (resolve-module user) (resolve-interface usee)))
 739
 740 (define (top-repl)
 741   (issue-deprecation-warning
 742    "`top-repl' has moved to the `(ice-9 top-repl)' module.")
 743   ((module-ref (resolve-module '(ice-9 top-repl)) 'top-repl)))
 744
 745 (set! debug-enable
 746       (let ((debug-enable debug-enable))
 747         (lambda opts
 748           (if (memq 'debug opts)
 749               (begin
 750                 (issue-deprecation-warning
 751                  "`(debug-enable 'debug)' is obsolete and has no effect."
 752                  "Remove it from your code.")
 753                 (apply debug-enable (delq 'debug opts)))
 754               (apply debug-enable opts)))))
 755
 756 (define (turn-on-debugging)
 757   (issue-deprecation-warning
 758    "`(turn-on-debugging)' is obsolete and usually has no effect."
 759    "Debugging capabilities are present by default.")
 760   (debug-enable 'backtrace)
 761   (read-enable 'positions))
 762
 763 (define (read-hash-procedures-warning)
 764   (issue-deprecation-warning
 765    "`read-hash-procedures' is deprecated."
 766    "Use the fluid `%read-hash-procedures' instead."))
 767
 768 (define-syntax read-hash-procedures
 769   (identifier-syntax
 770     (_
 771      (begin (read-hash-procedures-warning)
 772             (fluid-ref %read-hash-procedures)))
 773     ((set! _ expr)
 774      (begin (read-hash-procedures-warning)
 775             (fluid-set! %read-hash-procedures expr)))))
 776
 777 (define (process-define-module args)
 778   (define (missing kw)
 779     (error "missing argument to define-module keyword" kw))
 780   (define (unrecognized arg)
 781     (error "unrecognized define-module argument" arg))
 782
 783   (issue-deprecation-warning
 784    "`process-define-module' is deprecated.  Use `define-module*' instead.")
 785
 786   (let ((name (car args))
 787         (filename #f)
 788         (pure? #f)
 789         (version #f)
 790         (system? #f)
 791         (duplicates '())
 792         (transformer #f))
 793     (let loop ((kws (cdr args))
 794                (imports '())
 795                (exports '())
 796                (re-exports '())
 797                (replacements '())
 798                (autoloads '()))
 799       (if (null? kws)
 800           (define-module* name
 801             #:filename filename #:pure pure? #:version version
 802             #:duplicates duplicates #:transformer transformer
 803             #:imports (reverse! imports)
 804             #:exports exports
 805             #:re-exports re-exports
 806             #:replacements replacements
 807             #:autoloads autoloads)
 808           (case (car kws)
 809             ((#:use-module #:use-syntax)
 810              (or (pair? (cdr kws))
 811                  (missing (car kws)))
 812              (cond
 813               ((equal? (cadr kws) '(ice-9 syncase))
 814                (issue-deprecation-warning
 815                 "(ice-9 syncase) is deprecated. Support for syntax-case is now in Guile core.")
 816                (loop (cddr kws)
 817                      imports exports re-exports replacements autoloads))
 818               (else
 819                (let ((iface-spec (cadr kws)))
 820                  (if (eq? (car kws) #:use-syntax)
 821                      (set! transformer iface-spec))
 822                  (loop (cddr kws)
 823                        (cons iface-spec imports) exports re-exports
 824                        replacements autoloads)))))
 825             ((#:autoload)
 826              (or (and (pair? (cdr kws)) (pair? (cddr kws)))
 827                  (missing (car kws)))
 828              (let ((name (cadr kws))
 829                    (bindings (caddr kws)))
 830                (loop (cdddr kws)
 831                      imports exports re-exports
 832                      replacements (cons* name bindings autoloads))))
 833             ((#:no-backtrace)
 834              ;; FIXME: deprecate?
 835              (set! system? #t)
 836              (loop (cdr kws)
 837                    imports exports re-exports replacements autoloads))
 838             ((#:pure)
 839              (set! pure? #t)
 840              (loop (cdr kws)
 841                    imports exports re-exports replacements autoloads))
 842             ((#:version)
 843              (or (pair? (cdr kws))
 844                  (missing (car kws)))
 845              (set! version (cadr kws))
 846              (loop (cddr kws)
 847                    imports exports re-exports replacements autoloads))
 848             ((#:duplicates)
 849              (if (not (pair? (cdr kws)))
 850                  (missing (car kws)))
 851              (set! duplicates (cadr kws))
 852              (loop (cddr kws)
 853                    imports exports re-exports replacements autoloads))
 854             ((#:export #:export-syntax)
 855              (or (pair? (cdr kws))
 856                  (missing (car kws)))
 857              (loop (cddr kws)
 858                    imports (append exports (cadr kws)) re-exports
 859                    replacements autoloads))
 860             ((#:re-export #:re-export-syntax)
 861              (or (pair? (cdr kws))
 862                  (missing (car kws)))
 863              (loop (cddr kws)
 864                    imports exports (append re-exports (cadr kws))
 865                    replacements autoloads))
 866             ((#:replace #:replace-syntax)
 867              (or (pair? (cdr kws))
 868                  (missing (car kws)))
 869              (loop (cddr kws)
 870                    imports exports re-exports
 871                    (append replacements (cadr kws)) autoloads))
 872             ((#:filename)
 873              (or (pair? (cdr kws))
 874                  (missing (car kws)))
 875              (set! filename (cadr kws))
 876              (loop (cddr kws)
 877                    imports exports re-exports replacements autoloads))
 878             (else
 879              (unrecognized kws)))))))
 880
 881 (define-syntax fluid-let-syntax
 882   (lambda (x)
 883     (issue-deprecation-warning
 884      "`fluid-let-syntax' is deprecated.  Use syntax parameters instead.")
 885     (syntax-case x ()
 886       ((_ ((k v) ...) body0 body ...)
 887        #'(syntax-parameterize ((k v) ...)
 888            body0 body ...)))))
 889
 890 (define (close-io-port port)
 891   (issue-deprecation-warning
 892    "`close-io-port' is deprecated.  Use `close-port' instead.")
 893   (close-port port))
 894
 895 (define (set-system-module! m s)
 896   (issue-deprecation-warning
 897    "`set-system-module!' is deprecated.  There is no need to use it.")
 898   (set-procedure-property! (module-eval-closure m) 'system-module s))
 899
 900 (set! module-eval-closure
 901       (lambda (m)
 902         (issue-deprecation-warning
 903          "`module-eval-closure' is deprecated.  Use module-variable or module-define! instead.")
 904         (standard-eval-closure m)))
 905
 906 ;; Legacy definition.  We can't make it identifier-syntax yet though,
 907 ;; because compiled code might rely on it.
 908 (define char-code-limit 256)