#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/conpar.scm,v 14.24 1991/08/27 08:00:17 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/conpar.scm,v 14.25 1992/02/08 15:08:18 cph Exp $
-Copyright (c) 1988-1991 Massachusetts Institute of Technology
+Copyright (c) 1988-92 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(define-structure (stack-frame
(constructor make-stack-frame
- (type elements dynamic-state fluid-bindings
+ (type elements dynamic-state
interrupt-mask history
previous-history-offset
previous-history-control-point
(type false read-only true)
(elements false read-only true)
(dynamic-state false read-only true)
- (fluid-bindings false read-only true)
(interrupt-mask false read-only true)
(history false read-only true)
(previous-history-offset false read-only true)
(stack-frame/skip-non-subproblems stack-frame)))
(stack-frame/skip-non-subproblems stack-frame)))
-(define (stack-frame/skip-non-subproblems stack-frame)
- (if (stack-frame/subproblem? stack-frame)
- stack-frame
- (let ((stack-frame (stack-frame/next stack-frame)))
- (and stack-frame
- (stack-frame/skip-non-subproblems stack-frame)))))
-\f
(define-integrable (stack-frame/length stack-frame)
(vector-length (stack-frame/elements stack-frame)))
(and (interpreter-return-address? return-address)
(return-address/code return-address))))
-(define-integrable (stack-frame/subproblem? stack-frame)
+(define (stack-frame/subproblem? stack-frame)
(stack-frame-type/subproblem? (stack-frame/type stack-frame)))
(define-integrable (stack-frame/compiled-code? stack-frame)
(compiled-return-address? (stack-frame/return-address stack-frame)))
-
+\f
(define (stack-frame/resolve-stack-address frame address)
(let loop
((frame frame)
(if (< offset length)
(values frame offset)
(loop (stack-frame/next frame) (- offset length))))))
+
+(define (stack-frame/skip-non-subproblems stack-frame)
+ (let ((type (stack-frame/type stack-frame)))
+ (cond ((eq? type stack-frame-type/stack-marker)
+ (let loop ((stack-frame stack-frame))
+ (let ((stack-frame (stack-frame/next stack-frame)))
+ (and stack-frame
+ (if (stack-frame/subproblem? stack-frame)
+ (stack-frame/next-subproblem stack-frame)
+ (loop stack-frame))))))
+ ((and (stack-frame/subproblem? stack-frame)
+ (not (and (eq? type stack-frame-type/compiled-return-address)
+ (eq? (stack-frame/return-address stack-frame)
+ continuation-return-address))))
+ stack-frame)
+ (else
+ (let ((stack-frame (stack-frame/next stack-frame)))
+ (and stack-frame
+ (stack-frame/skip-non-subproblems stack-frame)))))))
+
+(define continuation-return-address)
+
+(define (initialize-special-frames!)
+ (set! continuation-return-address
+ (let ((stack-frame
+ (call-with-current-continuation
+ (lambda (k)
+ k
+ (call-with-current-continuation
+ continuation/first-subproblem)))))
+ (and (eq? (stack-frame/type stack-frame)
+ stack-frame-type/compiled-return-address)
+ (stack-frame/return-address stack-frame))))
+ unspecific)
\f
;;;; Parser
(define-structure (parser-state (constructor make-parser-state)
(conc-name parser-state/))
(dynamic-state false read-only true)
- (fluid-bindings false read-only true)
(interrupt-mask false read-only true)
(history false read-only true)
(previous-history-offset false read-only true)
(define (continuation->stack-frame continuation)
(parse-control-point (continuation/control-point continuation)
(continuation/dynamic-state continuation)
- (continuation/fluid-bindings continuation)
false))
-(define (parse-control-point control-point dynamic-state fluid-bindings type)
+(define (parse-control-point control-point dynamic-state type)
(let ((element-stream (control-point/element-stream control-point)))
(parse-one-frame
(make-parser-state
dynamic-state
- fluid-bindings
(control-point/interrupt-mask control-point)
(let ((history
(history-transform (control-point/history control-point))))
(parse-control-point
control-point
(parser-state/dynamic-state state)
- (parser-state/fluid-bindings state)
(parser-state/previous-type state))))))))
\f
;;; `make-intermediate-state' is used to construct an intermediate
(- (parser-state/n-elements state) length)))
(make-parser-state
(parser-state/dynamic-state state)
- (parser-state/fluid-bindings state)
(parser-state/interrupt-mask state)
(parser-state/history state)
(let ((previous (parser-state/previous-history-offset state)))
;;; call to `make-intermediate-state'). However, several of the
;;; parsers change the values of some of the components of `state'
;;; before calling `parser/standard' -- for example,
-;;; RESTORE-TO-STATE-POINT changes the `dynamic-state' component.
+;;; RESTORE-INTERRUPT-MASK changes the `interrupt-mask' component.
(define (parse/standard-next type elements state history? force-pop?)
(let ((n-elements (parser-state/n-elements state))
type
elements
(parser-state/dynamic-state state)
- (parser-state/fluid-bindings state)
(parser-state/interrupt-mask state)
(if history?
history
(+ (vector-length elements) n-elements)
(parser-state/previous-type state)
(make-parser-state (parser-state/dynamic-state state)
- (parser-state/fluid-bindings state)
(parser-state/interrupt-mask state)
(if (or force-pop? history-subproblem?)
(history-superproblem history)
(parse/standard-next type elements state
valid-history? valid-history?)))
\f
-(define (parser/restore-dynamic-state type elements state)
- ;; Possible problem: the dynamic state really consists of all of the
- ;; state spaces in existence. Probably we should have some
- ;; mechanism for keeping track of them all.
- (parser/standard
- type
- elements
- (make-parser-state (let ((dynamic-state (vector-ref elements 1)))
- (if (eq? system-state-space
- (state-point/space dynamic-state))
- dynamic-state
- (parser-state/dynamic-state state)))
- (parser-state/fluid-bindings state)
- (parser-state/interrupt-mask state)
- (parser-state/history state)
- (parser-state/previous-history-offset state)
- (parser-state/previous-history-control-point state)
- (parser-state/element-stream state)
- (parser-state/n-elements state)
- (parser-state/next-control-point state)
- (parser-state/previous-type state))))
-
-(define (parser/restore-fluid-bindings type elements state)
- (parser/standard
- type
- elements
- (make-parser-state (parser-state/dynamic-state state)
- (vector-ref elements 1)
- (parser-state/interrupt-mask state)
- (parser-state/history state)
- (parser-state/previous-history-offset state)
- (parser-state/previous-history-control-point state)
- (parser-state/element-stream state)
- (parser-state/n-elements state)
- (parser-state/next-control-point state)
- (parser-state/previous-type state))))
+(define (parser/stack-marker type elements state)
+ (let ((marker (vector-ref elements 1))
+ (continue
+ (lambda (dynamic-state interrupt-mask)
+ (parser/standard
+ type
+ elements
+ (make-parser-state
+ dynamic-state
+ interrupt-mask
+ (parser-state/history state)
+ (parser-state/previous-history-offset state)
+ (parser-state/previous-history-control-point state)
+ (parser-state/element-stream state)
+ (parser-state/n-elements state)
+ (parser-state/next-control-point state)
+ (parser-state/previous-type state))))))
+ (cond ((eq? marker %translate-to-state-point)
+ (continue (merge-dynamic-state (parser-state/dynamic-state state)
+ (vector-ref elements 2))
+ (parser-state/interrupt-mask state)))
+ ((eq? marker set-interrupt-enables!)
+ (continue (parser-state/dynamic-state state)
+ (vector-ref elements 2)))
+ (else
+ (continue (parser-state/dynamic-state state)
+ (parser-state/interrupt-mask state))))))
(define (parser/restore-interrupt-mask type elements state)
(parser/standard
type
elements
(make-parser-state (parser-state/dynamic-state state)
- (parser-state/fluid-bindings state)
(vector-ref elements 1)
(parser-state/history state)
(parser-state/previous-history-offset state)
type
elements
(make-parser-state (parser-state/dynamic-state state)
- (parser-state/fluid-bindings state)
(parser-state/interrupt-mask state)
(history-transform (vector-ref elements 1))
(vector-ref elements 2)
(define (stack-frame->continuation stack-frame)
(make-continuation 'REENTRANT
(stack-frame->control-point stack-frame)
- (stack-frame/dynamic-state stack-frame)
- (stack-frame/fluid-bindings stack-frame)))
+ (stack-frame/dynamic-state stack-frame)))
(define (stack-frame->control-point stack-frame)
(with-values (lambda () (unparse/stack-frame stack-frame))
offset
(+ index 1 (- (object-datum (element-stream/ref stream index)) missing)))
-(define (length/repeat-primitive stream offset)
- offset
- (primitive-procedure-arity (element-stream/ref stream 1)))
-
(define (length/compiled-return-address stream offset)
(let ((entry (element-stream/head stream)))
(let ((frame-size (compiled-continuation/next-continuation-offset entry)))
(set! stack-frame-types (make-stack-frame-types))
(set! stack-frame-type/hardware-trap
(microcode-return/name->type 'HARDWARE-TRAP))
+ (set! stack-frame-type/stack-marker
+ (microcode-return/name->type 'STACK-MARKER))
(set! stack-frame-type/compiled-return-address
(make-stack-frame-type false true false
length/compiled-return-address
(make-stack-frame-type false true false
1
parser/standard))
-
(set! word-size
(let ((initial (system-vector-length (make-bit-string 1 #f))))
(let loop ((size 2))
(if (= (system-vector-length (make-bit-string size #f)) initial)
(loop (1+ size))
(-1+ size)))))
+ (set! continuation-return-address false)
unspecific)
\f
(define stack-frame-types)
(define stack-frame-type/compiled-return-address)
(define stack-frame-type/return-to-interpreter)
(define stack-frame-type/hardware-trap)
+(define stack-frame-type/stack-marker)
(define stack-frame-type/interrupt-compiled-procedure)
(define stack-frame-type/interrupt-compiled-expression)
parser/standard
parser)))
- (standard-frame 'RESTORE-TO-STATE-POINT 2 parser/restore-dynamic-state)
- (standard-frame 'RESTORE-FLUIDS 2 parser/restore-fluid-bindings)
(standard-frame 'RESTORE-INTERRUPT-MASK 2 parser/restore-interrupt-mask)
(standard-frame 'RESTORE-HISTORY 4 parser/restore-history)
(standard-frame 'RESTORE-DONT-COPY-HISTORY 4 parser/restore-history)
+ (standard-frame 'STACK-MARKER 3 parser/stack-marker)
(standard-frame 'NON-EXISTENT-CONTINUATION 2)
(standard-frame 'HALT 2)
(standard-subproblem 'PRIMITIVE-COMBINATION-3-APPLY 4)
(standard-subproblem 'MOVE-TO-ADJACENT-POINT 6)
(standard-subproblem 'COMBINATION-SAVE-VALUE length/combination-save-value)
- (standard-subproblem 'REPEAT-PRIMITIVE length/repeat-primitive)
(let ((length (length/application-frame 2 0)))
(standard-subproblem 'COMBINATION-APPLY length)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/contin.scm,v 14.5 1991/02/15 18:04:39 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/contin.scm,v 14.6 1992/02/08 15:08:20 cph Exp $
-Copyright (c) 1988-91 Massachusetts Institute of Technology
+Copyright (c) 1988-92 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(primitive
(lambda (control-point)
(let ((continuation
- (make-continuation type
- control-point
- (current-dynamic-state)
- (get-fluid-bindings))))
+ (make-continuation type control-point (get-dynamic-state))))
(continuation (receiver continuation))))))
-(define (%within-continuation continuation thunk)
+(define (%within-continuation continuation thread-switch? thunk)
((ucode-primitive within-control-point 2)
(continuation/control-point continuation)
- (let ((dynamic-state (continuation/dynamic-state continuation))
- (fluid-bindings (continuation/fluid-bindings continuation)))
+ (let ((dynamic-state (continuation/dynamic-state continuation)))
(lambda ()
- (set-fluid-bindings! fluid-bindings)
- (translate-to-state-point dynamic-state)
+ (set-dynamic-state! dynamic-state thread-switch?)
(thunk)))))
(define (invocation-method/reentrant continuation value)
((ucode-primitive within-control-point 2)
(continuation/control-point continuation)
- (let ((dynamic-state (continuation/dynamic-state continuation))
- (fluid-bindings (continuation/fluid-bindings continuation)))
+ (let ((dynamic-state (continuation/dynamic-state continuation)))
(lambda ()
- (set-fluid-bindings! fluid-bindings)
- (translate-to-state-point dynamic-state)
+ (set-dynamic-state! dynamic-state false)
value))))
;; These two are correctly locked for multiprocessing, but not for
continuation
invocation-method/used)
true))))))
- (%within-continuation continuation thunk)
+ (%within-continuation continuation false thunk)
(error "Reentering used continuation" continuation)))
(define (invocation-method/unused continuation value)
value
(error "Reentering used continuation" continuation))
\f
-(define (make-continuation type control-point dynamic-state fluid-bindings)
+(define (make-continuation type control-point dynamic-state)
(make-entity
(case type
((REENTRANT) invocation-method/reentrant)
((UNUSED) invocation-method/unused)
((USED) invocation-method/used)
(else (error "Illegal continuation type" type)))
- (make-%continuation control-point dynamic-state fluid-bindings)))
+ (make-%continuation control-point dynamic-state)))
(define (continuation/type continuation)
(let ((invocation-method (continuation/invocation-method continuation)))
(define-integrable (continuation/dynamic-state continuation)
(%continuation/dynamic-state (entity-extra continuation)))
-(define-integrable (continuation/fluid-bindings continuation)
- (%continuation/fluid-bindings (entity-extra continuation)))
-
(define-structure (%continuation (constructor make-%continuation)
(conc-name %continuation/))
(control-point false read-only true)
- (dynamic-state false read-only true)
- (fluid-bindings false read-only true))
\ No newline at end of file
+ (dynamic-state false read-only true))
\ No newline at end of file
syntax-table/system-internal)
("system" (runtime system)
syntax-table/system-internal)
+ ("thread" (runtime thread)
+ syntax-table/system-internal)
("tscript" (runtime transcript)
syntax-table/system-internal)
("ttyio" (runtime console-i/o-port)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/emacs.scm,v 14.10 1991/11/26 07:05:34 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/emacs.scm,v 14.11 1992/02/08 15:08:23 cph Exp $
-Copyright (c) 1988-91 Massachusetts Institute of Technology
+Copyright (c) 1988-92 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(loop)))
true)
-(define (emacs/^G-interrupt interrupt-mask)
- interrupt-mask
+(define (emacs/^G-interrupt)
(transmit-signal the-console-port #\g))
;;;; Miscellaneous Hooks
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/framex.scm,v 14.15 1991/06/14 03:02:57 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/framex.scm,v 14.16 1992/02/08 15:08:24 cph Exp $
-Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
+Copyright (c) 1988-92 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(let ((method (method/application-frame 3)))
(record-method 'INTERNAL-APPLY method)
(record-method 'INTERNAL-APPLY-VAL method))
- (record-method 'REPEAT-PRIMITIVE (method/application-frame 1))
(let ((method (method/compiler-reference identity-procedure)))
(record-method 'COMPILER-REFERENCE-RESTART method)
(record-method 'COMPILER-SAFE-REFERENCE-RESTART method))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/global.scm,v 14.34 1991/11/26 07:06:16 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/global.scm,v 14.35 1992/02/08 15:08:26 cph Exp $
-Copyright (c) 1988-91 Massachusetts Institute of Technology
+Copyright (c) 1988-92 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(define-integrable (system-hunk3-cons type cxr0 cxr1 cxr2)
(object-new-type type (hunk3-cons cxr0 cxr1 cxr2)))
+(define (object-component-binder get-component set-component!)
+ (lambda (object new-value thunk)
+ (let ((old-value))
+ (shallow-fluid-bind
+ (lambda ()
+ (set! old-value (get-component object))
+ (set-component! object new-value)
+ (set! new-value false)
+ unspecific)
+ thunk
+ (lambda ()
+ (set! new-value (get-component object))
+ (set-component! object old-value)
+ (set! old-value false)
+ unspecific)))))
+
(define (bind-cell-contents! cell new-value thunk)
(let ((old-value))
- (dynamic-wind (lambda ()
- (set! old-value (cell-contents cell))
- (set-cell-contents! cell new-value)
- (set! new-value))
- thunk
- (lambda ()
- (set! new-value (cell-contents cell))
- (set-cell-contents! cell old-value)
- (set! old-value)))))
+ (shallow-fluid-bind
+ (lambda ()
+ (set! old-value (cell-contents cell))
+ (set-cell-contents! cell new-value)
+ (set! new-value)
+ unspecific)
+ thunk
+ (lambda ()
+ (set! new-value (cell-contents cell))
+ (set-cell-contents! cell old-value)
+ (set! old-value)
+ unspecific))))
(define (values . objects)
(lambda (receiver)
(with-output-to-truncated-string max
(lambda ()
(write object)))))
-
+\f
(define (pa procedure)
(if (not (procedure? procedure))
(error "Must be a procedure" procedure))
;; Compatibility.
(define %pwd pwd)
(define %cd cd)
-\f
+
(define (show-time thunk)
(let ((process-start (process-time-clock))
(real-start (real-time-clock)))
(define-integrable (object-pointer? object)
(not (object-non-pointer? object)))
-
+\f
(define (impurify object)
(if (and (object-pointer? object) (object-pure? object))
((ucode-primitive primitive-impurify) object))
(if (not ((ucode-primitive primitive-fasdump) object filename false))
(error "FASDUMP: Object is too large to be dumped:" object))
(write-string " -- done" port)))
-\f
+
(define (undefined-value? object)
;; Note: the unparser takes advantage of the fact that objects
;; satisfying this predicate also satisfy:
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/intrpt.scm,v 14.8 1991/11/26 07:06:25 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/intrpt.scm,v 14.9 1992/02/08 15:08:27 cph Exp $
-Copyright (c) 1988-91 Massachusetts Institute of Technology
+Copyright (c) 1988-92 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(fixed-objects-vector-slot 'SYSTEM-INTERRUPT-VECTOR))
(set! index:termination-vector
(fixed-objects-vector-slot 'MICROCODE-TERMINATIONS-PROCEDURES))
+ (set! keyboard-thread false)
(set! hook/clean-input/flush-typeahead false)
(set! hook/clean-input/keep-typeahead false)
(set! hook/^B-interrupt false)
(set! hook/^G-interrupt false)
(set! hook/^U-interrupt false)
(set! hook/^X-interrupt false)
- (set! timer-interrupt default/timer-interrupt)
- (set! external-interrupt default/external-interrupt)
- (set! keyboard-interrupts
- (let ((table (make-vector 256 losing-keyboard-interrupt)))
+ (set! keyboard-interrupt-vector
+ (let ((table (make-vector 256 false)))
(for-each (lambda (entry)
(vector-set! table
(char->ascii (car entry))
(cadr entry)))
- `((#\B ,(keep-typeahead ^B-interrupt-handler))
- (#\G ,(flush-typeahead ^G-interrupt-handler))
- (#\U ,(flush-typeahead ^U-interrupt-handler))
- (#\X ,(flush-typeahead ^X-interrupt-handler))))
+ `((#\B ,^B-interrupt-handler)
+ (#\G ,^G-interrupt-handler)
+ (#\U ,^U-interrupt-handler)
+ (#\X ,^X-interrupt-handler)))
table))
(install))
(define (timer-interrupt-handler interrupt-code interrupt-enables)
interrupt-code interrupt-enables
(clear-interrupts! interrupt-bit/timer)
- (timer-interrupt))
-
-(define timer-interrupt)
-(define (default/timer-interrupt)
- (process-timer-clear)
- (real-timer-clear)
- (error "Unhandled Timer interrupt received"))
+ (thread-timer-interrupt-handler))
(define (suspend-interrupt-handler interrupt-code interrupt-enables)
interrupt-code interrupt-enables
\f
;;;; Keyboard Interrupts
-(define (external-interrupt-handler interrupt-code interrupt-enables)
- interrupt-code
- (clear-interrupts! interrupt-bit/kbd)
- (external-interrupt (tty-next-interrupt-char) interrupt-enables))
-
-(define (with-external-interrupts-handler handler thunk)
- (fluid-let ((external-interrupt (flush-typeahead handler)))
- (thunk)))
-
-(define external-interrupt)
-(define (default/external-interrupt character interrupt-enables)
- ((vector-ref keyboard-interrupts character) character interrupt-enables))
-
-(define (losing-keyboard-interrupt character interrupt-enables)
- interrupt-enables
- (error "Bad interrupt character" character))
-
-(define keyboard-interrupts)
-
+(define keyboard-interrupt-vector)
+(define keyboard-thread)
(define hook/clean-input/flush-typeahead)
(define hook/clean-input/keep-typeahead)
(define hook/^B-interrupt)
(define hook/^U-interrupt)
(define hook/^X-interrupt)
-(define ((flush-typeahead kernel) char interrupt-enables)
- (if (or (not hook/clean-input/flush-typeahead)
- (hook/clean-input/flush-typeahead char))
- (kernel char interrupt-enables)))
+(define (keyboard-interrupt-thread)
+ keyboard-thread)
-(define ((keep-typeahead kernel) char interrupt-enables)
- (if (or (not hook/clean-input/keep-typeahead)
- (hook/clean-input/keep-typeahead char))
- (kernel char interrupt-enables)))
+(define (set-keyboard-interrupt-thread! thread)
+ (if (not (or (not thread) (thread? thread)))
+ (error:wrong-type-argument thread
+ "thread or #f"
+ set-keyboard-interrupt-thread!))
+ (set! keyboard-thread thread)
+ unspecific)
+
+(define (external-interrupt-handler interrupt-code interrupt-mask)
+ interrupt-code interrupt-mask
+ (clear-interrupts! interrupt-bit/kbd)
+ (let ((char (tty-next-interrupt-char)))
+ (let ((handler (vector-ref keyboard-interrupt-vector char)))
+ (if (not handler)
+ (error "Bad interrupt character:" char))
+ (handler char))))
-(define (^B-interrupt-handler char interrupt-mask)
- char
+(define (^B-interrupt-handler char)
(if hook/^B-interrupt
- (hook/^B-interrupt interrupt-mask))
- (cmdl-interrupt/breakpoint))
+ (hook/^B-interrupt))
+ (if (and (or (not hook/clean-input/keep-typeahead)
+ (hook/clean-input/keep-typeahead char))
+ keyboard-thread)
+ (signal-thread-event keyboard-thread cmdl-interrupt/breakpoint)))
-(define (^G-interrupt-handler char interrupt-mask)
- char
+(define (^G-interrupt-handler char)
(if hook/^G-interrupt
- (hook/^G-interrupt interrupt-mask))
- (cmdl-interrupt/abort-top-level))
+ (hook/^G-interrupt))
+ (if (and (or (not hook/clean-input/flush-typeahead)
+ (hook/clean-input/flush-typeahead char))
+ keyboard-thread)
+ (signal-thread-event keyboard-thread cmdl-interrupt/abort-top-level)))
-(define (^U-interrupt-handler char interrupt-mask)
- char
+(define (^U-interrupt-handler char)
(if hook/^U-interrupt
- (hook/^U-interrupt interrupt-mask))
- (cmdl-interrupt/abort-previous))
+ (hook/^U-interrupt))
+ (if (and (or (not hook/clean-input/flush-typeahead)
+ (hook/clean-input/flush-typeahead char))
+ keyboard-thread)
+ (signal-thread-event keyboard-thread cmdl-interrupt/abort-previous)))
-(define (^X-interrupt-handler char interrupt-mask)
- char
+(define (^X-interrupt-handler char)
(if hook/^X-interrupt
- (hook/^X-interrupt interrupt-mask))
- (cmdl-interrupt/abort-nearest))
+ (hook/^X-interrupt))
+ (if (and (or (not hook/clean-input/flush-typeahead)
+ (hook/clean-input/flush-typeahead char))
+ keyboard-thread)
+ (signal-thread-event keyboard-thread cmdl-interrupt/abort-nearest)))
\f
(define (install)
(without-interrupts
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/io.scm,v 14.28 1991/11/04 20:29:14 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/io.scm,v 14.29 1992/02/08 15:08:29 cph Exp $
-Copyright (c) 1988-91 Massachusetts Institute of Technology
+Copyright (c) 1988-92 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
\f
(define open-channels-list)
(define traversing?)
+(define open-directories-list)
(define (initialize-package!)
(set! open-channels-list (list 'OPEN-CHANNELS-LIST))
(set! traversing? false)
(add-gc-daemon! close-lost-open-files-daemon)
+ (set! open-directories-list (make-protection-list))
+ (add-gc-daemon! close-lost-open-directories-daemon)
(add-event-receiver! event:after-restore primitive-io/reset!))
(define-structure (channel (constructor %make-channel))
(define (pty-master-hangup channel)
((ucode-primitive pty-master-hangup 1) (channel-descriptor channel)))
\f
+;;;; Directory Primitives
+
+(define-structure (directory-channel (conc-name directory-channel/))
+ descriptor)
+
+(define (directory-channel-open name)
+ (without-interrupts
+ (lambda ()
+ (let ((descriptor ((ucode-primitive new-directory-open 1) name)))
+ (let ((channel (make-directory-channel descriptor)))
+ (add-to-protection-list! open-directories-list channel descriptor)
+ channel)))))
+
+(define (directory-channel-close channel)
+ (without-interrupts
+ (lambda ()
+ (let ((descriptor (directory-channel/descriptor channel)))
+ (if descriptor
+ (begin
+ ((ucode-primitive new-directory-close 1) descriptor)
+ (set-directory-channel/descriptor! channel false)
+ (remove-from-protection-list! open-directories-list channel)))))))
+
+(define (close-lost-open-directories-daemon)
+ (clean-lost-protected-objects open-directories-list
+ (ucode-primitive new-directory-close 1)))
+
+(define (directory-channel-read channel)
+ ((ucode-primitive new-directory-read 1)
+ (directory-channel/descriptor channel)))
+
+(define (directory-channel-read-matching channel prefix)
+ ((ucode-primitive new-directory-read-matching 2)
+ (directory-channel/descriptor channel)
+ prefix))
+
+;;;; Protection lists
+
+;;; These will cause problems on interpreted systems, due to the
+;;; consing of the interpreter. For now we'll only run this compiled.
+
+(define (make-protection-list)
+ (list 'PROTECTION-LIST))
+
+(define (add-to-protection-list! list scheme-object microcode-object)
+ (with-absolutely-no-interrupts
+ (lambda ()
+ (set-cdr! list
+ (cons (weak-cons scheme-object microcode-object)
+ (cdr list))))))
+
+(define (remove-from-protection-list! list scheme-object)
+ (with-absolutely-no-interrupts
+ (lambda ()
+ (let loop ((associations (cdr list)) (previous list))
+ (if (not (null? associations))
+ (if (eq? scheme-object (weak-pair/car? (car associations)))
+ (set-cdr! previous (cdr associations))
+ (loop (cdr associations) associations)))))))
+
+(define (clean-lost-protected-objects list cleaner)
+ (let loop ((associations (cdr list)) (previous list))
+ (if (not (null? associations))
+ (if (weak-pair/car? (car associations))
+ (loop (cdr associations) associations)
+ (begin
+ (cleaner (weak-cdr (car associations)))
+ (let ((next (cdr associations)))
+ (set-cdr! previous next)
+ (loop next previous)))))))
+
+(define (search-protection-list list microcode-object)
+ (let loop ((associations (cdr list)))
+ (and (not (null? associations))
+ (if (eq? microcode-object (system-pair-cdr (car associations)))
+ (system-pair-car (car associations))
+ (loop (cdr associations))))))
+\f
;;;; Buffered Output
(define-structure (output-buffer
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/make.scm,v 14.32 1992/02/07 19:47:32 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/make.scm,v 14.33 1992/02/08 15:08:31 cph Exp $
-Copyright (c) 1988-1992 Massachusetts Institute of Technology
+Copyright (c) 1988-92 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(RUNTIME INTERRUPT-HANDLER)
(RUNTIME GC-STATISTICS)
(RUNTIME REP)
+ (RUNTIME THREAD)
;; Debugging
(RUNTIME COMPILER-INFO)
(RUNTIME ADVICE)
;; Emacs -- last because it grabs the kitchen sink.
(RUNTIME EMACS-INTERFACE)))
\f
+(package-initialize '(RUNTIME CONTINUATION-PARSER) 'INITIALIZE-SPECIAL-FRAMES!)
+
(let ((filename (map-filename "site")))
(if (file-exists? filename)
(eval (fasload filename #t) system-global-environment)))
)
(package/add-child! system-global-package 'USER user-initial-environment)
+(set-keyboard-interrupt-thread! (current-thread))
+(start-thread-timer)
(initial-top-level-repl)
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/rep.scm,v 14.22 1991/11/26 07:06:53 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/rep.scm,v 14.23 1992/02/08 15:08:33 cph Exp $
-Copyright (c) 1988-91 Massachusetts Institute of Technology
+Copyright (c) 1988-92 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(with-interrupt-mask interrupt-mask/all
(lambda (interrupt-mask)
interrupt-mask
+ (unblock-thread-events)
(message cmdl)
((cmdl/driver cmdl) cmdl)))))))))))))
(if operation
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.132 1992/02/04 23:59:37 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.133 1992/02/08 15:08:35 cph Exp $
Copyright (c) 1988-92 Massachusetts Institute of Technology
call-with-current-continuation
continuation/control-point
continuation/dynamic-state
- continuation/fluid-bindings
continuation/type
continuation?
guarantee-continuation
make-continuation
non-reentrant-call-with-current-continuation
- within-continuation))
+ within-continuation)
+ (export (runtime thread)
+ %within-continuation))
(define-package (runtime continuation-parser)
(files "conpar")
stack-frame-type?
stack-frame/dynamic-state
stack-frame/elements
- stack-frame/fluid-bindings
stack-frame/interrupt-mask
stack-frame/length
stack-frame/next
(files "intrpt")
(parent ())
(export ()
- timer-interrupt
- with-external-interrupts-handler)
+ keyboard-interrupt-thread
+ set-keyboard-interrupt-thread!)
(export (runtime emacs-interface)
hook/^G-interrupt
hook/clean-input/flush-typeahead)
channel-write-string-block
channel?
close-all-open-files
+ directory-channel-close
+ directory-channel-open
+ directory-channel-read
+ directory-channel-read-matching
+ directory-channel?
file-length
file-open-append-channel
file-open-input-channel
(files "wind")
(parent ())
(export ()
- current-dynamic-state
dynamic-wind
- execute-at-new-state-point
- get-fluid-bindings
- make-state-space
- object-component-binder
- set-current-dynamic-state!
- set-fluid-bindings!
- translate-to-state-point)
+ shallow-fluid-bind)
+ (export (runtime continuation)
+ get-dynamic-state
+ set-dynamic-state!)
(export (runtime continuation-parser)
- state-point/space
- system-state-space)
+ %translate-to-state-point
+ merge-dynamic-state)
+ (export (runtime thread)
+ make-state-space
+ state-space:local)
(initialization (initialize-package!)))
(define-package (runtime stream)
port/gc-start)
(export (runtime emacs-interface)
port/read-finish
- port/read-start))
\ No newline at end of file
+ port/read-start))
+
+(define-package (runtime thread)
+ (files "thread")
+ (parent ())
+ (export ()
+ block-thread-events
+ condition-type:thread-deadlock
+ condition-type:thread-detached
+ condition-type:thread-error
+ create-thread
+ current-thread
+ detach-thread
+ exit-current-thread
+ join-thread
+ lock-thread-mutex
+ make-thread-mutex
+ other-running-threads?
+ set-thread-timer-interval!
+ signal-thread-event
+ sleep-current-thread
+ start-thread-timer
+ stop-thread-timer
+ suspend-current-thread
+ thread-continuation
+ thread-dead?
+ thread-mutex?
+ thread-timer-interval
+ thread?
+ try-lock-thread-mutex
+ unblock-thread-events
+ unlock-thread-mutex
+ yield-current-thread)
+ (export (runtime interrupt-handler)
+ thread-timer-interrupt-handler)
+ (initialization (initialize-package!)))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/savres.scm,v 14.23 1991/11/26 07:07:07 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/savres.scm,v 14.24 1992/02/08 15:08:37 cph Exp $
-Copyright (c) 1988-91 Massachusetts Institute of Technology
+Copyright (c) 1988-92 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(define (initialize-package!)
(set! disk-save (setup-image disk-save/kernel))
- (set! dump-world (setup-image dump-world/kernel)))
+ (set! dump-world (setup-image dump-world/kernel))
+ unspecific)
(define disk-save)
(define dump-world)
(lambda ()
(set! time-world-saved time)
(event-distributor/invoke! event:after-restore)
+ (start-thread-timer)
(cond ((string? identify)
(set! world-identification identify)
(clear console-output-port)
(call-with-current-continuation
(lambda (continuation)
(let ((fixed-objects (get-fixed-objects-vector))
- (dynamic-state (current-dynamic-state))
(filename (->namestring (merge-pathnames filename))))
- (fluid-let ()
- ((ucode-primitive call-with-current-continuation)
- (lambda (restart)
- (gc-flip)
- (do () (((ucode-primitive dump-band) restart filename))
- (with-simple-restart 'RETRY "Try again."
- (lambda ()
- (error "Disk save failed:" filename))))
- (continuation after-suspend)))
- ((ucode-primitive set-fixed-objects-vector!) fixed-objects)
- (set-current-dynamic-state! dynamic-state)
- (read-microcode-tables!)
- after-restore))))))))
+ ((ucode-primitive call-with-current-continuation)
+ (lambda (restart)
+ (gc-flip)
+ (do () (((ucode-primitive dump-band) restart filename))
+ (with-simple-restart 'RETRY "Try again."
+ (lambda ()
+ (error "Disk save failed:" filename))))
+ (continuation after-suspend)))
+ ((ucode-primitive set-fixed-objects-vector!) fixed-objects)
+ (read-microcode-tables!)
+ after-restore)))))))
(define (dump-world/kernel filename after-suspend after-restore)
((with-absolutely-no-interrupts
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/Attic/syntax.scm,v 14.16 1991/04/18 22:35:21 markf Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/Attic/syntax.scm,v 14.17 1992/02/08 15:08:39 cph Exp $
-Copyright (c) 1988-91 Massachusetts Institute of Technology
+Copyright (c) 1988-92 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(lambda (names values transfers-in transfers-out)
(make-closed-block lambda-tag:fluid-let names values
(make-combination*
- (make-absolute-reference 'DYNAMIC-WIND)
+ (make-absolute-reference 'SHALLOW-FLUID-BIND)
(make-thunk (make-scode-sequence transfers-in))
(make-thunk (syntax-sequence body))
(make-thunk (make-scode-sequence transfers-out))))))))
(else
(syntax-error "binding name illegal" (car binding)))))
(syntax-error "binding not a pair" binding)))
-
-(define (syntax/dynamic-state-let state-space bindings . body)
- (if (null? bindings)
- (syntax-sequence body)
- (syntax-fluid-bindings/shallow bindings
- (lambda (names values transfers-in transfers-out)
- (make-closed-block lambda-tag:dynamic-state-let names values
- (make-combination*
- (make-absolute-reference 'EXECUTE-AT-NEW-STATE-POINT)
- (syntax-expression state-space)
- (make-thunk (make-scode-sequence transfers-in))
- (make-thunk (syntax-sequence body))
- (make-thunk (make-scode-sequence transfers-out))))))))
\f
;;;; Extended Assignment Syntax
(define-integrable lambda-tag:let
(string->symbol "#[let-procedure]"))
-(define-integrable lambda-tag:dynamic-state-let
- (string->symbol "#[dynamic-state-let-procedure]"))
-
(define-integrable lambda-tag:fluid-let
(string->symbol "#[fluid-let-procedure]"))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/uerror.scm,v 14.30 1991/11/26 06:53:41 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/uerror.scm,v 14.31 1992/02/08 15:08:40 cph Exp $
-Copyright (c) 1988-91 Massachusetts Institute of Technology
+Copyright (c) 1988-92 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(eq? primitive (ucode-primitive file-open-output-channel 1)))
(values "open" "file"))
((or (eq? primitive (ucode-primitive directory-open 1))
- (eq? primitive (ucode-primitive directory-open-noread 1)))
+ (eq? primitive (ucode-primitive directory-open-noread 1))
+ (eq? primitive (ucode-primitive new-directory-open 1)))
(values "open" "directory"))
((or (eq? primitive (ucode-primitive file-modes 1))
(eq? primitive (ucode-primitive file-access 2)))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unsyn.scm,v 14.11 1991/02/15 18:07:27 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unsyn.scm,v 14.12 1992/02/08 15:08:42 cph Exp $
-Copyright (c) 1988-91 Massachusetts Institute of Technology
+Copyright (c) 1988-92 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
;; substitutions.
(cond ((not (null? substitutions))
(if-malformed))
- ((and (or (absolute-reference-to? operator 'DYNAMIC-WIND)
+ ((and (or (absolute-reference-to? operator 'SHALLOW-FLUID-BIND)
(and (variable? operator)
- (eq? (variable-name operator) 'DYNAMIC-WIND)))
+ (eq? (variable-name operator) 'SHALLOW-FLUID-BIND)))
(pair? operands)
(lambda? (car operands))
(pair? (cdr operands))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unxdir.scm,v 14.8 1991/11/04 20:30:16 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unxdir.scm,v 14.9 1992/02/08 15:08:44 cph Exp $
-Copyright (c) 1988-91 Massachusetts Institute of Technology
+Copyright (c) 1988-92 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(pathname-type instance)))))))))))
(define (generate-directory-pathnames pathname)
- (dynamic-wind
- (lambda () unspecific)
- (lambda ()
- ((ucode-primitive directory-open-noread 1) (->namestring pathname))
- (let loop ((result '()))
- (let ((name ((ucode-primitive directory-read 0))))
- (if name
- (loop (cons name result))
- result))))
- (ucode-primitive directory-close 0)))
+ (let ((channel (directory-channel-open (->namestring pathname))))
+ (let loop ((result '()))
+ (let ((name (directory-channel-read channel)))
+ (if name
+ (loop (cons name result))
+ (begin
+ (directory-channel-close channel)
+ result))))))
(define (match-component pattern instance)
(or (eq? pattern 'WILD)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.145 1992/02/07 19:47:41 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.146 1992/02/08 15:08:45 cph Exp $
-Copyright (c) 1988-1992 Massachusetts Institute of Technology
+Copyright (c) 1988-92 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
'()))
(add-system! microcode-system)
(add-event-receiver! event:after-restore snarf-microcode-version!)
- (add-identification! "Runtime" 14 145))
+ (add-identification! "Runtime" 14 146))
(define microcode-system)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/wind.scm,v 14.3 1989/03/06 19:59:05 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/wind.scm,v 14.4 1992/02/08 15:08:46 cph Exp $
-Copyright (c) 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1988-92 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
;;; package: (runtime state-space)
(declare (usual-integrations))
+
+;;; A STATE-SPACE is a tree of STATE-POINTs, except that the pointers
+;;; in the tree point towards the root of the tree rather than its
+;;; leaves. These pointers are the NEARER-POINT of each point.
+
+;;; Each point in the space has two procedures, TO-NEARER and
+;;; FROM-NEARER. To move the root of the space to an adjacent point,
+;;; one executes the FROM-NEARER of that point, then makes the
+;;; TO-NEARER and FROM-NEARER of the old root be the FROM-NEARER and
+;;; TO-NEARER of the new root, respectively.
+
+(define-integrable with-stack-marker
+ (ucode-primitive with-stack-marker 3))
\f
-(define (initialize-package!)
- (let ((fixed-objects (get-fixed-objects-vector))
- (state-space-tag "State Space")
- (state-point-tag "State Point"))
- (unparser/set-tagged-vector-method!
- state-space-tag
- (unparser/standard-method 'STATE-SPACE))
- (unparser/set-tagged-vector-method!
- state-point-tag
- (unparser/standard-method 'STATE-POINT))
- (vector-set! fixed-objects
- (fixed-objects-vector-slot 'STATE-SPACE-TAG)
- state-space-tag)
- (vector-set! fixed-objects
- (fixed-objects-vector-slot 'STATE-POINT-TAG)
- state-point-tag)
- (set! system-state-space (make-state-space false))
- (vector-set! fixed-objects
- (fixed-objects-vector-slot 'STATE-SPACE-ROOT)
- (current-dynamic-state))
- ((ucode-primitive set-fixed-objects-vector!) fixed-objects)))
-
-(define-structure (state-point (type vector)
- (initial-offset 1)
- (constructor false)
- (conc-name state-point/))
- (before-thunk false read-only true)
- (after-thunk false read-only true)
- (nearer-point false read-only true)
- (distance-to-root false read-only true))
+(define-structure (state-space
+ (conc-name state-space/)
+ (constructor %make-state-space))
+ nearest-point)
+
+(define (make-state-space)
+ (let ((space (%make-state-space '())))
+ ;; Save the state space in the TO-NEARER field of the root point,
+ ;; because it is needed by %TRANSLATE-TO-STATE-POINT.
+ (set-state-space/nearest-point! space (make-state-point false space false))
+ space))
+
+(define-structure (state-point (conc-name state-point/))
+ nearer-point
+ to-nearer
+ from-nearer)
+
+(define (%execute-at-new-state-point space before during after)
+ (let ((old-root
+ (without-interrupts
+ (lambda ()
+ (let ((old-root (state-space/nearest-point space)))
+ (let ((new-point (make-state-point false space false)))
+ (set-state-point/nearer-point! old-root new-point)
+ (set-state-point/to-nearer! old-root before)
+ (set-state-point/from-nearer! old-root after)
+ (set-state-space/nearest-point! space new-point))
+ (before)
+ old-root)))))
+ (let ((value
+ (with-stack-marker during %translate-to-state-point old-root)))
+ (%translate-to-state-point old-root)
+ value)))
+
+(define (%translate-to-state-point point)
+ (without-interrupts
+ (lambda ()
+ (let find-nearest ((point point) (chain '()))
+ (let ((nearer-point (state-point/nearer-point point)))
+ (if nearer-point
+ (find-nearest nearer-point (cons point chain))
+ (let ((space (state-point/to-nearer point)))
+ (let traverse-chain ((old-root point) (chain chain))
+ (if (not (null? chain))
+ (let ((new-root (car chain)))
+ ;; Move to NEW-ROOT.
+ (let ((to-nearer (state-point/to-nearer new-root))
+ (from-nearer (state-point/from-nearer new-root)))
+ (set-state-point/nearer-point! old-root new-root)
+ (set-state-point/to-nearer! old-root from-nearer)
+ (set-state-point/from-nearer! old-root to-nearer)
+ (set-state-point/nearer-point! new-root false)
+ (set-state-point/to-nearer! new-root space)
+ (set-state-point/from-nearer! new-root false)
+ (set-state-space/nearest-point! space new-root)
+ (with-stack-marker from-nearer
+ set-interrupt-enables! interrupt-mask/gc-ok))
+ ;; Disable interrupts again in case FROM-NEARER
+ ;; re-enabled them.
+ (set-interrupt-enables! interrupt-mask/gc-ok)
+ ;; Make sure that NEW-ROOT is still the root,
+ ;; because FROM-NEARER might have moved it. If
+ ;; it has been moved, find the new root, and
+ ;; adjust CHAIN as needed.
+ (let find-root ((chain chain))
+ (let ((nearer-point
+ (state-point/nearer-point (car chain))))
+ (cond ((not nearer-point)
+ ;; (CAR CHAIN) is the root.
+ (traverse-chain (car chain) (cdr chain)))
+ ((and (not (null? (cdr chain)))
+ (eq? nearer-point (cadr chain)))
+ ;; The root has moved along CHAIN.
+ (find-root (cdr chain)))
+ (else
+ ;; The root has moved elsewhere.
+ (find-nearest nearer-point
+ chain)))))))))))))))
+\f
+(define-integrable (guarantee-state-space space procedure)
+ (if (not (state-space? space))
+ (error:wrong-type-argument space "state space" procedure)))
-(define (state-point/space point)
- (let ((next (state-point/nearer-point point)))
- (if (positive? (state-point/distance-to-root point))
- (state-point/space next)
- next)))
+(define-integrable (guarantee-state-point point procedure)
+ (if (not (state-point? point))
+ (error:wrong-type-argument point "state point" procedure)))
-(define-primitives
- execute-at-new-state-point
- translate-to-state-point
- set-current-dynamic-state!
- (get-fluid-bindings 0)
- (set-fluid-bindings! 1))
+(define (current-state-point space)
+ (guarantee-state-space space current-state-point)
+ (state-space/nearest-point space))
-(define (make-state-space #!optional mutable?)
- ((ucode-primitive make-state-space)
- (if (default-object? mutable?) true mutable?)))
+(define (execute-at-new-state-point space before during after)
+ (guarantee-state-space space execute-at-new-state-point)
+ (%execute-at-new-state-point space before during after))
-(define system-state-space)
+(define (translate-to-state-point point)
+ (guarantee-state-point point translate-to-state-point)
+ (%translate-to-state-point point))
-(define (current-dynamic-state #!optional state-space)
- ((ucode-primitive current-dynamic-state)
- (if (default-object? state-space) system-state-space state-space)))
+(define (state-point/space point)
+ (guarantee-state-point point state-point/space)
+ (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
+ (let loop ((point point))
+ (let ((nearer-point (state-point/nearer-point point)))
+ (if nearer-point
+ (loop nearer-point)
+ (begin
+ (set-interrupt-enables! interrupt-mask)
+ point))))))
+
+(define state-space:global)
+(define state-space:local)
+
+(define (shallow-fluid-bind before during after)
+ (%execute-at-new-state-point state-space:global before during after))
(define (dynamic-wind before during after)
- ;; NOTE: the "before" thunk is executed IN THE NEW STATE, the
- ;; "after" thunk is executed IN THE OLD STATE. Your programs should
- ;; not depend on this if it can be avoided.
- (execute-at-new-state-point system-state-space before during after))
-
-(define (object-component-binder get-component set-component!)
- (lambda (object new-value thunk)
- (let ((old-value))
- (dynamic-wind (lambda ()
- (set! old-value (get-component object))
- (set-component! object new-value)
- (set! new-value false)
- unspecific)
- thunk
- (lambda ()
- (set! new-value (get-component object))
- (set-component! object old-value)
- (set! old-value false)
- unspecific)))))
\ No newline at end of file
+ (let ((fluid-bindings (state-space/nearest-point state-space:global)))
+ (%execute-at-new-state-point
+ state-space:local
+ (lambda ()
+ (%translate-to-state-point fluid-bindings)
+ (before))
+ during
+ (lambda ()
+ (%translate-to-state-point fluid-bindings)
+ (after)))))
+
+(define (initialize-package!)
+ (set! state-space:global (make-state-space))
+ (set! state-space:local (make-state-space))
+ unspecific)
+\f
+(define-structure (dynamic-state (conc-name dynamic-state/))
+ (global false read-only true)
+ (local false read-only true))
+
+(define (get-dynamic-state)
+ (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
+ (let ((state
+ (make-dynamic-state
+ (state-space/nearest-point state-space:global)
+ (state-space/nearest-point state-space:local))))
+ (set-interrupt-enables! interrupt-mask)
+ state)))
+
+(define (set-dynamic-state! state global-only?)
+ (if (not (dynamic-state? state))
+ (error:wrong-type-argument state "dynamic state" set-dynamic-state!))
+ (if (not global-only?)
+ (%translate-to-state-point (dynamic-state/local state)))
+ (%translate-to-state-point (dynamic-state/global state)))
+
+(define (merge-dynamic-state state point)
+ (let ((space (state-point/space point))
+ (global (dynamic-state/global state))
+ (local (dynamic-state/local state)))
+ (cond ((eq? space (state-point/space global))
+ (make-dynamic-state point local))
+ ((eq? space (state-point/space local))
+ (make-dynamic-state global point))
+ (else
+ state))))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/wrkdir.scm,v 14.5 1991/11/26 07:07:31 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/wrkdir.scm,v 14.6 1992/02/08 15:08:47 cph Exp $
-Copyright (c) 1988-91 Massachusetts Institute of Technology
+Copyright (c) 1988-92 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(define (working-directory-pathname)
*working-directory-pathname*)
-(define (%set-working-directory-pathname! name)
+(define (set-working-directory-pathname! name)
(let ((pathname
(pathname-as-directory
(merge-pathnames name *working-directory-pathname*))))
(if (not (file-directory? pathname))
(error "Not a valid directory:" pathname))
(let ((pathname (pathname-simplify pathname)))
- (if (eq? *default-pathname-defaults* *working-directory-pathname*)
- (set! *default-pathname-defaults* pathname))
(set! *working-directory-pathname* pathname)
+ (set! *default-pathname-defaults*
+ (merge-pathnames pathname *default-pathname-defaults*))
((ucode-primitive set-working-directory-pathname! 1)
(->namestring pathname))
+ (port/set-default-directory (nearest-cmdl/port) pathname)
pathname)))
-(define (set-working-directory-pathname! name)
- (let ((pathname (%set-working-directory-pathname! name)))
- (port/set-default-directory (nearest-cmdl/port) pathname)
- pathname))
-
(define (with-working-directory-pathname name thunk)
- (let ((old-pathname))
- (dynamic-wind (lambda ()
- (set! old-pathname (working-directory-pathname))
- (%set-working-directory-pathname! name))
- thunk
- (lambda ()
- (set! name (working-directory-pathname))
- (%set-working-directory-pathname! old-pathname)))))
\ No newline at end of file
+ (let ((pathname
+ (pathname-as-directory
+ (merge-pathnames name *working-directory-pathname*))))
+ (if (not (file-directory? pathname))
+ (error "Not a valid directory:" pathname))
+ (let ((pathname (pathname-simplify pathname)))
+ (fluid-let ((*working-directory-pathname* pathname)
+ (*default-pathname-defaults*
+ (merge-pathnames pathname *default-pathname-defaults*)))
+ (thunk)))))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/conpar.scm,v 14.24 1991/08/27 08:00:17 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/conpar.scm,v 14.25 1992/02/08 15:08:18 cph Exp $
-Copyright (c) 1988-1991 Massachusetts Institute of Technology
+Copyright (c) 1988-92 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(define-structure (stack-frame
(constructor make-stack-frame
- (type elements dynamic-state fluid-bindings
+ (type elements dynamic-state
interrupt-mask history
previous-history-offset
previous-history-control-point
(type false read-only true)
(elements false read-only true)
(dynamic-state false read-only true)
- (fluid-bindings false read-only true)
(interrupt-mask false read-only true)
(history false read-only true)
(previous-history-offset false read-only true)
(stack-frame/skip-non-subproblems stack-frame)))
(stack-frame/skip-non-subproblems stack-frame)))
-(define (stack-frame/skip-non-subproblems stack-frame)
- (if (stack-frame/subproblem? stack-frame)
- stack-frame
- (let ((stack-frame (stack-frame/next stack-frame)))
- (and stack-frame
- (stack-frame/skip-non-subproblems stack-frame)))))
-\f
(define-integrable (stack-frame/length stack-frame)
(vector-length (stack-frame/elements stack-frame)))
(and (interpreter-return-address? return-address)
(return-address/code return-address))))
-(define-integrable (stack-frame/subproblem? stack-frame)
+(define (stack-frame/subproblem? stack-frame)
(stack-frame-type/subproblem? (stack-frame/type stack-frame)))
(define-integrable (stack-frame/compiled-code? stack-frame)
(compiled-return-address? (stack-frame/return-address stack-frame)))
-
+\f
(define (stack-frame/resolve-stack-address frame address)
(let loop
((frame frame)
(if (< offset length)
(values frame offset)
(loop (stack-frame/next frame) (- offset length))))))
+
+(define (stack-frame/skip-non-subproblems stack-frame)
+ (let ((type (stack-frame/type stack-frame)))
+ (cond ((eq? type stack-frame-type/stack-marker)
+ (let loop ((stack-frame stack-frame))
+ (let ((stack-frame (stack-frame/next stack-frame)))
+ (and stack-frame
+ (if (stack-frame/subproblem? stack-frame)
+ (stack-frame/next-subproblem stack-frame)
+ (loop stack-frame))))))
+ ((and (stack-frame/subproblem? stack-frame)
+ (not (and (eq? type stack-frame-type/compiled-return-address)
+ (eq? (stack-frame/return-address stack-frame)
+ continuation-return-address))))
+ stack-frame)
+ (else
+ (let ((stack-frame (stack-frame/next stack-frame)))
+ (and stack-frame
+ (stack-frame/skip-non-subproblems stack-frame)))))))
+
+(define continuation-return-address)
+
+(define (initialize-special-frames!)
+ (set! continuation-return-address
+ (let ((stack-frame
+ (call-with-current-continuation
+ (lambda (k)
+ k
+ (call-with-current-continuation
+ continuation/first-subproblem)))))
+ (and (eq? (stack-frame/type stack-frame)
+ stack-frame-type/compiled-return-address)
+ (stack-frame/return-address stack-frame))))
+ unspecific)
\f
;;;; Parser
(define-structure (parser-state (constructor make-parser-state)
(conc-name parser-state/))
(dynamic-state false read-only true)
- (fluid-bindings false read-only true)
(interrupt-mask false read-only true)
(history false read-only true)
(previous-history-offset false read-only true)
(define (continuation->stack-frame continuation)
(parse-control-point (continuation/control-point continuation)
(continuation/dynamic-state continuation)
- (continuation/fluid-bindings continuation)
false))
-(define (parse-control-point control-point dynamic-state fluid-bindings type)
+(define (parse-control-point control-point dynamic-state type)
(let ((element-stream (control-point/element-stream control-point)))
(parse-one-frame
(make-parser-state
dynamic-state
- fluid-bindings
(control-point/interrupt-mask control-point)
(let ((history
(history-transform (control-point/history control-point))))
(parse-control-point
control-point
(parser-state/dynamic-state state)
- (parser-state/fluid-bindings state)
(parser-state/previous-type state))))))))
\f
;;; `make-intermediate-state' is used to construct an intermediate
(- (parser-state/n-elements state) length)))
(make-parser-state
(parser-state/dynamic-state state)
- (parser-state/fluid-bindings state)
(parser-state/interrupt-mask state)
(parser-state/history state)
(let ((previous (parser-state/previous-history-offset state)))
;;; call to `make-intermediate-state'). However, several of the
;;; parsers change the values of some of the components of `state'
;;; before calling `parser/standard' -- for example,
-;;; RESTORE-TO-STATE-POINT changes the `dynamic-state' component.
+;;; RESTORE-INTERRUPT-MASK changes the `interrupt-mask' component.
(define (parse/standard-next type elements state history? force-pop?)
(let ((n-elements (parser-state/n-elements state))
type
elements
(parser-state/dynamic-state state)
- (parser-state/fluid-bindings state)
(parser-state/interrupt-mask state)
(if history?
history
(+ (vector-length elements) n-elements)
(parser-state/previous-type state)
(make-parser-state (parser-state/dynamic-state state)
- (parser-state/fluid-bindings state)
(parser-state/interrupt-mask state)
(if (or force-pop? history-subproblem?)
(history-superproblem history)
(parse/standard-next type elements state
valid-history? valid-history?)))
\f
-(define (parser/restore-dynamic-state type elements state)
- ;; Possible problem: the dynamic state really consists of all of the
- ;; state spaces in existence. Probably we should have some
- ;; mechanism for keeping track of them all.
- (parser/standard
- type
- elements
- (make-parser-state (let ((dynamic-state (vector-ref elements 1)))
- (if (eq? system-state-space
- (state-point/space dynamic-state))
- dynamic-state
- (parser-state/dynamic-state state)))
- (parser-state/fluid-bindings state)
- (parser-state/interrupt-mask state)
- (parser-state/history state)
- (parser-state/previous-history-offset state)
- (parser-state/previous-history-control-point state)
- (parser-state/element-stream state)
- (parser-state/n-elements state)
- (parser-state/next-control-point state)
- (parser-state/previous-type state))))
-
-(define (parser/restore-fluid-bindings type elements state)
- (parser/standard
- type
- elements
- (make-parser-state (parser-state/dynamic-state state)
- (vector-ref elements 1)
- (parser-state/interrupt-mask state)
- (parser-state/history state)
- (parser-state/previous-history-offset state)
- (parser-state/previous-history-control-point state)
- (parser-state/element-stream state)
- (parser-state/n-elements state)
- (parser-state/next-control-point state)
- (parser-state/previous-type state))))
+(define (parser/stack-marker type elements state)
+ (let ((marker (vector-ref elements 1))
+ (continue
+ (lambda (dynamic-state interrupt-mask)
+ (parser/standard
+ type
+ elements
+ (make-parser-state
+ dynamic-state
+ interrupt-mask
+ (parser-state/history state)
+ (parser-state/previous-history-offset state)
+ (parser-state/previous-history-control-point state)
+ (parser-state/element-stream state)
+ (parser-state/n-elements state)
+ (parser-state/next-control-point state)
+ (parser-state/previous-type state))))))
+ (cond ((eq? marker %translate-to-state-point)
+ (continue (merge-dynamic-state (parser-state/dynamic-state state)
+ (vector-ref elements 2))
+ (parser-state/interrupt-mask state)))
+ ((eq? marker set-interrupt-enables!)
+ (continue (parser-state/dynamic-state state)
+ (vector-ref elements 2)))
+ (else
+ (continue (parser-state/dynamic-state state)
+ (parser-state/interrupt-mask state))))))
(define (parser/restore-interrupt-mask type elements state)
(parser/standard
type
elements
(make-parser-state (parser-state/dynamic-state state)
- (parser-state/fluid-bindings state)
(vector-ref elements 1)
(parser-state/history state)
(parser-state/previous-history-offset state)
type
elements
(make-parser-state (parser-state/dynamic-state state)
- (parser-state/fluid-bindings state)
(parser-state/interrupt-mask state)
(history-transform (vector-ref elements 1))
(vector-ref elements 2)
(define (stack-frame->continuation stack-frame)
(make-continuation 'REENTRANT
(stack-frame->control-point stack-frame)
- (stack-frame/dynamic-state stack-frame)
- (stack-frame/fluid-bindings stack-frame)))
+ (stack-frame/dynamic-state stack-frame)))
(define (stack-frame->control-point stack-frame)
(with-values (lambda () (unparse/stack-frame stack-frame))
offset
(+ index 1 (- (object-datum (element-stream/ref stream index)) missing)))
-(define (length/repeat-primitive stream offset)
- offset
- (primitive-procedure-arity (element-stream/ref stream 1)))
-
(define (length/compiled-return-address stream offset)
(let ((entry (element-stream/head stream)))
(let ((frame-size (compiled-continuation/next-continuation-offset entry)))
(set! stack-frame-types (make-stack-frame-types))
(set! stack-frame-type/hardware-trap
(microcode-return/name->type 'HARDWARE-TRAP))
+ (set! stack-frame-type/stack-marker
+ (microcode-return/name->type 'STACK-MARKER))
(set! stack-frame-type/compiled-return-address
(make-stack-frame-type false true false
length/compiled-return-address
(make-stack-frame-type false true false
1
parser/standard))
-
(set! word-size
(let ((initial (system-vector-length (make-bit-string 1 #f))))
(let loop ((size 2))
(if (= (system-vector-length (make-bit-string size #f)) initial)
(loop (1+ size))
(-1+ size)))))
+ (set! continuation-return-address false)
unspecific)
\f
(define stack-frame-types)
(define stack-frame-type/compiled-return-address)
(define stack-frame-type/return-to-interpreter)
(define stack-frame-type/hardware-trap)
+(define stack-frame-type/stack-marker)
(define stack-frame-type/interrupt-compiled-procedure)
(define stack-frame-type/interrupt-compiled-expression)
parser/standard
parser)))
- (standard-frame 'RESTORE-TO-STATE-POINT 2 parser/restore-dynamic-state)
- (standard-frame 'RESTORE-FLUIDS 2 parser/restore-fluid-bindings)
(standard-frame 'RESTORE-INTERRUPT-MASK 2 parser/restore-interrupt-mask)
(standard-frame 'RESTORE-HISTORY 4 parser/restore-history)
(standard-frame 'RESTORE-DONT-COPY-HISTORY 4 parser/restore-history)
+ (standard-frame 'STACK-MARKER 3 parser/stack-marker)
(standard-frame 'NON-EXISTENT-CONTINUATION 2)
(standard-frame 'HALT 2)
(standard-subproblem 'PRIMITIVE-COMBINATION-3-APPLY 4)
(standard-subproblem 'MOVE-TO-ADJACENT-POINT 6)
(standard-subproblem 'COMBINATION-SAVE-VALUE length/combination-save-value)
- (standard-subproblem 'REPEAT-PRIMITIVE length/repeat-primitive)
(let ((length (length/application-frame 2 0)))
(standard-subproblem 'COMBINATION-APPLY length)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/framex.scm,v 14.15 1991/06/14 03:02:57 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/framex.scm,v 14.16 1992/02/08 15:08:24 cph Exp $
-Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
+Copyright (c) 1988-92 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(let ((method (method/application-frame 3)))
(record-method 'INTERNAL-APPLY method)
(record-method 'INTERNAL-APPLY-VAL method))
- (record-method 'REPEAT-PRIMITIVE (method/application-frame 1))
(let ((method (method/compiler-reference identity-procedure)))
(record-method 'COMPILER-REFERENCE-RESTART method)
(record-method 'COMPILER-SAFE-REFERENCE-RESTART method))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/global.scm,v 14.34 1991/11/26 07:06:16 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/global.scm,v 14.35 1992/02/08 15:08:26 cph Exp $
-Copyright (c) 1988-91 Massachusetts Institute of Technology
+Copyright (c) 1988-92 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(define-integrable (system-hunk3-cons type cxr0 cxr1 cxr2)
(object-new-type type (hunk3-cons cxr0 cxr1 cxr2)))
+(define (object-component-binder get-component set-component!)
+ (lambda (object new-value thunk)
+ (let ((old-value))
+ (shallow-fluid-bind
+ (lambda ()
+ (set! old-value (get-component object))
+ (set-component! object new-value)
+ (set! new-value false)
+ unspecific)
+ thunk
+ (lambda ()
+ (set! new-value (get-component object))
+ (set-component! object old-value)
+ (set! old-value false)
+ unspecific)))))
+
(define (bind-cell-contents! cell new-value thunk)
(let ((old-value))
- (dynamic-wind (lambda ()
- (set! old-value (cell-contents cell))
- (set-cell-contents! cell new-value)
- (set! new-value))
- thunk
- (lambda ()
- (set! new-value (cell-contents cell))
- (set-cell-contents! cell old-value)
- (set! old-value)))))
+ (shallow-fluid-bind
+ (lambda ()
+ (set! old-value (cell-contents cell))
+ (set-cell-contents! cell new-value)
+ (set! new-value)
+ unspecific)
+ thunk
+ (lambda ()
+ (set! new-value (cell-contents cell))
+ (set-cell-contents! cell old-value)
+ (set! old-value)
+ unspecific))))
(define (values . objects)
(lambda (receiver)
(with-output-to-truncated-string max
(lambda ()
(write object)))))
-
+\f
(define (pa procedure)
(if (not (procedure? procedure))
(error "Must be a procedure" procedure))
;; Compatibility.
(define %pwd pwd)
(define %cd cd)
-\f
+
(define (show-time thunk)
(let ((process-start (process-time-clock))
(real-start (real-time-clock)))
(define-integrable (object-pointer? object)
(not (object-non-pointer? object)))
-
+\f
(define (impurify object)
(if (and (object-pointer? object) (object-pure? object))
((ucode-primitive primitive-impurify) object))
(if (not ((ucode-primitive primitive-fasdump) object filename false))
(error "FASDUMP: Object is too large to be dumped:" object))
(write-string " -- done" port)))
-\f
+
(define (undefined-value? object)
;; Note: the unparser takes advantage of the fact that objects
;; satisfying this predicate also satisfy:
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/make.scm,v 14.32 1992/02/07 19:47:32 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/make.scm,v 14.33 1992/02/08 15:08:31 cph Exp $
-Copyright (c) 1988-1992 Massachusetts Institute of Technology
+Copyright (c) 1988-92 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(RUNTIME INTERRUPT-HANDLER)
(RUNTIME GC-STATISTICS)
(RUNTIME REP)
+ (RUNTIME THREAD)
;; Debugging
(RUNTIME COMPILER-INFO)
(RUNTIME ADVICE)
;; Emacs -- last because it grabs the kitchen sink.
(RUNTIME EMACS-INTERFACE)))
\f
+(package-initialize '(RUNTIME CONTINUATION-PARSER) 'INITIALIZE-SPECIAL-FRAMES!)
+
(let ((filename (map-filename "site")))
(if (file-exists? filename)
(eval (fasload filename #t) system-global-environment)))
)
(package/add-child! system-global-package 'USER user-initial-environment)
+(set-keyboard-interrupt-thread! (current-thread))
+(start-thread-timer)
(initial-top-level-repl)
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.132 1992/02/04 23:59:37 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.133 1992/02/08 15:08:35 cph Exp $
Copyright (c) 1988-92 Massachusetts Institute of Technology
call-with-current-continuation
continuation/control-point
continuation/dynamic-state
- continuation/fluid-bindings
continuation/type
continuation?
guarantee-continuation
make-continuation
non-reentrant-call-with-current-continuation
- within-continuation))
+ within-continuation)
+ (export (runtime thread)
+ %within-continuation))
(define-package (runtime continuation-parser)
(files "conpar")
stack-frame-type?
stack-frame/dynamic-state
stack-frame/elements
- stack-frame/fluid-bindings
stack-frame/interrupt-mask
stack-frame/length
stack-frame/next
(files "intrpt")
(parent ())
(export ()
- timer-interrupt
- with-external-interrupts-handler)
+ keyboard-interrupt-thread
+ set-keyboard-interrupt-thread!)
(export (runtime emacs-interface)
hook/^G-interrupt
hook/clean-input/flush-typeahead)
channel-write-string-block
channel?
close-all-open-files
+ directory-channel-close
+ directory-channel-open
+ directory-channel-read
+ directory-channel-read-matching
+ directory-channel?
file-length
file-open-append-channel
file-open-input-channel
(files "wind")
(parent ())
(export ()
- current-dynamic-state
dynamic-wind
- execute-at-new-state-point
- get-fluid-bindings
- make-state-space
- object-component-binder
- set-current-dynamic-state!
- set-fluid-bindings!
- translate-to-state-point)
+ shallow-fluid-bind)
+ (export (runtime continuation)
+ get-dynamic-state
+ set-dynamic-state!)
(export (runtime continuation-parser)
- state-point/space
- system-state-space)
+ %translate-to-state-point
+ merge-dynamic-state)
+ (export (runtime thread)
+ make-state-space
+ state-space:local)
(initialization (initialize-package!)))
(define-package (runtime stream)
port/gc-start)
(export (runtime emacs-interface)
port/read-finish
- port/read-start))
\ No newline at end of file
+ port/read-start))
+
+(define-package (runtime thread)
+ (files "thread")
+ (parent ())
+ (export ()
+ block-thread-events
+ condition-type:thread-deadlock
+ condition-type:thread-detached
+ condition-type:thread-error
+ create-thread
+ current-thread
+ detach-thread
+ exit-current-thread
+ join-thread
+ lock-thread-mutex
+ make-thread-mutex
+ other-running-threads?
+ set-thread-timer-interval!
+ signal-thread-event
+ sleep-current-thread
+ start-thread-timer
+ stop-thread-timer
+ suspend-current-thread
+ thread-continuation
+ thread-dead?
+ thread-mutex?
+ thread-timer-interval
+ thread?
+ try-lock-thread-mutex
+ unblock-thread-events
+ unlock-thread-mutex
+ yield-current-thread)
+ (export (runtime interrupt-handler)
+ thread-timer-interrupt-handler)
+ (initialization (initialize-package!)))
\ No newline at end of file
projects / mit-scheme.git / commitdiff