;;; -*- Mode:Lisp; Readtable:CL; Package:USER; Base:10; Patch-File:T -*-
;;; Patch file for System version 126.1
;;; Reason:
;;;  SI:SHOW-VIRTUAL-MEMORY-FRAGMENTATION draws image of <all> regions; limit
;;;  used to be 256.  Correct quantity is now SI:NUMBER-OF-REGIONS. -Keith
;;; Written 26-Jul-88 05:20:40 by pld (Peter L. DeWolf) at site Gigamos Cambridge
;;; while running on Azathoth from band 2
;;; with ZWEI 125.3, ZMail 73.0, Local-File 75.0, File-Server 24.0, Unix-Interface 13.0, Tape 24.1, Lambda-Diag 17.0, Experimental System 126.0, Experimental MEDIUM-RESOLUTION-COLOR 4.0, microcode 1762, SDU Boot Tape 3.14, SDU ROM 8, the old ones.



; From modified file DJ: L.SYS; DESCRIBE.LISP#24 at 26-Jul-88 05:20:41
#10R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; DESCRIBE  "

(defun show-virtual-memory-fragmentation (&optional (window tv:selected-window))
  (unless (send window :operation-handled-p :draw-point)
    (ferror nil "Window does not support graphics operations"))
  (let* ((blinkers (tv:sheet-blinker-list window))
	 (visibility-list (mapcar #'(lambda (blinker) (send blinker :visibility)) blinkers)))
    (unwind-protect
	(progn (dolist (blinker blinkers)
		 (send blinker :set-visibility nil))
	       (send window :clear-screen)
	       (do* ((region 0 (add1 region))
		     (current-y 0)
		     (current-x 0)
		     (inside-width (send window :inside-width))
		     (vpage 0)
		     region-fill
		     region-size)
		    ((= region number-of-regions)
		     (multiple-value-bind (final-y final-x)
			 (floor vpage inside-width)
		       (send window :draw-triangle
			     final-x final-y
			     (- final-x 10) (+ final-y 10)
			     (+ final-x 10) (+ final-y 10))
		       (cursorpos (+ (ceiling final-y (send window :line-height)) 2) 0)))
		 (setq region-fill (ash (%region-free-pointer region) -8)
		       region-size (ash (%region-length region) -8))
		 (cond ((<= region-fill (- inside-width current-x))
			(send window :draw-line current-x current-y (+ current-x region-fill) current-y))
		       (t
			(send window :draw-line current-x current-y inside-width current-y)
			(send window :draw-line
			      0
			      (add1 current-y)
			      (- region-fill (- inside-width current-x))
			      (add1 current-y))))
		 (if (<= region-size (- inside-width current-x))
		     (incf current-x region-size)
		   (setq current-x (- region-size (- inside-width current-x))
			 current-y (add1 current-y)))
		 (incf vpage region-size)))
      (mapcar #'(lambda (blinker vis) (send blinker :set-visibility vis))
	      blinkers visibility-list))))

))