;***************************************************************************
;*		************************************************************
;* SPOOL.M68	************************************************************
;*		************************************************************
;***************************************************************************
;
; Programmed by:	John Ryan
;			Ryan & Vint Associates
;			Santa Ana, CA
;			(714)835-3073
;
; Replacement for AM's SPOOL.SBR 1.0(100)-1, which either causes parity errors
; or keeps hanging the system when called with more than one parameter.
;
;
	SEARCH	SYS
	SEARCH	SYSSYM
;
	ARGBLK=10.			; BASIC argument block size
;
	OBJNAM	0,0,[SBR]
	EXTERN	$GTARG
;
; Program variables - impure area allocated from free region @A1:
	.OFINI
	.OFDEF	SWITCH,2		; Switches - see BASIC manual for list
	.OFDEF	PRINTR,4		; Printer name packed RAD50
	.OFDEF	COPIES,2		; Number of copies
	.OFDEF	BLOCKS,2		; Number of blocks required
	.OFDEF	FORM,4			; Form name packed RAD50
	.OFDEF	WIDTH,1			; Header line width
	.OFDEF	LPP,1			; Lines per page
	.OFDEF	DDBBUF,512.		; Buffer for DDB
	.OFDEF	DDB,D.DDB		; DDB for file to spool
	EVEN
	.OFSIZ	IMPSIZ			; Size of impure area
;
; Line printer queue block offsets for elements within queue for a particular
; printer. LPTQUE => first queue element, which is a list of printers.  Each
; printer begins another queue of requests pending for that printer.
; These offsets are from start of the data area (after 1st longword pointer to
; next queue block or 0 if none) as deduced from disassembly of SPOOL).
; Names are my own of course.
	LP.FIL=0			; file name
	LP.EXT=LP.FIL+4			; extension
	LP.DEV=LP.EXT+2			; device name
	LP.PPN=LP.DEV+2			; PPN
	LP.UNI=LP.PPN+2			; device unit number
	LP.COP=LP.UNI+2			; copies
	LP.SWI=LP.COP+2			; switches
	LP.FRM=LP.SWI+2			; form name
	LP.LPP=LP.FRM+4			; lines per page
	LP.WID=LP.LPP+2			; width (also 1 word)
;
; Offsets for first printer queue, listing available printers
	LP.PTR=4			; addr of 1st element in queue this printer
	LP.NAM=10			; printer name word (RAD50)
	LP.BLK=20			; number of blocks pending for this printer
	LP.FLG=22			; flag word
	LP.JOB=24			; addr of spooler job using this printer
;
	LP.DEF=20			; bit pattern in flag word - if set,
					; indicates this is the default printer
;
	VMAJOR=1.
	VMINOR=0.
	VSUB=1.
	VEDIT=1.
	PHDR	-1,0,PH$REE!PH$REU
;
; Setup code - use A1 to point to base of my impure area
SPOOL::	EVNA	A4			; ensure A4 is even
	MOV	A4,A1			; point to base
	ADD	#IMPSIZ,A4		; add size - so later $GTARG calls ok
	CMP	A4,A5			; make sure there's room
	JHIS	ERR1
;	
	CALL	CLRARG			; clear impure area
	CALL	GETARG			; get arguments and store
	JNE	BACK
;
	MOV     LPTQUE,A2		; line printer queue head
	MOV	A2,D7			; copy so sets condition codes
	JEQ     NOPRT			; no printers set up for spooling
	TST     PRINTR(A1)		; was the printer name passed?
	JEQ     FNDPRT			; no - find the default printer
10$:	MOV     PRINTR(A1),D7		; yes - find specified printer
	CMP	D7,LP.NAM(A2)		; right name?
	BEQ     HAVPRT			; match
	MOV     @A2,A2			; point to next element (& set Z bit)
	MOV	A2,D7			; copy to set condition codes
	JEQ	NOPRT			; no more to test?
	BR	10$			; test the next
