From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 13 Apr 1987 18:44:18 +0000 (+0000)
Subject: *** empty log message ***
X-Git-Tag: 20090517-FFI~13635
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=733050452a5c036a36eeda5fb047b28ffdd59b18;p=mit-scheme.git

*** empty log message ***
---

diff --git a/v7/src/runtime/error.scm b/v7/src/runtime/error.scm
index ddd9be876..d6792dfaa 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 13.45 1987/04/03 00:51:34 jinx Exp $
+;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/error.scm,v 13.46 1987/04/13 18:42:53 cph Exp $
 ;;;
 ;;;	Copyright (c) 1987 Massachusetts Institute of Technology
 ;;;
@@ -85,7 +85,7 @@
        (*error-hook* environment message irritant false)))))
 
 (define ((error-handler-wrapper handler) error-code interrupt-enables)
-  (with-interrupts-reduced INTERRUPT-MASK-GC-OK
+  (with-interrupts-reduced interrupt-mask-gc-ok
    (lambda (old-mask)
      (fluid-let ((*error-code* error-code))
        (with-proceed-point
@@ -97,6 +97,15 @@
 (define (wrapped-error-handler wrapper)
   (access handler (procedure-environment wrapper)))
 
+;;; (PROCEED) means retry error expression, (PROCEED value) means
+;;; return VALUE as the value of the error subproblem.
+
+(define (proceed-value-filter value)
+  (let ((continuation (rep-continuation)))
+    (if (or (null? value) (null-continuation? continuation))
+	(continuation '())
+	((continuation-next-continuation continuation) (car value)))))
+
 (define (start-error-rep message irritant)
   (fluid-let ((error-message message)
 	      (error-irritant irritant))
@@ -127,15 +136,6 @@ using the current read-eval-print environment."))
 	(write-string (cdr out))
 	(if (car out) (write-string "..."))))
   (if *error-decision-hook* (*error-decision-hook*)))
-
-;;; (PROCEED) means retry error expression, (PROCEED value) means
-;;; return VALUE as the value of the error subproblem.
-
-(define (proceed-value-filter value)
-  (let ((continuation (rep-continuation)))
-    (if (or (null? value) (null-continuation? continuation))
-	(continuation '())
-	((continuation-next-continuation continuation) (car value)))))
 
 ;;;; Error Handlers
 
@@ -286,8 +286,7 @@ using the current read-eval-print environment."))
 
 (define ((combination-error-rep message selector) combination)
   (start-error-rep
-   (string-append message
-		  " "
+   (string-append message " "
 		  (let ((out (write-to-string (selector combination) 40)))
 		    (if (car out)
 			(string-append (cdr out) "...")
@@ -510,5 +509,4 @@ using the current read-eval-print environment."))
   identity-procedure)
 
 ;;; end ERROR-SYSTEM package.
-))
 ))
\ No newline at end of file
diff --git a/v7/src/runtime/gcstat.scm b/v7/src/runtime/gcstat.scm
index 3428185cf..ac86593f3 100644
--- a/v7/src/runtime/gcstat.scm
+++ b/v7/src/runtime/gcstat.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gcstat.scm,v 13.42 1987/03/17 18:50:11 cph Exp $
+;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gcstat.scm,v 13.43 1987/04/13 18:43:38 cph Exp $
 ;;;
 ;;;	Copyright (c) 1987 Massachusetts Institute of Technology
 ;;;
@@ -54,7 +54,7 @@
 (define (gc-finish-hook state) 'DONE)
 
 (define ((make-flip-hook old-flip) . More)
-  (with-interrupts-reduced INTERRUPT-MASK-NONE
+  (with-interrupts-reduced interrupt-mask-none
     (lambda (Old-Interrupt-Mask)
      (measure-interval
       false			;i.e. do not count the interval in RUNTIME.
diff --git a/v7/src/runtime/io.scm b/v7/src/runtime/io.scm
index 0a42f3b6c..76fd1e7b3 100644
--- a/v7/src/runtime/io.scm
+++ b/v7/src/runtime/io.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/io.scm,v 13.44 1987/03/18 20:05:36 jinx Exp $
+;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/io.scm,v 13.45 1987/04/13 18:43:17 cph Rel $
 ;;;
 ;;;	Copyright (c) 1987 Massachusetts Institute of Technology
 ;;;
@@ -56,7 +56,7 @@
 	(set-channel-direction! system-hunk3-set-cxr2!)
 
 	(closed-direction 0)
-	(closed-descriptor #F))
+	(closed-descriptor false))
 
     (make-environment
     
@@ -73,8 +73,8 @@
     
 (define (initialize)
   (set! open-files-list (list open-file-list-tag))
-  (set! traversing? #F)
-  #T)
+  (set! traversing? false)
+  true)
 
 ;;;; Open/Close Files
 
@@ -92,20 +92,18 @@
 		(make-physical-channel (open-channel filename direction)
 				       filename
 				       direction)))
-	   
-	   (with-interrupt-mask INTERRUPT-MASK-NONE ; Disallow gc
+	   (with-interrupt-mask interrupt-mask-none ; Disallow gc
 	    (lambda (ie)
 	      (set-cdr! open-files-list
-			(cons (system-pair-cons
-			       weak-cons-type
-			       channel
-			       (channel-descriptor channel))
+			(cons (system-pair-cons weak-cons-type
+						channel
+						(channel-descriptor channel))
 			      (cdr open-files-list)))))
 	   channel))))))
 
-(define open-input-channel (open-channel-wrapper #F))
-(define open-output-channel (open-channel-wrapper #T))
-
+(define open-input-channel (open-channel-wrapper false))
+(define open-output-channel (open-channel-wrapper true))
+
 ;; This is locked from interrupts, but GC can occur since the
 ;; procedure itself hangs on to the channel until the last moment,
 ;; when it returns the channel's name.  The list will not be spliced
@@ -114,37 +112,40 @@
 (define close-physical-channel
   (let ((primitive (make-primitive-procedure 'FILE-CLOSE-CHANNEL)))
     (named-lambda (close-physical-channel channel)
-      (fluid-let ((traversing? #T))
+      (fluid-let ((traversing? true))
 	(without-interrupts
 	 (lambda ()
 	   (if (eq? closed-direction
 		    (set-channel-direction! channel closed-direction))
-	       #T			;Already closed!
+	       true			;Already closed!
 	       (begin
-		 (primitive (set-channel-descriptor! channel closed-descriptor))
-		 (let loop ((l1 open-files-list)
-			    (l2 (cdr open-files-list)))
+		 (primitive (set-channel-descriptor! channel
+						     closed-descriptor))
+		 (let loop
+		     ((l1 open-files-list)
+		      (l2 (cdr open-files-list)))
 		   (cond ((null? l2)
-			  (set! traversing? #F)
-			  (error "close-physical-channel: lost channel"
+			  (set! traversing? false)
+			  (error "CLOSE-PHYSICAL-CHANNEL: lost channel"
 				 channel))
 			 ((eq? channel (system-pair-car (car l2)))
 			  (set-cdr! l1 (cdr l2))
 			  (channel-name channel))
-			 (else (loop l2 (cdr l2)))))))))))))
+			 (else
+			  (loop l2 (cdr l2)))))))))))))
 
 ;;;; Finalization and daemon.
 
 (define (close-files action)
   (lambda ()
-    (fluid-let ((traversing? #T))
+    (fluid-let ((traversing? true))
       (without-interrupts
        (lambda ()
 	 (let loop ((l (cdr open-files-list)))
-	   (cond ((null? l) #T)
+	   (cond ((null? l) true)
 		 (else
 		  (let ((channel (system-pair-car (car l))))
-		    (if (not (eq? channel #F))
+		    (if (not (eq? channel false))
 			(begin
 			  (set-channel-descriptor! channel
 						   closed-descriptor)
@@ -154,16 +155,16 @@
 		    (set-cdr! open-files-list (cdr l)))
 		  (loop (cdr open-files-list))))))))))
 
-;; This is invoked before disk-restoring.  It "cleans" the microcode.
+;;; This is invoked before disk-restoring.  It "cleans" the microcode.
 
 (set! close-all-open-files
   (close-files (make-primitive-procedure 'FILE-CLOSE-CHANNEL)))
 
-;; This is invoked after disk-restoring.  It "cleans" the new runtime system.
+;;; This is invoked after disk-restoring.  It "cleans" the new runtime system.
 
 (define reset!
-  (close-files (lambda (ignore) #T)))
-
+  (close-files (lambda (ignore) true)))
+
 ;; This is the daemon which closes files which no one points to.
 ;; Runs with GC, and lower priority interrupts, disabled.
 ;; It is unsafe because of the (unnecessary) consing by the
@@ -177,14 +178,17 @@
   (let ((primitive (make-primitive-procedure 'FILE-CLOSE-CHANNEL)))
     (named-lambda (close-lost-open-files-daemon)
       (if (not traversing?)
-	  (let loop ((l1 open-files-list)
-		     (l2 (cdr open-files-list)))
-	    (cond ((null? l2) #T)
+	  (let loop
+	      ((l1 open-files-list)
+	       (l2 (cdr open-files-list)))
+	    (cond ((null? l2)
+		   true)
 		  ((null? (system-pair-car (car l2)))
 		   (primitive (system-pair-cdr (car l2)))
 		   (set-cdr! l1 (cdr l2))
 		   (loop l1 (cdr l1)))
-		  (else (loop l2 (cdr l2)))))))))
+		  (else
+		   (loop l2 (cdr l2)))))))))
 
 |#
 
@@ -194,8 +198,8 @@
       (if (not traversing?)
 	  (primitive open-files-list)))))
 
-))) ;; End of PRIMITIVE-IO package.
+;;; End of PRIMITIVE-IO package.
+)))
 
 ((access initialize primitive-io))
-(add-gc-daemon! (access close-lost-open-files-daemon primitive-io))
 (add-gc-daemon! (access close-lost-open-files-daemon primitive-io))
\ No newline at end of file
diff --git a/v7/src/runtime/rep.scm b/v7/src/runtime/rep.scm
index da64ac220..8ceaa5e7a 100644
--- a/v7/src/runtime/rep.scm
+++ b/v7/src/runtime/rep.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/rep.scm,v 13.41 1987/01/23 00:18:26 jinx Exp $
+;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/rep.scm,v 13.42 1987/04/13 18:44:00 cph Rel $
 ;;;
 ;;;	Copyright (c) 1987 Massachusetts Institute of Technology
 ;;;
@@ -20,9 +20,9 @@
 ;;;	future releases; and (b) to inform MIT of noteworthy uses of
 ;;;	this software.
 ;;;
-;;;	3.  All materials developed as a consequence of the use of
-;;;	this software shall duly acknowledge such use, in accordance
-;;;	with the usual standards of acknowledging credit in academic
+;;;	3. All materials developed as a consequence of the use of this
+;;;	software shall duly acknowledge such use, in accordance with
+;;;	the usual standards of acknowledging credit in academic
 ;;;	research.
 ;;;
 ;;;	4. MIT has made no warrantee or representation that the
@@ -30,7 +30,7 @@
 ;;;	under no obligation to provide any services, by way of
 ;;;	maintenance, update, or otherwise.
 ;;;
-;;;	5.  In conjunction with products arising from the use of this
+;;;	5. In conjunction with products arising from the use of this
 ;;;	material, there shall be no use of the name of the
 ;;;	Massachusetts Institute of Technology nor of any adaptation
 ;;;	thereof in any advertising, promotional, or sales literature
@@ -78,7 +78,7 @@
 	      (set! top-level-driver-hook quit)
 	      (set! nearest-driver-hook quit)
 	      (driver message)))))
-	(set-interrupt-enables! INTERRUPT-MASK-GC-OK)
+	(set-interrupt-enables! interrupt-mask-gc-ok)
 	(fluid-let ((top-level-driver-hook)
 		    (nearest-driver-hook))
 	  (driver-loop message))))
@@ -90,11 +90,11 @@
 	   (call-with-current-continuation
 	    (lambda (again)
 	      (set! nearest-driver-hook again)
-	      (set-interrupt-enables! INTERRUPT-MASK-ALL)
+	      (set-interrupt-enables! interrupt-mask-all)
 	      (each-time)
 	      (entry-hook)
 	      (loop)))))
-      (set-interrupt-enables! INTERRUPT-MASK-GC-OK)
+      (set-interrupt-enables! interrupt-mask-gc-ok)
       (restart reentry-hook each-time)))
 
   (define (loop)
@@ -198,7 +198,7 @@
 (define (set-rep-base-syntax-table! syntax-table)
   (set! *rep-base-syntax-table* syntax-table)
   (set! *rep-current-syntax-table* syntax-table))
-
+
 (define (rep-prompt)
   *rep-current-prompt*)
 
@@ -217,7 +217,7 @@
 
 (define (rep-output-port)
   *rep-current-output-port*)
-
+
 (define environment-warning-hook
   identity-procedure)
 
@@ -229,7 +229,7 @@
 (define reader-history)
 (define printer-history)
 (let ()
-
+
 (set! make-rep
 (named-lambda (make-rep environment syntax-table prompt input-port output-port
 			message)
@@ -327,6 +327,4 @@
 (set! printer-history
       (history-reader rep-state-printer-history 'PRINTER-HISTORY))
 
-)
-
 )
\ No newline at end of file
diff --git a/v7/src/runtime/system.scm b/v7/src/runtime/system.scm
index e44244a78..5ec8fdf1b 100644
--- a/v7/src/runtime/system.scm
+++ b/v7/src/runtime/system.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/system.scm,v 13.44 1987/04/03 00:53:06 jinx Exp $
+;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/system.scm,v 13.45 1987/04/13 18:44:18 cph Exp $
 ;;;
 ;;;	Copyright (c) 1987 Massachusetts Institute of Technology
 ;;;
@@ -105,14 +105,14 @@
 
 (set! dump-world
       (setup-image
-       (let ((primitive (make-primitive-procedure 'DUMP-WORLD #T)))
+       (let ((primitive (make-primitive-procedure 'DUMP-WORLD true)))
 	 (lambda (filename after-dumping after-restoring)
-	   (let ((ie (set-interrupt-enables! INTERRUPT-MASK-NONE)))
+	   (let ((ie (set-interrupt-enables! interrupt-mask-none)))
 	     ((if (primitive filename)
 		  after-restoring
 		  after-dumping)
 	      ie))))))
-
+
 (set! event:after-restore (make-event-distributor))
 (set! event:after-restart (make-event-distributor))
 
@@ -277,5 +277,4 @@
 	   false)
 	  (else (beep) (query prompt)))))
 
-)
 )
\ No newline at end of file