⟦e927ae503⟧

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

;;;; Microcode Table Interface

(declare (usual-integrations)
	 (compilable-primitive-functions
	  &=
	  1+
	  map-machine-address-to-code
	  map-code-to-machine-address
	  get-external-name
	  get-external-number
	  get-external-counts
))
\f


;;;; Fixed Objects Vector

(define fixed-objects-vector-slot)

(let ((fixed-objects-vector-slots (vector-ref (get-fixed-objects-vector) 15)))

(define number-of-fixed-objects-vector-slots
  (vector-size fixed-objects-vector-slots))

(set! fixed-objects-vector-slot
      (named-lambda (fixed-objects-vector-slot name)
	(let loop ((index 0))
	  (cond ((&= index number-of-fixed-objects-vector-slots)
		 (error "Unknown name -- FIXED-OBJECTS-VECTOR-SLOT" name))
		((eq? name (vector-ref fixed-objects-vector-slots index))
		 index)
		(else
		 (loop (1+ index)))))))

)
\f


;;;; Type Operations

(define number-of-microcode-types)
(define microcode-type-name)
(define microcode-type)
(define object-type)

(let ((microcode-types-vector
       (vector-ref (get-fixed-objects-vector)
		   (fixed-objects-vector-slot 'MICROCODE-TYPES-VECTOR)))
      (renamed-user-object-types
       '((FIXNUM . NUMBER)
	 (BIG-FIXNUM . NUMBER) (BIG-FLONUM . NUMBER)
	 (EXTENDED-FIXNUM . NUMBER)
	 (EXTENDED-PROCEDURE . PROCEDURE)
	 (LEXPR . LAMBDA) (EXTENDED-LAMBDA . LAMBDA)
	 (COMBINATION-1 . COMBINATION) (COMBINATION-2 . COMBINATION)
	 (PRIMITIVE-COMBINATION-0 . COMBINATION)
	 (PRIMITIVE-COMBINATION-1 . COMBINATION)
	 (PRIMITIVE-COMBINATION-2 . COMBINATION)
	 (PRIMITIVE-COMBINATION-3 . COMBINATION)
	 (SEQUENCE-2 . SEQUENCE) (SEQUENCE-3 . SEQUENCE)
	 (INTERN-SYMBOL . SYMBOL)
	 (PRIMITIVE . PRIMITIVE-PROCEDURE)
	 (PRIMITIVE-EXTERNAL . PRIMITIVE-PROCEDURE)
	 )))
  (set! number-of-microcode-types
	(vector-size microcode-types-vector))

  (set! microcode-type-name
	(named-lambda (microcode-type-name type)
	  (let ((entry (vector-ref microcode-types-vector type)))
	    (if (pair? entry)
		(car entry)
		entry))))

  (set! microcode-type
	(named-lambda (microcode-type name)
	  (let loop ((index 0))
	    (if (&= index number-of-microcode-types)
		#!FALSE
		(let ((entry (vector-ref microcode-types-vector index)))
		  (if (if (pair? entry)
			  (memq name entry)
			  (eq? name entry))
		      index
		      (loop (1+ index))))))))

  (set! object-type
	(named-lambda (object-type object)
	  (let ((type (microcode-type-name (primitive-type object))))
	    (disjunction (cdr (assq type renamed-user-object-types))
			 type)))))

(define (microcode-type-predicate name)
  (let ((type (microcode-type name)))
    (lambda (object)
      (primitive-type? type object))))
\f


;;;; Microcode Return Types

(define number-of-microcode-returns)
(define microcode-return)

(let ((returns-vector
       (vector-ref (get-fixed-objects-vector)
		   (fixed-objects-vector-slot 'MICROCODE-RETURNS-VECTOR))))

(set! number-of-microcode-returns
  (vector-size returns-vector))

(set! microcode-return
      (named-lambda (microcode-return name)
	(define (loop index)
	  (conjunction (not (&= index number-of-microcode-returns))
		       (if (eq? name (vector-ref returns-vector index))
			   index
			   (loop (1+ index)))))
	(loop 0)))

)

(define make-return-address)
(define return-address?)
(define return-address-code)

(let ((microcode-type-return-address (microcode-type 'RETURN-ADDRESS)))
  (declare (compilable-primitive-functions map-code-to-machine-address
					   map-machine-address-to-code))
  (set! make-return-address
	(lambda (code)
	  (map-code-to-machine-address microcode-type-return-address code)))
  (set! return-address?
	(lambda (object)
	  (primitive-type? microcode-type-return-address object)))
  (set! return-address-code
	(lambda (return-address)
	  (map-machine-address-to-code microcode-type-return-address
				       return-address))))
\f


;;;; Microcode Error Codes

(define number-of-microcode-errors)
(define microcode-error)

(let ((microcode-errors-vector
       (vector-ref (get-fixed-objects-vector)
		   (fixed-objects-vector-slot 'MICROCODE-ERRORS-VECTOR))))

(set! number-of-microcode-errors
      (vector-size microcode-errors-vector))

(set! microcode-error
      (named-lambda (microcode-error name)
	(let loop ((index 0))
	  (cond ((&= index number-of-microcode-errors) #!FALSE)
		((eq? name (vector-ref microcode-errors-vector index)) index)
		(else (loop (1+ index)))))))

)
\f


;;;; Microcode Primitives

(define make-primitive-procedure)
(define primitive-procedure?)
(define primitive-procedure-name)
(define implemented-primitive-procedure?)

(let ((normal-type (microcode-type 'PRIMITIVE))
      (external-type (microcode-type 'PRIMITIVE-EXTERNAL))

      ;; This strange construct allows us to get the procedures
      ;; integrated into bindings of the same name at compile
      ;; time even though they aren't defined in global.
      (map-machine-address-to-code map-machine-address-to-code)
      (map-code-to-machine-address map-code-to-machine-address))
\f


(set! primitive-procedure?
      (named-lambda (primitive-procedure? object)
	(disjunction (primitive-type? normal-type object)
		     (primitive-type? external-type object))))

(set! implemented-primitive-procedure?
      (named-lambda (implemented-primitive-procedure? object)
	(cond ((primitive-type? normal-type object))
	      ((primitive-type? external-type object)
	       (not (false? (external-name->code
			     (external-code->name (primitive-datum object))
			     #!false))))
	      (else
	       (error "Implemented-Primitive-Procedure?: not a primitive"
		      object)))))

(set! make-primitive-procedure
      (named-lambda (make-primitive-procedure name #!optional force?)
	(if (unassigned? force?) (set! force? #!false))
	(let ((normal-code (normal-name->code name)))
	  (if normal-code
	      (map-code-to-machine-address normal-type normal-code)
	      (disjunction
	       (external-name->code name force?)
	       (error "Unknown name -- MAKE-PRIMITIVE-PROCEDURE"
		      name))))))

(set! primitive-procedure-name
      (named-lambda (primitive-procedure-name primitive-procedure)
	(cond ((primitive-type? normal-type primitive-procedure)
	       (normal-code->name
		(map-machine-address-to-code normal-type
					     primitive-procedure)))
	      ((primitive-type? external-type primitive-procedure)
	       (external-code->name (primitive-datum primitive-procedure)))
	      (else
	       (error "Not a primitive procedure -- PRIMITIVE-PROCEDURE-NAME"
		      primitive-procedure)))))

(define ((name->code vector limit type) name)
  (disjunction (conjunction (pair? name)
			    (eq? (car name) type)
			    (pair? (cdr name))
			    (let ((x (cdr name)))
			      (conjunction (integer? (car x))
					   (< -1 (car x) limit)
					   (null? (cdr x))
					   (car x))))
	       (let loop ((index 0))
		 (if (eq? index limit)
		     #!FALSE
		     (let ((entry (vector-ref vector index)))
		       (disjunction (conjunction entry
						 (if (pair? entry)
						     (memq name entry)
						     (eq? name entry))
						 index)
				    (loop (1+ index))))))))

(define ((code->name vector limit type) code)
  (disjunction (conjunction (< -1 code limit)
			    (let ((name (vector-ref vector code)))
			      (if (pair? name) (car name) name)))
	       (cons type (cons code '()))))
\f


(define normal-primitives)
(define number-of-normal-primitives)
(define normal-name->code)
(define normal-code->name)

(define (install-normal-primitives-vector! vector)
  (set! normal-primitives vector)
  (set! number-of-normal-primitives (vector-size vector))
  (set! normal-name->code
	(name->code normal-primitives
		    number-of-normal-primitives
		    'NORMAL-PRIMITIVE))
  (set! normal-code->name
	(code->name normal-primitives
		    number-of-normal-primitives
		    'NORMAL-PRIMITIVE)))

(install-normal-primitives-vector!
 (vector-ref (get-fixed-objects-vector)
	     (fixed-objects-vector-slot 'MICROCODE-PRIMITIVES-VECTOR)))

(define external-name->code)
(define external-code->name)

(let ((get-external-counts get-external-counts)
      (get-external-number get-external-number)
      (get-external-name get-external-name))

(set! external-name->code get-external-number)

(set! external-code->name
  (named-lambda (external-code->name code)
    (let ((current-counts (get-external-counts)))
      (cond ((< code (car current-counts)) (get-external-name code))
	    ((< code (+ (car current-counts) (cdr current-counts)))
	     (get-external-name code))	; Maybe should warn about undefined
	    (else
	     (error "Not an external procedure name -- EXTERNAL-CODE->NAME"
		    code)))))))

)



;;;Microcode Termination Codes

(define number-of-microcode-terminations)
(define microcode-termination)
(define microcode-termination-name)

(let ((microcode-terminations-vector
       (vector-ref (get-fixed-objects-vector)
		   (fixed-objects-vector-slot 'MICROCODE-TERMINATIONS-VECTOR))))
  (set! number-of-microcode-terminations
	(vector-size microcode-terminations-vector))

  (set! microcode-termination
	(named-lambda (microcode-termination name)
	  (let loop ((index 0))
	       (cond ((&= index number-of-microcode-terminations) #!false)
		     ((eq? name (vector-ref microcode-terminations-vector index)) index)
		     (else (loop (1+ index)))))))

  (set! microcode-termination-name
	(named-lambda (microcode-termination-name type)
	  (vector-ref microcode-terminations-vector type)))
  )
DataMuseum.dk

DKUUG/EUUG Conference tapes

⟦e927ae503⟧ TextFile

Derivation

TextFile