; A1 is my impure pointer
; A2 points to printer queue element to use
HAVPRT:	LOOKUP	DDB(A1)			; setup D.WRK area
	JNE     BACK			; file not found
	JOBIDX	A6
	MOVW    JOBUSR(A6),D1		; get current PPN
	CMPW	D1,DDB+D.PPN(A1)	; compare to file's
	BEQ     CKQUE			; same - ok
	ANDW    #-5,SWITCH(A1)		; reset deletion switch if PPNs
	ORW     #10,SWITCH(A1)		;   differ
CKQUE:	CMP     QFREE ,#15.		; at least 15 free queue blks remain?
	BLOS    WTQUE
	JLOCK				; no context switch while updating queue
	MOVW    COPIES(A1),D0		; number copies requested
	MOV     DDB+D.WRK(A1),D2	; number of blocks in file
	MUL     D0,D2			; total number blocks required in D0
	CMP	D0,#^H0FFFF		; range check
	BLOS	20$			; use unsigned arithmetic
10$:	CALL	ERR5			; inform caller
	BR	DONE			; and return
20$:	MOVW	D0,BLOCKS(A1)		; save number blocks required
	ADDW	LP.BLK(A2),D2		; bump number pending
	BVS	10$			; too many?
	LEA     A3,LP.PTR(A2)		; addr of start of queue for this printer
	QADD	A3			; add block to end of list
	BNE	DONE			; no block available
	MOVW	D2,LP.BLK(A2)		; save total pending for printer
; fill in queue block
	MOV     DDB+D.FIL(A1),(A3)+	; filename from DDB
	MOVW    DDB+D.EXT(A1),(A3)+	; extension
	MOVW    DDB+D.DEV(A1),(A3)+	; device
	MOVW    DDB+D.PPN(A1),(A3)+	; PPN
	MOVW    DDB+D.DRV(A1),(A3)+	; unit number
	MOVW    COPIES(A1),(A3)+	; copies
	MOVW    SWITCH(A1),@A3		; switches
	ANDW    #-401,(A3)+		; clear extra bits
	MOV     FORM(A1),(A3)+		; copy form
	MOVW	BLOCKS(A1),(A3)+	; number of blocks
	MOVB	LPP(A1),(A3)+		; lines per page
	MOVB	WIDTH(A1),(A3)+		; page width
DONE:	JUNLOK				; permit context switching
	MOV     LP.JOB(A2),A0		; point to spooler for this printer
	JRUN	40			; start up the spooler
	RTN				; to BASIC - normally
;
; **************************************************************************
; Extended mainline routines
; See if should wait for queue blocks or just return
WTQUE:	MOVW    SWITCH(A1),D7
	ANDW    #400,D7
	BEQ     10$
	MOV     #10000.,D6		; 1 second wait
	SLEEP
	JMP     CKQUE
10$:	TYPECR  ?Not enough queue blocks for spooler request
	RTN				; to user - not enough queue space
NOPRT:	TYPECR  ?Unable to find specified printer
BACK:	RTN				; to user
; find the default printer to use - A2 points to head of line printer queue
FNDPRT:	MOVW    LP.BLK(A2),D2		; number of blocks
; use SP as save area for pointer to queue element chosen
	PUSH    A2			; first printer in queue
	MOVW    LP.FLG(A2),D7		; test - is this the default printer?
	ANDW    #LP.DEF,D7		; bit test
	BNE     GOTPRT			; yes
10$:	MOV     @A2,A2			; point to next element and repeat test
	MOV	A2,D7			; set condition codes
	BEQ     GOTPRT			; any more?
	MOVW    LP.FLG(A2),D7		; get status
	ANDW    #LP.DEF,D7		; bit test
	BNE     20$			; have printer => br
	CMPW	D2,LP.BLK(A2)		; if none flagged, use printer with
	BLO	10$			;   fewest pending blocks
	MOVW    LP.BLK(A2),D2		; D2 saves least number blocks
	MOV     A2,@SP			; (SP) saves ptr to queue w/ least blks
	BR      10$			; search next queue element
20$:	MOV     A2,@SP			; set up for next instruction
GOTPRT:	POP     A2			; set A2 to queue element to use
	JMP     HAVPRT			; return
