DataMuseum.dk

top - download

    Length: 9288 (0x2448)
    Types: TextFile
    Names: »ustruc.scm.165«

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

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

;;; Note: This file must be after the SCODE abstraction in the boot sequence.

(declare (usual-integrations))
\f


;;;; Procedure

(define compound-procedure?)
(define procedure?)

(let ((p-type (microcode-type 'PRIMITIVE))
      (e-type (microcode-type 'PRIMITIVE-EXTERNAL))
      (c-type (microcode-type 'PROCEDURE))
      (x-type (microcode-type 'EXTENDED-PROCEDURE)))
  (set! compound-procedure?
	(named-lambda (compound-procedure? object)
	  (disjunction (primitive-type? c-type object)
		       (primitive-type? x-type object))))
  (set! procedure?
	(named-lambda (procedure? object)
	  (disjunction (primitive-type? p-type object)
		       (primitive-type? e-type object)
		       (primitive-type? c-type object)
		       (primitive-type? x-type object)))))

(define procedure-lambda)
(define procedure-environment)
(define procedure-components)

(define procedure-package
  (make-environment

(define select-lambda system-pair-car)
(define modify-lambda! system-pair-set-car!)
(define select-environment system-pair-cdr)
(define modify-environment! system-pair-set-cdr!)

(define (select-components procedure receiver)
  (receiver (select-lambda procedure)
	    (select-environment procedure)))

(define ((type-dispatch name p-operation c-operation) procedure)
  ((cond ((compound-procedure? procedure) c-operation)
	 ((primitive-procedure? procedure) p-operation)
	 (else (error "Not a procedure" name procedure)))
   procedure))

(define (compound-system-operation name operation)
  (type-dispatch name
		 (compound-operation-error name)
		 operation))

(define ((compound-operation-error name) procedure)
  (error "Not a compound procedure" name procedure))

(define (user-operation name p-operation c-operation)
  (type-dispatch name
		 p-operation
		 (trap-internal-lambdas name c-operation)))

(define ((trap-internal-lambdas name operation) procedure)
  (if ((access is-internal-lambda? lambda-package)
       (select-lambda procedure))
      (error "Internal procedure encountered -- get a wizard" name procedure)
      (operation procedure)))
\f


(define system-procedure-lambda
  (compound-system-operation 'SYSTEM-PROCEDURE-LAMBDA select-lambda))

(define system-procedure-environment
  (compound-system-operation 'SYSTEM-PROCEDURE-ENVIRONMENT
			     select-environment))

(set! procedure-lambda
      (user-operation 'PROCEDURE-LAMBDA
		      (compound-operation-error 'PROCEDURE-LAMBDA)
		      select-lambda))

(set! procedure-environment
      (user-operation 'PROCEDURE-ENVIRONMENT
		     (lambda (primitive-procedure) system-global-environment)
		     select-environment))

(set! procedure-components
      (user-operation 'PROCEDURE-COMPONENTS
		      (compound-operation-error 'PROCEDURE-COMPONENTS)
		      select-components))

))
\f


;;;; Environment

(define environment?
  (microcode-type-predicate 'ENVIRONMENT))

(define environment-procedure)
(define environment-has-parent?)
(define environment-parent)
(define environment-bindings)
(define environment-arguments)

(define environment-package
  (make-environment

(define null-environment
  (primitive-set-type (microcode-type 'NULL) 1))

(define system-procedure-lambda
  (access system-procedure-lambda procedure-package))

(define system-procedure-environment
  (access system-procedure-environment procedure-package))

(define ((environment-operation name operation global) environment)
  (cond ((environment? environment)
	 (let ((procedure (select-procedure environment)))
	   (let ((lambda (system-procedure-lambda procedure)))
	     (if ((access has-internal-lambda? lambda-package) lambda)
		 (error "External environment frame encountered" name)
		 (operation (if ((access is-internal-lambda? lambda-package)
				 lambda)
				(system-procedure-environment procedure)
				environment)
			    environment)))))
	((eq? environment system-global-environment)
	 (global name))
	(else
	 (error "Not an environment" name environment))))

(define (global-environment-error name)
  (error "Operation not implemented for global environment" name))

(define (select-procedure environment)
  (system-vector-ref environment 2))

(define (select-parent environment)
  (system-procedure-environment (select-procedure environment)))

(define (select-lambda environment)
  (system-procedure-lambda (select-procedure environment)))

(define (environment-value environment name)
  (if (lexical-unassigned? environment name)
      '()
      (list (lexical-reference environment name))))
\f


(set! environment-procedure
      (environment-operation 'ENVIRONMENT-PROCEDURE
	(lambda (external-environment internal-environment)
	  (select-procedure external-environment))
	global-environment-error))

(set! environment-has-parent?
      (environment-operation 'ENVIRONMENT-HAS-PARENT?
	(lambda (external-environment internal-environment)
	  (not (eq? (select-parent external-environment) null-environment)))
	(lambda (name)
	  #!FALSE)))

(set! environment-parent
      (environment-operation 'ENVIRONMENT-PARENT
	(lambda (external-environment internal-environment)
	  (select-parent external-environment))
	global-environment-error))

(set! environment-bindings
      (environment-operation 'ENVIRONMENT-BINDINGS
	(lambda (external-environment internal-environment)
	  (mapcar (lambda (name)
		    (cons name (environment-value internal-environment name)))
		  (mapcar* (lambda-bound (select-lambda external-environment))
			   car
			   (system-vector-ref internal-environment 0))))
	global-environment-error))

(set! environment-arguments
      (environment-operation 'ENVIRONMENT-ARGUMENTS
	(lambda (external-environment internal-environment)
	  (define (lookup name)
	    (if (lexical-unassigned? internal-environment name)
		(make-unassigned-object)
		(lexical-reference internal-environment name)))
	  (lambda-components (select-lambda external-environment)
	    (lambda (name required optional rest auxiliary body)
	      (mapcar* (let optional-loop ((names optional))
			 (cond ((null? names)
				(if (null? rest)
				    '()
				    (lookup rest)))
			       ((lexical-unreferenceable? internal-environment
							  (car names))
				'())
			       (else
				(cons (lookup (car names))
				      (optional-loop (cdr names))))))
		       lookup
		       required))))
	global-environment-error))

(define (system-environment-add-parent! environment parent)
  (system-pair-set-cdr! (environment-procedure environment)
			parent))

(define (system-environment-remove-parent! environment)
  (system-pair-set-cdr! (environment-procedure environment)
			null-environment))

(define (system-external-environment? environment)
  ((access has-internal-lambda? lambda-package)
   (select-lambda environment)))

))
\f


;;;; Delayed Evaluation

(define delayed?
  (microcode-type-predicate 'DELAYED))

(define delayed-evaluation-forced?
  (let ((true-type (microcode-type 'TRUE)))
    (lambda (delayed-evaluation)
      (primitive-type? true-type (system-pair-car delayed-evaluation)))))

(define (delayed-evaluation-value delayed-evaluation)
  (if (delayed-evaluation-forced? delayed-evaluation)
      (system-pair-cdr delayed-evaluation)
      (error "Delayed Evaluation not yet forced"
	     'DELAYED-EVALUATION-VALUE
	     delayed-evaluation)))

(define (delayed-evaluation-expression delayed-evaluation)
  (if (delayed-evaluation-forced? delayed-evaluation)
      (error "Delayed Evaluation already forced"
	     'DELAYED-EVALUATION-EXPRESSION
	     delayed-evaluation)
      (system-pair-cdr delayed-evaluation)))

(define (delayed-evaluation-environment delayed-evaluation)
  (if (delayed-evaluation-forced? delayed-evaluation)
      (error "Delayed Evaluation already forced"
	     'DELAYED-EVALUATION-ENVIRONMENT
	     delayed-evaluation)
      (system-pair-car delayed-evaluation)))