From: Chris Hanson Date: Fri, 15 Oct 1993 10:26:42 +0000 (+0000) Subject: * Breakpoints have been reimplemented to use the condition system. A X-Git-Tag: 20090517-FFI~7754 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=82dc5c11aeea26ed3b6588ffbb10c611ad77eb22;p=mit-scheme.git * Breakpoints have been reimplemented to use the condition system. A breakpoint is now a condition, and the continuation of that condition is the continuation of the breakpoint. (The debugger will not show the internal frames of the breakpoint any more.) * The procedure BREAKPOINT now takes a condition as an additional optional argument. * The environment of a breakpoint may be specified as the symbol CONTINUATION-ENVIRONMENT, in which case the breakpoint signaller will attempt to extract an environment from the continuation. If that fails, it uses the REPL environment, and prints a message informing the user that it was unable to find an appropriate environment for the breakpoint. * CMDL/START has been modified to detect the situation where the thread starting the CMDL is not the owner of its port. Previously this check was done only for errors. As a result of this change, CONDITION-TYPE:DERIVED-THREAD-ERROR has been generalized to accept any kind of condition, not just error conditions. * The WRITE-RESULT output-port operation has been redefined to accept an additional argument: the expression that was evaluated to produce the value being printed. This expression is useful if the CURRENT-EXPRESSION-CONTEXT operation is implemented; it is the key needed to get the context information. As a result of this change, HOOK/REPL-WRITE was redefined to accept the same additional argument. * A new procedure CURRENT-LOAD-PATHNAME has been defined. When a file is being loaded, this procedure returns that file's pathname. At other times, it signals an error of type CONDITION-TYPE:NOT-LOADING. LOAD/PUSH-HOOK! has been changed to signal this error in the same situation, rather than the anonymous error it signalled before. --- diff --git a/v7/src/runtime/advice.scm b/v7/src/runtime/advice.scm index cd0b13cb5..9366b7581 100644 --- a/v7/src/runtime/advice.scm +++ b/v7/src/runtime/advice.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: advice.scm,v 14.11 1992/11/20 19:37:03 gjr Exp $ +$Id: advice.scm,v 14.12 1993/10/15 10:26:28 cph Exp $ -Copyright (c) 1988-1992 Massachusetts Institute of Technology +Copyright (c) 1988-93 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -227,30 +227,33 @@ MIT in each case. |# (lambda (original-body state) (call-with-current-continuation (lambda (continuation) - (bind-restart 'USE-VALUE - "Return a value from the advised procedure." - continuation - (lambda (restart) - (restart/put! restart 'INTERACTIVE - (lambda () - (prompt-for-evaluated-expression "Procedure value"))) - (for-each (lambda (advice) - (with-simple-restart 'CONTINUE - "Continue with advised procedure." - (lambda () - (advice procedure arguments environment)))) - (car state)) - (let ((value (scode-eval original-body environment))) + (fluid-let ((advice-continuation continuation)) + (bind-restart 'USE-VALUE + "Return a value from the advised procedure." + continuation + (lambda (restart) + (restart/put! restart 'INTERACTIVE + (lambda () + (prompt-for-evaluated-expression "Procedure value"))) (for-each (lambda (advice) (with-simple-restart 'CONTINUE - "Return from advised procedure." + "Continue with advised procedure." (lambda () - (advice procedure - arguments - value - environment)))) - (cdr state)) - value))))))))) + (advice procedure arguments environment)))) + (car state)) + (let ((value (scode-eval original-body environment))) + (for-each (lambda (advice) + (with-simple-restart 'CONTINUE + "Return from advised procedure." + (lambda () + (advice procedure + arguments + value + environment)))) + (cdr state)) + value)))))))))) + +(define advice-continuation #f) ;;;; Primitive Advisors @@ -406,16 +409,6 @@ MIT in each case. |# (newline) (write-string " ...]")))))))) -(define (break-rep environment message . info) - (breakpoint (cmdl-message/append - (cmdl-message/active - (lambda (port) - (with-output-to-port port - (lambda () - (apply trace-display info))))) - (cmdl-message/strings message)) - environment)) - (define (break-entry-advice procedure arguments environment) (fluid-let ((the-procedure procedure) (the-arguments arguments)) @@ -427,6 +420,16 @@ MIT in each case. |# (the-result result)) (break-rep environment "Breakpoint on exit" procedure arguments result)) result) + +(define (break-rep environment message . info) + (breakpoint (cmdl-message/append (cmdl-message/active + (lambda (port) + (with-output-to-port port + (lambda () + (apply trace-display info))))) + message) + environment + advice-continuation)) ;;;; Top Level Wrappers diff --git a/v7/src/runtime/emacs.scm b/v7/src/runtime/emacs.scm index 5174ca03c..b9f80dac4 100644 --- a/v7/src/runtime/emacs.scm +++ b/v7/src/runtime/emacs.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/emacs.scm,v 14.13 1992/02/27 01:12:02 cph Exp $ +$Id: emacs.scm,v 14.14 1993/10/15 10:26:29 cph Exp $ -Copyright (c) 1988-92 Massachusetts Institute of Technology +Copyright (c) 1988-93 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -145,7 +145,8 @@ MIT in each case. |# ;;;; Miscellaneous Hooks -(define (emacs/write-result port object hash-number) +(define (emacs/write-result port expression object hash-number) + expression (cond ((undefined-value? object) (transmit-signal-with-argument port #\v "")) (hash-number diff --git a/v7/src/runtime/error.scm b/v7/src/runtime/error.scm index c9cedb7e3..8c3b56c40 100644 --- a/v7/src/runtime/error.scm +++ b/v7/src/runtime/error.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: error.scm,v 14.34 1993/07/01 22:19:21 cph Exp $ +$Id: error.scm,v 14.35 1993/10/15 10:26:30 cph Exp $ Copyright (c) 1988-93 Massachusetts Institute of Technology @@ -528,16 +528,7 @@ MIT in each case. |# (if hook (fluid-let ((standard-error-hook false)) (hook condition)))) - (let ((thread (current-thread)) - (owner (thread-mutex-owner (port/thread-mutex (nearest-cmdl/port))))) - (if (and owner (not (eq? thread owner))) - (begin - (signal-thread-event owner - (lambda () - (unblock-thread-events) - (error:derived-thread thread condition))) - (stop-current-thread)) - (repl/start (push-repl 'INHERIT 'INHERIT condition '() "error>"))))) + (repl/start (push-repl 'INHERIT 'INHERIT condition '() "error>"))) (define (standard-warning-handler condition) (let ((hook standard-warning-hook)) @@ -844,7 +835,7 @@ MIT in each case. |# (write-string "The restart named " port) (write (access-condition condition 'NAME) port) (write-string " is not bound." port)))) - + (let ((anonymous-error (lambda (type-name field-name) (make-condition-type type-name condition-type:error @@ -857,7 +848,7 @@ MIT in each case. |# (set! condition-type:file-error (anonymous-error 'FILE-ERROR 'FILENAME)) (set! condition-type:cell-error (anonymous-error 'CELL-ERROR 'LOCATION)) (set! condition-type:thread-error (anonymous-error 'THREAD-ERROR 'THREAD))) - + (set! condition-type:derived-port-error (make-condition-type 'DERIVED-PORT-ERROR condition-type:port-error '(CONDITION) @@ -906,10 +897,15 @@ MIT in each case. |# (lambda (condition port) (write-string "The thread " port) (write (access-condition condition 'THREAD) port) - (write-string " signalled an error:" port) - (newline port) - (write-condition-report (access-condition condition 'CONDITION) - port)))) + (write-string " signalled " port) + (let ((condition (access-condition condition 'CONDITION))) + (write-string (if (condition/error? condition) + "an error" + "a condition") + port) + (write-string ":" port) + (newline port) + (write-condition-report condition port))))) (set! error:derived-thread (let ((make-condition (condition-constructor condition-type:derived-thread-error diff --git a/v7/src/runtime/load.scm b/v7/src/runtime/load.scm index bc0f4f24c..f7809e80a 100644 --- a/v7/src/runtime/load.scm +++ b/v7/src/runtime/load.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: load.scm,v 14.43 1993/08/12 08:23:59 cph Exp $ +$Id: load.scm,v 14.44 1993/10/15 10:26:32 cph Exp $ Copyright (c) 1988-1993 Massachusetts Institute of Technology @@ -45,6 +45,10 @@ MIT in each case. |# (set! load/default-types '("com" "bin" "scm")) (set! load/default-find-pathname-with-type search-types-in-order) (set! fasload/default-types '("com" "bin")) + (set! load/current-pathname) + (set! condition-type:not-loading + (make-condition-type 'NOT-LOADING condition-type:error '() + "No file being loaded.")) (initialize-command-line-parsers) (set! hook/process-command-line default/process-command-line) (add-event-receiver! event:after-restart process-command-line)) @@ -55,6 +59,7 @@ MIT in each case. |# (define load/default-types) (define load/after-load-hooks) (define load/current-pathname) +(define condition-type:not-loading) (define load/default-find-pathname-with-type) (define fasload/default-types) @@ -157,9 +162,12 @@ MIT in each case. |# (for-each (lambda (hook) (hook)) (reverse hooks))) result)))) +(define (current-load-pathname) + (if (not load/loading?) (error condition-type:not-loading)) + load/current-pathname) + (define (load/push-hook! hook) - (if (not load/loading?) - (error "not loading any file" 'LOAD/PUSH-HOOK!)) + (if (not load/loading?) (error condition-type:not-loading)) (set! load/after-load-hooks (cons hook load/after-load-hooks)) unspecific) @@ -233,12 +241,14 @@ MIT in each case. |# (eval-stream (read-stream port) environment syntax-table)))) (if load-noisily? (write-stream (value-stream) - (lambda (value) - (hook/repl-write (nearest-repl) value))) + (lambda (exp&value) + (hook/repl-write (nearest-repl) + (car exp&value) + (cdr exp&value)))) (loading-message load/suppress-loading-message? pathname (lambda () (write-stream (value-stream) - (lambda (value) value false))))))))) + (lambda (exp&value) exp&value false))))))))) (define *purification-root-marker*) @@ -257,7 +267,7 @@ MIT in each case. |# (eq? (car frob) *purification-root-marker*) (cdr frob)))))) object)) - + (define (read-stream port) (parse-objects port (current-parser-table) @@ -280,19 +290,20 @@ MIT in each case. |# (repl/syntax-table repl) syntax-table)))) (lambda (s-expression) - (hook/repl-eval #f - s-expression - environment - syntax-table)))))) + (cons s-expression + (hook/repl-eval #f + s-expression + environment + syntax-table))))))) (define (write-stream stream write) (if (stream-pair? stream) - (let loop ((value (stream-car stream)) (stream (stream-cdr stream))) + (let loop ((exp&value (stream-car stream)) (stream (stream-cdr stream))) (if (stream-pair? stream) (begin - (write value) + (write exp&value) (loop (stream-car stream) (stream-cdr stream))) - value)) + (cdr exp&value))) unspecific)) (define (process-command-line) diff --git a/v7/src/runtime/rep.scm b/v7/src/runtime/rep.scm index 83916e392..d0aa19990 100644 --- a/v7/src/runtime/rep.scm +++ b/v7/src/runtime/rep.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: rep.scm,v 14.35 1993/08/13 00:07:10 cph Exp $ +$Id: rep.scm,v 14.36 1993/10/15 10:26:33 cph Exp $ Copyright (c) 1988-93 Massachusetts Institute of Technology @@ -47,6 +47,7 @@ MIT in each case. |# (set! hook/repl-write default/repl-write) (set! hook/set-default-environment default/set-default-environment) (set! hook/error-decision false) + (initialize-breakpoint-condition!) unspecific) (define (initial-top-level-repl) @@ -120,18 +121,16 @@ MIT in each case. |# (port/set-default-directory (cmdl/port cmdl) pathname)) (define (cmdl/start cmdl message) - (let ((operation - (let ((parent (cmdl/parent cmdl))) - (and parent - (cmdl/local-operation parent 'START-CHILD)))) + (let ((port (cmdl/port cmdl)) (thunk (lambda () (fluid-let ((*nearest-cmdl* cmdl) (dynamic-handler-frames '()) (*bound-restarts* (if (cmdl/parent cmdl) *bound-restarts* '())) - (standard-error-hook false) - (standard-warning-hook false) + (standard-error-hook #f) + (standard-warning-hook #f) + (standard-breakpoint-hook #f) (*working-directory-pathname* *working-directory-pathname*) (*default-pathname-defaults* @@ -144,17 +143,34 @@ MIT in each case. |# (lambda (interrupt-mask) interrupt-mask (unblock-thread-events) - (message cmdl) + ((->cmdl-message message) cmdl) (call-with-current-continuation (lambda (continuation) (with-create-thread-continuation continuation (lambda () ((cmdl/driver cmdl) cmdl))))))))))))))) - (if operation - (operation cmdl thunk) - (with-thread-mutex-locked (port/thread-mutex (cmdl/port cmdl)) - thunk)))) - + (let ((mutex (port/thread-mutex port))) + (let ((thread (current-thread)) + (owner (thread-mutex-owner mutex))) + (cond ((and owner (not (eq? thread owner))) + (signal-thread-event owner + (let ((signaller + (or (cmdl/local-operation cmdl 'START-NON-OWNED) + (lambda (cmdl thread) + cmdl + (error "Non-owner thread can't start CMDL:" + thread))))) + (lambda () + (unblock-thread-events) + (signaller cmdl thread)))) + (stop-current-thread)) + ((let ((parent (cmdl/parent cmdl))) + (and parent + (cmdl/local-operation parent 'START-CHILD))) + => (lambda (operation) (operation cmdl thunk))) + (else + (with-thread-mutex-locked mutex thunk))))))) + (define (bind-abort-restart cmdl thunk) (call-with-current-continuation (lambda (continuation) @@ -174,9 +190,7 @@ MIT in each case. |# ;; Inform the port that the default directory has changed. (port/set-default-directory port (working-directory-pathname)))) - (if (default-object? message) - (cmdl-message/strings "Abort!") - message)))) + (if (default-object? message) "Abort!" message)))) (lambda (restart) (restart/put! restart make-cmdl cmdl) (thunk)))))) @@ -243,6 +257,11 @@ MIT in each case. |# ;;;; Messages +(define (->cmdl-message object) + (cond ((not object) (cmdl-message/null)) + ((string? object) (cmdl-message/strings object)) + (else object))) + (define ((cmdl-message/strings . strings) cmdl) (let ((port (cmdl/port cmdl))) (port/with-output-terminal-mode port 'COOKED @@ -260,6 +279,9 @@ MIT in each case. |# (actor port))))) (define (cmdl-message/append . messages) + (do ((messages messages (cdr messages))) + ((null? messages)) + (set-car! messages (->cmdl-message (car messages)))) (let ((messages (delq! %cmdl-message/null messages))) (cond ((null? messages) (cmdl-message/null)) @@ -327,8 +349,7 @@ MIT in each case. |# (define (invoke-abort restart message) (let ((effector (restart/effector restart))) (if (restart/get restart make-cmdl) - (effector - (if (string? message) (cmdl-message/strings message) message)) + (effector message) (effector)))) ;;;; REP Loops @@ -359,7 +380,13 @@ MIT in each case. |# default-repl-operations))) (define default-repl-operations - `((START-CHILD ,(lambda (cmdl thunk) cmdl (with-history-disabled thunk))))) + `((START-CHILD ,(lambda (cmdl thunk) cmdl (with-history-disabled thunk))) + (START-NON-OWNED + ,(lambda (repl thread) + (let ((condition (repl/condition repl))) + (if condition + (error:derived-thread thread condition) + (error "Non-owner thread can't start REPL:" thread))))))) (define (push-repl environment syntax-table #!optional condition operations prompt) @@ -378,23 +405,20 @@ MIT in each case. |# (port/set-default-environment (cmdl/port repl) (repl/environment repl)) (port/set-default-syntax-table (cmdl/port repl) (repl/syntax-table repl)) (do () (false) - (hook/repl-write - repl - (let ((value - (hook/repl-eval - repl - (let ((s-expression - (hook/repl-prompt - (string-append (number->string (cmdl/level repl)) - " " - (repl/prompt repl)) - (cmdl/port repl)))) - (repl-history/record! reader-history s-expression) - s-expression) - (repl/environment repl) - (repl/syntax-table repl)))) - (repl-history/record! printer-history value) - value))))) + (let ((s-expression + (hook/repl-prompt + (string-append (number->string (cmdl/level repl)) + " " + (repl/prompt repl)) + (cmdl/port repl)))) + (repl-history/record! reader-history s-expression) + (let ((value + (hook/repl-eval repl + s-expression + (repl/environment repl) + (repl/syntax-table repl)))) + (repl-history/record! printer-history value) + (hook/repl-write repl s-expression value)))))) (define hook/repl-prompt) (define (default/repl-prompt prompt port) @@ -419,8 +443,9 @@ MIT in each case. |# repl)) (define hook/repl-write) -(define (default/repl-write repl object) +(define (default/repl-write repl s-expression object) (port/write-result (cmdl/port repl) + s-expression object (and repl:write-result-hash-numbers? (object-pointer? object) @@ -438,32 +463,24 @@ MIT in each case. |# (define (make-repl-message repl message) (let ((condition (repl/condition repl))) (cmdl-message/append - (cond ((not message) - (if condition - (cmdl-message/strings - (fluid-let ((*unparser-list-depth-limit* 25) - (*unparser-list-breadth-limit* 100) - (*unparser-string-length-limit* 500)) - (condition/report-string condition))) - (cmdl-message/null))) - ((string? message) - (cmdl-message/strings message)) - (else - message)) - (if condition - (cmdl-message/append - (if (condition/error? condition) - (lambda (repl) - (cond ((cmdl/operation repl 'ERROR-DECISION) - => (lambda (operation) - (operation repl condition))) - (hook/error-decision - (hook/error-decision repl condition)))) - (cmdl-message/null)) - (if repl:allow-restart-notifications? - (condition-restarts-message condition) - (cmdl-message/null))) - (cmdl-message/null)) + (or message + (and condition + (cmdl-message/strings + (fluid-let ((*unparser-list-depth-limit* 25) + (*unparser-list-breadth-limit* 100) + (*unparser-string-length-limit* 500)) + (condition/report-string condition))))) + (and condition + (cmdl-message/append + (and (condition/error? condition) + (lambda (repl) + (cond ((cmdl/operation repl 'ERROR-DECISION) + => (lambda (operation) + (operation repl condition))) + (hook/error-decision + (hook/error-decision repl condition))))) + (and repl:allow-restart-notifications? + (condition-restarts-message condition)))) repl/set-default-environment))) (define hook/error-decision) @@ -747,28 +764,10 @@ MIT in each case. |# (define (out #!optional index) (repl-history/read (repl/printer-history (nearest-repl)) (- (if (default-object? index) 1 index) 1))) - + (define (read-eval-print environment message prompt) (repl/start (push-repl environment 'INHERIT false '() prompt) message)) -(define (breakpoint #!optional message environment) - (with-simple-restart 'CONTINUE "Continue from breakpoint." - (lambda () - (read-eval-print (if (default-object? environment) 'INHERIT environment) - (if (default-object? message) "Break!" message) - "break>")))) - -(define (breakpoint-procedure environment datum . arguments) - ;; BKPT expands into this. - (with-simple-restart 'CONTINUE "Return from BKPT." - (lambda () - (read-eval-print environment - (cmdl-message/active - (lambda (port) - (newline port) - (format-error-message datum arguments port))) - "bkpt>")))) - (define (ve environment) (read-eval-print (->environment environment) false 'INHERIT)) @@ -778,4 +777,126 @@ MIT in each case. |# (use-value value)) (let ((port (nearest-cmdl/port))) (fresh-line port) - (write-string ";Unable to PROCEED" port))) \ No newline at end of file + (write-string ";Unable to PROCEED" port))) + +;;;; Breakpoints + +(define (new-bkpt datum . arguments) + (apply breakpoint-procedure 'CONTINUATION-ENVIRONMENT datum arguments)) + +(define (breakpoint-procedure environment datum . arguments) + ;; BKPT expands into this. + (signal-breakpoint #f + environment + (cmdl-message/active + (lambda (port) + (fresh-line port) + (format-error-message datum arguments port))) + "bkpt>")) + +(define (breakpoint #!optional message environment continuation) + (signal-breakpoint (if (default-object? continuation) + #f + continuation) + (if (default-object? environment) + (nearest-repl/environment) + environment) + (if (default-object? message) + "Break!" + message) + "break>")) + +(define (signal-breakpoint continuation environment message prompt) + (call-with-current-continuation + (lambda (restart-continuation) + (let ((continuation (or continuation restart-continuation))) + (bind-restart 'CONTINUE + (if (string=? "bkpt>" prompt) + "Return from BKPT." + "Continue from breakpoint.") + (lambda () (restart-continuation unspecific)) + (lambda (restart) + restart + (call-with-values + (lambda () + (get-breakpoint-environment continuation environment message)) + (lambda (environment message) + (%signal-breakpoint continuation + environment + message + prompt))))))))) + +(define (get-breakpoint-environment continuation environment message) + (let ((environment + (if (eq? 'CONTINUATION-ENVIRONMENT environment) + (continuation/first-subproblem-environment continuation) + environment))) + (if (eq? 'NO-ENVIRONMENT environment) + (values (nearest-repl/environment) + (cmdl-message/append + message + (cmdl-message/strings + "Breakpoint environment unavailable;" + "using REPL environment instead."))) + (values environment message)))) + +(define (continuation/first-subproblem-environment continuation) + (let ((frame (continuation/first-subproblem continuation))) + (if frame + (call-with-values (lambda () (stack-frame/debugging-info frame)) + (lambda (expression environment subexpression) + expression subexpression + (if (debugging-info/undefined-environment? environment) + 'NO-ENVIRONMENT + environment))) + 'NO-ENVIRONMENT))) + +(define condition-type:breakpoint) +(define condition/breakpoint?) +(define breakpoint/environment) +(define breakpoint/message) +(define breakpoint/prompt) +(define %signal-breakpoint) + +(define (initialize-breakpoint-condition!) + (set! condition-type:breakpoint + (make-condition-type 'BREAKPOINT #f '(ENVIRONMENT MESSAGE PROMPT) + (lambda (condition port) + condition + (write-string "Breakpoint." port)))) + (set! condition/breakpoint? + (condition-predicate condition-type:breakpoint)) + (set! breakpoint/environment + (condition-accessor condition-type:breakpoint 'ENVIRONMENT)) + (set! breakpoint/message + (condition-accessor condition-type:breakpoint 'MESSAGE)) + (set! breakpoint/prompt + (condition-accessor condition-type:breakpoint 'PROMPT)) + (set! %signal-breakpoint + (let ((make-condition + (condition-constructor condition-type:breakpoint + '(ENVIRONMENT MESSAGE PROMPT)))) + (lambda (continuation environment message prompt) + (let ((condition + (make-condition continuation + 'BOUND-RESTARTS + environment + message + prompt))) + (signal-condition condition) + (standard-breakpoint-handler condition))))) + unspecific) + +(define (standard-breakpoint-handler condition) + (let ((hook standard-breakpoint-hook)) + (if hook + (fluid-let ((standard-breakpoint-hook #f)) + (hook condition)))) + (repl/start (push-repl (breakpoint/environment condition) + 'INHERIT + condition + '() + (breakpoint/prompt condition)) + (breakpoint/message condition))) + +(define standard-breakpoint-hook #f) \ No newline at end of file diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index 1c3828277..36f1f218b 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.203 1993/10/12 22:19:14 cph Exp $ +$Id: runtime.pkg,v 14.204 1993/10/15 10:26:34 cph Exp $ Copyright (c) 1988-1993 Massachusetts Institute of Technology @@ -1219,16 +1219,18 @@ MIT in each case. |# (files "load") (parent ()) (export () + condition-type:not-loading + current-load-pathname fasload + fasload-latest fasload/default-types load load-latest - fasload-latest load-noisily load-noisily? - load/loading? - load/default-types load/default-find-pathname-with-type + load/default-types + load/loading? load/purification-root load/push-hook! load/suppress-loading-message? @@ -1785,8 +1787,10 @@ MIT in each case. |# abort->nearest abort->previous abort->top-level + ;;bkpt breakpoint breakpoint-procedure + breakpoint/environment cmdl-interrupt/abort-nearest cmdl-interrupt/abort-previous cmdl-interrupt/abort-top-level @@ -1806,6 +1810,8 @@ MIT in each case. |# cmdl/start cmdl/state cmdl? + condition-type:breakpoint + condition/breakpoint? ge gst in @@ -1853,6 +1859,9 @@ MIT in each case. |# set-repl/prompt! set-repl/reader-history! set-repl/syntax-table! + signal-breakpoint + standard-breakpoint-handler + standard-breakpoint-hook ve with-repl-eval-boundary) (export (runtime load) diff --git a/v7/src/runtime/usrint.scm b/v7/src/runtime/usrint.scm index da03c35bb..e6740cd16 100644 --- a/v7/src/runtime/usrint.scm +++ b/v7/src/runtime/usrint.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: usrint.scm,v 1.4 1993/08/12 08:23:52 cph Exp $ +$Id: usrint.scm,v 1.5 1993/10/15 10:26:42 cph Exp $ Copyright (c) 1991-93 Massachusetts Institute of Technology @@ -175,13 +175,14 @@ MIT in each case. |# ;;;; Miscellaneous Hooks -(define (port/write-result port value hash-number) +(define (port/write-result port expression value hash-number) (let ((operation (port/operation port 'WRITE-RESULT))) (if operation - (operation port value hash-number) - (default/write-result port value hash-number)))) + (operation port expression value hash-number) + (default/write-result port expression value hash-number)))) -(define (default/write-result port object hash-number) +(define (default/write-result port expression object hash-number) + expression (port/with-output-terminal-mode port 'COOKED (lambda () (fresh-line port) diff --git a/v8/src/runtime/load.scm b/v8/src/runtime/load.scm index bc0f4f24c..f7809e80a 100644 --- a/v8/src/runtime/load.scm +++ b/v8/src/runtime/load.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: load.scm,v 14.43 1993/08/12 08:23:59 cph Exp $ +$Id: load.scm,v 14.44 1993/10/15 10:26:32 cph Exp $ Copyright (c) 1988-1993 Massachusetts Institute of Technology @@ -45,6 +45,10 @@ MIT in each case. |# (set! load/default-types '("com" "bin" "scm")) (set! load/default-find-pathname-with-type search-types-in-order) (set! fasload/default-types '("com" "bin")) + (set! load/current-pathname) + (set! condition-type:not-loading + (make-condition-type 'NOT-LOADING condition-type:error '() + "No file being loaded.")) (initialize-command-line-parsers) (set! hook/process-command-line default/process-command-line) (add-event-receiver! event:after-restart process-command-line)) @@ -55,6 +59,7 @@ MIT in each case. |# (define load/default-types) (define load/after-load-hooks) (define load/current-pathname) +(define condition-type:not-loading) (define load/default-find-pathname-with-type) (define fasload/default-types) @@ -157,9 +162,12 @@ MIT in each case. |# (for-each (lambda (hook) (hook)) (reverse hooks))) result)))) +(define (current-load-pathname) + (if (not load/loading?) (error condition-type:not-loading)) + load/current-pathname) + (define (load/push-hook! hook) - (if (not load/loading?) - (error "not loading any file" 'LOAD/PUSH-HOOK!)) + (if (not load/loading?) (error condition-type:not-loading)) (set! load/after-load-hooks (cons hook load/after-load-hooks)) unspecific) @@ -233,12 +241,14 @@ MIT in each case. |# (eval-stream (read-stream port) environment syntax-table)))) (if load-noisily? (write-stream (value-stream) - (lambda (value) - (hook/repl-write (nearest-repl) value))) + (lambda (exp&value) + (hook/repl-write (nearest-repl) + (car exp&value) + (cdr exp&value)))) (loading-message load/suppress-loading-message? pathname (lambda () (write-stream (value-stream) - (lambda (value) value false))))))))) + (lambda (exp&value) exp&value false))))))))) (define *purification-root-marker*) @@ -257,7 +267,7 @@ MIT in each case. |# (eq? (car frob) *purification-root-marker*) (cdr frob)))))) object)) - + (define (read-stream port) (parse-objects port (current-parser-table) @@ -280,19 +290,20 @@ MIT in each case. |# (repl/syntax-table repl) syntax-table)))) (lambda (s-expression) - (hook/repl-eval #f - s-expression - environment - syntax-table)))))) + (cons s-expression + (hook/repl-eval #f + s-expression + environment + syntax-table))))))) (define (write-stream stream write) (if (stream-pair? stream) - (let loop ((value (stream-car stream)) (stream (stream-cdr stream))) + (let loop ((exp&value (stream-car stream)) (stream (stream-cdr stream))) (if (stream-pair? stream) (begin - (write value) + (write exp&value) (loop (stream-car stream) (stream-cdr stream))) - value)) + (cdr exp&value))) unspecific)) (define (process-command-line) diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg index 1c3828277..36f1f218b 100644 --- a/v8/src/runtime/runtime.pkg +++ b/v8/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.203 1993/10/12 22:19:14 cph Exp $ +$Id: runtime.pkg,v 14.204 1993/10/15 10:26:34 cph Exp $ Copyright (c) 1988-1993 Massachusetts Institute of Technology @@ -1219,16 +1219,18 @@ MIT in each case. |# (files "load") (parent ()) (export () + condition-type:not-loading + current-load-pathname fasload + fasload-latest fasload/default-types load load-latest - fasload-latest load-noisily load-noisily? - load/loading? - load/default-types load/default-find-pathname-with-type + load/default-types + load/loading? load/purification-root load/push-hook! load/suppress-loading-message? @@ -1785,8 +1787,10 @@ MIT in each case. |# abort->nearest abort->previous abort->top-level + ;;bkpt breakpoint breakpoint-procedure + breakpoint/environment cmdl-interrupt/abort-nearest cmdl-interrupt/abort-previous cmdl-interrupt/abort-top-level @@ -1806,6 +1810,8 @@ MIT in each case. |# cmdl/start cmdl/state cmdl? + condition-type:breakpoint + condition/breakpoint? ge gst in @@ -1853,6 +1859,9 @@ MIT in each case. |# set-repl/prompt! set-repl/reader-history! set-repl/syntax-table! + signal-breakpoint + standard-breakpoint-handler + standard-breakpoint-hook ve with-repl-eval-boundary) (export (runtime load)