;
; ***** Subroutines ********************************************************
;
; **************************************************************************
;	These were extracted from WLSRCH subroutine for speedy use, with
;	minor modifications - JRR.
; **************************************************************************	
;
; Clear the impure area from (A1)
CLRARG:	MOV	A1,A6
	MOV	#<IMPSIZ/2>-1,D7
1$:	CLRW	(A6)+
	DBF	D7,1$
	RTN
;
; Get the parameters passed:
; D0 = index to argument blocks
; D1, D2 = parameter passing registers
; D3, D4 = work registers
; A0 = BASIC impure area pointer
; A3 = BASIC argument pointer
; A4 = BASIC's free pointer
; A5 = BASIC's arithmetic stack
; A1 = my impure area pointer
; A2 = string pointer work register
; A6 = work register (not preserved across monitor calls)
GETARG:	TSTW	(A3)			; see if at least 1 argument passed
	JEQ	ERR2			; nope
	CMPW	(A3),#7			; more than 7 arguments?
	JGT	ERR2			; yep - jump
	LEA	A4,DDB(A1)		; Use A4 as DDB base register
	MOV	#2,D0			; initialize argument pointer
;
	MOVW	#1,COPIES(A1)		; set copy default
	MOVW	#[NOR],FORM(A1)		; set printer form default
	MOVW	#[MAL],FORM+2(A1)
;
	CALL	GTADDR			; get addr of filename parm
	JNE	110$			; error return
	LEA	A6,DDBBUF(A1)		; point to buffer
	MOV	A6,DDB+D.BUF(A1)	; save absolute buffer addr in DDB
	MOVB	#D$INI!D$ERC,DDB+D.FLG(A1) ; flag buffer inited, return on error
	MOV	D1,A2			; copy pointer to addr
	MOV	A2,A6			; another copy
	ADD	D2,A6			; add size
	MOV	A6,D4			; save end pointer
	MOVB	(A6),D3			; save last byte
	CLRB	(A6)			; clear the byte - ensure legal string
	FSPEC	DDB(A1),LST		; set up DDB
	MOV	D4,A6			; restore end pointer	
	MOVB	D3,(A6)			; restore former byte
	TSTB	DDB+D.ERR(A1)		; check for errors
	JNE	110$			; return if so
;
; LOOKUP use 0 defaults - ok for INPUT, etc. but not printer spooler
; replace defaults with job's defaults
	JOBIDX	A6
	TSTW	DDB+D.PPN(A1)		; PPN specified?
	BNE	10$
	MOVW	JOBUSR(A6),DDB+D.PPN(A1)
10$:	TSTW	DDB+D.DEV(A1)		; device name
	BNE	20$
	MOVW	JOBDEV(A6),DDB+D.DEV(A1)
	MOVW	JOBDRV(A6),DDB+D.DRV(A1)
	BR	30$
20$:	CMPW	DDB+D.DRV(A1),#-1
	BNE	30$
	MOVW	JOBDRV(A6),DDB+D.DRV(A1)
30$:	CMPW	(A3),#1			; 1 argument?
	JEQ	100$			; yes - we are done
	CALL	GTADDR			; get addr of printer name string
	JNE	110$			; error
	MOV	A1,D3			; save my impure pointer
	LEA	A1,PRINTR(A1)		; point A1 to buffer
	MOV	D1,A2			; A2 points to string to pack
	PACK
	PACK
	MOV	D3,A1			; restore impure pointer
;
	CMPW	(A3),#2			; 2 arguments?
	JEQ	100$			; yes => done
	CALL	GTNMBR			; get a number
	JNE	110$			; error?
	MOVW	D1,SWITCH(A1)		; save switches
;
	CMPW	(A3),#3			; 3 arguments?
	JEQ	100$			; done?
	CALL	GTNMBR			; get number
	JNE	110$			; error?
	CMP	D1,#^H0FFFF		; out of range?
	BLOS	40$			; use unsigned arithmetic
	CALL	ERR4			; inform caller
	JMP	110$			; and take error return
40$:	MOVW	D1,COPIES(A1)		; save copies requested
	BNE	42$			; no - leave default
	MOVW	#1,COPIES(A1)		; restore copy default
