; ************************** AMUS Program Label ******************************
; Filename: WLDSCN.M68 -> WLDSCN.OBJ -> WLDSCN.LIB          Date: 02/06/90
; Category: UTIL         Hash Code: 275-510-373-412      Version: 2.0(106)
; Initials: ULTR/AM      Name: DAVID PALLMANN
; Company: ULTRASOFT CORPORATION                   Telephone #: 5163484848
; Related Files:                                                     
; Min. Op. Sys.: AMOSL 1.3B                    Expertise Level: BEG
; Special: .M68 WLDSCN then .LIBLIT WLDSCN=WLDSCN to make WLDSCN.LIB
; Description: Wildcard directory scanner.  Supports traditional and
; extended directory formats.  Required by many utilities that perform
; wildcard directory processing (such as D.LIT). Requires 2.0 assembler
; ****************************************************************************

;****************************************************************************
;*									    *
;*				   WLDSCN				    *
;*			 Wildcard Directory Scanner			    *
;*									    *
;****************************************************************************
;Copyright (C) 1986, 1989 UltraSoft Corp.  All Rights Reserved.
;
;Written by: David Pallmann
;
;Edit History:
;1.0(100)  20-Dec-83 created. /DFP
;1.1(101)  09-Feb-84 add hyphen ('not') command line prefix support. /DFP
;1.2(102)  12-Sep-86 add WLIST and WFULL calls. /DFP
;1.3(103)  12-Sep-86 add support of AMOS/L 1.3 user-defineable ersatz
;                    devices. /DFP
;1.4(104)  15-Sep-86 allow PPN spec before or after file spec. /DFP
;1.5(105)  27-Sep-86 add @ (alphabetic wildcard) and # (digit wildcard)
;                    support. /DFP
;1.6(106)  05-May-88 fix bug with device drivers not in system memory. /DFP
;1.6A(107) 03-Oct-88 change CMMx's to CMP's where allowed for compacter
;                    code. /DFP
;1.7(108)  30-Dec-88 add support for AMOS 2.0 extended directory
;                    structure. /DFP
;1.7A(109) 30-Dec-88 add WS$DEL flag to return deleted file entries. /DFP
;1.8(110)  19-Feb-89 add {output=}input support. /DFP
;1.8(111)  21-Apr-89 don't process deleted PPNs!. /DFP
;1.8(112)  14-Jul-89 fix problem with redirection & length of filenames. /DFP
;1.8(113)  27-Nov-89 fix ersatz/non-DSK device problems. /DFP
;1.9(114)  06-Feb-90 fix bug where we returned deleted files when processing
;		     extended directories. /DFP

	INTERN	W.INIT,W.SPEC,W.SCAN,W.FULL,W.LIST,W.DEL,W.OUT

	SEARCH	SYS
	SEARCH	SYSSYM

;MFD symbols (traditional directory structure)

	MF.LNK	=506.
	MF.PPN	=0
	MF.UFD	=2
	MF.SIZ	=8.

;UFD symbols (traditional directory structure)

	UF.FIL	=0
	UF.EXT	=4
	UF.BLK	=6
	UF.ACT	=10
	UF.LNK	=12
	UF.SIZ	=14

;extended directory MFD entry

	.OFINI
	.OFDEF	D$TYP,	4		; flags
	.OFDEF	D$PRT,	4		; protection code
	.OFDEF	D$DAT,	4*3		; creation, update, backup dates
	.OFDEF	D$NXT,	4		; pointer to next directory level
	.OFDEF	D$CUR,	4		; reserved
	.OFDEF	D$PRV,	4		; reserved
	.OFDEF	D$NAM,	6		; account information
	.OFDEF	D$SIZ			; size of entry

;extended directory UFD entry

	.OFINI
	.OFDEF	D$TYP,	4		; flags
	.OFDEF	D$PRT,	4		; protection code
	.OFDEF	D$DAT,	4*3		; creation, update, backup dates
	.OFDEF	D$BAS,	4		; base of file
	.OFDEF	D$FSZ,	4		; file size
	.OFDEF	D$RSV,	2		; default record size
	.OFDEF	D$LSZ,	2		; bytes in last block
	.OFDEF	D$NAM,	6		; filename information
	.OFDEF	D$SIZ			; size of entry

;impure	area

	.OFINI
	.OFDEF	WS.DDB,D.DDB		; DDB for disk I/O
	.OFDEF	WS.REN,6		; rename area			[109]
	.OFDEF	WS.DEV,4		; device code RAD50		[103]
	.OFDEF	WS.DRV,2		; drive number
	.OFDEF	WS.FIL,6		; filename
	.OFDEF	WS.EXT,4		; extension
	.OFDEF	WS.PRG,3		; programmer number
	.OFDEF	WS.PRJ,3		; project number
	.OFDEF	WS.TMP,10.		; temporary storage
	.OFDEF	WS.DFX,4		; default extension
	.OFDEF	WS.DTI,4		; device table index
	.OFDEF	WS.MFL,4		; MFD link
	.OFDEF	WS.MFB,512.		; MFD buffer
	.OFDEF	WS.MFI,4		; MFD index
	.OFDEF	WS.RPN,2		; remaining PPNs in MFD block
	.OFDEF	WS.UFL,4		; UFD link
	.OFDEF	WS.UFB,512.		; UFD buffer
	.OFDEF	WS.UFI,4		; UFD index
	.OFDEF	WS.RFN,2		; remaining files in UFD block
	.OFDEF	WS.FLG,4		; flags:
		WS$DEV	=1		;   device was specified
		WS$ALL	=2		;   device ALL: was specified
		WS$ERZ	=4		;   erastz device was specified
		WS$FIL	=10		;   filename was specified
		WS$EXT	=20		;   extension was specified
		WS$PPN	=40		;   [P,PN] was specified
		WS$ERR	=100		;   specification invalid
		WS$UNM	=200		;   device not mounted
		WS$DNE	=400		;   device does not exist
		WS$NOT	=1000		;   'NOT' specified
		WS$EXD	=2000		;   current device is extended format	[108]
		WS$DEL	=4000		;   return deleted file entries
		WS$OUT	=10000		;   redirection (output=input) specified [110]
	.OFDEF	WS.ODV,4		; redirected device code RAD50	[110]
	.OFDEF	WS.ODR,2		; redirected drive number	[110]
	.OFDEF	WS.OFL,6		; redirected filename		[110]
	.OFDEF	WS.OEX,4		; redirected extension		[110]
	.OFDEF	WS.OPG,3		; redirected programmer number	[110]
	.OFDEF	WS.OPJ,3		; redirected project number	[110]
	.OFSIZ	WS.IMP

