(FILECREATED " 5-Mar-85 17:30:58" {ERIS}<SANNELLA>LISP>VMEMBANG.;10
 5809   

      changes to:  (FNS TEST.ARRAYS TEST.\ALLOCBLOCK)

      previous date: "26-Feb-85 10:54:11" {ERIS}<SANNELLA>LISP>VMEMBANG.;8)


(* Copyright (c) 1985 by Xerox Corporation. All rights reserved.)

(PRETTYCOMPRINT VMEMBANGCOMS)

(RPAQQ VMEMBANGCOMS
 ((FNS TEST.ARRAYS TEST.\ALLOCBLOCK)))
(DEFINEQ

(TEST.ARRAYS

  [LAMBDA (RESETFLG MAX.TOTAL.SIZE MAX.VMEM.SIZE)            (* mjs " 5-Mar-85 17:29")

    (if
 (
NULL
 MAX.TOTAL.SIZE)
	then
 (
SETQ
 MAX.TOTAL.SIZE 1000000))
    (if
 (
NOT
 ARRAYBLOCKCHECKING)
	then
 (
SETQ
 ARRAYBLOCKCHECKING T)
	     (printout
 T "resetting ARRAYBLOCKCHECKING to T" T))
    (
PROG
 (SIZE OLDARRAY TOTALSIZE)
          (if
 [
OR
 RESETFLG (
NOT
 (
BOUNDP
 (
QUOTE
 TEST.ARRAYS.LIST)))
		  (
NLISTP
 TEST.ARRAYS.LIST)
		  (for
 X in
 TEST.ARRAYS.LIST thereis
 (
NOT
 (
ARRAYP
 X]
	      then
 (
SETQ
 TEST.ARRAYS.LIST NIL)
		   (printout
 T "resetting TEST.ARRAYS.LIST" T))
          (for
 OP from
 1 until
 (
AND
 MAX.VMEM.SIZE (
GREATERP
 (
VMEMSIZE
)
							    MAX.VMEM.SIZE))
	     do
 (
BLOCK
)
		(
SETQ
 TOTALSIZE (for
 X in
 TEST.ARRAYS.LIST sum
 (
ARRAYSIZE
 X)))
		(printout
 T "Operation " OP ,, "total size=" TOTALSIZE ,, "#arrays=" (
LENGTH
 
										 TEST.ARRAYS.LIST)
			  ,, "vmemsize=" (
VMEMSIZE
)
			  ,,,
			  (
DATE
)
			  T)
		(if
 (
LESSP
 TOTALSIZE MAX.TOTAL.SIZE)
		    then
 (
SETQ
 SIZE (
RAND
 0 65533))
			 (printout
 T ,,, "ADDING array" ,,, "size=" SIZE T)
			 (
SETQ
 TEST.ARRAYS.LIST (
CONS
 (
ARRAY
 SIZE)
						      TEST.ARRAYS.LIST))
		  else
 [
SETQ
 OLDARRAY (
CAR
 (
NTH
 TEST.ARRAYS.LIST (
RAND
 1 (
LENGTH
 TEST.ARRAYS.LIST]
		       (printout
 T ,,, "DELETING array" ,,, "size=" (
ARRAYSIZE
 OLDARRAY)
				 T)
		       (
SETQ
 TEST.ARRAYS.LIST (
DREMOVE
 OLDARRAY TEST.ARRAYS.LIST)))
		(
\PARSEARRAYSPACE
])

(TEST.\ALLOCBLOCK

  [LAMBDA (RESETFLG MAX.TOTAL.SIZE MAX.VMEM.SIZE)            (* mjs " 5-Mar-85 17:30")

    (if
 (
NULL
 MAX.TOTAL.SIZE)
	then
 (
SETQ
 MAX.TOTAL.SIZE 1000000))
    (if
 (
NOT
 ARRAYBLOCKCHECKING)
	then
 (
SETQ
 ARRAYBLOCKCHECKING T)
	     (printout
 T "resetting ARRAYBLOCKCHECKING to T" T))
    (
PROG
 (#CELLS OLDBLOCK TOTALSIZE GCTYPE INITONPAGE ALIGN NEWBLOCK)
          (if
 [
OR
 RESETFLG (
NOT
 (
BOUNDP
 (
QUOTE
 TEST.\ALLOCBLOCK.LIST)))
		  (
NLISTP
 TEST.\ALLOCBLOCK.LIST)
		  (for
 X in
 TEST.\ALLOCBLOCK.LIST thereis
 (
NOT
 (
LISTP
 X]
	      then
 (
SETQ
 TEST.\ALLOCBLOCK.LIST NIL)
		   (printout
 T "resetting TEST.\ALLOCBLOCK.LIST " T))
          (for
 OP from
 1 until
 (
AND
 MAX.VMEM.SIZE (
GREATERP
 (
VMEMSIZE
)
							    MAX.VMEM.SIZE))
	     do
 (
BLOCK
)
		(
SETQ
 TOTALSIZE (for
 X in
 TEST.\ALLOCBLOCK.LIST sum
 (
CADR
 X)))
		(printout
 T "Operation " OP "total size=" ,, TOTALSIZE ,, "#blocks=" (
LENGTH
 
									    TEST.\ALLOCBLOCK.LIST)
			  ,, "vmemsize=" (
VMEMSIZE
)
			  ,,,
			  (
DATE
)
			  T)
		(if
 (
LESSP
 TOTALSIZE MAX.TOTAL.SIZE)
		    then
 (
SETQ
 GCTYPE (
SELECTQ
 (
RAND
 1 3)
					       (1 UNBOXEDBLOCK.GCT)
					       (2 PTRBLOCK.GCT)
					       (3 CODEBLOCK.GCT)
					       (
SHOULDNT
)))
			 (
SETQ
 INITONPAGE (
RAND
 1 150))
			 (if
 (
GREATERP
 INITONPAGE 127)
			     then
 (
SETQ
 INITONPAGE NIL))
			 [if
 (
EQ
 GCTYPE CODEBLOCK.GCT)
			     then
                            (* codeblocks can't be aligned tighter than 2 cells 

							     <see AR 3373>)

				  (
SETQ
 ALIGN (
SELECTQ
 (
RAND
 0 1)
						       (0 2)
						       (1 NIL)
						       (
SHOULDNT
)))
			   else
 (
SETQ
 ALIGN (
SELECTQ
 (
RAND
 0 3)
						     (0 2)
						     (1 4)
						     (2 8)
						     (3 NIL)
						     (
SHOULDNT
]
			 (
SETQ
 #CELLS (if
 (
AND
 INITONPAGE ALIGN (
EQ
 GCTYPE CODEBLOCK.GCT))
					  then
 (
RAND
 0 32768)
					else
 (
RAND
 0 65533)))
			 (printout
 T "ADDING block   #cells=" #CELLS "  gctype=" GCTYPE 
				   "   INITONPAGE="
				   INITONPAGE "   ALIGN=" ALIGN T)
			 (
SETQ
 NEWBLOCK (
\ALLOCBLOCK
 #CELLS GCTYPE INITONPAGE ALIGN))
			 (
SETQ
 TEST.\ALLOCBLOCK.LIST (
CONS
 (
LIST
 NEWBLOCK #CELLS GCTYPE INITONPAGE 
								 ALIGN)
							   TEST.\ALLOCBLOCK.LIST))
			 (if
 (
AND
 INITONPAGE (
GREATERP
 (
PLUS
 (fetch
 (POINTER CELLINPAGE)
								of
 NEWBLOCK)
							     INITONPAGE)
						       128))
			     then
 (printout
 T "bad INITONPAGE; CELLINPAGE=" (fetch
 (POINTER 
										       CELLINPAGE)
									       of
 NEWBLOCK)
					    T)
				  (
ERROR
))
			 (if
 (
AND
 ALIGN (
NOT
 (
EVENP
 (fetch
 (POINTER CELLINSEGMENT) of
 NEWBLOCK)
						    ALIGN)))
			     then
 (printout
 T "bad alignment; CELLINSEGMENT=" (fetch
 (POINTER 
										    CELLINSEGMENT)
										 of
 NEWBLOCK)
					    (
ERROR
)))
			 (if
 (
AND
 INITONPAGE ALIGN (
EQ
 GCTYPE CODEBLOCK.GCT)
				  (
GREATERP
 (
PLUS
 (fetch
 (POINTER CELLINSEGMENT) of
 NEWBLOCK)
						  #CELLS)
					    32768))
			     then
 (printout
 T "code segment crosses segment boundary" T)
				  (
ERROR
))
		  else
 [
SETQ
 OLDBLOCK (
CAR
 (
NTH
 TEST.\ALLOCBLOCK.LIST (
RAND
 1 (
LENGTH
 
									    TEST.\ALLOCBLOCK.LIST]
		       (printout
 T ,,, "DELETING array" ,,, "size=" (
CADR
 OLDBLOCK)
				 T)
		       (
SETQ
 TEST.\ALLOCBLOCK.LIST (
DREMOVE
 OLDBLOCK TEST.\ALLOCBLOCK.LIST)))
		(
\PARSEARRAYSPACE
])
)
(PUTPROPS VMEMBANG COPYRIGHT ("Xerox Corporation" 1985))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (376 5730 (TEST.ARRAYS 386 . 2025) (TEST.\ALLOCBLOCK 2027 . 5728)))))
STOP