;
42$:	CMPW	(A3),#4			; 4 arguments?
	JEQ	100$			; done?
	CALL	GTADDR			; get addr of form string
	JNE	110$			; error?
	MOV	A1,D3			; save my impure pointer
	LEA	A1,FORM(A1)		; point A1 to buffer
	MOV	D1,A2			; A2 points to string to pack
	PACK
	PACK
	MOV	D3,A1			; restore impure pointer
	TST	FORM(A1)
	BNE	44$
	MOVW	#[NOR],FORM(A1)		; restore printer form default
	MOVW	#[MAL],FORM+2(A1)
;
44$:	CMPW	(A3),#5			; 5 arguments?
	JEQ	100$			; done?
	CALL	GTNMBR			; get number
	JNE	110$			; error?
	CMP	D1,#^H0FF		; out of range?
	BLOS	50$			; use unsigned arithmetic
	CALL	ERR4			; inform caller
	JMP	110$			; and take error return
50$:	MOVB	D1,WIDTH(A1)		; save line width for header
;
	CMPW	(A3),#6			; 6 arguments?
	JEQ	100$			; done?
	CALL	GTNMBR			; get number
	JNE	110$			; error?
	CMP	D1,#^H0FF		; out of range?
	BLOS	60$			; use unsigned arithmetic
	CALL	ERR4			; inform caller
	JMP	110$			; and take error return
60$:	MOVB	D1,LPP(A1)		; save lines per page
;
;
100$:	LCC	#4			; normal return
	RTN
110$:	LCC	#0			; error return
	RTN
;
; Return a numeric argument value into D1 (binary, fp or string)
; Address of argument returned in D2
; A3, A5 are as entered subroutine from BASIC - D0 has offset to argument blk
GTNMBR:	MOV	D0,D1			; index to D1
	MOV	2(A3)[D1],D2		; save address
	ANDW	#7,0(A3)[D1]		; clear meaningless & subscript bit
	CMPW	0(A3)[D1],#0		; unformatted variable?
	JEQ	ERR3			; yes - a no no
	CMPW	0(A3)[D1],#6		; binary variable?
	BNE	1$			; nope
	CMP	6(A3)[D1],#4		; 4 bytes or less?
	JGT	ERR3			; no => error
	MOV	2(A3)[D1],A6		; addr to A6
	MOV	@A6,D1			; binary var to D1
	BR	NXTARG
1$:	CALL	$GTARG			; decode fp or string variable
	JNE	ERR3			; conversion error check
NXTARG:	ADD	#ARGBLK,D0		; bump argument index
	LCC	#4			; set Z bit
	RTN
;
; Return an address in D1, and size in D2 - strings or unformatted variables
; A3 = Basic argument pointer
; D0 = argument index
GTADDR:	MOV	D0,D1			; put index into D1
	ANDW	#7,0(A3)[D1]		; clear meaningless & subscript bit
	CMPW	0(A3)[D1],#4		; fp?
	JEQ	ERR3
	CMPW	0(A3)[D1],#6		; binary?
	JEQ	ERR3
; Don't check variable type
GTADR2:	MOV	D0,D1			; set up index again
	MOV	6(A3)[D1],D2		; size to D2
	MOV	2(A3)[D1],D1		; addr to D1
	BR	NXTARG
;
; ***************************************************************************
; Error routines
ERR1:	TYPE <?Insufficient impure memory space>
	JMP	ERRMSG
ERR2:	TYPE <?Missing or excess arguments>
	JMP	ERRMSG
ERR3:	TYPE <?Bad argument #>
ERR31:	SUB	#2,D0				; subtract 1st word
	MOV	#1,D1				; counter for # arguments
1$:	TST	D0				; when 0, at the argument
	BLE	2$
	SUB	#ARGBLK,D0
	INC	D1
	BR	1$
2$:	DCVT	2,OT$TRM!OT$LSP!OT$TSP		; decimal #, bracket w/ blanks
	BR	ERRMSG
ERR4:	TYPE <?Result too large for argument #>
	SUB	#ARGBLK,D0
	BR	ERR31
ERR5:	TYPE <?Too many blocks total pending to print>
ERRMSG: TYPECR < in XCALL SPOOL>
	LCC	#0				; clear Z bit
	RTN
;
	END