;macros

DEFINE	MOVBLK	SRC,DST,SIZE
	MOV	#SIZE-1,D0
	LEA	A0,SRC
	LEA	A1,DST
10$$:	MOVB	(A0)+,(A1)+
	DBF	D0,10$$
	ENDM

DEFINE	CEQ	ADDR
	BNE	1$$
	CALL	ADDR
1$$:
	ENDM

DEFINE	CNE	ADDR
	BEQ	1$$
	CALL	ADDR
1$$:
	ENDM

DEFINE	REQ
	BNE	1$$
	RTN
1$$:
	ENDM

DEFINE	BIT	SRC,DST
	MOV	DST,D7
	AND	SRC,D7
	ENDM

DEFINE	BITW	SRC,DST
	MOVW	DST,D7
	ANDW	SRC,D7
	ENDM

PAGE
;************
;*  W.INIT  *
;************
;Function:	Allocate local memory for other WLDSCN calls
;
;Outputs:	A4 - set to base of impure area MEM:WLDSCN.IMP

W.INIT:	GETIMP	WS.IMP,A4		; allocate impure area
	MOVW	#[IMP],-2(A4)		; name module WLDSCN.IMP
	MOVW	#[SCN],-4(A4)		; 
	MOVW	#[WLD],-6(A4)		; 
	INIT	WS.DDB(A4)		; 
	CLR	WS.DDB+D.DVR(A4)	; 				[113]
	RTN				; 

PAGE
;************
;*  W.SPEC  *
;************
;Function:	Process wildcard file specification
;
;Inputs:	A2 - address of file specification
;		A4 - address of work area (normally set-up by W.INIT)
;
;Outputs:	Z  - set if specification is valid, -or- cleared if invalid
;		A2 - updated past file specification

W.SPEC:	POP	A6			; 
	MOV	(A6)+,WS.DFX(A4)	; 
	PUSH	A6			; 
	CLR	WS.FLG(A4)		; clear flags
	CMPB	@A2,#'-			; leading dash?			[1.1]
	BNE	10$			;  no				[1.1]
	OR	#WS$NOT,WS.FLG(A4)	;  yes - set NOT flag		[1.1]
	INC	A2			;  bypass dash			[1.1]
	BYP				;  bypass white space		[1.1]
10$:	CALL	DEFDEV			; set default device
	CALL	CHKDEV			; device specified?
	CEQ	GETDEV			; yes -	get device
	CALL	DEFFIL			; set default filename
	CALL	DEFPPN			; set default PPN
	CALL	CHKPPN			; 
	CEQ	GETPPN			; 
	CALL	CHKFIL			; filename specified?
	CEQ	GETFIL			;  yes - get filename
	CALL	DEFEXT			; set default extension
	CALL	CHKEXT			; extension specified?
	CEQ	GETEXT			;  yes - get extension
	CALL	CHKPPN			; PPN specified?
	CEQ	GETPPN			;  yes - get PPN
	CALL	CHKRED			; redirection present?		[110]
	BNE	20$			;   no				[110]
	CALL	GETRED			; shift input specs to output	[110]
	BR	10$			; go get input specs again	[110]
20$:	CALL	INIMEM			; initialize impure area
	CALL	ERROR			; display errmsg if required
	RTN				; 

;************
;*  DEFDEV  *
;************
;Function:	Define default device

DEFDEV:	MOV	JOBCUR,A6		; 
	MOVW	JOBDEV(A6),WS.DEV(A4)	; 
	CLRW	WS.DEV+2(A4)		; 				[113]
	MOVW	JOBDRV(A6),WS.DRV(A4)	; 
	RTN				; 

;************
;*  CHKDEV  *
;************
;Function:	Check for device specification

CHKDEV:	SAVE	A2,D0			; 
	MOV	#6,D0			; 
10$:	ALF				; 
	BEQ	20$			; 
	NUM				; 
	BEQ	20$			; 
	BR	30$			; 
20$:	INC	A2			; 
	SOB	D0,10$			; 
30$:	CMPB	@A2,#':			; 				[1.6A]
	BNE	40$			; 
	OR	#WS$DEV,WS.FLG(A4)	; 
	REST	A2,D0			; 
	LCC	#PS.Z			; 
	RTN				; 
40$:	REST	A2,D0			; 
	LCC	#0			; 
	RTN				; 

;************
;*  GETDEV  *
;************
;Function:	Get device specification

GETDEV:	SAVE	A1			; 
	LEA	A1,WS.DEV(A4)		; 
	CLR	@A1			; 				[113]
	PACK				; 
	SAVE	A1,A2			; 
	GTDEC				; 
	MOVW	D1,WS.DRV(A4)		; 
	REST	A1,A2			; 
	PACK				; 
10$:	INC	A2			; 
	CMP	WS.DEV(A4),#[ALL]_16.	;  				[1.6A]
	BNE	20$			; 
	OR	#WS$ALL,WS.FLG(A4)	; 
	REST	A1			; 
	RTN				; 
20$:	CALL	ERZDEV			; 
	CALL	PHYDEV			; 
	REST	A1			;  
	RTN				; 

;************
;*  PHYDEV  *
;************
;Function:	Search for mounted physical device matching specification

PHYDEV:	MOV	DEVTBL,A6		; 
10$:	CMMW	DV.DEV(A6),WS.DEV(A4)	; 
	BNE	30$			; 
	CMMW	DV.UNT(A6),WS.DRV(A4)	; 
	BNE	30$			; 
	BITW	#DV$MNT,DV.FLG(A6)	; 
	BNE	20$			; 
	OR	#<WS$ERR!WS$UNM>,WS.FLG(A4)
20$:	LCC	#PS.Z			; 
	RTN				; 
30$:	TST	@A6			; 
	BEQ	40$			; 
	MOV	@A6,A6			; 
	BR	10$			; 
40$:	OR	#<WS$ERR!WS$DNE>,WS.FLG(A4)
	LCC	#0			; 
	RTN				; 

;************
;*  ERZDEV  *
;************
;Function:	Search for device in ersatz table

ERZDEV:	SAVE	A0			;  
	TST	ERSATZ			; new ersatz table defined?
	JNE	ERZNEW			;  yes - use it

