;;; -*-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
;;;
(*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
(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)))))
+\f
(define (start-error-rep message irritant)
(fluid-let ((error-message message)
(error-irritant irritant))
(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)))))
\f
;;;; Error Handlers
(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) "...")
identity-procedure)
;;; end ERROR-SYSTEM package.
-))
))
\ No newline at end of file
;;; -*-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
;;;
(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.
;;; -*-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
;;;
(set-channel-direction! system-hunk3-set-cxr2!)
(closed-direction 0)
- (closed-descriptor #F))
+ (closed-descriptor false))
(make-environment
(define (initialize)
(set! open-files-list (list open-file-list-tag))
- (set! traversing? #F)
- #T)
+ (set! traversing? false)
+ true)
\f
;;;; Open/Close Files
(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))
+\f
;; 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
(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)))))))))))))
\f
;;;; 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)
(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)))
+\f
;; 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
(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)))))))))
|#
(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
;;; -*-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
;;;
;;; 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
;;; 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
(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))))
(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)
(define (set-rep-base-syntax-table! syntax-table)
(set! *rep-base-syntax-table* syntax-table)
(set! *rep-current-syntax-table* syntax-table))
-
+\f
(define (rep-prompt)
*rep-current-prompt*)
(define (rep-output-port)
*rep-current-output-port*)
-\f
+
(define environment-warning-hook
identity-procedure)
(define reader-history)
(define printer-history)
(let ()
-
+\f
(set! make-rep
(named-lambda (make-rep environment syntax-table prompt input-port output-port
message)
(set! printer-history
(history-reader rep-state-printer-history 'PRINTER-HISTORY))
-)
-
)
\ No newline at end of file
;;; -*-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
;;;
(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))))))
-
+\f
(set! event:after-restore (make-event-distributor))
(set! event:after-restart (make-event-distributor))
false)
(else (beep) (query prompt)))))
-)
)
\ No newline at end of file
projects / mit-scheme.git / commitdiff