From 3b4712e7d437db69e21165e5578967694702d68f Mon Sep 17 00:00:00 2001 From: sybok Date: Mon, 2 Sep 1991 03:57:21 +0000 Subject: [PATCH] Stepping stuff moved here from global.scm --- v7/src/runtime/error.scm | 42 ++++++++++++++++++++++++++++++++++++-- v7/src/runtime/global.scm | 38 +--------------------------------- v7/src/runtime/runtime.pkg | 4 +++- v8/src/runtime/global.scm | 38 +--------------------------------- v8/src/runtime/runtime.pkg | 4 +++- 5 files changed, 48 insertions(+), 78 deletions(-) diff --git a/v7/src/runtime/error.scm b/v7/src/runtime/error.scm index b89359381..9434787c5 100644 --- a/v7/src/runtime/error.scm +++ b/v7/src/runtime/error.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/error.scm,v 14.20 1991/08/27 00:52:40 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/error.scm,v 14.21 1991/09/02 03:55:24 sybok Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -1136,4 +1136,42 @@ MIT in each case. |# (define-integrable (guarantee-restarts object operator) (if (not (and (list? object) (for-all? object restart?))) - (error:wrong-type-argument object "list of restarts" operator))) \ No newline at end of file + (error:wrong-type-argument object "list of restarts" operator))) + +;; WITHOUT-STEPPING restores the stepper hooks to the state +;; encountered on each entry to the thunk. It might be better to +;; restore the hooks to the initial state. I flipped a coin. + +(define *old-hook-storage-environment*) + +(let-syntax ((ufixed-objects-slot + (macro (name) + (fixed-objects-vector-slot name)))) + + (define (without-stepping thunk) + (define (get-stepper-hooks) + (vector-ref (get-fixed-objects-vector) + (ufixed-objects-slot stepper-state))) + (let ((old-stepper-hooks) + (null-hooks (hunk3-cons #f #f #f))) + (set! *old-hook-storage-environment* (the-environment)) + (dynamic-wind + (lambda () + (set! old-stepper-hooks (get-stepper-hooks)) + (if old-stepper-hooks + ((ucode-primitive primitive-return-step 2) + unspecific null-hooks))) + thunk + (lambda () + ((ucode-primitive primitive-return-step 2) + unspecific + (or old-stepper-hooks + null-hooks))))))) + +;; Without-stepping doesn't work right with the stepper unless stepping-off! +;; is included in the thunk passed to it. + +(define (stepping-off!) + (set! (access old-stepper-hooks *old-hook-storage-environment*) + (access null-hooks *old-hook-storage-environment*))) + diff --git a/v7/src/runtime/global.scm b/v7/src/runtime/global.scm index 116f89805..00ac70d79 100644 --- a/v7/src/runtime/global.scm +++ b/v7/src/runtime/global.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/global.scm,v 14.31 1991/09/02 03:41:05 sybok Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/global.scm,v 14.32 1991/09/02 03:55:52 sybok Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -259,39 +259,3 @@ MIT in each case. |# (cdr bucket) (cons (car bucket) accumulator)))))))) -;; WITHOUT-STEPPING restores the stepper hooks to the state -;; encountered on each entry to the thunk. It might be better to -;; restore the hooks to the initial state. I flipped a coin. - - - -(let-syntax ((ufixed-objects-slot - (macro (name) - (fixed-objects-vector-slot name)))) - - (define (without-stepping thunk) - (define (get-stepper-hooks) - (vector-ref (get-fixed-objects-vector) - (ufixed-objects-slot stepper-state))) - (define old-hook-storage-environment) - (let ((old-stepper-hooks) - (null-hooks (hunk3-cons #f #f #f))) - (set! *old-hook-storage-environment* (the-environment)) - (dynamic-wind - (lambda () - (set! old-stepper-hooks (get-stepper-hooks)) - (if old-stepper-hooks - ((ucode-primitive primitive-return-step 2) - unspecific null-hooks))) - thunk - (lambda () - ((ucode-primitive primitive-return-step 2) - unspecific - (or old-stepper-hooks - null-hooks))))))) - -(define (stepping-off!) - (let ((hook-environment (access old-hook-storage-environment (procedure-environment without-stepping)))) - (set! (access old-stepper-hooks hook-environment) (access null-hooks hook-environment)))) - - diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index a407c5f3f..dfeda0166 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.119 1991/08/29 21:47:26 sybok Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.120 1991/09/02 03:57:21 sybok Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -619,10 +619,12 @@ MIT in each case. |# standard-error-hook standard-warning-handler standard-warning-hook + stepping-off! store-value use-value warn with-simple-restart + without-stepping write-condition-report write-restart-report) (export (runtime microcode-errors) diff --git a/v8/src/runtime/global.scm b/v8/src/runtime/global.scm index 8f624e31b..76ce1e162 100644 --- a/v8/src/runtime/global.scm +++ b/v8/src/runtime/global.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/global.scm,v 14.31 1991/09/02 03:41:05 sybok Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/global.scm,v 14.32 1991/09/02 03:55:52 sybok Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -259,39 +259,3 @@ MIT in each case. |# (cdr bucket) (cons (car bucket) accumulator)))))))) -;; WITHOUT-STEPPING restores the stepper hooks to the state -;; encountered on each entry to the thunk. It might be better to -;; restore the hooks to the initial state. I flipped a coin. - - - -(let-syntax ((ufixed-objects-slot - (macro (name) - (fixed-objects-vector-slot name)))) - - (define (without-stepping thunk) - (define (get-stepper-hooks) - (vector-ref (get-fixed-objects-vector) - (ufixed-objects-slot stepper-state))) - (define old-hook-storage-environment) - (let ((old-stepper-hooks) - (null-hooks (hunk3-cons #f #f #f))) - (set! *old-hook-storage-environment* (the-environment)) - (dynamic-wind - (lambda () - (set! old-stepper-hooks (get-stepper-hooks)) - (if old-stepper-hooks - ((ucode-primitive primitive-return-step 2) - unspecific null-hooks))) - thunk - (lambda () - ((ucode-primitive primitive-return-step 2) - unspecific - (or old-stepper-hooks - null-hooks))))))) - -(define (stepping-off!) - (let ((hook-environment (access old-hook-storage-environment (procedure-environment without-stepping)))) - (set! (access old-stepper-hooks hook-environment) (access null-hooks hook-environment)))) - - diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg index 53a658657..905ce4895 100644 --- a/v8/src/runtime/runtime.pkg +++ b/v8/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.119 1991/08/29 21:47:26 sybok Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.120 1991/09/02 03:57:21 sybok Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -619,10 +619,12 @@ MIT in each case. |# standard-error-hook standard-warning-handler standard-warning-hook + stepping-off! store-value use-value warn with-simple-restart + without-stepping write-condition-report write-restart-report) (export (runtime microcode-errors) -- 2.25.1