;no user-defineable ersatz table, use our own definitions of OPR:, SYS:, etc.

ERZOLD:	TSTW	WS.DEV+2(A4)		; >3 character ersatz name?	[113]
	BNE	20$			;   yes - automatically not found [113]
	LEA	A0,ERZTBL		; 
10$:	TSTW	@A0			; 
	BEQ	20$			; 
	ADD	#4,A0			; 
	CMMW	-4(A0),WS.DEV(A4)	; 
	BNE	10$			; 
	BR	30$			; 
20$:	REST	A0			; 
	LCC	#0			; 
	RTN				; 
30$:	SAVE	A2,D1			; 
	CLR	D1			; 
	LEA	A2,WS.PRG(A4)		; 
	MOVB	-2(A0),D1		; 
	MOVB	#40,@A2			; 
	MOVB	#40,1(A2)		; 
	MOVB	#40,2(A2)		; 
	OCVT	0,OT$MEM		; 
	LEA	A2,WS.PRJ(A4)		; 
	MOVB	-1(A0),D1		; 
	MOVB	#40,@A2			; 
	MOVB	#40,1(A2)		; 
	MOVB	#40,2(A2)		; 
	OCVT	0,OT$MEM		; 
	REST	A2,D1			; 
	MOVW	#[DSK],WS.DEV(A4)	; 
	CLRW	WS.DEV+2(A4)		; 				[113]
	CLRW	WS.DRV(A4)		; 
	OR	#WS$ERZ,WS.FLG(A4)	; 
	REST	A0			; 
	LCC	#PS.Z			; 
	RTN				; 

;process new ersatz device table

ERZNEW:	MOV	ERSATZ,A0		; 
10$:	CMM	WS.DEV(A4),EZ.NAM(A0)	; 
	BEQ	20$			; 
	ADD	#EZ.SIZ,A0		; 
	TSTW	@A0			; 
	BNE	10$			; 
	REST	A0			; 
	LCC	#0			; 
	RTN				; 
20$:	SAVE	A2,D1			; 
	LEA	A2,WS.PRG(A4)		; 
	MOVB	#40,@A2			; 
	MOVB	#40,1(A2)		; 
	MOVB	#40,2(A2)		; 
	CLR	D1			; 
	MOVW	EZ.PPN(A0),D1		; 
	RORW	D1,#8.			; 
	AND	#377,D1			;  
	OCVT	0,OT$MEM		; 
	LEA	A2,WS.PRJ(A4)		; 
	MOVB	#40,@A2			; 
	MOVB	#40,1(A2)		; 
	MOVB	#40,2(A2)		; 
	CLR	D1			; 
	MOVW	EZ.PPN(A0),D1		; 
	AND	#377,D1			; 
	OCVT	0,OT$MEM		; 
	REST	A2,D1			; 
	MOVW	EZ.DEV(A0),WS.DEV(A4)	; 
	CLRW	WS.DEV+2(A4)		; 				[113]
	MOVW	EZ.UNT(A0),WS.DRV(A4)	; 
	OR	#WS$ERZ,WS.FLG(A4)	; 
	REST	A0			; 
	LCC	#PS.Z			; 
	RTN				; 

;************
;*  DEFFIL  *
;************
;Function:	Define default filename

DEFFIL:	LEA	A6,WS.FIL(A4)		; 
	MOV	#5,D7			; 
10$:	MOVB	#'?,(A6)+		; 
	DBF	D7,10$			; 
	RTN				; 

;************
;*  CHKFIL  *
;************
;Function:	Check for filename specification

CHKFIL:	NUM				; 
	BEQ	10$			; 
	ALF				; 
	BEQ	10$			; 
	CMPB	@A2,#'?			; 				[1.6A]
	BEQ	10$			; 
	CMPB	@A2,#'@			;				[1.5][1.6A]
	BEQ	10$			;				[1.5]
	CMPB	@A2,#'#			;				[1.5][1.6A]
	BEQ	10$			;				[1.5]
	CMPB	@A2,#'*			; 				[1.6A]
	BEQ	10$			; 
	LCC	#0			; 
	RTN				; 
10$:	OR	#WS$FIL,WS.FLG(A4)	; 
	LCC	#PS.Z			; 
	RTN				; 

;************
;*  GETFIL  *
;************
;Function:	Get filename

GETFIL:	SAVE	A0,D0			; 
	LEA	A0,WS.FIL(A4)		; 
	MOV	#6,D0			; 
10$:	ALF				; 
	BEQ	20$			; 
	NUM				; 
	BEQ	20$			; 
	CMPB	@A2,#'?			; 
	BEQ	20$			; 
	CMPB	@A2,#'@			 				;[1.5]
	BEQ	20$			 				;[1.5]
	CMPB	@A2,#'#							;[1.5]
	BEQ	20$							;[1.5]
	CMPB	@A2,#'*			; 
	BEQ	30$			; 
14$:	MOVB	#40,(A0)+		; 
	SOB	D0,14$			; 
	BR	50$			; 
20$:	MOVB	(A2)+,(A0)+		; 
	SOB	D0,10$			; 
	BR	50$			; 
30$:	INC	A2			; 
40$:	MOVB	#'?,(A0)+		; 
	SOB	D0,40$			; 
50$:	REST	A0,D0			; 
	RTN				; 

;DEFEXT - define default extension

DEFEXT:	MOV	WS.DFX(A4),WS.EXT(A4)	; 
	RTN				; 

;CHKEXT - check for extension present

CHKEXT:	CMPB	@A2,#'.			; 
	BEQ	10$			; 
	LCC	#0			; 
	RTN				; 
10$:	OR	#WS$EXT,WS.FLG(A4)	; 
	LCC	#PS.Z			; 
	RTN				; 

;GETEXT - get extension

GETEXT:	SAVE	A0,D0			; 
	INC	A2			; 
	LEA	A0,WS.EXT(A4)		; 
	MOV	#3,D0			; 
10$:	ALF				; 
	BEQ	20$			; 
	NUM				; 
	BEQ	20$			; 
	CMPB	@A2,#'?			; 
	BEQ	20$			; 
	CMPB	@A2,#'@							;[1.5]
	BEQ	20$							;[1.5]
	CMPB	@A2,#'#							;[1.5]
	BEQ	20$							;[1.5]
	CMPB	@A2,#'*			; 
	BEQ	30$			; 
14$:	MOVB	#40,(A0)+		; 
	SOB	D0,14$			; 
	BR	50$			; 
