;*; Updated on 24-Aug-93 at 1:42 AM by James A. Jarboe I V; edit time: 0:42:40
;
; DSPFLK.M68 --- display all FLOCK locks on system
;
; 1993-Aug-24 - Modified by James A. Jarboe IV
;               Fixed problem with Basic 1.4 having a pre-memory module
;               that does not have a name before the BASIC table.
;               Fixed to work with d/BASIC.
;               Fixed to work with AlphaBASIC+
;               The major part of this work is by Bob Fowler. 
;
; 1992-Feb-21 - created by Bob Fowler

;;;	COPY	SYS                     ; Bob uses SYS.M68 without Universal.

	SEARCH	SYS			; We search the universal.	[JAJ]
	SEARCH	SYSSYM			; Need SYSSYM for Pheader. 	[JAJ]

; I have taken the liberty to add the external library call from AMOS 2.x
; for those that may not have it. If DSPFLK does not work then I suggest
; that you uncomment the following line and comment out the code at the
; $FLSET: label and assemble DSPFLK with the AMOS SYSLIB.LIB library.			[JAJ]
;
;;;	AUTOEXTERN			; Using external library call.  [JAJ]


	VMAJOR	=	1.		; Added version number.		[JAJ]
	VMINOR	=	0
	VEDIT	=	101.	

START:	PHDR	-1,0,PH$REE!PH$REU	; Added standard Pheader.	[JAJ]

;------------------------------------------;
; PART 1 - find FLOCK.SBR in system memory ;
;------------------------------------------;

	MOV	SYSBAS,A0	; base of system memory modules
CHKRES:	MOV	@A0,D0		; end of modules?
	BEQ	MISING		; yes - FLOCK.SBR not found
	CMPW	6(A0), #[FLO]	; check for "FLOCK.SBR"
	BNE	NXTRES
	CMPW	10(A0),#[CK ]
	BNE	NXTRES
	CMPW	12(A0),#[SBR]
	BEQ	GOTFLK
NXTRES:	ADD	D0,A0		; skip to next module
	BR	CHKRES		; keep searching

MISING:	TYPECR	<FLOCK.SBR not in system memory>
	EXIT

;-------------------------------------;
; PART 2 - Locate FLOCK's queue links ;
;-------------------------------------;

; Two consequetive longwords in FLOCK are links to its lock queues.
; They are both initially zero when FLOCK.SBR is loaded into memory,
; and are the only bytes in FLOCK.SBR that change during execution.
;
; Various methods for finding these links:
;   (1) Use the actual relative address offset within FLOCK.SBR
;       Simple code, but certain to fail when FLOCK.SBR revised.
;       The link offset is given below for several versions of FLOCK.
;   (2) Look for 8 consequetive zero bytes in FLOCK.SBR (on disk).
;       In memory, these bytes are subject to change.
;       On disk, they are the only 8 consequetive zeros in FLOCK.
;       Exception: Patch SPN-404 to FLOCK created an unnecessary string
;       of 228 consequetive zero bytes, which thwarts this method.
;   (3) Look for what part of FLOCK changes during usage (in memory).
;       This works, but you may have to use FLOCK a bit before it works.
;   (4) Search for all "LEA An,label" commands within FLOCK.SBR.
;       The only such commands in FLOCK are those that access the links.
;       The bit pattern for these commands is 0 100 nnn 111 111 010.
;       Some internal checking is possible, because there are two links,
;       thus, exactly two values of "label" should exist, 4 bytes apart.
;       This method should be invulnerable to revisions in FLOCK.SBR.
;       This method works on disk or in memory.  It is used below.

; Information on various releases of FLOCK.SBR:
;
;   AMOS -------------FLOCK-------------          QUEUE
;   VERS VERSION    SIZE HASH CODE       COMMENTS  LINK
;   ---- ---------  ---- --------------- -------- -----
;   1.0  1.0(100)   1496 351-570-311-662           506
;   1.0A 1.0(100)-1 1532 440-073-715-727 SPN-039   506
;   1.1A 1.0(102)   1534 566-251-642-245           544
;   1.2  same
;   1.3  1.0(103)   1540 102-226-023-562           552
;   1.3B same
;   1.3C 1.0(103)-1 1802 526-065-507-735 SPN-404   552
;   1.3D 1.0(104)   1790 016-070-014-154             ?

