DataMuseum.dk

top - download

    Length: 8520 (0x2148)
    Types: TextFile
    Names: »rep.scm.340«

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

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.
;;;

;;;; Read-Eval-Print Loop

(declare (usual-integrations))
\f


;;;; Command Loops

(define make-command-loop)
(define push-command-loop)
(define with-rep-continuation)
(define continue-rep)
(define rep-continuation)
(define rep-state)
(define rep-level)
(define abort->nearest)
(define abort->previous)
(define abort->top-level)

(let ((top-level-driver-hook)
      (previous-driver-hook)
      (nearest-driver-hook)
      (current-continuation)
      (current-state)
      (current-level 0))

(set! make-command-loop
      (named-lambda (make-command-loop message driver)
	(define (driver-loop message)
	  (driver-loop
	   (with-rep-continuation
	    (lambda (quit)
	      (set! top-level-driver-hook quit)
	      (set! nearest-driver-hook quit)
	      (driver message)))))
	(set-interrupt-enables! INTERRUPT-MASK-GC-OK)
	(fluid-let ((top-level-driver-hook)
		    (nearest-driver-hook))
	  (driver-loop message))))

(set! push-command-loop
      (named-lambda (push-command-loop startup-hook driver initial-state)
	(define (restart entry-hook)
	  (let ((reentry-hook
		 (catch
		  (lambda (again)
		    (set! nearest-driver-hook again)
		    (set-interrupt-enables! INTERRUPT-MASK-ALL)
		    (entry-hook)
		    (loop)))))
	    (set-interrupt-enables! INTERRUPT-MASK-GC-OK)
	    (restart reentry-hook)))

	(define (loop)
	  (set! current-state (driver current-state))
	  (loop))

	(fluid-let ((current-level (1+ current-level))
		    (previous-driver-hook nearest-driver-hook)
		    (nearest-driver-hook)
		    (current-state initial-state))
	  (restart startup-hook))))

(set! with-rep-continuation
      (named-lambda (with-rep-continuation receiver)
	(catch
	 (lambda (continuation)
	   (fluid-let ((current-continuation continuation))
	     (receiver continuation))))))
\f


(set! continue-rep
      (named-lambda (continue-rep value)
	(current-continuation
	 (if (eq? current-continuation top-level-driver-hook)
	     (lambda ()
	       (print value))
	     value))))

(set! abort->nearest
      (named-lambda (abort->nearest message)
	(nearest-driver-hook message)))

(set! abort->previous
      (named-lambda (abort->previous message)
	((if (null? previous-driver-hook)
	     nearest-driver-hook
	     previous-driver-hook)
	 message)))

(set! abort->top-level
      (named-lambda (abort->top-level message)
	(top-level-driver-hook message)))

(set! rep-continuation
      (named-lambda (rep-continuation)
	current-continuation))

(set! rep-state
      (named-lambda (rep-state)
	current-state))

(set! rep-level
      (named-lambda (rep-level)
	current-level))
)
\f


;;;; Read-Eval-Print Loops

(define make-rep)
(define push-rep)
(define rep-environment)
(define rep-base-environment)
(define set-rep-environment!)
(define set-rep-base-environment!)
(define rep-prompt)
(define rep-base-prompt)
(define set-rep-prompt!)
(define set-rep-base-prompt!)
(define rep-input-stream)
(define rep-output-stream)
(define reader-history)
(define printer-history)

(define environment-warning-hook
  identity-procedure)

(let ((user-base-environment)
      (user-current-environment)
      (user-base-prompt)
      (user-current-prompt)
      (input-stream)
      (output-stream))

(set! make-rep
(named-lambda (make-rep environment message prompt)
  (fluid-let ((user-base-environment environment)
	      (user-base-prompt prompt)
	      (input-stream (current-input-stream))
	      (output-stream (current-output-stream)))
    (make-command-loop message rep-top-driver))))

(define (rep-top-driver message)
  (push-rep user-base-environment message user-base-prompt))

(set! push-rep
(named-lambda (push-rep environment message prompt)
  (fluid-let ((user-current-environment environment)
	      (user-current-prompt prompt))
    (with-input-from-stream input-stream
      (lambda ()
	(with-output-to-stream output-stream
	  (lambda ()
	    (with-syntax-environment user-base-environment
	      (lambda ()
		(environment-warning-hook user-current-environment)
		(push-command-loop message
				   rep-driver
				   (make-rep-state (make-history 5)
						   (make-history 10))))))))))))

(define (rep-driver state)
  (user-current-prompt)
  (let ((object
	 (let ((scode (let ((s-expression (read)))
			(record-in-history! (rep-state-reader-history state)
					    s-expression)
			(syntax s-expression))))
	   (with-new-history
	     (lambda ()
	       (scode-eval scode user-current-environment))))))
    (record-in-history! (rep-state-printer-history state) object)
    (print object))
  state)
\f


;;; History Manipulation

(define (make-history size)
  (let ((list (make-list size '())))
    (append! list list)
    (vector history-tag size list)))

(define history-tag
  '(REP-HISTORY))

(define (record-in-history! history object)
  (if (not (null? (vector-ref history 2)))
      (sequence (set-car! (vector-ref history 2) object)
		(vector-set! history 2 (cdr (vector-ref history 2))))))

(define (read-history history n)
  (list-ref (vector-ref history 2)
	    (remainder (- (vector-ref history 1) n 1)
		       (vector-ref history 1))))

(define ((history-reader selector name) n)
  (let ((state (rep-state)))
    (if (rep-state? state)
	(read-history (selector state) n)
	(error "Not in REP loop" name))))

(define rep-state-tag
  '(REP-STATE))

(define (make-rep-state reader-history printer-history)
  (vector rep-state-tag reader-history printer-history))

(define (rep-state? object)
  (conjunction (vector? object)
	       (not (zero? (vector-size object)))
	       (eq? (vector-ref object 0) rep-state-tag)))

(define rep-state-reader-history vector-second)
(define rep-state-printer-history vector-third)

(set! reader-history
      (history-reader rep-state-reader-history 'READER-HISTORY))

(set! printer-history
      (history-reader rep-state-printer-history 'PRINTER-HISTORY))
\f


;;; REP Accessors

(set! rep-environment
      (named-lambda (rep-environment)
	user-current-environment))

(set! rep-base-environment
      (named-lambda (rep-base-environment)
	user-base-environment))

(set! set-rep-environment!
      (named-lambda (set-rep-environment! environment)
	(set! user-current-environment environment)
	(environment-warning-hook user-current-environment)))

(set! set-rep-base-environment!
      (named-lambda (set-rep-base-environment! environment)
	(set! user-base-environment environment)
	(set! user-current-environment environment)
	(environment-warning-hook user-current-environment)))

(set! rep-prompt
      (named-lambda (rep-prompt)
	user-current-prompt))

(set! rep-base-prompt
      (named-lambda (rep-base-prompt)
	user-base-prompt))

(set! set-rep-prompt!
      (named-lambda (set-rep-prompt! prompt)
	(set! user-current-prompt prompt)))

(set! set-rep-base-prompt!
      (named-lambda (set-rep-base-prompt! prompt)
	(set! user-base-prompt prompt)
	(set! user-current-prompt prompt)))

(set! rep-input-stream
      (named-lambda (rep-input-stream)
	input-stream))

(set! rep-output-stream
      (named-lambda (rep-output-stream)
	output-stream))


)