DataMuseum.dk

top - metrics - download

    Length: 4451 (0x1163)
    Types: TextFile
    Names: »system.scm.8«

└─⟦a0efdde77⟧ Bits:30001252 EUUGD11 Tape, 1987 Spring Conference Helsinki
    └─⟦this⟧ »EUUGD11/gnu-31mar87/scheme/scm/system.scm.8« 

TextFile

;;; -*-Scheme-*-
;;;
;;;	Copyright (c) 1984 Massachusetts Institute of Technology
;;;
;;;	This material was developed by the Scheme project at the
;;;	Massachusetts Institute of Technology, Department of
;;;	Electrical Engineering and Computer Science.  Permission to
;;;	copy this software, to redistribute it, and to use it for any
;;;	purpose is granted, subject to the following restrictions and
;;;	understandings.
;;;
;;;	1. Any copy made of this software must include this copyright
;;;	notice in full.
;;;
;;;	2. Users of this software agree to make their best efforts (a)
;;;	to return to the MIT Scheme project any improvements or
;;;	extensions that they make, so that these may be included in
;;;	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
;;;	research.
;;;
;;;	4. MIT has made no warrantee or representation that the
;;;	operation of this software will be error-free, and MIT is
;;;	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
;;;	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
;;;	without prior written consent from MIT in each case.
;;;

;;;; Systems

(declare (usual-integrations)
	 (compilable-primitive-functions clear-screen))
\f


;;; (DISK-SAVE filename #!optional identify)
;;; Saves a world image in FILENAME.  IDENTIFY has the following meaning:
;;;
;;;    [] Not supplied => ^G on restore (normal for saving band).
;;;    [] String => New world ID message, and ^G on restore.
;;;    [] Otherwise => Returns normally (very useful for saving bugs!).

(define disk-save)
(define dump-world)
(define event:after-restore)
(define full-quit)
(define identify-world)
(define add-system!)
(define add-secondary-gc-daemon!)

(let ((world-identification "Scheme")
      (known-systems '())
      (secondary-gc-daemons '())
      (date-world-saved)
      (time-world-saved))

(define (restart-world)
  (clear-screen)
  (abort->top-level identify-world))

(define ((disk-save-generator gc? world-savior)
	 filename #!optional identify)
  (let ((d (date)) (t (time)))
    (if gc? (gc-flip))
    (let loop ((daemons secondary-gc-daemons))
      (if (not (null? daemons))
	  (sequence ((car daemons))
		    (loop (cdr daemons)))))
    (world-savior filename
		  (lambda (ie)
		    (set-interrupt-enables! ie)
		    *the-non-printing-object*)
		  (lambda (ie)
		    (set-interrupt-enables! ie)
		    (set! date-world-saved d)
		    (set! time-world-saved t)
		    (event:after-restore)
		    (cond ((unassigned? identify)
			   (restart-world))
			  ((string? identify)
			   (set! world-identification identify)
			   (restart-world))
			  (else
			   *the-non-printing-object*))))))

(set! disk-save (disk-save-generator #!true save-world))

(set! dump-world
      (disk-save-generator
       #!false
       (let ((prim (make-primitive-procedure 'DUMP-WORLD #!true)))
	 (lambda (name on-return on-restore)
	   (let ((ie (set-interrupt-enables! INTERRUPT-MASK-NONE)))
	     ((if (prim name) on-restore on-return) ie))))))

(set! event:after-restore (make-event-distributor))

(set! full-quit
      (named-lambda (full-quit)
	(quit)
	(restart-world)))

(set! identify-world
      (named-lambda (identify-world)
	(newline) (princ world-identification)
                  (princ " saved on ")
	          (princ (apply date->string date-world-saved))
		  (princ " at ")
		  (princ (apply time->string time-world-saved))
	(newline) (princ "  Release ")
	          (princ (access :release microcode-system))
	(mapc (lambda (system)
		(newline) (princ "  ")
		          (princ (access :name system))
			  (tyo #\SP)
			  (prin1 (access :version system))
			  (tyo #/.)
			  (prin1 (access :modification system)))
	      known-systems)))

(set! add-system!
      (named-lambda (add-system! system)
	(set! known-systems (append! known-systems (list system)))))

(set! add-secondary-gc-daemon!
      (named-lambda (add-secondary-gc-daemon! daemon)
	(if (not (memq daemon secondary-gc-daemons))
	    (set! secondary-gc-daemons (cons daemon secondary-gc-daemons)))))

)