GOTFLK:	MOV	A0,A1		; first address of module
	MOV	A0,A1		; last address of module = base ...
	ADD	@A0,A1		;   + size
	ADD	#14,A0		; skip header area
	MOV	#0,A3		; clear queue link

	TYPE	<FLOCK.SBR is at address >
	MOV	A0,D1
	OCVT	0,OT$TRM
	CRLF

	TYPE	<Possible FLOCK queue links at>
FNDLNK:	CMP	A0,A1		; end of FLOCK.SBR?
	BEQ	DSPFLK		;   yes - done
	MOVW	(A0)+,D0	; pick up next word of program
	ANDW	#170777,D0	; mask off register bits
	CMPW	D0,#040772	; is this an "LEA An,label" command?
	BNE	FNDLNK		; no - keep looking
	LEA	A2,@A0		; get address of LEA relative offset
	ADDW	@A0,A2		; sign extends to 32 bits before adding
; Display all potential queue links
	MOV	A2,D1		; set up OCVT
	OCVT	0,OT$TRM!OT$LSP	; output to terminal with lead space
; Do some checking against previous offsets
	CMP	A3,#0		; queue link found yet?
	BEQ	GOTLNK		;   no - copy it in
	SUB	A3,A2		; all addresses should be x and x+4
	CMP	A2,#0		; are they the same?
	BEQ	FNDLNK		;   yes - continue scan
	CMP	A2,#4		; is this address 4 bytes larger?
	BEQ	FNDLNK		;   yes - fine
	CMP	A2,#-4		; is this address 4 bytes smaller?
	BNE	BADLNK		;   no - bad news
	SUB	#4,A3		; yes - fine
	BR	FNDLNK		; keep looking

GOTLNK:	MOV	A2,A3		; queue link 
	BR	FNDLNK

BADLNK:	TYPECR	<Cannot determine where FLOCK.SBR queue links are>
	EXIT

;--------------------------------;
; PART 3 - Display current locks ;
;--------------------------------;

; A3 = address of FLOCK lock tree
DSPFLK:	CRLF
	TYPE	<Queue links assumed to be at >
	MOV	A3,D1
	OCVT	0,OT$TRM
	CRLF
	CRLF
	TYPECR	<Open FLOCK locks are as follows (FILEBASE 0):>
	GETIMP	MEMLTH,A0	; get user work area
NXTJOB:	MOV	@A3,A3		; next user 
	CMP	A3,#0		; any more?
	BEQ	LSTJOB		;   no - done
	LEA	A4,10(A3)	; base of file channel list
NXTCHN:	MOV	@A4,A4		; next file channel
	CMP	A4,#0		; any more?
	BEQ	NXTJOB		;   no - go to next job
	LEA	A5,14(A4)	; base of block list

; Three types of display formats
	BTST	#0,20(A4)	; check all-records-locked flag
	BNE	NXTALL		;   flag on - do all-block display
	TST	@A5		; any blocks locked?
	BNE	NXTBLK		;   yes - do one-block display
; Format 1 - no blocks locked
	CALL	DSPCHN		; display JOB/TERM/CHANNEL
	CRLF			; finish display line
	BR	NXTCHN		; next user
; Format 2 - all blocks locked
NXTALL:	CALL	DSPCHN		; display JOB/TERM/CHANNEL
	CALL	DSPALL		; display all-blocks
	CRLF			; finish display line
; Format 3 - one block locked
NXTBLK:	MOV	@A5,A5		; next block
	CMP	A5,#0		; any more blocks locked?
	BEQ	NXTCHN		;   no - go to next file
	CALL	DSPCHN		; display JOB/TERM/CHANNEL
	CALL	DSPBLK		; display BLOCK
	CRLF			; finish display line
	BR	NXTBLK		; next block
