$tanh
closure?
%nil
- @bind)
+ @bind
+ bad-throw
+ error-catching-loop
+ error-catching-repl
+ scm-style-repl
+ apply-to-args
+ has-suffix?
+ scheme-file-suffix
+ get-option
+ for-next-option
+ display-usage-report
+ transform-usage-lambda
+ collect
+ assert-repl-silence
+ assert-repl-print-unspecified
+ assert-repl-verbosity
+ set-repl-prompt!
+ set-batch-mode?!
+ repl
+ pre-unwind-handler-dispatch
+ default-pre-unwind-handler
+ handle-system-error
+ stack-saved?
+ the-last-stack
+ save-stack
+ named-module-use!
+ top-repl)
#:replace (module-ref-submodule module-define-submodule!))
(define (module-ref-submodule module name)
(or (hashq-ref (module-submodules module) name)
+ (and (module-submodule-binder module)
+ ((module-submodule-binder module) module name))
(let ((var (module-local-variable module name)))
(and (variable-bound? var)
(module? (variable-ref var))
(module-define-submodule! the-root-module '%app %app)
(module-define-submodule! the-root-module 'app %app)
(module-define-submodule! %app 'modules (resolve-module '() #f)))
+
+;; Allow code that poked %module-public-interface to keep on working.
+;;
+(set! module-public-interface
+ (let ((getter module-public-interface))
+ (lambda (mod)
+ (or (getter mod)
+ (cond
+ ((and=> (module-local-variable mod '%module-public-interface)
+ variable-ref)
+ => (lambda (iface)
+ (issue-deprecation-warning
+"Setting a module's public interface via munging %module-public-interface is
+deprecated. Use set-module-public-interface! instead.")
+ (set-module-public-interface! mod iface)
+ iface))
+ (else #f))))))
+
+(set! set-module-public-interface!
+ (let ((setter set-module-public-interface!))
+ (lambda (mod iface)
+ (setter mod iface)
+ (module-define! mod '%module-public-interface iface))))
+
+(define (bad-throw key . args)
+ (issue-deprecation-warning
+ "`bad-throw' in the default environment is deprecated.
+Find it in the `(ice-9 scm-style-repl)' module instead.")
+ (apply (@ (ice-9 scm-style-repl) bad-throw) key args))
+
+(define (error-catching-loop thunk)
+ (issue-deprecation-warning
+ "`error-catching-loop' in the default environment is deprecated.
+Find it in the `(ice-9 scm-style-repl)' module instead.")
+ ((@ (ice-9 scm-style-repl) error-catching-loop) thunk))
+
+(define (error-catching-repl r e p)
+ (issue-deprecation-warning
+ "`error-catching-repl' in the default environment is deprecated.
+Find it in the `(ice-9 scm-style-repl)' module instead.")
+ ((@ (ice-9 scm-style-repl) error-catching-repl) r e p))
+
+(define (scm-style-repl)
+ (issue-deprecation-warning
+ "`scm-style-repl' in the default environment is deprecated.
+Find it in the `(ice-9 scm-style-repl)' module instead, or
+better yet, use the repl from `(system repl repl)'.")
+ ((@ (ice-9 scm-style-repl) scm-style-repl)))
+
+
+;;; Apply-to-args had the following comment attached to it in boot-9, but it's
+;;; wrong-headed: in the mentioned case, a point should either be a record or
+;;; multiple values.
+;;;
+;;; apply-to-args is functionally redundant with apply and, worse,
+;;; is less general than apply since it only takes two arguments.
+;;;
+;;; On the other hand, apply-to-args is a syntacticly convenient way to
+;;; perform binding in many circumstances when the "let" family of
+;;; of forms don't cut it. E.g.:
+;;;
+;;; (apply-to-args (return-3d-mouse-coords)
+;;; (lambda (x y z)
+;;; ...))
+;;;
+
+(define (apply-to-args args fn)
+ (issue-deprecation-warning
+ "`apply-to-args' is deprecated. Include a local copy in your program.")
+ (apply fn args))
+
+(define (has-suffix? str suffix)
+ (issue-deprecation-warning
+ "`has-suffix?' is deprecated. Use `string-suffix?' instead (args reversed).")
+ (string-suffix? suffix str))
+
+(define scheme-file-suffix
+ (lambda ()
+ (issue-deprecation-warning
+ "`scheme-file-suffix' is deprecated. Use `%load-extensions' instead.")
+ ".scm"))
+
+\f
+
+;;; {Command Line Options}
+;;;
+
+(define (get-option argv kw-opts kw-args return)
+ (issue-deprecation-warning
+ "`get-option' is deprecated. Use `(ice-9 getopt-long)' instead.")
+ (cond
+ ((null? argv)
+ (return #f #f argv))
+
+ ((or (not (eq? #\- (string-ref (car argv) 0)))
+ (eq? (string-length (car argv)) 1))
+ (return 'normal-arg (car argv) (cdr argv)))
+
+ ((eq? #\- (string-ref (car argv) 1))
+ (let* ((kw-arg-pos (or (string-index (car argv) #\=)
+ (string-length (car argv))))
+ (kw (symbol->keyword (substring (car argv) 2 kw-arg-pos)))
+ (kw-opt? (member kw kw-opts))
+ (kw-arg? (member kw kw-args))
+ (arg (or (and (not (eq? kw-arg-pos (string-length (car argv))))
+ (substring (car argv)
+ (+ kw-arg-pos 1)
+ (string-length (car argv))))
+ (and kw-arg?
+ (begin (set! argv (cdr argv)) (car argv))))))
+ (if (or kw-opt? kw-arg?)
+ (return kw arg (cdr argv))
+ (return 'usage-error kw (cdr argv)))))
+
+ (else
+ (let* ((char (substring (car argv) 1 2))
+ (kw (symbol->keyword char)))
+ (cond
+
+ ((member kw kw-opts)
+ (let* ((rest-car (substring (car argv) 2 (string-length (car argv))))
+ (new-argv (if (= 0 (string-length rest-car))
+ (cdr argv)
+ (cons (string-append "-" rest-car) (cdr argv)))))
+ (return kw #f new-argv)))
+
+ ((member kw kw-args)
+ (let* ((rest-car (substring (car argv) 2 (string-length (car argv))))
+ (arg (if (= 0 (string-length rest-car))
+ (cadr argv)
+ rest-car))
+ (new-argv (if (= 0 (string-length rest-car))
+ (cddr argv)
+ (cdr argv))))
+ (return kw arg new-argv)))
+
+ (else (return 'usage-error kw argv)))))))
+
+(define (for-next-option proc argv kw-opts kw-args)
+ (issue-deprecation-warning
+ "`for-next-option' is deprecated. Use `(ice-9 getopt-long)' instead.")
+ (let loop ((argv argv))
+ (get-option argv kw-opts kw-args
+ (lambda (opt opt-arg argv)
+ (and opt (proc opt opt-arg argv loop))))))
+
+(define (display-usage-report kw-desc)
+ (issue-deprecation-warning
+ "`display-usage-report' is deprecated. Use `(ice-9 getopt-long)' instead.")
+ (for-each
+ (lambda (kw)
+ (or (eq? (car kw) #t)
+ (eq? (car kw) 'else)
+ (let* ((opt-desc kw)
+ (help (cadr opt-desc))
+ (opts (car opt-desc))
+ (opts-proper (if (string? (car opts)) (cdr opts) opts))
+ (arg-name (if (string? (car opts))
+ (string-append "<" (car opts) ">")
+ ""))
+ (left-part (string-append
+ (with-output-to-string
+ (lambda ()
+ (map (lambda (x) (display (keyword->symbol x)) (display " "))
+ opts-proper)))
+ arg-name))
+ (middle-part (if (and (< (string-length left-part) 30)
+ (< (string-length help) 40))
+ (make-string (- 30 (string-length left-part)) #\ )
+ "\n\t")))
+ (display left-part)
+ (display middle-part)
+ (display help)
+ (newline))))
+ kw-desc))
+
+(define (transform-usage-lambda cases)
+ (issue-deprecation-warning
+ "`display-usage-report' is deprecated. Use `(ice-9 getopt-long)' instead.")
+ (let* ((raw-usage (delq! 'else (map car cases)))
+ (usage-sans-specials (map (lambda (x)
+ (or (and (not (list? x)) x)
+ (and (symbol? (car x)) #t)
+ (and (boolean? (car x)) #t)
+ x))
+ raw-usage))
+ (usage-desc (delq! #t usage-sans-specials))
+ (kw-desc (map car usage-desc))
+ (kw-opts (apply append (map (lambda (x) (and (not (string? (car x))) x)) kw-desc)))
+ (kw-args (apply append (map (lambda (x) (and (string? (car x)) (cdr x))) kw-desc)))
+ (transmogrified-cases (map (lambda (case)
+ (cons (let ((opts (car case)))
+ (if (or (boolean? opts) (eq? 'else opts))
+ opts
+ (cond
+ ((symbol? (car opts)) opts)
+ ((boolean? (car opts)) opts)
+ ((string? (caar opts)) (cdar opts))
+ (else (car opts)))))
+ (cdr case)))
+ cases)))
+ `(let ((%display-usage (lambda () (display-usage-report ',usage-desc))))
+ (lambda (%argv)
+ (let %next-arg ((%argv %argv))
+ (get-option %argv
+ ',kw-opts
+ ',kw-args
+ (lambda (%opt %arg %new-argv)
+ (case %opt
+ ,@ transmogrified-cases))))))))
+
+\f
+
+;;; {collect}
+;;;
+;;; Similar to `begin' but returns a list of the results of all constituent
+;;; forms instead of the result of the last form.
+;;;
+
+(define-syntax collect
+ (lambda (x)
+ (issue-deprecation-warning
+ "`collect' is deprecated. Define it yourself.")
+ (syntax-case x ()
+ ((_) #''())
+ ((_ x x* ...)
+ #'(let ((val x))
+ (cons val (collect x* ...)))))))
+
+
+\f
+
+(define (assert-repl-silence v)
+ (issue-deprecation-warning
+ "`assert-repl-silence' has moved to `(ice-9 scm-style-repl)'.")
+ ((@ (ice-9 scm-style-repl) assert-repl-silence) v))
+
+(define (assert-repl-print-unspecified v)
+ (issue-deprecation-warning
+ "`assert-repl-print-unspecified' has moved to `(ice-9 scm-style-repl)'.")
+ ((@ (ice-9 scm-style-repl) assert-repl-print-unspecified) v))
+
+(define (assert-repl-verbosity v)
+ (issue-deprecation-warning
+ "`assert-repl-verbosity' has moved to `(ice-9 scm-style-repl)'.")
+ ((@ (ice-9 scm-style-repl) assert-repl-verbosity) v))
+
+(define (set-repl-prompt! v)
+ (issue-deprecation-warning
+ "`set-repl-prompt!' is deprecated. Use `repl-default-prompt-set!' from
+the `(system repl common)' module.")
+ ;; Avoid @, as when bootstrapping it will cause the (system repl common)
+ ;; module to be loaded at expansion time, which eventually loads srfi-1, but
+ ;; that fails due to an unbuilt supporting lib... grrrrrrrrr.
+ ((module-ref (resolve-interface '(system repl common))
+ 'repl-default-prompt-set!)
+ v))
+
+(define (set-batch-mode?! arg)
+ (cond
+ (arg
+ (issue-deprecation-warning
+ "`set-batch-mode?!' is deprecated. Use `ensure-batch-mode!' instead.")
+ (ensure-batch-mode!))
+ (else
+ (issue-deprecation-warning
+ "`set-batch-mode?!' with an argument of `#f' is deprecated. Use the
+`*repl-stack*' fluid instead.")
+ #t)))
+
+(define (repl read evaler print)
+ (issue-deprecation-warning
+ "`repl' is deprecated. Define it yourself.")
+ (let loop ((source (read (current-input-port))))
+ (print (evaler source))
+ (loop (read (current-input-port)))))
+
+(define (pre-unwind-handler-dispatch key . args)
+ (issue-deprecation-warning
+ "`pre-unwind-handler-dispatch' is deprecated. Use
+`default-pre-unwind-handler' from `(ice-9 scm-style-repl)' directly.")
+ (apply (@ (ice-9 scm-style-repl) default-pre-unwind-handler) key args))
+
+(define (default-pre-unwind-handler key . args)
+ (issue-deprecation-warning
+ "`default-pre-unwind-handler' is deprecated. Use it from
+`(ice-9 scm-style-repl)' if you need it.")
+ (apply (@ (ice-9 scm-style-repl) default-pre-unwind-handler) key args))
+
+(define (handle-system-error key . args)
+ (issue-deprecation-warning
+ "`handle-system-error' is deprecated. Use it from
+`(ice-9 scm-style-repl)' if you need it.")
+ (apply (@ (ice-9 scm-style-repl) handle-system-error) key args))
+
+(define-syntax stack-saved?
+ (make-variable-transformer
+ (lambda (x)
+ (issue-deprecation-warning
+ "`stack-saved?' is deprecated. Use it from
+`(ice-9 save-stack)' if you need it.")
+ (syntax-case x (set!)
+ ((set! id val)
+ (identifier? #'id)
+ #'(set! (@ (ice-9 save-stack) stack-saved?) val))
+ (id
+ (identifier? #'id)
+ #'(@ (ice-9 save-stack) stack-saved?))))))
+
+(define-syntax the-last-stack
+ (lambda (x)
+ (issue-deprecation-warning
+ "`the-last-stack' is deprecated. Use it from `(ice-9 save-stack)'
+if you need it.")
+ (syntax-case x ()
+ (id
+ (identifier? #'id)
+ #'(@ (ice-9 save-stack) the-last-stack)))))
+
+(define (save-stack . args)
+ (issue-deprecation-warning
+ "`save-stack' is deprecated. Use it from `(ice-9 save-stack)' if you need
+it.")
+ (apply (@ (ice-9 save-stack) save-stack) args))
+
+(define (named-module-use! user usee)
+ (issue-deprecation-warning
+ "`named-module-use!' is deprecated. Define it yourself if you need it.")
+ (module-use! (resolve-module user) (resolve-interface usee)))
+
+(define (top-repl)
+ (issue-deprecation-warning
+ "`top-repl' has moved to the `(ice-9 top-repl)' module.")
+ ((module-ref (resolve-module '(ice-9 top-repl)) 'top-repl)))
HCoop / bpt / guile.git / blobdiff