diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 12714bd6c..c8dc1a534 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -3086,113 +3086,6 @@ module '(ice-9 q) '(make-q q-length))}." (run-hook before-read-hook) ((or reader read) (current-input-port)))) -(define (scm-style-repl) - - (letrec ( - (start-gc-rt #f) - (start-rt #f) - (repl-report-start-timing (lambda () - (set! start-gc-rt (gc-run-time)) - (set! start-rt (get-internal-run-time)))) - (repl-report (lambda () - (display ";;; ") - (display (inexact->exact - (* 1000 (/ (- (get-internal-run-time) start-rt) - internal-time-units-per-second)))) - (display " msec (") - (display (inexact->exact - (* 1000 (/ (- (gc-run-time) start-gc-rt) - internal-time-units-per-second)))) - (display " msec in gc)\n"))) - - (consume-trailing-whitespace - (lambda () - (let ((ch (peek-char))) - (cond - ((eof-object? ch)) - ((or (char=? ch #\space) (char=? ch #\tab)) - (read-char) - (consume-trailing-whitespace)) - ((char=? ch #\newline) - (read-char)))))) - (-read (lambda () - (let ((val - (let ((prompt (cond ((string? scm-repl-prompt) - scm-repl-prompt) - ((thunk? scm-repl-prompt) - (scm-repl-prompt)) - (scm-repl-prompt "> ") - (else "")))) - (repl-reader prompt)))) - - ;; As described in R4RS, the READ procedure updates the - ;; port to point to the first character past the end of - ;; the external representation of the object. This - ;; means that it doesn't consume the newline typically - ;; found after an expression. This means that, when - ;; debugging Guile with GDB, GDB gets the newline, which - ;; it often interprets as a "continue" command, making - ;; breakpoints kind of useless. So, consume any - ;; trailing newline here, as well as any whitespace - ;; before it. - ;; But not if EOF, for control-D. - (if (not (eof-object? val)) - (consume-trailing-whitespace)) - (run-hook after-read-hook) - (if (eof-object? val) - (begin - (repl-report-start-timing) - (if scm-repl-verbose - (begin - (newline) - (display ";;; EOF -- quitting") - (newline))) - (quit 0))) - val))) - - (-eval (lambda (sourc) - (repl-report-start-timing) - (run-hook before-eval-hook sourc) - (let ((val (start-stack 'repl-stack - ;; If you change this procedure - ;; (primitive-eval), please also - ;; modify the repl-stack case in - ;; save-stack so that stack cutting - ;; continues to work. - (primitive-eval sourc)))) - (run-hook after-eval-hook sourc) - val))) - - - (-print (let ((maybe-print (lambda (result) - (if (or scm-repl-print-unspecified - (not (unspecified? result))) - (begin - (write result) - (newline)))))) - (lambda (result) - (if (not scm-repl-silent) - (begin - (run-hook before-print-hook result) - (maybe-print result) - (run-hook after-print-hook result) - (if scm-repl-verbose - (repl-report)) - (force-output)))))) - - (-quit (lambda (args) - (if scm-repl-verbose - (begin - (display ";;; QUIT executed, repl exitting") - (newline) - (repl-report))) - args))) - - (let ((status (error-catching-repl -read - -eval - -print))) - (-quit status)))) - diff --git a/module/ice-9/deprecated.scm b/module/ice-9/deprecated.scm index d55f20f89..1eec6c3f7 100644 --- a/module/ice-9/deprecated.scm +++ b/module/ice-9/deprecated.scm @@ -38,7 +38,8 @@ $tanh closure? %nil - @bind) + @bind + scm-style-repl) #:replace (module-ref-submodule module-define-submodule!)) @@ -350,3 +351,111 @@ deprecated. Use set-module-public-interface! instead.") (lambda (mod iface) (setter mod iface) (module-define! mod '%module-public-interface iface)))) + +(define (scm-style-repl) + (issue-deprecation-warning + "`scm-style-repl' is deprecated. Use the repl from `(system repl repl)' instead.") + (letrec ( + (start-gc-rt #f) + (start-rt #f) + (repl-report-start-timing (lambda () + (set! start-gc-rt (gc-run-time)) + (set! start-rt (get-internal-run-time)))) + (repl-report (lambda () + (display ";;; ") + (display (inexact->exact + (* 1000 (/ (- (get-internal-run-time) start-rt) + internal-time-units-per-second)))) + (display " msec (") + (display (inexact->exact + (* 1000 (/ (- (gc-run-time) start-gc-rt) + internal-time-units-per-second)))) + (display " msec in gc)\n"))) + + (consume-trailing-whitespace + (lambda () + (let ((ch (peek-char))) + (cond + ((eof-object? ch)) + ((or (char=? ch #\space) (char=? ch #\tab)) + (read-char) + (consume-trailing-whitespace)) + ((char=? ch #\newline) + (read-char)))))) + (-read (lambda () + (let ((val + (let ((prompt (cond ((string? scm-repl-prompt) + scm-repl-prompt) + ((thunk? scm-repl-prompt) + (scm-repl-prompt)) + (scm-repl-prompt "> ") + (else "")))) + (repl-reader prompt)))) + + ;; As described in R4RS, the READ procedure updates the + ;; port to point to the first character past the end of + ;; the external representation of the object. This + ;; means that it doesn't consume the newline typically + ;; found after an expression. This means that, when + ;; debugging Guile with GDB, GDB gets the newline, which + ;; it often interprets as a "continue" command, making + ;; breakpoints kind of useless. So, consume any + ;; trailing newline here, as well as any whitespace + ;; before it. + ;; But not if EOF, for control-D. + (if (not (eof-object? val)) + (consume-trailing-whitespace)) + (run-hook after-read-hook) + (if (eof-object? val) + (begin + (repl-report-start-timing) + (if scm-repl-verbose + (begin + (newline) + (display ";;; EOF -- quitting") + (newline))) + (quit 0))) + val))) + + (-eval (lambda (sourc) + (repl-report-start-timing) + (run-hook before-eval-hook sourc) + (let ((val (start-stack 'repl-stack + ;; If you change this procedure + ;; (primitive-eval), please also + ;; modify the repl-stack case in + ;; save-stack so that stack cutting + ;; continues to work. + (primitive-eval sourc)))) + (run-hook after-eval-hook sourc) + val))) + + + (-print (let ((maybe-print (lambda (result) + (if (or scm-repl-print-unspecified + (not (unspecified? result))) + (begin + (write result) + (newline)))))) + (lambda (result) + (if (not scm-repl-silent) + (begin + (run-hook before-print-hook result) + (maybe-print result) + (run-hook after-print-hook result) + (if scm-repl-verbose + (repl-report)) + (force-output)))))) + + (-quit (lambda (args) + (if scm-repl-verbose + (begin + (display ";;; QUIT executed, repl exitting") + (newline) + (repl-report))) + args))) + + (let ((status (error-catching-repl -read + -eval + -print))) + (-quit status))))