LSTJOB:	EXIT

; Display JOB,TERMINAL,CHANNEL
DSPCHN:	TYPE	<JOB >		; title
	MOV	4(A3),A1	; pointer to JCB
	LEA	A1,JOBNAM(A1)	; name of JOB (in RAD50)
	CALL	DSPSTR		; unpack and display on terminal

	TYPE	< - TERM >	; title
	MOV	4(A3),A1	; pointer to JCB
	MOV	JOBTRM(A1),A1	; link to terminal definition
; TRMDEF structure is undocumented - use FIX on TRMDEF.LIT to get it
	LEA	A1,-4(A1)	; name of terminal (in RAD50)
	CALL	DSPSTR		; display terminal name

; Display file channel	
	TYPE	< - CHANNEL>	; title
	MOV	4(A4),D1	; file channel #
	DCVT	6,OT$TRM ! OT$LSP ! OT$TSP	; display in decimal
	MOV	10(A4),A1	; link to other Queue list tree
	MOVW	10(A1),D0	; get inclusive/exclusive user count
	BLT	EXCCHN		; -1 = exclusive lock
	TYPE	<incl>		; inclusive file open
	BR	ALLCHN		; done
EXCCHN:	TYPE	<excl>		; exclusive file open
ALLCHN:

; If any of the undocumented constants below changes, disable routine
;;;	RTN			; to disable routine, return here

	TYPE	< (>
; Scan user's memory for AlphaBASIC control block (blank module name)
;[JAJ]
; Now we are going to check for any knownBASIC control block.
; and use the $FLSET library call to find the info we need.
; AlphaBasic has a blank module name.
; AlphaBasic 1.4 has a pre-blank module before the real control block,
;                which is also blank.
; AlphaBasic+ has a blank module name but different offsets.
; d/BASIC calls it's module name: DRUN.MEM
;[JAJ]

	MOV	4(A3),A1	; pointer to JCB
	MOV	JOBBAS(A1),A1	; base of user memory
CHKUSR:	MOV	@A1,D0		; end of modules?
	BEQ	NOFNM		;   yes - BASIC control block not found

; AlphaBasic 1.4 uses a pre-module that is 14.+2. in size. We check for
; 20. just in case it grows.
;
	CMP	D0, #20.	; Is module smaller than 20.?
	BLE	NXTUSR		; Yes..

	CMPW	6(A1), #[   ]	; check for blank module name
	BNE	DBASIC		;   ...
	CMPW	10(A1),#[   ]	;   ...
	BNE	DBASIC		;   ...
	CMPW	12(A1),#[   ]	;   ...
	BEQ	GOTBCB		;   Yes..use it.
DBASIC:	CMPW	6(A1), #[DRU]	; Is this d/BASIC's memory module?
	BNE	NXTUSR		;   ...
	CMPW	10(A1),#[N  ]	;   ...
	BNE	NXTUSR		;   ...
	CMPW	12(A1),#[MEM]	;   ...
	BEQ	GOTBCB		; Yes..use it.

NXTUSR:	ADD	D0,A1		; skip to next module
	BR	CHKUSR		; keep searching

; use blank file name
NOFNM:	TYPE	<------>	; no file open on this channel
	BR	ENDFNM

; Second, locate channel in AlphaBASIC open file table
;
GOTBCB:	ADD	#14,A1		; skip past AMOS module header

; DSPFLK's work area (from GETIMP) is also memory module with blank name
;
	CMP	A1,A0		; did we find DSPFLK's impure area?
	BEQ	NOFNM		;   yes - BCB not found
	PUSH	A0		; Save A0 as call needs it.
	MOV	A1, A0		; Set up for FLSET call.
	MOV	4(A4), D1	; Preset file channel to find.
	CALL	$FLSET		; Use what ever method needed.
	POP	A0		; Restore register.
	BNE	NOFNM		; Opps...not found.

;[JAJ] - Following commented out as $FLSET call does the work no matter
;        what basic is used.
;
;	MOV	34(A1),A2	; AlphaBASIC open files (undocumented)
;	ADD	#2,A2		; first word in table is a dummy zero
;	MOV	4(A4),D1	; file channel #
;SCNBCB:	CMP	A2,40(A1)	; end of open files? (undocumented)
;	BEQ	NOFNM		;   yes - file not open
;	CMPW	D1,152(A2)	; file channel match? (undocumented)
;	BEQ	GOTFNM		;   yes - got open file
;	ADDW	150(A2),A2	; size of open file entry (undocumented)
;	BR	SCNBCB		; check next open file
;[JAJ] - 


GOTFNM:	LEA	A1,D.FIL(A2)	; open file name (in standard AMOS DDB)
	CALL	DSPSTR		; display open file name
ENDFNM:	TYPE	<)>
	RTN

