;;; -*- Mode:Lisp; Readtable:T; Package:USER; Base:8; Patch-File:T -*-
;;; Patch file for VERIFY version 1.1
;;; Reason:
;;;  basic incompats fixed
;;; Written 6-May-85 12:30:23 by rg,
;;; while running on Lambda Nine from band 0
;;; with Experimental System 104.5, Experimental VERIFY 1.0, microcode 1143, 104 Volatile.



; From file DEFTEST.LISP#> L.VERIFY; DJ: (49)
#8R VERIFICATION-INTERNALS#:
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "VERIFICATION-INTERNALS")))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: VERIFY; DEFTEST  "


(defun print-a-frame (number sg frame stream &aux fn)
  (setq fn (si:rp-function-word (si:sg-regular-pdl sg) frame))
  (if (or (eq fn #'a-frame-to-stop-on)
	  ;; a compiled call to verbose-error-catch
	  (and (eq fn #'si:eval1)
	       (= 1  (eh:sg-frame-number-of-spread-args sg frame))
	       (let ((arg-to-*eval (AREF (eh:SG-REGULAR-PDL SG) (+ FRAME 1))))
		 (and (not (atom arg-to-*eval))
		      ;; an interpreted call.
		      (eq (car arg-to-*eval) 'a-frame-to-stop-on)))))
      (*throw 'print-n-frames ()))
  (format-puntable stream
		   "~%Frame number ~D is an ~:[open-frame to call~;active call to~] ~S"
		   number
		   (eh:sg-frame-active-p sg frame)
		   fn)
  (terpri-puntable stream)
  (let ((l (and (functionp fn t) (arglist fn))))
    (cond (l
	   (format-puntable stream "Arglist: ~S" l)
	   (terpri-puntable stream))))
  (cond ((eh:sg-frame-active-p sg frame)
	 (do ((j 0 (1+ j))
	      (n (eh:sg-frame-number-of-spread-args sg frame))
	      (l (eh:sg-frame-rest-arg-value sg frame)))
	     ((and (>= j n) (atom l)))
	   (format-puntable stream
			    "Arg[~D]= ~S"
			    j
			    (if (>= j n)
				(pop l)
			      ;; the eh:sg-frame-arg-value goes to
			      ;; a lot more trouble than this to
			      ;; print the present value of a
			      ;; argument which also gets specbound.
			      (AREF (eh:SG-REGULAR-PDL SG) (+ FRAME j 1))))
	   (terpri-puntable stream)))))

))

; From file DIGEST.LISP#> L.VERIFY; DJ: (30)
#10R VERIFICATION-INTERNALS#:
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "VERIFICATION-INTERNALS")))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: VERIFY; DIGEST  "


(defun sorted-alist-by-package (alist)
  (do ((sorted ())
       (l alist (cdr l)))
      ((null l)
       (sort
	 (mapc #'(lambda (x)
		   (setf (cdr x) (sort (cdr x) #'(lambda (a b) (> (cdr a) (cdr b))))))
	       sorted)
	 #'(lambda (x y) (string-lessp (package-name (car x))
				       (package-name (car y))))))
      (let ((cell (assq (symbol-package (caar l)) sorted)))
	(if cell
	    (push (car l) (cdr cell))
	  (push (list (symbol-package (caar l)) (car l)) sorted)))))


))