module/ice-9/deprecated.scm

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