20$:	MOVB	(A2)+,(A0)+		; 
	SOB	D0,10$			; 
	BR	50$			; 
30$:	INC	A2			; 
40$:	MOVB	#'?,(A0)+		; 
	SOB	D0,40$			; 
50$:	REST	A0,D0			; 
	RTN				; 

;DEFPPN - define default [P,PN]

DEFPPN:	SAVE	A1-A2,D1		; 
	BIT	#WS$ERZ,WS.FLG(A4)	; 
	BNE	10$			; 
	CLR	D1			; 
	MOV	JOBCUR,A1		; 
	MOVB	JOBUSR+1(A1),D1		; 
	LEA	A2,WS.PRG(A4)		; 
	CALL	20$			; 
	MOVB	JOBUSR(A1),D1		; 
	LEA	A2,WS.PRJ(A4)		; 
	CALL	20$			; 
10$:	REST	A1-A2,D1		; 
	RTN				; 
20$:	MOVB	#40,@A2			; 
	MOVB	#40,1(A2)		; 
	MOVB	#40,2(A2)		; 
	OCVT	0,OT$MEM		; 
	RTN				; 

;CHKPPN - check for PPN

CHKPPN:	BIT	#WS$PPN,WS.FLG(A4)	; PPN already specified?
	BNE	10$			;  yes
	CMPB	@A2,#'[			; 
	BEQ	20$			; 
10$:	LCC	#0			; 
	RTN				; 
20$:	OR	#WS$PPN,WS.FLG(A4)	; 
	LCC	#PS.Z			; 
	RTN				; 

;GETPPN - get PPN

GETPPN:	SAVE	A0,D0			; 
	INC	A2			; 
	CMPB	@A2,#']			; 				[1.6A]
	BEQ	10$			; 
	LEA	A0,WS.PRG(A4)		; 
	MOV	#3,D0			; 
	CALL	GETNUM			; 
	CMPB	(A2)+,#<',>		; 				[1.6A]
	BNE	40$			; 
	LEA	A0,WS.PRJ(A4)		; 
	MOV	#3,D0			; 
	CALL	GETNUM			; 
	CMPB	(A2)+,#']		; 				[1.6A]
	BNE	40$			; 
	BR	30$			; 
10$:	INC	A2			; 
	LEA	A6,WS.PRG(A4)		; 
	MOV	#5,D7			; 
20$:	MOVB	#'?,(A6)+		; 
	DBF	D7,20$			; 
30$:	REST	A0,D0			; 
	RTN				; 
40$:	OR	#WS$ERR,WS.FLG(A4)	; 
	BR	30$			; 

GETNUM:	NUM				; 
	BEQ	20$			; 
	CMPB	@A2,#'?			; 
	BEQ	20$			; 
	CMPB	@A2,#'#							;[1.5]
	BEQ	20$							;[1.5]
	CMPB	@A2,#'*			; 
	BEQ	30$			; 
10$:	MOVB	#40,(A0)+		; 
	SOB	D0,10$			; 
	BR	50$			; 
20$:	MOVB	(A2)+,(A0)+		; 
	SOB	D0,GETNUM		; 
	BR	50$			; 
30$:	INC	A2			; 
40$:	MOVB	#'?,(A0)+		; 
	SOB	D0,40$			; 
50$:	RTN				; 

;************
;*  CHKRED  *
;************
;Function:	Check for redirection (= in command line)

CHKRED:	BYP				; 				[110]
	CMPB	@A2,#'=			; 				[110]
	BEQ	10$			; 				[110]
	LCC	#0			; 				[110]
	RTN				; 				[110]
10$:	INC	A2			; bypass =			[110]
	BYP				; 				[110]
	LCC	#PS.Z			; 				[110]
	RTN				; 				[110]

;************
;*  GETRED  *
;************
;Function:	Get redirection (copy input specs to output)

GETRED:	OR	#WS$OUT,WS.FLG(A4)	; set redirection flag		[110]
	MOV	WS.DEV(A4),WS.ODV(A4)	; copy device code		[110]
	MOVW	WS.DRV(A4),WS.ODR(A4)	; copy drive number		[110]
	MOVBLK	WS.FIL(A4),WS.OFL(A4),6	; copy filename			[110]
	MOV	WS.EXT(A4),WS.OEX(A4)	; copy extension		[110]
	MOVBLK	WS.PRG(A4),WS.OPG(A4),3	; copy programmer number	[110]
	MOVBLK	WS.PRJ(A4),WS.OPJ(A4),3	; copy project number		[110]
	RTN				; return			[110]

;************
;*  INIMEM  *
;************

INIMEM:	CLRW	WS.RFN(A4)		;initialize impure area
	CLR	WS.UFL(A4)		; 
	CLRW	WS.RPN(A4)		; 
	CLR	WS.MFL(A4)		; 
	MOV	DEVTBL,WS.DTI(A4)	; 
	RTN				; 

ERROR:	BIT	#WS$ERR,WS.FLG(A4)	; 
	BNE	10$			; 
	LCC	#PS.Z			; 
	RTN				; 
10$:	BIT	#WS$UNM,WS.FLG(A4)	; 
	BEQ	20$			; 
	TYPECR	?Device not mounted	; 
	BR	40$			; 
20$:	BIT	#WS$DNE,WS.FLG(A4)	; 
	BEQ	30$			; 
	TYPECR	?Device does not exist	; 
	BR	40$			; 
30$:	TYPECR	?Specification error	; 
40$:	LCC	#0			; 
	RTN				; 

PAGE
;***********
;*  WSCAN  *
;***********
;Function:	Return next matching file

W.SCAN:

NEWFIL:	CALL	NXTFIL			; 
	REQ				; 
NEWUFD:	CALL	NXTUFD			; 
	BEQ	NEWFIL			; 
	CTRLC	EXIT			; 
NEWPPN:	CALL	NXTPPN			; 
	BEQ	NEWUFD			; 
NEWMFD:	CALL	NXTMFD			; 
	BEQ	NEWPPN			; 
NEWDEV:	CALL	NXTDEV			; 
	BEQ	NEWMFD			; 
EXIT:	RTN				; 

;************
;*  NXTFIL  *
;************
;Function:	Return next file from UFD
;		Automatically redirect if {output=input} was present in
;		command line

NXTFIL:	SAVE	A0			; save registers

