DataMuseum.dk

top - metrics - download

    Length: 13238 (0x33b6)
    Types: TextFile
    Names: »studentmd.scm.83«

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

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

;;;; Environment, syntax and read table hacking for 6.001 students.

(declare (usual-integrations))
\f


;;;; Minimal stream code

(define head car)

(define (tail stream)
  (force (cdr stream)))

(define the-empty-stream '())

(define empty-stream? null?)

(define student-package
  (make-package student-package ()
\f


;;;; Syntax Modifications

(define system-parser-table
  (current-parser-table))

(define pure-student-parser-table
  (copy-parser-table system-parser-table))

(let ((alphabetic-entry (parser-table-entry system-parser-table "A")))
  (set-parser-table-entry! pure-student-parser-table "`" alphabetic-entry)
  (set-parser-table-entry! pure-student-parser-table "," alphabetic-entry)
  (set-parser-table-entry! pure-student-parser-table "|" alphabetic-entry))

(let ((undefined-special-entry (parser-table-entry system-parser-table "#[")))
  (set-parser-table-entry! pure-student-parser-table "#|"
			   undefined-special-entry))

(define student-parser-table)

(define system-syntax-table
  (current-syntax-table))

(define pure-student-syntax-table
  (make-syntax-table
   (mapcar (lambda (name)
	     (let ((quantum (lookup-syntax name system-syntax-table)))
	       (if (not quantum)
		   (error "Missing syntactic keyword" name))
	       (cons name quantum)))
	   '(BKPT COLLECT COND CONS-STREAM DEFINE DELAY ERROR IF
		  LAMBDA LET MAKE-ENVIRONMENT QUOTE SEQUENCE
		  SET! THE-ENVIRONMENT))))

(define student-syntax-table)

(define (setup-student-syntax)
  (set! student-parser-table
	(copy-parser-table pure-student-parser-table))
  (set! student-syntax-table
	(copy-syntax-table pure-student-syntax-table)))

(define (enable-system-syntax)
  (enable-scan-defines!)
  (set-current-parser-table! system-parser-table)
  (set-current-syntax-table! system-syntax-table))

(define (disable-system-syntax)
  (disable-scan-defines!)
  (set-current-parser-table! student-parser-table)
  (set-current-syntax-table! student-syntax-table))
\f


;;;; Global Environment

(define (global-environment-enabled?)
  (disjunction (eq? user-global-environment system-global-environment)
	       (environment-has-parent? user-global-environment)))

(define (in-user-environment-chain? environment)
  (disjunction
   (eq? environment user-global-environment)
   (conjunction
    (not (eq? environment system-global-environment))
    (environment-has-parent? environment)
    (in-user-environment-chain? (environment-parent environment)))))

(define (enable-global-environment)
  ((access system-environment-add-parent! environment-package)
   user-global-environment
   system-global-environment)
  'ENABLED)

(define (disable-global-environment)
  ((access system-environment-remove-parent! environment-package)
   user-global-environment)
  'DISABLED)

(define (environment-warning-hook environment)
  (if (not (in-user-environment-chain? environment))
      (sequence
       (newline)
       (princ "This environment is part of the Scheme system.")
       (newline)
       (princ
	"Performing side-effects in it may cause damage to the system."))))
\f


;;;; Feature hackery

(define (enable-language-features . prompt)
  (without-interrupts
   (lambda ()
     (enable-global-environment)
     (enable-system-syntax)
     (change-prompt-wrapper "]" ""
			    (coerce-prompt 'ENABLE-LANGUAGE-FEATURES prompt))
     *the-non-printing-object*)))

(define (disable-language-features . prompt)
  (without-interrupts
   (lambda ()
     (disable-global-environment)
     (disable-system-syntax)
     (change-prompt-wrapper "" "" 
			    (coerce-prompt 'DISABLE-LANGUAGE-FEATURES prompt))
     *the-non-printing-object*)))

(define (coerce-prompt name prompt)
  (cond ((null? prompt) #!FALSE)
	((string? (car prompt)) (car prompt))
	(else (error "Prompt is not a string" name (car prompt)))))

(define (change-prompt-wrapper prefix suffix string)
  (let ((base-prompt (rep-base-prompt))
	(current-prompt (rep-prompt)))
    (set-rep-base-prompt!
     (make-student-prompt prefix
			  (if (eq? base-prompt current-prompt)
			      (disjunction string
					   (student-prompt-string base-prompt))
			      (student-prompt-string base-prompt))
			  suffix))
    (set-rep-prompt!
     (make-student-prompt prefix
			  (disjunction string
				       (student-prompt-string current-prompt))
			  suffix))))

(define (reset-student-prompt string)
  (let ((prompt (make-student-prompt "" string "")))
    (set-rep-base-prompt! prompt)
    (set-rep-prompt! prompt)))

(define ((make-student-prompt prefix string suffix))
  (newline)
  (newline)
  (prin1 (rep-level))
  (tyo #\SP)
  (princ prefix)
  (princ string)
  (princ suffix)
  (tyo #\SP))

(define (student-prompt-string prompt)
  (access string (procedure-environment prompt)))
\f


;;;; Clean environment hackery

(define missing-user-objects '())
(define debugging '())

(define (setup-user-global-environment)
  (define (copy-if-proc object)
    (if debugging (bkpt "COPY-IF-PROC entry" object))
    (let ((result
	   (if (compound-procedure? object)
	       (scode-eval (lambda-components (procedure-lambda object)
			     make-lambda)
			   (procedure-environment object))
	       object)))
      (if debugging (bkpt "COPY-IF-PROC exit" result))
      result))

  (set! user-global-environment
	(make-package user-global-environment
		      ((%IN) 
		       (%OUT)
		       (*)
		       (*ARGS*)
		       (*PROC*)
		       (*RESULT*)
		       (+)
		       (-)
		       (-1+)
		       (/)
		       (1+)
		       (<)
		       (<=)
		       (=)
		       (>)
		       (>=)
		       (ABS)
		       (ADVICE)
		       (ADVISE-ENTRY)
		       (ADVISE-EXIT)
		       (ALPHALESS?)
		       (AND)
		       (APPEND)
		       (APPLICABLE?)
		       (APPLY)
		       (ASCII)
		       (ASSOC)
		       (ASSQ)
		       (ASSV)
		       (ATAN)
		       (ATOM?)
		       (BREAK)
		       (BREAK-BOTH)
		       (BREAK-ENTRY)
		       (BREAK-EXIT)
		       (BREAKPOINT-PROCEDURE)
		       (CAR)
		       (CAAAAR)
		       (CAAADR)
		       (CAAAR)
		       (CAADAR)
		       (CAADDR)
		       (CAADR)
		       (CAAR)
		       (CADAAR)
		       (CADADR)
		       (CADAR)
		       (CADDAR)
		       (CADDDR)
		       (CADDR)
		       (CADR)
		       (CDR)
		       (CDAAAR)
		       (CDAADR)
		       (CDAAR)
		       (CDADAR)
		       (CDADDR)
		       (CDADR)
		       (CDAR)
		       (CDDAAR)
		       (CDDADR)
		       (CDDAR)
		       (CDDDAR)
		       (CDDDDR)
		       (CDDDR)
		       (CDDR)
		       (CEILING)
		       (CHAR)
		       (CHDIR)
		       (CHOOSE-PEN)
		       (CLEAR-GRAPHICS)
		       (CLEAR-POINT)
		       (CLOSE-CHANNEL)
		       (CONS)
		       (CONS*)
		       (COPY-FILE)
		       (COS)
		       (DEBUG)
		       (DELETE-FILE)
		       (DRAW-LINE-TO)
		       (DRAW-POINT)
		       (EDIT)
		       (EIGHTH)
		       (EMACS)
		       (EMACSL)
		       (EMPTY-STREAM?)
		       (ENABLE-LANGUAGE-FEATURES)
		       (ENVIRONMENT?)
		       (ENDGRAPHICS)
		       (EQ?)
		       (EQUAL?)
		       (EQV?)
		       (ERROR-PROCEDURE)
		       (EVAL)
		       (EVEN?)
		       (EXP)
		       (EXPLODE)
		       (EXPT)
		       (EXIT)
		       (EXEC)
		       (FALSE)
		       (FIFTH)
		       (FILE-EXISTS?)
		       (FIRST)
		       (FLOOR)
		       (FORCE)
		       (FOURTH)
		       (GCD)
		       (GENERATE-UNINTERNED-SYMBOL)
		       (HEAD)
		       (IMPLODE)
		       (INIT-GRAPHICS)
		       (INTEGER-DIVIDE)
		       (INTEGER?)
		       (LABEL-GRAPH)
		       (LAST)
		       (LENGTH)
		       (LIST)
		       (LIST*)
		       (LIST-REF)
		       (LIST-TAIL)
		       (LIST?)
		       (LOAD)
		       (LOAD-NOISILY)
		       (LOG)
		       (MAPC)
		       (MAPCAR)
		       (MAX)
		       (MEMBER)
		       (MEMQ)
		       (MEMV)
		       (MIN)
		       (NEGATIVE?)
		       (NEWLINE)
		       (NIL)
		       (NIL?)
		       (NOT)
		       (NTH)
		       (NTHCDR)
		       (NULL?)
		       (NUMBER?)
		       (OBJECT-TYPE)
		       (ODD?)
		       (OPEN-READER-CHANNEL)
		       (OPEN-PRINTER-CHANNEL)
		       (OR)
		       (PAIR?)
		       (PEEKCH)
		       (PHOTO)
		       (PICK-LINE-STYLE)
		       (POSITION-PEN)
		       (POSITIVE?)
		       (PP)
		       (PRIN1)
		       (PRINC)
		       (PRINT)
		       (PRINT-BREADTH)
		       (PRINT-DEPTH)
		       (PROCEED)
		       (QUIT)
		       (QUOTIENT)
		       (RANDOM)
		       (READ)
		       (READCH)
		       (RELOAD)
		       (REDEF-PEN)
		       (REMAINDER)
		       (REVERSE)
		       (ROUND)
		       (RUNTIME)
		       (SECOND)
		       (SET-CAR!)
		       (SET-CDR!)
		       (SET-ALPHA-STYLE!)
		       (SEVENTH)
		       (SIN)
		       (SIXTH)
		       (SQRT)
		       (STRING-LESS?)
		       (SYMBOL?)
		       (T)
		       (TAIL)
		       (TAN)
		       (THE-EMPTY-STREAM)
		       (THIRD)
		       (TOFU)
		       (TRACE)
		       (TRACE-BOTH)
		       (TRACE-ENTRY)
		       (TRACE-EXIT)
		       (THREE-D-INIT)
		       (THREE-D-PLOT)
		       (TRUE)
		       (TRUNCATE)
		       (TYI)
		       (TYIPEEK)
		       (TYO)
		       (UNADVISE)
		       (UNADVISE-ENTRY)
		       (UNADVISE-EXIT)
		       (UNBREAK)
		       (UNBREAK-ENTRY)
		       (UNBREAK-EXIT)
		       (UNTRACE)
		       (UNTRACE-ENTRY)
		       (UNTRACE-EXIT)
		       (USER-INITIAL-ENVIRONMENT)
		       (VECTOR)
		       (VECTOR-CONS)
		       (VECTOR-REF)
		       (VECTOR-SET!)
		       (VECTOR-SIZE)
		       (VECTOR?)
		       (WHERE)
		       (WHERE-IS-PEN?)
		       (ZERO?))
	  (set! user-initial-environment (make-environment))))

  (set! user-initial-environment
	(access user-initial-environment user-global-environment))
  
  (set! missing-user-objects '())

  (let copy-procs-and-lexprs
    ((names
      #|						; comment
      (let ((proc (procedure-lambda
		   (environment-procedure user-global-environment))))
	(append (lambda-required proc)
		(lambda-optional proc)
		(if (lambda-rest proc) (list (lambda-rest proc)) '())
		(lambda-auxiliary proc)))
      |#
      (cdr (lambda-bound (procedure-lambda
			  (environment-procedure
			   user-global-environment))))
      ))
    (let ((name (assq (car names)
		      '((MEMQ . USER-MEMQ)
			(ASSQ . USER-ASSQ)
			(NIL? . NOT)))))
      (set! name (if name (cdr name) (car names)))
      (cond ((null? names) '())
	    ((lexical-unreferenceable? system-global-environment name)
	     (set! missing-user-objects
		   (cons name missing-user-objects))
	     (copy-procs-and-lexprs (cdr names)))
	    (else
	     (local-assignment
	      user-global-environment
	      (car names)
	      (copy-if-proc
	       (lexical-reference system-global-environment name)))
	     (copy-procs-and-lexprs (cdr names))))))
  (setup-student-syntax)

;;; end SETUP-USER-GLOBAL-ENVIRONMENT.
)

(define (student-band filename)
  (disk-save filename #!true)
  (disable-language-features)
; ((access start-login-loop scheme-login-package))
)

(define (student-dump)
  (quit)
  (reload))

(define (reload)
  (disk-restore (access band-file-name student-system)))

;;; End STUDENT-PACKAGE.
))
\f


;;;; Exports

(define user-global-environment)

(set! environment-warning-hook
      (access environment-warning-hook student-package))

(define enable-language-features
  (access enable-language-features student-package))

(define disable-language-features
  (access disable-language-features student-package))

(define setup-user-global-environment
  (access setup-user-global-environment student-package))

(define reload
  (access reload student-package))

(define student-band
  (access student-band student-package))

(define student-dump
  (access student-dump student-package))

;;; Install the student package

(setup-user-global-environment)
(goto-environment user-initial-environment)
((access reset-student-prompt student-package) "==>")
(enable-language-features)