; Display one block locked
DSPBLK:	TYPE	< - BLOCK>
	MOV	4(A5),D1	; block #
	DCVT	6,OT$TRM ! OT$LSP ! OT$TSP	; display in decimal
	MOV	10(A5),A1	; link to other Queue list tree
	MOVW	10(A1),D0	; get inclusive/exclusive user count
	BLT	EXCBLK		; -1 = exclusive lock
	TYPE	<incl>		; inclusive block lock
	BR	ALLBLK
EXCBLK:	TYPE	<excl>		; exclusive block lock
ALLBLK:	RTN

; Display all blocks locked
DSPALL:	TYPE	<   BLOCK (all)  incl>
	RTN

; Unpack 4-byte RAD50 string and display on terminal
DSPSTR:	LEA	A2,WRKSTR(A0)	; ASCII destination
	UNPACK			; unpack 2 RAD50 bytes to 3 ASCII bytes
	UNPACK			; unpack 2 more
	CLRB	@A2		; terminating null
	LEA	A2,WRKSTR(A0)	; go back to beginning of string
	TTYL	@A2		; display job name
	RTN

; [JAJ]
; $FLSET From AMOS 2.x SYSLIB.LIB library. Normally this routine is used
; in an basic XCALL to find on open file in BASIC. Here we just set
; up the registers and return what is needed for DSPFLK.
;
; Incoming:
;    A0	-> Contains the AlphaBasic impure area pointer.
;    D1 -> Contains the file channel number.
;
; Outgoing:
;    A2 -> Indexes the file DDB
;    Z set = File found opened.
;    Z clr = File not open.
;
$FLSET:	CMP	@A0,#-2			; Is this AlphaBasic+?
	BNE	SFLSET			; No..do it the standard way.
	SAVE	D0,D7,A0,A1,A3,A4,A5
	MOV	A0,A5
	MOV	A1,A3
	PUSH	D1
	MOV	42(A5),A6
	ADD	#100000,A5
	CALL	@A6
	ADD	#4,SP
	MOV	A6,D7
	REST	A5,A4,A3,A1,A0,D7,D0
	BEQ	10$
	MOV	@A6,A2
	LCC	#4
	RTN

10$:	SUB	A2,A2
	LCC	#0
	RTN

SFLSET:	MOV	34(A0),A2
	ADD	#2,A2
10$:	CMP	A2,40(A0)
	BEQ	30$
	CMPW	D1,152(A2)
	BEQ	20$
	ADDW	150(A2),A2
	BR	10$

20$:	LEA	A6,202(A2)
	MOV	A6,22(A2)
	LCC	#4
	RTN

30$:	LCC	#0
	RTN

;; End of FLSET routine.
;; [JAJ]

	ASECT
	.=0
; Symbols for impure work.buffer area - MUST BE PUT HERE
; (if put at beginning, FIX uses these labels instead of PSECT labels !)

WRKSTR:	BLKB	8.		; work area - six ASCII bytes + null
MEMLTH:				; memory used

	END


.