NF.LOP:	TSTW	WS.RFN(A4)		; is remaining file count zero?
	JEQ	NF.ERR			;   yes
	DECW	WS.RFN(A4)		; decrement remaining file count
	MOV	WS.UFI(A4),A0		; get UFD index
	BIT	#WS$EXD,WS.FLG(A4)	; extended directory?		[108]
	BNE	NF.EXT			;  yes				[108]

;traditional directory structure

NF.TRA:	ADD	#UF.SIZ,WS.UFI(A4)	; add UFD size to index
	TSTW	UF.FIL(A0)		; end of UFD?
	JEQ	NF.ERR			;   yes
	BIT	#WS$DEL,WS.FLG(A4)	; do we want deleted files?
	BNE	10$			;   yes
	CMPW	UF.FIL(A0),#-1		; deleted file entry?		[1.6A]
	BEQ	NF.LOP			;   yes - go get next one
	CALL	MATFIL			; matching file specification?
	BNE	NF.LOP			;   no - go get next one
10$:	MOV	UF.FIL(A0),WS.DDB+D.FIL(A4);
	MOVW	UF.EXT(A0),WS.DDB+D.EXT(A4);
	MOVW	UF.BLK(A0),WS.DDB+D.WRK+2(A4);
	MOVW	UF.ACT(A0),WS.DDB+D.WRK+6(A4);
	MOVW	UF.LNK(A0),WS.DDB+D.WRK+12(A4);
	CLR	WS.DDB+D.DVR(A4)	; 				[113]
	LCC	#PS.Z			; set Z (file returned)
	BR	NF.RTN			; return

;extended directory structure

NF.EXT:	ADD	#D$SIZ,WS.UFI(A4)	; add UFD size to index		[108]
	ADD	#D$NAM,A0		; point to file information	[108]
	MOVW	UF.FIL(A0),D7		; end of UFD?			[108]
	BEQ	NF.ERR			;   yes				[108]
	BIT	#WS$DEL,WS.FLG(A4)	; do we want deleted files?
	BNE	10$			;   yes

	MOVW	D$TYP-D$NAM(A0),D7	; 				[114]
	ANDW	#100000,D7		; deleted file entry?		[114]
	JNE	NF.LOP			;  yes - go get next one	[114]

	MOVW	UF.FIL(A0),D7		; 
	CMPW	D7,#-1			; deleted file entry?		[108]
	JEQ	NF.LOP			;   yes - go get next one	[108]
	CMPW	D7,#[$  ]		; is this a hidden file?	[108]
	JEQ	NF.LOP			;   yes - go get next one	[108]
	CMPW	D7,#[$$ ]		; is this a hidden file?	[108]
	JEQ	NF.LOP			;   yes - go get next one	[108]
	CALL	MATFIL			; matching file specification?	[108]
	JNE	NF.LOP			;   no - go get next one	[108]
10$:	MOV	UF.FIL(A0),WS.DDB+D.FIL(A4);				[108]
	MOVW	UF.EXT(A0),WS.DDB+D.EXT(A4);				[108]
	SUB	#D$NAM,A0		; 				[108]
	MOV	D$FSZ(A0),WS.DDB+D.WRK(A4);				[108]
	MOVW	D$LSZ(A0),WS.DDB+D.WRK+6(A4);				[108]
	MOV	D$BAS(A0),WS.DDB+D.WRK+10(A4);				[108]
	CLR	WS.DDB+D.DVR(A4)	; 				[113]
	LCC	#PS.Z			; set Z (file returned)		[108]
	BR	NF.RTN			; return			[108]

NF.ERR:	LCC	#0			; clear Z (end of UFD)

NF.RTN:	REST	A0			; restore registers
	RTN				; return

;************
;*  MATFIL  *
;************
;Function:	Check for matching file specification
;
;Inputs:	A0 - address of 6-word UFD file information

MATFIL:	SAVE	A0-A2,D0		; save registers
	LEA	A1,UF.FIL(A0)		; 
	LEA	A2,WS.TMP(A4)		; 
	UNPACK				; 
	UNPACK				; 
	UNPACK				; 
	LEA	A0,WS.FIL(A4)		; 
	LEA	A1,WS.TMP(A4)		; 
	MOV	#9.,D0			; 
10$:	CMPB	(A0)+,(A1)+		; 				[1.6A]
	BNE	30$			; 
20$:	SOB	D0,10$			; 
	BIT	#WS$NOT,WS.FLG(A4)	; 
	JNE	MATCHN			; 
	BR	MATCHY			; 
30$:	CMPB	-1(A0),#'?		; 				[1.6A]
	BEQ	20$
	CMPB	-1(A0),#'@						;[1.5][1.6A]
	BEQ	50$							;[1.5]
	CMPB	-1(A0),#'#						;[1.5][1.6A]
	BEQ	60$			 				;[1.5]
40$:	BIT	#WS$NOT,WS.FLG(A4)	; 
	BNE	MATCHY			; 
	BR	MATCHN			; 
50$:	CMPB	-1(A1),#'A						;[1.5]
	BLO	40$							;[1.5]
	CMPB	-1(A1),#'Z						;[1.5]
	BHI	40$							;[1.5]
	BR	20$							;[1.5]
60$:	CMPB	-1(A1),#'0						;[1.5]
	BLO	40$							;[1.5]
	CMPB	-1(A1),#'9						;[1.5]
	BHI	40$			 				;[1.5]
	BR	20$							;[1.5]
MATCHN:	LCC	#0			; 
	BR	MATCHR			; 
MATCHY:	LCC	#PS.Z			; 
MATCHR:	REST	A0-A2,D0		; 
	RTN				; 

;************
;*  NXTUFD  *
;************
;Function:	Return next UFD block

NXTUFD:	SAVE	A0,D0			; save registers
	CTRLC	NU.ERR			; ^C check
	TST	WS.UFL(A4)		; check link
	BEQ	NU.ERR			;   end of user file directory chain
	MOV	WS.UFL(A4),WS.DDB+D.REC(A4); set block number
	PUSH	WS.DDB+D.BUF(A4)	; push buffer address
	LEA	A0,WS.UFB(A4)		; change buffer address
	MOV	A0,WS.DDB+D.BUF(A4)	;   to UFD buffer
	CLR	WS.DDB+D.DVR(A4)	; clear driver address		[1.6]
	READ	WS.DDB(A4)		; read UFD block
	POP	WS.DDB+D.BUF(A4)	; restore buffer address
	CLR	D0			; get
	BIT	#WS$EXD,WS.FLG(A4)	; extended directory structure?	[108]
	BNE	NU.EXT			;   yes

