#| -*-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
(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)
\f
;;;; Primitive Advisors
(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))
(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))
\f
;;;; Top Level Wrappers
#| -*-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
;;;; 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
#| -*-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
(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))
(write-string "The restart named " port)
(write (access-condition condition 'NAME) port)
(write-string " is not bound." port))))
-\f
+
(let ((anonymous-error
(lambda (type-name field-name)
(make-condition-type type-name condition-type:error
(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)))
-
+\f
(set! condition-type:derived-port-error
(make-condition-type 'DERIVED-PORT-ERROR condition-type:port-error
'(CONDITION)
(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
#| -*-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
(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))
(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)
(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)
(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*)
(eq? (car frob) *purification-root-marker*)
(cdr frob))))))
object))
-
+\f
(define (read-stream port)
(parse-objects port
(current-parser-table)
(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))
\f
(define (process-command-line)
#| -*-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
(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)
(port/set-default-directory (cmdl/port cmdl) pathname))
\f
(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*
(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)))))))
+\f
(define (bind-abort-restart cmdl thunk)
(call-with-current-continuation
(lambda (continuation)
;; 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))))))
\f
;;;; 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
(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))
(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))))
\f
;;;; REP Loops
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)
(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)
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)
(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)
(define (out #!optional index)
(repl-history/read (repl/printer-history (nearest-repl))
(- (if (default-object? index) 1 index) 1)))
-\f
+
(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))
(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)))
+\f
+;;;; 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)))
+\f
+(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
#| -*-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
(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?
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
cmdl/start
cmdl/state
cmdl?
+ condition-type:breakpoint
+ condition/breakpoint?
ge
gst
in
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)
#| -*-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
\f
;;;; 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)
#| -*-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
(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))
(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)
(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)
(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*)
(eq? (car frob) *purification-root-marker*)
(cdr frob))))))
object))
-
+\f
(define (read-stream port)
(parse-objects port
(current-parser-table)
(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))
\f
(define (process-command-line)
#| -*-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
(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?
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
cmdl/start
cmdl/state
cmdl?
+ condition-type:breakpoint
+ condition/breakpoint?
ge
gst
in
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)
projects / mit-scheme.git / commitdiff