trivia-1976-1977/trivia/9006234/ar1.tv/lister.13

<DEFINE SFIND (GZORK "OPTIONAL" (D ,TVASS)) #DECL ((GZORK) FIX (D) ASYLUM)
  <PRINC "
Id     Address	   Length    Data">
  <REPEAT ((CT 0)(UV1 ,DUV1)(FROB <+ <* <MFDPAGE ,TVASS> 1024> ,DIRPTRS>))
    #DECL ((CT FROB) FIX (UV1) <UVECTOR <PRIMTYPE WORD>>)
    <COND (<0? <CHTYPE <1 <GET-LOC .FROB .UV1>> FIX>>
	   <RETURN>)
	  (T
	   <FINDIT .CT .D .GZORK>
	   <SET CT <+ .CT 1>>
	   <SET FROB <+ .FROB 1>>)>>>

<DEFINE FINDIT (DIRNUM D "OPTIONAL" (TARGET 0)
	       "AUX" LOC HI (DUV ,DATUV) (UV1 ,DUV1) DPAGE TEMP)
   #DECL ((DIRNUM TARGET TEMP) FIX (D) ASYLUM (LOC HI) FIX (DPAGE) <OR FALSE FIX>
	  (UV1) <UVECTOR [1 WORD]> (DUV) <UVECTOR [4 WORD]>)
   <COND
    (<SET DPAGE <DIR-FIND .D <* .DIRNUM ,DIRSIZE>>>
     <SET HI <CHTYPE <1 <GET-LOC <+ ,HIGHID <* <MFDPAGE .D> 1024>> .UV1>> FIX>>
     <SET LOC <+ <* .DPAGE 1024> ,OBJSTART>>
     <REPEAT ((NAME <* .DIRNUM ,DIRSIZE>) (FOO ,DIRSIZE) BAR)
	     #DECL ((NAME FOO BAR) FIX)
	     <COND
	      (<OR <1? .FOO> <G? .NAME .HI>> <PRINC .DIRNUM> <RETURN>)
	      (T
	       <SET BAR <CHTYPE <NTH <GET-LOC .LOC ,NAMUV> <+ ,NAMDATA 1>> FIX>>
	       <COND (<==? .TARGET <CHTYPE <NTH ,NAMUV <+ ,NAMMISC 1>> FIX>>
		      <CRLF> 
		      <PRIN1 .NAME>
		      <INDENT-TO 7> 
		      <AND <==? <NTH ,NAMUV 1> #WORD *0*> <PRINC "*">>
		      <PRIN1 .BAR>
		      <INDENT-TO 19>
		      <PRIN1 <CHTYPE <NTH ,NAMUV <+ ,NAMCHNCDR 1>> FIX>>
		      <INDENT-TO 29>
		      <PRIN1 <COND (<OR <0? .TARGET>
					<N==?
					 <SET TEMP
					      <CHTYPE <NTH ,NAMUV <+ ,NAMMISC 1>> FIX>>
					 .TARGET>> .TEMP)
				   ("**WINNER**")>>)>
	       <SET NAME <+ .NAME 1>>
	       <SET FOO <- .FOO 1>>
	       <SET LOC <+ .LOC ,NAMBLKLEN>>)>>)>>