;traditional directory structure

NU.TRA:	MOVW	(A0)+,D0		;   link
	MOV	D0,WS.UFL(A4)		; store link
	MOVW	#42.,WS.RFN(A4)		; set number of files to be processed
	MOV	A0,WS.UFI(A4)		; set UFD index
	LCC	#PS.Z			; set Z
	BR	NU.RTN			; return

;extended directory structure

NU.EXT:	MOV	(A0)+,WS.UFL(A4)	; store link
	MOVW	#<512.-4>/D$SIZ,WS.RFN(A4); set number of files to be processed
	MOV	A0,WS.UFI(A4)		; set UFD index
	LCC	#PS.Z			; set Z
	BR	NU.RTN			; return

NU.ERR:	LCC	#0			; clear Z

NU.RTN:	REST	A0,D0			; restore registers
	RTN				; return

;************
;*  NXTDEV  *
;************
;Function:	Find next mounted disk in device table & setup for processing
;
;Sets or clears WS$EXD bit to flag extended or traditional directory format

NXTDEV:	SAVE	A0			; 
10$:	TST	WS.DTI(A4)		; 
	JEQ	40$			; 
	MOV	WS.DTI(A4),A0		; 
	MOV	DV.NXT(A0),WS.DTI(A4)	; 
	BITW	#DV$MNT,DV.FLG(A0)	; 
	BEQ	10$			; 
	BIT	#WS$ALL,WS.FLG(A4)	; 
	BNE	30$			; 
20$:	CMMW	WS.DEV(A4),DV.DEV(A0)	; 
	BNE	10$			; 
	CMMW	WS.DRV(A4),DV.UNT(A0)	; 
	BNE	10$			; 
30$:	MOVW	DV.DEV(A0),WS.DDB+D.DEV(A4)
	MOVW	DV.UNT(A0),WS.DDB+D.DRV(A4)
	CLR	WS.DDB+D.DVR(A4)	; 				[113]

	AND	#^C<WS$EXD>,WS.FLG(A4)	; clear extended flag		[108]
	BITW	#DV$14D,DV.FLG(A0)	; extended directory?		[108]
	BEQ	32$			;   no				[108]
	OR	#WS$EXD,WS.FLG(A4)	; set extended flag		[108]
32$:

	MOV	JOBCUR,A0		; 
	CMMW	WS.DDB+D.DEV(A4),JOBDEV(A0)
	BNE	34$			; 
	CMMW	WS.DDB+D.DRV(A4),JOBDRV(A0)
	BNE	34$			; 
	CLRW	WS.DDB+D.DEV(A4)	; 
	MOVW	#-1,WS.DDB+D.DRV(A4)	; 
	CLR	WS.DDB+D.DVR(A4)	; 				[113]

34$:	MOV	#1,WS.MFL(A4)		; set MFD block number to 1
	LCC	#PS.Z			; set Z
	BR	50$			; 
40$:	LCC	#0			; 
50$:	REST	A0			; 
	RTN				; 

;************
;*  NXTMFD  *
;************
;Function:	Load next block of master file directory
;
;Inputs:	WS.MFL(A4) - link to next block of MFD

NXTMFD:	SAVE	A0,D0			; 
	MOV	WS.MFL(A4),D0		; 
	BEQ	NM.ERR			; 
	MOV	D0,WS.DDB+D.REC(A4)	; 
	PUSH	WS.DDB+D.BUF(A4)	; 
	LEA	A0,WS.MFB(A4)		; 
	MOV	A0,WS.DDB+D.BUF(A4)	; 
	CLR	WS.DDB+D.DVR(A4)	; clear driver address		[1.6]
	READ	WS.DDB(A4)		; 
	POP	WS.DDB+D.BUF(A4)	; 
	BIT	#WS$EXD,WS.FLG(A4)	; extended directory?		[108]
	BNE	NM.EXT			;   yes				[108]

;traditional directory structure
;A0 indexes buffer

NM.TRA:	CLR	D0			; get
	MOVW	MF.LNK(A0),D0		;   MFD link
	MOV	D0,WS.MFL(A4)		; set link to next MFD block
	LEA	A0,WS.MFB(A4)		; set MFD
	MOV	A0,WS.MFI(A4)		;   index
	MOVW	#63.,WS.RPN(A4)		; set remaining PPN count
	LCC	#PS.Z			; set Z
	BR	NM.RTN			; return

;extended directory structure
;A0 indexes buffer

NM.EXT:	MOV	(A0)+,WS.MFL(A4)	; store link to next block	[108]
	MOV	A0,WS.MFI(A4)		; set MFD index			[108]
	MOVW	#<512.-4>/D$SIZ,WS.RPN(A4); set remaining PPN count	[108]
	LCC	#PS.Z			; set Z				[108]
	BR	NM.RTN			; return			[108]

NM.ERR:	LCC	#0			; 

NM.RTN:	REST	A0,D0			; 
	RTN				; 

;************
;*  NXTPPN  *
;************
;Function:	Return next PPN of MFD
;
;Outputs:	Z  - 0 if end of this MFD block

NXTPPN:	SAVE	A0,D0,D5		; save registers		[108]
NP.LOP:	TSTW	WS.RPN(A4)		; is remaining PPN count zero?
	BEQ	NP.ERR			;   yes
	DECW	WS.RPN(A4)		; decrement remaining PPN count
	MOV	WS.MFI(A4),A0		; get MFD index
	BIT	#WS$EXD,WS.FLG(A4)	; extended directory structure?	[108]
	BNE	NP.EXT			;   yes				[108]

;traditional directory structure

NP.TRA:	ADD	#MF.SIZ,WS.MFI(A4)	; add size of traditional MFD entry
	MOVW	MF.PPN(A0),D5		; is this the end of the MFD?	[108]
	BEQ	NP.ERR			;   yes
	CMPW	D5,#-1			; deleted PPN?			[111]
	BEQ	NP.LOP			;   yes - skip it		[111]
	CALL	MATPPN			; matching PPN?
	BNE	NP.LOP			;   no - go try next PPN
	CLR	D0			; get
	MOVW	MF.UFD(A0),D0		;   UFD pointer
	BEQ	NP.LOP			; 				[113]
	MOV	D0,WS.UFL(A4)		; store UFD pointer
	MOVW	#42.,WS.RFN(A4)		; set remaining file count
	MOVW	MF.PPN(A0),WS.DDB+D.PPN(A4); set PPN into DDB
	LCC	#PS.Z			; set Z
	BR	NP.RTN			; return

