DataMuseum.dk

top - download

    Length: 4973 (0x136d)
    Types: TextFile
    Names: »repuse.scm.21«

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

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

;;;; REP User Interface

(declare (usual-integrations))
\f


;;; Standard Format

(define ((standard-rep-message string))
  (newline)
  (princ string))

(define ((standard-rep-prompt string))
  (newline)
  (newline)
  (prin1 (rep-level))
  (tyo #\SP)
  (princ string)
  (tyo #\SP))

;;; Standard Drivers

(define top-level-driver-prompt "]=>")

(define (top-level-driver environment string)
  (make-rep environment
	    (standard-rep-message string)
	    (standard-rep-prompt top-level-driver-prompt)))

(define (read-eval-print environment message prompt)
  (with-standard-proceed-point
   (lambda ()
     (push-rep environment
	       (standard-rep-message message)
	       (standard-rep-prompt prompt)))))

(define breakpoint-prompt "Bkpt->")

(define (breakpoint message environment)
  (push-rep environment
	    (standard-rep-message message)
	    (standard-rep-prompt breakpoint-prompt)))

(define (breakpoint-procedure message irritant environment)
  (with-history-disabled
   (lambda ()
     (with-standard-proceed-point
      (lambda ()
	(breakpoint message environment))))))
\f


;;; PROCEED

(define with-proceed-point)
(define with-standard-proceed-point)
(define proceed)

(let ((proceed-value-filter))

  (define (standard-value-filter arguments)
    (if (null? arguments)
	*the-non-printing-object*
	(car arguments)))

  (set! proceed-value-filter standard-value-filter)
  (set! with-proceed-point
	(lambda (value-filter thunk)
	  (with-rep-continuation
	   (lambda (continuation)
	     (fluid-let ((proceed-value-filter value-filter))
	       (thunk))))))
  (set! with-standard-proceed-point
	(lambda (thunk)
	  (with-proceed-point standard-value-filter thunk)))
  (set! proceed
	(lambda args
	  (continue-rep (proceed-value-filter args)))))
\f


;;; User-interfaced Stuff

;;; These commands were defined such that if the optional argument isn't
;;; supplied, the result was that nothing happened.  Somehow I don't think
;;; that was intentional.  But just in case someone is depending on it
;;; behaving that way, I will leave it.

(define (goto-environment #!optional environment)
  (if (not (unassigned? environment))
      (set-rep-base-environment! (coerce-to-environment environment)))
  (rep-environment))

(define visiting-prompt "Visiting->")

(define (visit-environment #!optional environment)
  (if (not (unassigned? environment))
      (set-rep-environment! (coerce-to-environment environment)))
  (set-rep-prompt! (standard-rep-prompt visiting-prompt))
  (rep-environment))

(define (coerce-to-environment object)
  (cond ((disjunction (eq? object system-global-environment)
		      (environment? object))
	 object)
	((compound-procedure? object)
	 (procedure-environment object))
	(else
	 (error "Not an environment" 'COERCE-TO-ENVIRONMENT object))))

(define (abort-to-nearest-driver message)
  (abort->nearest (standard-rep-message message)))

(define (abort-to-previous-driver message)
  (abort->previous (standard-rep-message message)))

(define (abort-to-top-level-driver message)
  (abort->top-level (standard-rep-message message)))

(define (%in . tail)			;(%in #!OPTIONAL (index 1))
  (reader-history (if (null? tail) 1 (car tail))))

(define (%out . tail)			;(%out #!OPTIONAL (index 1))
  (printer-history (-1+ (if (null? tail) 1 (car tail)))))

;; This one is just famous.

(define (eval expression environment)
  (scode-eval (syntax expression (current-syntax-table) environment)
	      environment))