<DEFINE LISTF (DIRNUM D "AUX" LOC HI (DUV ,DATUV) (UV1 ,DUV1) DPAGE)
   #DECL ((DIRNUM) FIX (D) ASYLUM (LOC HI) FIX (DPAGE) <OR FALSE FIX>
	  (UV1) <UVECTOR [1 WORD]> (DUV) <UVECTOR [4 WORD]>)
   <COND
    (<SET DPAGE <DIR-FIND .D <* .DIRNUM ,DIRSIZE>>>
     <SET HI <CHTYPE <1 <GET-LOC <+ ,HIGHID <* <MFDPAGE .D> 1024>> .UV1>> FIX>>
     <SET LOC <+ <* .DPAGE 1024> ,OBJSTART>>
     <PRINC "
Id     Address     Length    Data">
     <REPEAT ((NAME <* .DIRNUM ,DIRSIZE>) (FOO ,DIRSIZE) BAR)
	     #DECL ((NAME FOO BAR) FIX)
	     <COND
	      (<OR <1? .FOO> <G? .NAME .HI>> <RETURN <CRLF>>)
	      (T
	       <COND (<AND <0? <SET BAR
			           <CHTYPE <NTH <GET-LOC .LOC ,NAMUV>
					        <+ ,NAMDATA 1>>
				           FIX>>>
			   <==? <NTH ,NAMUV <+ ,NAMMISC 1>> #WORD *0*>>
		      <COND (<0? <SET BAR 
				      <CHTYPE <NTH ,NAMUV <+ ,NAMCHNCDR 1>> FIX>>>)
			    (<CRLF>
			     <PRINC !"[>
			     <PRIN1 .NAME>
			     <PRINC !"]>)>)
		     (<CRLF> 
		      <PRIN1 .NAME>
		      <INDENT-TO 7> 
		      <AND <==? <NTH ,NAMUV 1> #WORD *0*> <PRINC "*">>
		      <PRIN1 .BAR>
		      <INDENT-TO 19>
		      <PRIN1 <CHTYPE <NTH ,NAMUV <+ ,NAMCHNCDR 1>> FIX>>
		      <INDENT-TO 29>
		      <PRIN1 <CHTYPE <NTH ,NAMUV <+ ,NAMMISC 1>> FIX>>)>
	       <SET NAME <+ .NAME 1>>
	       <SET FOO <- .FOO 1>>
	       <SET LOC <+ .LOC ,NAMBLKLEN>>)>>)>>

<DEFINE LISTA (D
	       "AUX" (MFD <* <MFDPAGE .D> 1024>) (ALLOC <* <ALLOCPAGE .D> 1024>)
		     HIGH LO CNT ALOC)
	#DECL ((D) ASYLUM (MFD ALLOC CNT ALOC) FIX)
	<ALLOC-MAP .D>
	<PRINC "
Database Allocator Statistics">
	<SET ALPTR <1 <GET-LOC .ALLOC ,DUV1>>>
	<SET CNT
	     <CHTYPE <ORB <GETBITS .ALPTR <BITS 18 18>> #WORD *777777000000*>
		     FIX>>
	<CRLF>
	<SET ALOC
	     <+ <CHTYPE <ANDB <GETBITS .ALPTR <BITS 18 0>> #WORD *000000001777*>
			FIX>
		.ALLOC>>
	<CRLF>
	<PRINC "From     To     Length">
	<REPEAT ((UV ,AUV2))
		<GET-LOC .ALOC .UV>
		<CRLF>
		<PRIN1 <SET LO <CHTYPE <2 .UV> FIX>>>
		<PRINC "	 ">
		<PRIN1 <SET HIGH <+ .LO <CHTYPE <1 .UV> FIX>>>>
		<PRINC "	">
		<PRIN1 <- .HIGH .LO>>
		<SET ALOC <+ .ALOC 2>>
		<SET CNT <+ .CNT 2>>
		<AND <0? .CNT> <RETURN <CRLF>>>>>

<DEFINE LISTM (D
	       "AUX" (MFD <* <MFDPAGE .D> 1024>) (ALLOC <* <ALLOCPAGE .D> 1024>)
		     HIGH LO CNT ALOC (DUV ,DUV1) A)
	#DECL ((D) ASYLUM (MFD ALLOC CNT ALOC) FIX (DUV) <UVECTOR [1 WORD]>
	       (A) <PRIMTYPE WORD>)
	<SET A <1 <GET-LOC <+ .MFD ,DPGLOCK> .DUV>>>
	<PRINC "
MFD Lock -- ">
	<COND (<==? .A #WORD *000000000000*> <PRINC "LOCKED">)
	      (<PRINC "UNLOCKED">)>
	<PRINC "
UP time -- ">
	<PDSKDATE <1 <GET-LOC <+ .MFD ,DINITRQ> .DUV>>>
	<PRINC "
ALTER time -- ">
	<PDSKDATE <1 <GET-LOC <+ .MFD ,DINITDN> .DUV>>>
	<SET CNT
	     <CHTYPE <ORB <GETBITS <1 <GET-LOC .ALLOC .DUV>>
				   <BITS 18 18>>
			  #WORD *777777000000*>
		     FIX>>
	<PRINC "
ALLOCATOR Use -- ">
	<PRIN1 <SET ALOC </ <- .CNT> 2>>>
	<PRINC " entries [">
	<PRIN1 </ <* .ALOC 100> 511>>
	<PRINC "%]">
	<PRINC "
ALLOCATOR Lock -- ">
	<COND (<==? <1 <GET-LOC <+ .MFD ,ALLOCLOCK> .DUV>>
		    #WORD *000000000000*>
	       <PRINC "LOCKED">)
	      (<PRINC "UNLOCKED">)>
	<PRINC "
High Address -- ">
	<PRIN1 <SET A <CHTYPE <1 <GET-LOC <+ .MFD ,HIGHADR> .DUV>> FIX>>>
	<PRINC " [Page ">
	<PRIN1 </ .A 1024>>
	<PRINC "]">
	<PRINC "
Maximum Address -- ">
	<PRIN1 <SET A <CHTYPE <1 <GET-LOC <+ .MFD ,MAXADR> .DUV>> FIX>>>
	<PRINC " [Page ">
	<PRIN1 </ .A 1024>>
	<PRINC "]">
	<PRINC "
High ID -- ">
	<PRIN1 <CHTYPE <1 <GET-LOC <+ .ALLOC ,HIGHID> .DUV>> FIX>>
	<REPEAT ((N ,DIRPTRS) (DIR 0))
		#DECL ((N DIR) FIX)
		<COND (<0? <SET A <CHTYPE <1 <GET-LOC <+ .MFD .N> .DUV>> FIX>>>
		       <RETURN>)
		      (<CRLF>
		       <PRINC "Directory ">
		       <PRIN1 .DIR>
		       <PRINC " at ">
		       <PRIN1 .A>
		       <PRINC " [Page ">
		       <PRIN1 </ .A 1024>>
		       <PRINC "]">
		       <SET N <+ .N 1>>
		       <SET DIR <+ .DIR 1>>)>>
	<REPEAT ((N ,PGLOCKS))
		<COND (<==? .N 1024> <RETURN>)
		      (T
		       <COND (<==? <1 <GET-LOC <+ .MFD .N> .DUV>>
				   #WORD *000000000000*>
			      <PRINC "
Pages Locked from ">
			      <PRIN1 <SET A </ <- .N ,PGLOCKS> .P/L>>>
			      <PRINC " to ">
			      <PRIN1 <+ .A ,P/L>>)>
		       <SET N <+ .N 1>>)>>
	,NULL>

<DEFINE LISTB (DC "OPTIONAL" (VERB <>) (SALV <>)
		   "AUX" (MFD <* <MFDPAGE .DC> 1024>) (UV1 ,DUV1) (DUV ,NAMUV)
			 (ALLOCK <+ .MFD ,ALLOCLOCK>) DF HI FROB (LOST 0) MOBY)
   #DECL ((DC) ASYLUM (MFD ALLOCK) FIX (UV1) <UVECTOR [1 WORD]> (HI) WORD
	  (LOST) FIX (DUV) <UVECTOR [4 WORD]> (DF) <OR FALSE FIX>
	  (MOBY) <UVECTOR [REST WORD]> (VERB SALV) <OR 'T FALSE>)
   <ALLOC-MAP .DC>
   <SET HI <1 <GET-LOC <+ ,HIGHID <* <ALLOCPAGE .DC> 1024>> .UV1>>>
   <SET ALPTR
	<+ <* 1024 <ALLOCPAGE .DC>>
	   <CHTYPE <ANDB <1 <GET-LOC <* <ALLOCPAGE .DC> 1024> .UV1>>
			 #WORD *000000001777*>
		   FIX>>>
   <SET MOBY
	<IUVECTOR <+ 4
		     <* <CHTYPE .HI FIX> 2>
		     <SET ALLEN <- <+ 1023 <* <ALLOCPAGE .DC> 1024>> .ALPTR>>>
		  #WORD *000000000000*>>
   <GET-LOC-X .ALPTR <REST .MOBY 2> .ALLEN>
   <PUT .MOBY 1 #WORD *777777003777*>
   <PUT .MOBY 2 #WORD *000000000001*>
   <SET MOBY <REST .MOBY <+ 2 .ALLEN>>>
   <REPEAT ((DIR <+ .MFD ,DIRPTRS>) (DIRNUM 0) (ID 0))
     #DECL ((DIR DIRNUM ID) FIX)
     <COND
      (<OR <0? <CHTYPE .DIR FIX>>
	   <NOT <SET DF <DIR-FIND .DC <* .DIRNUM ,DIRSIZE>>>>>
       <RETURN>)
      (<SET DPG <+ ,OBJSTART <* 1024 .DF>>>
       <REPEAT ((NUM ,DIRSIZE) (WHR 0) WD)
	       <COND (<OR <EMPTY? .MOBY> <0? .NUM>> <RETURN>)
		     (<GET-LOC .DPG .DUV>
		      <AND <==? <NTH .DUV <+ ,NAMDATA 1>> #WORD *000000000000*>
			   <SET DPG <+ .DPG ,NAMBLKLEN>>
			   <SET LOST <+ .LOST 2>>
			   <SET NUM <- .NUM 1>>
			   <SET WHR <+ .WHR 1>>
			   <AGAIN>>
		      <PUT .MOBY 2 <NTH .DUV <+ ,NAMDATA 1>>>
		      <SET WD <NTH .DUV <+ ,NAMCHNCDR 1>>>
		      <PUT .MOBY
			   1
			   <PUTBITS .WD
				    <BITS 18 18>
				    <CHTYPE <+ <* .DIRNUM ,DIRSIZE> .WHR>
					    WORD>>>
		      <SET MOBY <REST .MOBY 2>>
		      <SET DPG <+ .DPG ,NAMBLKLEN>>
		      <SET NUM <- .NUM 1>>
		      <SET WHR <+ .WHR 1>>)>>
       <SET DIRNUM <+ .DIRNUM 1>>)>>
   <SET MOBY <SORT <> <TOP .MOBY> 2 1>>
   <AND .VERB
        <PRINC "
From     To     Length    Use">>
   <REPEAT ((M .MOBY) LO HI (LSTLO -1) (LSTHI -1) (LSTM -1))
	   #DECL ((LO HI LSTLO LSTHI) FIX (M) UVECTOR)
	   <AND <EMPTY? .M> <RETURN>>
	   <AND <==? <1 .M> #WORD *000000000000*>
		<SET M <REST .M 2>>
		<AGAIN>>
	   <SET LO <CHTYPE <2 .M> FIX>>
	   <SET HI <+ <CHTYPE <2 .M> FIX>
		      <CHTYPE <GETBITS <1 .M> <BITS 18>> FIX>>>
	   <COND (<==? .LO .LSTLO>
		  <SALVERR "**SHARED BLOCK**" .LSTLO .LSTHI .LSTM .LO .HI <1 .M>>)
		 (<L? .LO .LSTHI>
		  <SALVERR "**BLOCKS OVERLAP**" .LSTLO .LSTHI .LSTM .LO .HI <1 .M>>)
		 (<AND .SALV
		       <G? .LO .LSTHI>
		       <0? <CHTYPE <GETBITS <1 .M> <BITS 18 18>> FIX>>
		       <0? <CHTYPE <GETBITS .LSTM <BITS 18 18>> FIX>>>
		  <CRLF>
		  <PRINC "DEALLOCATING BLOCK - Length = ">
		  <PRIN1 <- .LO .LSTHI>>
		  <PRINC "  Location = ">
		  <PRIN1 .LSTHI>  
		  <SALVDEALLOC .DC <- .LO .LSTHI> .LSTHI>)>
	   <AND .VERB
		<PBLOCK .LO .HI <1 .M>>>
	   <SET LSTLO .LO>
	   <SET LSTHI .HI>
	   <SET LSTM <1 .M>>
	   <SET M <REST .M 2>>>>

<DEFINE PRTYPE (WD "AUX" HOW)
    #DECL ((WD) WORD (HOW) FIX)
    <COND (<0? <SET HOW <CHTYPE <GETBITS .WD <BITS 18 18>> FIX>>>
 	   <PRINC "Unallocated">)
	  (<==? <CHTYPE .HOW WORD> #WORD *000000777777*>
	   <PRINC "Reserved">)
	  (<PRINC "Object #"> <PRIN1 .HOW>)>>

<DEFINE SALVERR (ERR LLO LHI LM LO HI M)
    #DECL ((ERR) STRING (LLO LHI LO HI) FIX (LM M) WORD)
    <PRINC "
ERROR -- ">
    <PRINC .ERR>
    <PBLOCK .LLO .LHI .LM>
    <PBLOCK .LO .HI .M>
    <CRLF>>

<DEFINE PBLOCK (LO HI M)
    #DECL ((LO HI) FIX (M) WORD)
    <CRLF>
    <PRIN1 .LO>
    <INDENT-TO 9>
    <PRIN1 .HI>
    <INDENT-TO 16>
    <PRIN1 <CHTYPE <GETBITS .M <BITS 18>> FIX>>
    <INDENT-TO 26>
    <PRTYPE .M>>
<DEFINE LISTU ("AUX" (ALL <* 1024 <ALLOCPAGE ,TVASS>>) HI V)
    #DECL ((ALL HI) FIX (V) UVECTOR)
    <SET HI <CHTYPE <1 <GET-LOC <+ .ALL ,HIGHID> ,DUV1>> FIX>>
    <SET V <AIUVECTOR ,MOBYSPACE <- .HI 1> 0>>
    <REPEAT ((VEC .V) (N 1) FX)
	#DECL ((VEC) UVECTOR (N FX) FIX)
	<AND <==? .N .HI> <RETURN>>
	<SET FX <CHTYPE <DATA-READW .N ,TVASS> FIX>>
	<COND (<AND <G? .FX 0> <L? .FX .HI>>
	       <PUT .VEC .FX 1>)>
	<SET N <+ .N 1>>>
    <MAPR <>
	<FUNCTION (X "AUX" FOO)
	    #DECL ((X) UVECTOR (FOO) FIX)
	    <COND (<1? <1 .X>>)
		  (<DATA-AREAD ,TVASS <SET FOO <- <LENGTH .V> <LENGTH .X> -1>>
			 <ARESET ,TVSPACE>>
		   <COND (<OR <MEMQ <- .FOO 3> ,LOSSTABLE>
			      <MEMQ <- .FOO 6> ,LOSSTABLE>>)
		         (<PRINC "
Non-referenced object #">
		 	  <PRIN1 .FOO>)>)>>
	.V>
    ,NULL>