;extended directory structure

NP.EXT:	ADD	#D$SIZ,WS.MFI(A4)	; add size of MFD entry		[108]
	MOVW	D$NAM(A0),D5		; is this the end of the MFD?	[108]
	BEQ	NP.ERR			;   yes				[108]
	CMPW	D5,#-1			; deleted PPN?			[108]
	BEQ	NP.LOP			;   yes - ignore it		[108]
	CALL	MATPPN			; matching PPN?			[108]
	BNE	NP.LOP			;   no - go try next PPN	[108]
	MOV	D$NXT(A0),D0		; get UFD pointer		[108]
	MOV	D0,WS.UFL(A4)		; store UFD pointer		[108]
	MOVW	#<512.-4>/D$SIZ,WS.RFN(A4); set remaining file count	[108]
	MOVW	D$NAM(A0),WS.DDB+D.PPN(A4); set PPN into DDB		[108]
	LCC	#PS.Z			; set Z				[108]
	BR	NP.RTN			; return			[108]

NP.ERR:	LCC	#0			; clear Z
NP.RTN:	REST	A0,D0,D5		; restore registers		[108]
	RTN				; return

;************
;*  MATPPN  *
;************
;Function:	Determine if current PPN entry in MFD matches specification
;		Traditional file structure
;
;Inputs:	D5 - current PPN
;
;Outputs:	Z  - set if we have a match

MATPPN:	SAVE	A2-A3,D0-D1,D5		; save registers
	CLR	D1			; get
	RORW	D5,#8.			; 				[108]
	MOVB	D5,D1			;   programmer number		[108]
	LEA	A2,WS.TMP(A4)		; index buffer
	MOVB	#40,WS.TMP+1(A4)	; load w/
	MOVB	#40,WS.TMP+2(A4)	;   spaces
	OCVT	0,OT$MEM		; output as an octal number
	LEA	A2,WS.PRG(A4)		; index programmer number spec
	LEA	A3,WS.TMP(A4)		; index current programmer number
	CALL	30$			; compare
	BNE	10$			;   no match

	ROLW	D5,#8.			; move project into low byte	[108]
	CLR	D1			; 				[108]
	MOVB	D5,D1			; get project number		[108]
	LEA	A2,WS.TMP(A4)		; index buffer
	MOVB	#40,WS.TMP+1(A4)	; load w/
	MOVB	#40,WS.TMP+2(A4)	;   spaces
	OCVT	0,OT$MEM		; output as an octal number
	LEA	A2,WS.PRJ(A4)		; index project number spec
	LEA	A3,WS.TMP(A4)		; index current project
	CALL	30$			; compare
	BNE	10$			;   no match

	LCC	#PS.Z			; set Z
	BR	20$			; return

10$:	LCC	#0			; clear Z

20$:	REST	A2-A3,D0-D1,D5		; restore registers
	RTN				; return

;compare

30$:	MOV	#3,D0			; max count is three
40$:	CMPB	(A2)+,(A3)+		; match?			[1.6A]
	BNE	60$			;   no
50$:	SOB	D0,40$			; loop
	LCC	#PS.Z			; set Z - we have a match
	RTN				; return
60$:	CMPB	-1(A2),#'?		; wildcard?			[1.6A]
	BEQ	50$			;   yes
	LCC	#0			; clear Z - no match
	RTN				; return

PAGE
;************
;*  W.FULL  *
;************
;Function:	Insure full file specification @A4

W.FULL:	JOBIDX
	TSTW	D.DEV(A4)
	BNE	10$
	MOVW	JOBDEV(A6),D.DEV(A4)
	MOVW	JOBDRV(A6),D.DRV(A4)
10$:	TSTW	D.PPN(A4)
	BNE	20$
	MOVW	JOBUSR(A6),D.PPN(A4)
20$:	RTN

PAGE
;************
;*  W.LIST  *
;************
;Function:	Return list of matching file specifications
;
;Inputs:	A4 - must have been pre-indexed by W.INIT and W.SPEC calls
;		A0 - must index table to return list in 
;		D0 - must contain maximum number of files table can hold
;
;Outputs:	A0 - unchanged
;		D0 - contains number of filenames returned

W.LIST:	SAVE	A0,D2			; 
	CLR	D2			; 
10$:	CTRLC	30$			; 
	CALL	W.SCAN			; 
	BNE	30$			; 
20$:	INC	D2			; 
	MOVW	D.DEV(A4),(A0)+		; 
	MOVW	D.DRV(A4),(A0)+		; 
	MOV	D.FIL(A4),(A0)+		; 
	MOVW	D.EXT(A4),(A0)+		; 
	MOVW	D.PPN(A4),(A0)+		; 
	SOB	D0,10$			; 
30$:	MOV	D2,D0			; 
	REST	A0,D2			; 
	RTN				; 

PAGE
;"default" ersatz table - used if no user-definable ersatz table defined

DEFINE	ERSATZ	NAM,A,B
	RAD50	/'NAM/
	BYTE	A,B
	ENDM

ERZTBL:	ERSATZ	OPR,1,2
	ERSATZ	SYS,1,4
	ERSATZ	DVR,1,6
	ERSATZ	CMD,2,2
	ERSATZ	LIB,7,0
	ERSATZ	HLP,7,1
	ERSATZ	BOX,7,2
	ERSATZ	VUE,7,3
	ERSATZ	LSP,7,4
	ERSATZ	PAS,7,5
	ERSATZ	BAS,7,6
	ERSATZ	MAC,7,7
	ERSATZ	MNU,7,11
	0

PAGE
;***********
;*  W.DEL  *
;***********
;Function:	Set WS$DEL flag, which returns all files (even deleted ones)
;		in each account.

W.DEL:	OR	#WS$DEL,WS.FLG(A4)	; 
	RTN				; 

PAGE
;***********
;*  W.OUT  *
;***********
;Function:	Transform WS.DDB(A4) as per output redirection specification
;		Normally, this call immediately follows a W.SCAN call
;
;Inputs:	A4 - pointer to wildcard scanner impure area
;
;Outputs:	Z          - set if output redirection was specified and performed
;		WS.DDB(A4) - modified appropriately

