;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*-
;;; Patch file for System version 121.8
;;; Reason:
;;;  Improve error reporting of subscript-out-of-bounds error. Also, enable global more processing..
;;; Written 19-Jan-87 21:13:57 by RG at site LMI Cambridge
;;; while running on Harpo from band 4
;;; with Experimental System 121.7, Experimental Lambda-Diag 15.0, Experimental ZMail 70.1, Experimental KERMIT 32.0, Experimental Unix-Interface 10.0, Experimental Local-File 72.0, Experimental FILE-Server 21.0, Experimental Tape 13.0, microcode 1733, SDU Boot Tape 3.12, SDU ROM 102.



; From file DJ: L.WINDOW; COLD.LISP#184 at 19-Jan-87 21:14:00
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: WINDOW; COLD  "

(SET-globally 'TV:MORE-PROCESSING-GLOBAL-ENABLE T) ;;this form gets handled by the cold load builder specially

))

; From modified file DJ: L.DEBUGGER; TRAP.LISP#32 at 19-Jan-87 21:18:44
#8R EH#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "EH")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: DEBUGGER; TRAP  "

(defun subscript-oob-subscript-list (sg ete)
  (let* ((object (if (fifth ete) (sg-contents sg (fifth ete))))
	 (frame (sg-ipmark sg))
	 (rp (sg-regular-pdl sg))
	 (fn (rp-function-word rp frame)))
    (if (locativep object)	;for reasons having to do with array-caching,
				; the ucode changes the data-type to DTP-LOCATIVE
				; for displaced or indirect arrays.
	(setq object (%make-pointer dtp-array-pointer object)))
    (if (and (arrayp object) (neq (sixth ete) 1))
	(if (sixth ete)
	    ;; This is AREF, ALOC, ASET or array called as function.
	    (do ((p (sg-regular-pdl-pointer sg) (1- p))
		 subscripts
		 (limit (+ frame (cond ((eq fn #'aset) 2)
				       ((typep fn 'array) 0)
				       (t 1)))))
		((= p limit) subscripts)
	      (push (aref rp p) subscripts))
	  ;; It is AX-1, AX-2 or AX-3.  Since we are past the point of getting
	  ;; a wrong-number-dimensions error, we can tell which by the rank of the array.
	  ;; The ETE cannot distinguish since the errors come from the same spot.
;	  (if array-index-order
	  (let ((rank (array-rank object)))
	    (case rank
	      (1 (list (sg-fixnum-contents sg (second ete))))
	      (2 (list (sg-contents sg 'm-j)
		       (- (sg-fixnum-contents sg (second ete))
			  (* (array-dimension object 1)
			     (sg-contents sg 'm-j)))))
	      (3 (list (sg-contents sg 'm-i)
		       (sg-contents sg 'm-j)
		       (- (sg-fixnum-contents sg (second ete))
			  (* (array-dimension object 2)
			     (+ (sg-contents sg 'm-j)
				(* (array-dimension object 1)
				   (sg-contents sg 'm-i)))))))))
;	    (let ((rank (array-rank object)))
;	      (case rank
;		(1 (list (sg-fixnum-contents sg (second ete))))
;		(2 (list (- (sg-fixnum-contents sg (second ete))
;			    (* (array-dimension object 0)
;			       (sg-contents sg 'm-j)))
;			 (sg-contents sg 'm-j)))
;		(3 (list (- (sg-fixnum-contents sg (second ete))
;			    (* (array-dimension object 0)
;			       (+ (sg-contents sg 'm-j)
;				  (* (array-dimension object 1)
;				     (sg-contents sg 'm-i)))))
;			 (sg-contents sg 'm-j)
;			 (sg-contents sg 'm-i))))))
	  )
      ;; If object is not known or not an array, or if AX-1-FORCE.
      (list (sg-fixnum-contents sg (second ete))))))

))

; From modified file DJ: L.DEBUGGER; TRAP.LISP#32 at 19-Jan-87 21:18:57
#8R EH#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "EH")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: DEBUGGER; TRAP  "

(defmethod (subscript-error :report) (stream)
  (cond (dimension-number
	 (format stream "The subscript for dimension ~D was ~S, which is out of range for ~S."
		 dimension-number (nth dimension-number subscripts-given) object))
	(object
	 (if (locativep object)		;see comment above.
	     (setq object (%make-pointer dtp-array-pointer object)))
	 (if (= (length subscripts-given) 1)
	     (format stream "The subscript ~S for ~S was out of range in ~S."
		     subscript-used object function)
	   (format stream "The subscripts ~S for ~S were out of range in ~S."
		   subscripts-given object function)))
	((< subscript-used 0)
	 (format stream "The index, ~S, was negative in ~S."
		 subscript-used function))
	(t 
	 (format stream "The index, ~S, was beyond the length, ~S, in ~S."
		 subscript-used subscript-limit function))))

))