⟦a6009ebf0⟧

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

;;;; Error System

(declare (usual-integrations)
	 (compilable-primitive-functions set-fixed-objects-vector!))

(define error-procedure)

(define (error-from-compiled-code message . irritant-info)
  (error-procedure message
		   (cond ((null? irritant-info) *the-non-printing-object*)
			 ((null? (cdr irritant-info)) (car irritant-info))
			 (else irritant-info))
		   (rep-environment)))

(define (error-message)
  (access error-message error-system))

(define (error-irritant) 
  (access error-irritant error-system))

(define error-prompt
  "Error->")

(define error-system
  (make-package error-system
		((*error-code*)

		 (wrapped-operator combination-operator)
		 (wrapped-operands combination-operands)
		 )
\f


;;;; REP Interface

(define error-message "")
(define error-irritant *the-non-printing-object*)

(set! error-procedure
      (named-lambda (error-procedure message irritant environment)
	(with-history-disabled
	 (lambda ()
	   (with-standard-proceed-point
	    (lambda ()
	      (fluid-let ((error-message message)
			  (error-irritant irritant))
		(push-rep environment
			  (make-error-message message irritant)
			  (standard-rep-prompt error-prompt)))))))))

(define ((error-handler-wrapper handler) error-code interrupt-enables)
  (with-interrupt-mask INTERRUPT-MASK-GC-OK
   (lambda (old-mask)
     (fluid-let ((*error-code* error-code))
       (with-proceed-point
	proceed-value-filter
	(lambda ()
	  (set-interrupt-enables! interrupt-enables)
	  (set-continuation-interrupt-enables! (rep-continuation)
					       interrupt-enables)
	  (handler (continuation-expression (rep-continuation)))))))))

(define (wrapped-error-handler wrapper)
  (access handler (procedure-environment wrapper)))

(define (start-error-rep message irritant)
  (fluid-let ((error-message message)
	      (error-irritant irritant))
    (let ((environment (continuation-environment (rep-continuation)))
	  (message (make-error-message message irritant)))
      (if (continuation-undefined-environment? environment)
	  (push-rep
	   (rep-environment)
	   (lambda ()
	     (message)
	     (newline) (princ "There is no environment available;")
	     (newline)
	     (princ "using the current read-eval-print environment."))
	   (standard-rep-prompt error-prompt))
	  (push-rep environment
		    message
		    (standard-rep-prompt error-prompt))))))

;;; (PROCEED) means retry error expression, (PROCEED value) means
;;; return VALUE as the value of the error subproblem.

(define (proceed-value-filter value)
  (let ((continuation (rep-continuation)))
    (if (disjunction (null? value) (null-continuation? continuation))
	(continuation '())
	((continuation-next-continuation continuation) (car value)))))

(define ((make-error-message message irritant))
  (newline) (princ message)
  (if (not (eq? irritant *the-non-printing-object*))
      (sequence (tyo #\SP) (prin1 irritant))))
\f


;;;; Error Handlers

;;; All error handlers have the following form:

(define ((make-error-handler direction-alist operator-alist
			     default-handler default-combination-handler)
	 expression)
  ((let direction-loop ((alist direction-alist))
     (cond ((null? alist)
	    (cond ((combination? expression)
		   (let ((operator (combination-operator expression)))
		     (let operator-loop ((alist operator-alist))
		       (cond ((null? alist) default-combination-handler)
			     ((memq operator (caar alist)) (cdar alist))
			     (else (operator-loop (cdr alist)))))))
		  (else default-handler)))
	   (((caar alist) expression) (cdar alist))
	   (else (direction-loop (cdr alist)))))
   expression))

;;; Then there are several methods for modifying the behavior of a
;;; given error handler.

(define expression-specific-adder)
(define operation-specific-adder)

(let ()
  (define (((alist-adder name) error-handler) filter receiver)
    (let ((environment
	   (procedure-environment (wrapped-error-handler error-handler))))
      (lexical-assignment environment
			  name
			  (cons (cons filter receiver)
				(lexical-reference environment name)))))

  (set! expression-specific-adder
	(alist-adder 'DIRECTION-ALIST))
  (set! operation-specific-adder
	(alist-adder 'OPERATOR-ALIST)))

(define default-expression-setter)
(define default-combination-setter)

(let ()
  (define (((set-default name) error-handler) receiver)
    (lexical-assignment
     (procedure-environment (wrapped-error-handler error-handler))
     name
     receiver))

  (set! default-expression-setter
	(set-default 'DEFAULT-HANDLER))
  (set! default-combination-setter
	(set-default 'DEFAULT-COMBINATION-HANDLER)))
\f


;;;; Error Vector

;;; Initialize the error vector to the default state:

(define (default-error-handler expression)
  (start-error-rep "Anomalous error -- get a wizard" *error-code*))

(define system-error-vector
  (make-initialized-vector number-of-microcode-errors
    (lambda (error-code)
      (error-handler-wrapper
       (make-error-handler '()
			   '()
			   default-error-handler
			   default-error-handler)))))

;;; Use this procedure to displace the default handler completely.

(define (define-total-error-handler error-name handler)
  (vector-set! system-error-vector
	       (microcode-error error-name)
	       (error-handler-wrapper handler)))

;;; It will be installed later.

(define (install)
  (vector-set! (get-fixed-objects-vector)
	       (fixed-objects-vector-slot 'SYSTEM-ERROR-VECTOR)
	       system-error-vector)
  (set-fixed-objects-vector! (get-fixed-objects-vector)))
\f


;;;; Error Definers

(define ((define-definer type definer) error-name . args)
  (apply definer
	 (cons (type (vector-ref system-error-vector
				 (microcode-error error-name)))
	       args)))

(define ((define-specific-error error-name message) filter selector)
  ((cond ((pair? filter) define-operation-specific-error)
	 (else define-expression-specific-error))
   error-name filter message selector))

(define define-expression-specific-error
  (define-definer expression-specific-adder
    (lambda (adder filter message selector)
      (adder filter (expression-error-rep message selector)))))

(define define-operation-specific-error
  (define-definer operation-specific-adder
    (lambda (adder filter message selector)
      (adder filter (combination-error-rep message selector)))))

(define define-operand-error
  (define-definer default-combination-setter
    (lambda (setter message selector)
      (setter (combination-error-rep message selector)))))
\f


(define define-operator-error
  (define-definer default-combination-setter
    (lambda (setter message)
      (setter (expression-error-rep message combination-operator)))))

(define define-combination-error
  (define-definer default-combination-setter
    (lambda (setter message selector)
      (setter (expression-error-rep message selector)))))

(define define-default-error
  (define-definer default-expression-setter
    (lambda (setter message selector)
      (setter (expression-error-rep message selector)))))

(define ((expression-error-rep message selector) expression)
  (start-error-rep message (selector expression)))

(define ((combination-error-rep message selector) combination)
  (start-error-rep
   (string-append message
		  " "
		  (cdr (with-output-to-truncated-string
			40
			(lambda ()
			  (*unparse-object (selector combination)))))
		  (character->string #\CR)
		  "within procedure")
 		   (combination-operator combination)))
\f


;;;; Combination Operations

;;; Combinations coming out of the continuation parser are either all
;;; unevaluated, or all evaluated, or all operands evaluated and the
;;; operator undefined.  Thus we must be careful about unwrapping
;;; the components when necessary.  In practice, it turns out that
;;; all but one of the interesting errors happen at the application
;;; point, at which all of the combination's components are evaluated.

(define (combination-operator combination)
  (unwrap-evaluated-object (wrapped-operator combination)))

(define ((combination-operand selector) combination)
  (unwrap-evaluated-object (selector (wrapped-operands combination))))

(define combination-first-operand (combination-operand first))
(define combination-second-operand (combination-operand second))
(define combination-third-operand (combination-operand third))

(define (combination-operands combination)
  (mapcar unwrap-evaluated-object (wrapped-operands combination)))

(define (unwrap-evaluated-object object)
  (if (continuation-evaluated-object? object)
      (continuation-evaluated-object-value object)
      (error "Not evaluated -- get a wizard"
	     unwrap-evaluated-object object)))
\f


;;;; Environment Operation Errors

(define define-unbound-variable-error
  (define-specific-error 'UNBOUND-VARIABLE
    "Unbound Variable"))

(define-unbound-variable-error variable? variable-name)
(define-unbound-variable-error access? access-name)
(define-unbound-variable-error assignment? assignment-name)
(define-unbound-variable-error
  (list (make-primitive-procedure 'LEXICAL-REFERENCE)
	(make-primitive-procedure 'LEXICAL-ASSIGNMENT))
  combination-second-operand)

(define define-unassigned-variable-error
  (define-specific-error 'UNASSIGNED-VARIABLE
    "Unassigned Variable"))

(define-unassigned-variable-error variable? variable-name)
(define-unassigned-variable-error access? access-name)
(define-unassigned-variable-error
  (list (make-primitive-procedure 'LEXICAL-REFERENCE))
  combination-second-operand)

(define define-bad-frame-error
  (define-specific-error 'BAD-FRAME
    "Illegal Environment Frame"))

(define-bad-frame-error access? access-environment)
(define-bad-frame-error in-package? in-package-environment)

(define define-assignment-to-procedure-error
  (define-specific-error 'ASSIGN-LAMBDA-NAME
    "Attempt to assign procedure's name"))

(define-assignment-to-procedure-error assignment? assignment-name)
(define-assignment-to-procedure-error definition? definition-name)
(define-assignment-to-procedure-error
  (list (make-primitive-procedure 'LEXICAL-ASSIGNMENT)
	(make-primitive-procedure 'LOCAL-ASSIGNMENT))
  combination-second-operand)
\f


;;;; Application Errors

(define-operator-error 'UNDEFINED-PROCEDURE
  "Application of Non-Procedure Object")

(define-operator-error 'UNDEFINED-PRIMITIVE-OPERATION
  "Undefined Primitive Procedure")

(define-operand-error 'WRONG-NUMBER-OF-ARGUMENTS
  "Wrong Number of Arguments; called with: "
  (lambda (combination)
    (length (combination-operands combination))))

(let ((make
       (lambda (wta-error-code bra-error-code
	        position-string position-selector)
	 (let ((ap-string (string-append position-string
					 " argument position"))
	       (selector (combination-operand position-selector)))
	   (define-operand-error wta-error-code
	     (string-append "Illegal datum in " ap-string)
	     selector)
	   (define-operand-error bra-error-code
	     (string-append "Datum out of range in " ap-string)
	     selector)))))
  (make 'WRONG-TYPE-ARGUMENT-0 'BAD-RANGE-ARGUMENT-0 "first" first)
  (make 'WRONG-TYPE-ARGUMENT-1 'BAD-RANGE-ARGUMENT-1 "second" second)
  (make 'WRONG-TYPE-ARGUMENT-2 'BAD-RANGE-ARGUMENT-2 "third" third)
  (make 'WRONG-TYPE-ARGUMENT-3 'BAD-RANGE-ARGUMENT-3 "fourth" fourth)
  (make 'WRONG-TYPE-ARGUMENT-4 'BAD-RANGE-ARGUMENT-4 "fifth" fifth)
  (make 'WRONG-TYPE-ARGUMENT-5 'BAD-RANGE-ARGUMENT-5 "sixth" sixth)
  (make 'WRONG-TYPE-ARGUMENT-6 'BAD-RANGE-ARGUMENT-6 "seventh" seventh)
  (make 'WRONG-TYPE-ARGUMENT-7 'BAD-RANGE-ARGUMENT-7 "eighth" eighth)
  (make 'WRONG-TYPE-ARGUMENT-8 'BAD-RANGE-ARGUMENT-8
	"ninth" (lambda (list) (general-car-cdr list #x1400)))
  (make 'WRONG-TYPE-ARGUMENT-9 'BAD-RANGE-ARGUMENT-9
	"tenth" (lambda (list) (general-car-cdr list #x3000))))
\f


;;;; Primitive Operator Errors

(define-operation-specific-error 'FASL-FILE-TOO-BIG
  (list (make-primitive-procedure 'PRIMITIVE-FASLOAD)
	(make-primitive-procedure 'BINARY-FASLOAD))
  "Not enough room to Fasload"
  combination-first-operand)

(define-operation-specific-error 'FASL-FILE-BAD-DATA
  (list (make-primitive-procedure 'PRIMITIVE-FASLOAD)
	(make-primitive-procedure 'BINARY-FASLOAD))
  "Fasload file would not relocate correctly"
  combination-first-operand)

;;; This will trap any external-primitive errors that
;;; aren't caught by special handlers.

(define-operator-error 'EXTERNAL-RETURN
  "Error during External Application")

(define-operation-specific-error 'EXTERNAL-RETURN
  (list (make-primitive-procedure 'OPEN-CHANNEL))
  "Unable to open file"
  combination-first-operand)
\f


;;;; SCODE Syntax Errors

;;; This error gets an unevaluated combination, but it doesn't ever
;;; look at the components, so it doesn't matter.

(define define-broken-variable-error
  (define-specific-error 'BROKEN-CVARIABLE
    "Broken Compiled Variable -- get a wizard"))

(define-broken-variable-error variable? variable-name)
(define-broken-variable-error assignment? assignment-name)
\f


;;;; System Errors

(define-total-error-handler 'BAD-ERROR-CODE
  (lambda (error-code)
    (start-error-rep "Bad Error Code -- get a wizard" error-code)))

(define-default-error 'EXECUTE-MANIFEST-VECTOR
  "Attempt to execute Manifest Vector -- get a wizard"
  identity-procedure)

(define-default-error 'UNDEFINED-USER-TYPE
  "Undefined Type Code -- get a wizard"
  identity-procedure)

;;;; Cscheme specific errors (for now)

(define-operand-error 'FAILED-ARG-1-COERCION
  "First argument cannot be coerced to floating point"
  combination-first-operand)

(define-operand-error 'FAILED-ARG-2-COERCION
  "Second argument cannot be coerced to floating point"
  combination-second-operand)

(define-operand-error 'IMPURIFY-OBJECT-TOO-LARGE
  "Not enough room to Impurify during Side effecting primitive"
  combination-first-operand)
\f


(define-operation-specific-error 'IMPURIFY-OBJECT-TOO-LARGE
  (list (make-primitive-procedure 'PRIMITIVE-IMPURIFY))
  "Not enough room to Impurify"
  combination-first-operand)

(define-operation-specific-error 'OUT-OF-FILE-HANDLES
  (list (make-primitive-procedure 'OPEN-CHANNEL))
  "Unable to open file"
  combination-first-operand)

(define-operation-specific-error 'WRITE-INTO-PURE-SPACE
  (list set-car! set-cdr! vector-set!
	(make-primitive-procedure 'SYSTEM-PAIR-SET-CAR!)
	(make-primitive-procedure 'SYSTEM-PAIR-SET-CDR!)
	(make-primitive-procedure 'HUNK3-SET-CXR!)
	(make-primitive-procedure 'SYSTEM-HUNK3-SET-CXR0!)
	(make-primitive-procedure 'SYSTEM-HUNK3-SET-CXR1!)
	(make-primitive-procedure 'SYSTEM-HUNK3-SET-CXR2!)
	(make-primitive-procedure 'SET-CELL-CONTENTS!)
	(make-primitive-procedure 'SYSTEM-VECTOR-SET!))
  "Side-effect on object in pure space"
  combination-first-operand)

(define-operator-error 'NO-HASH-TABLE
; (list (make-primitive-procedure 'OBJECT-HASH)
;	(make-primitive-procedure 'OBJECT-UNHASH))
  "No hash table found")

;;; end ERROR-SYSTEM package.
))
DataMuseum.dk

DKUUG/EUUG Conference tapes

⟦a6009ebf0⟧ TextFile

Derivation

TextFile