W.OUT:	BIT	#WS$OUT,WS.FLG(A4)	; was redirection specified?
	BEQ	W.ONR			;   no
	SAVE	A0-A2,D0-D2		; save registers
	CALL	REDDEV			; redirect device
	CALL	REDDRV			; redirect drive
	CALL	REDFIL			; redirect filename
	CALL	REDEXT			; redirect extension
	CALL	REDPRG			; redirect programmer number
	CALL	REDPRJ			; redirect project number
	REST	A0-A2,D0-D2		; restore registers
	LCC	#PS.Z			; set Z (redirection performed)
	RTN				; return
W.ONR:	LCC	#0			; no redirection
	RTN				; return

;************
;*  REDDEV  *
;************
;Function:	Redirect device code

REDDEV:	MOVW	WS.ODV(A4),D0		; get redirected device code
	BEQ	10$			;   none - leave device alone
	CMPW	D0,#[ALL]		; ALL:?
	BEQ	10$			;   yes - leave device alone
	MOVW	D0,WS.DDB+D.DEV(A4)	; set new device code
10$:	JOBIDX				; index JCB with A6
	CMMW	WS.DDB+D.DEV(A4),JOBDEV(A6); login device?
	BNE	20$			;   no
	CLRW	WS.DDB+D.DEV(A4)	;   yes - set default
20$:	RTN				; 

;************
;*  REDDRV  *
;************
;Function:	Redirect drive number

REDDRV:	CMPW	WS.ODV(A4),#[ALL]	; ALL:?
	BEQ	10$			;   yes - leave drive alone
	MOVW	WS.ODR(A4),WS.DDB+D.DRV(A4); set new drive number
10$:	JOBIDX				; index JCB with A6
	CMMW	WS.DDB+D.DRV(A4),JOBDRV(A6); login drive?
	BNE	20$			;   no
	MOVW	#-1,WS.DDB+D.DRV(A4)	;   yes - set default
20$:	CLR	WS.DDB+D.DVR(A4)	; 				[113]
	RTN				; 

;************
;*  REDFIL  *
;************
;Function:	Redirect filename

REDFIL:	LEA	A1,WS.DDB+D.FIL(A4)	; index
	LEA	A2,WS.TMP(A4)		; 
	UNPACK				; 
	UNPACK				; 
10$:	CMPB	-(A2),#40		; 
	BEQ	10$			; 
	CLRB	1(A2)			; 

	LEA	A0,WS.OFL(A4)		; index output filename
	LEA	A1,WS.TMP(A4)		; 
	MOV	#6.,D2			; 
20$:	MOVB	(A0)+,D0		; get char of output spec
	BEQ	40$			;   end of filename
	MOVB	@A1,D1			; get original filename char	[112]
	CMPB	D0,#'?			; wildcard in redirected spec?	[112]
	BNE	30$			;   no				[112]
	MOVB	D1,D0			;   yes - use original character[112]
30$:	MOVB	D0,(A1)+		; set new char in filename	[112]
	SOB	D2,20$			; loop till done
40$:	CLRB	@A1			; end of string

	LEA	A1,WS.DDB+D.FIL(A4)	; 
	LEA	A2,WS.TMP(A4)		; 
	PACK				; 
	PACK				; 

	RTN				; 

;************
;*  REDEXT  *
;************
;Function:	Redirect extension

REDEXT:	LEA	A1,WS.DDB+D.EXT(A4)	; index
	LEA	A2,WS.TMP(A4)		; 
	UNPACK				; 
10$:	CMPB	-(A2),#40		; 
	BEQ	10$			; 
	CLRB	1(A2)			; 

	LEA	A0,WS.OEX(A4)		; index output filename
	LEA	A1,WS.TMP(A4)		; 
	MOV	#3,D2			; 
20$:	MOVB	(A0)+,D0		; 
	BEQ	40$			; 
	MOVB	(A1)+,D1		; 
	BEQ	40$			; 
	CMPB	D0,#'?			; 
	BEQ	30$			; 
	MOVB	D0,-1(A1)		; 
30$:	SOB	D2,20$			; 
40$:	CLRB	@A1			; 

	LEA	A1,WS.DDB+D.EXT(A4)	; 
	LEA	A2,WS.TMP(A4)		; 
	PACK				; 

	RTN				; 

;************
;*  REDPRJ  *
;************
;Function:	Redirect project number

REDPRJ:	CLR	D1			; 
	MOVB	WS.DDB+D.PPN(A4),D1	; index
	LEA	A2,WS.TMP(A4)		; 
	OCVT	0,OT$MEM		; 
	MOVB	#40,(A2)+		; 
	MOVB	#40,(A2)+		; 

	LEA	A0,WS.OPJ(A4)		; index output
	LEA	A1,WS.TMP(A4)		; 
	MOV	#3,D2			; 
20$:	MOVB	(A0)+,D0		; 
	BEQ	40$			; 
	MOVB	(A1)+,D1		; 
	BEQ	40$			; 
	CMPB	D0,#'?			; 
	BEQ	30$			; 
	MOVB	D0,-1(A1)		; 
30$:	SOB	D2,20$			; 
40$:	CLRB	@A1			; 

	LEA	A2,WS.TMP(A4)		; 
	GTOCT				; 
	MOVB	D1,WS.DDB+D.PPN(A4)	; 

	RTN				; 

;************
;*  REDPRG  *
;************
;Function:	Redirect programmer number

REDPRG:	CLR	D1			; 
	MOVB	WS.DDB+D.PPN+1(A4),D1	; index
	LEA	A2,WS.TMP(A4)		; 
	OCVT	0,OT$MEM		; 
	MOVB	#40,(A2)+		; 
	MOVB	#40,(A2)+		; 

	LEA	A0,WS.OPG(A4)		; index output
	LEA	A1,WS.TMP(A4)		; 
	MOV	#3,D2			; 
20$:	MOVB	(A0)+,D0		; 
	BEQ	40$			; 
	MOVB	(A1)+,D1		; 
	BEQ	40$			; 
	CMPB	D0,#'?			; 
	BEQ	30$			; 
	MOVB	D0,-1(A1)		; 
30$:	SOB	D2,20$			; 
40$:	CLRB	@A1			; 

	LEA	A2,WS.TMP(A4)		; 
	GTOCT				; 
	MOVB	D1,WS.DDB+D.PPN+1(A4)	; 

	JOBIDX				; index JCB with A6
	CMPW	D1,WS.DDB+D.PPN(A4)	; is PPN login default?
	BNE	50$			;   no
	CLRW	WS.DDB+D.PPN(A4)	; 

50$:	RTN				; 

	END

.