From 20ce2946b91aaaaca82509e8864641068c0e1446 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Fri, 19 Nov 2004 17:28:51 +0000 Subject: [PATCH] DEFAULT-OBJECT? is no longer a special form. --- v7/src/runtime/error.scm | 27 +++++++--------- v7/src/runtime/load.scm | 66 ++++++++++++++++------------------------ 2 files changed, 37 insertions(+), 56 deletions(-) diff --git a/v7/src/runtime/error.scm b/v7/src/runtime/error.scm index aa6d96840..b37fa3f4e 100644 --- a/v7/src/runtime/error.scm +++ b/v7/src/runtime/error.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: error.scm,v 14.65 2004/02/16 05:36:11 cph Exp $ +$Id: error.scm,v 14.66 2004/11/19 17:25:28 cph Exp $ Copyright 1986,1987,1988,1989,1990,1991 Massachusetts Institute of Technology Copyright 1992,1993,1995,2000,2001,2002 Massachusetts Institute of Technology @@ -419,21 +419,6 @@ USA. (if (eq? name (%restart/name (car restarts))) (car restarts) (loop (cdr restarts)))))) - -(define-syntax restarts-default - (sc-macro-transformer - (lambda (form environment) - (let ((restarts (close-syntax (cadr form) environment)) - (name (close-syntax (caddr form) environment))) - ;; This is a macro because DEFAULT-OBJECT? is. - `(COND ((OR (DEFAULT-OBJECT? ,restarts) - (EQ? 'BOUND-RESTARTS ,restarts)) - *BOUND-RESTARTS*) - ((CONDITION? ,restarts) - (%CONDITION/RESTARTS ,restarts)) - (ELSE - (GUARANTEE-RESTARTS ,restarts ,name) - ,restarts)))))) (define (find-restart name #!optional restarts) (guarantee-symbol name 'FIND-RESTART) @@ -478,6 +463,16 @@ USA. (restarts-default restarts 'USE-VALUE)))) (if restart ((%restart/effector restart) datum)))) + +(define (restarts-default restarts name) + (cond ((or (default-object? restarts) + (eq? 'BOUND-RESTARTS restarts)) + *bound-restarts*) + ((condition? restarts) + (%condition/restarts restarts)) + (else + (guarantee-restarts restarts name) + restarts))) ;;;; Condition Signalling and Handling diff --git a/v7/src/runtime/load.scm b/v7/src/runtime/load.scm index d0cc13fa6..e190a7e19 100644 --- a/v7/src/runtime/load.scm +++ b/v7/src/runtime/load.scm @@ -1,9 +1,10 @@ #| -*-Scheme-*- -$Id: load.scm,v 14.66 2003/09/05 20:51:14 cph Exp $ +$Id: load.scm,v 14.67 2004/11/19 17:28:51 cph Exp $ Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology Copyright 1994,1999,2000,2001,2002,2003 Massachusetts Institute of Technology +Copyright 2004 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -71,13 +72,11 @@ USA. (define (load filename/s #!optional environment syntax-table purify?) syntax-table ;ignored (let ((environment - ;; Kludge until optional defaulting fixed. - (if (or (default-object? environment) - (eq? environment default-object)) - default-object + (if (default-object? environment) + environment (->environment environment))) (purify? - (if (or (default-object? purify?) (eq? purify? default-object)) + (if (default-object? purify?) #f purify?))) (handle-load-hooks @@ -133,20 +132,10 @@ USA. (lambda (result hooks) (for-each (lambda (hook) (hook)) hooks) result))) - -(define default-object - (list 'DEFAULT-OBJECT)) (define (load-noisily filename #!optional environment syntax-table purify?) - syntax-table ;ignored (fluid-let ((load-noisily? #t)) - (load filename - ;; This defaulting is a kludge until we get the optional - ;; defaulting fixed. Right now it must match the defaulting - ;; of `load'. - (if (default-object? environment) default-object environment) - 'DEFAULT - (if (default-object? purify?) default-object purify?)))) + (load filename environment syntax-table purify?))) (define (load-latest . args) (fluid-let ((load/default-find-pathname-with-type find-latest-file)) @@ -277,7 +266,7 @@ USA. (define (load-scode-end scode environment purify?) (if purify? (purify (load/purification-root scode))) (extended-scode-eval scode - (if (eq? environment default-object) + (if (default-object? environment) (nearest-repl/environment) environment))) @@ -370,7 +359,7 @@ USA. (stream-map stream (let ((repl (nearest-repl))) (let* ((environment - (if (eq? environment default-object) + (if (default-object? environment) (repl/environment repl) environment))) (lambda (s-expression) @@ -579,27 +568,24 @@ USA. ((load (lambda (fname #!optional env syntax-table purify?) syntax-table ;ignored - (let ((env (if (default-object? env) default-object env)) - (purify? - (if (default-object? purify?) default-object purify?))) - (let ((place (find-filename fname alist))) - (if (not place) - (real-load fname env 'DEFAULT purify?) - (handle-load-hooks - (lambda () - (let ((scode (caddr place))) - (loading-message fname - load/suppress-loading-message? - ";Pseudo-loading ") - (if (and (not (eq? purify? default-object)) purify?) - (set! to-purify - (cons (load/purification-root scode) - to-purify))) - (fluid-let ((load/current-pathname (cadr place))) - (extended-scode-eval scode - (if (eq? env default-object) - environment - env))))))))))) + (let ((place (find-filename fname alist))) + (if (not place) + (real-load fname env 'DEFAULT purify?) + (handle-load-hooks + (lambda () + (let ((scode (caddr place))) + (loading-message fname + load/suppress-loading-message? + ";Pseudo-loading ") + (if (if (default-object? purify?) #f purify?) + (set! to-purify + (cons (load/purification-root scode) + to-purify))) + (fluid-let ((load/current-pathname (cadr place))) + (extended-scode-eval scode + (if (default-object? env) + environment + env)))))))))) (fasload (lambda (filename #!optional suppress-message?) (let ((suppress-message? -- 2.25.1