⟦0b9ef813c⟧

PTS(SC)

	IDENT	ASSRUT	REL 10.0 80-04-11 
			80-03-18/PEEN
			UPD 79-11-01/PEEN
			UPD 79-10-18/PEEN
			UPD 79-10-04/PEEN
			UPD 79-09-24/DALI
			UPD 79 08 14/PEEN$$
			UPD 79-04-24/PEEN
			UPD 79-02-28/PEEN
			UPD 79-01-30/PEEN
* ASSEMBLER ROUTINES USED BY PTS DE-SYSTEM

	ENTRY	ATTWB
	ENTRY	ATTDB
	ENTRY	SAVE 
	ENTRY	RESTOR 
	ENTRY	GETFRE 
	ENTRY	SETFRE 
	ENTRY	SETOCC 
	ENTRY	CHANFC 
	ENTRY	GETVOL 
	ENTRY	UPDBOL 
	ENTRY	UPDBIN 
	ENTRY	SETB 
	ENTRY	TESTB
	ENTRY	CLEARB 
	ENTRY	MSKOUT 
	ENTRY	RCNTRL 
	ENTRY	WCNTRL 
	ENTRY	GETVAL 
	ENTRY	GETACC 
	ENTRY	GETGEN 
	ENTRY	GETDUP 
	ENTRY	ATTBUF 
	ENTRY	FORCED 
	ENTRY	GETIND 
	ENTRY	CMPIND 
	ENTRY	WRITDK 
	ENTRY	READDK 
	ENTRY	CLOSEF 
	ENTRY	OPENF
	ENTRY	POOLA
	ENTRY	GETFWD 
	ENTRY	ADJUST 
* 
	EXTRN	I:EVA0,I:RT1 
	EXTRN	T:FDSP 
	EXTRN	P:BAS
	EXTRN	T:GETF 
	EXTRN	T:GRFC 
	EXTRN	P:MTAB 
* 
* 
* 
CALL	FORM	16=/F6A1,16 
* 
FVAL	EQU	/C5
FACC	EQU	/C7
FGEN	EQU	/C6
FDUP	EQU	/CC
FLINK	EQU	/DE 
FCBIX	EQU	12
FCBNIX	EQU	44 
FCBROW	EQU	14 
FCBNLI	EQU	46 
FCBLP	EQU	4 
FCBFMA	EQU	2


	EJECT
* 
*  ATTACH A STRING VARIABLE AS WORKBLOCK TO 
*  THE TERMINAL CONTROL AREA
*   SYNTAX:    CALL  ATTWB,STRG,DISPL,BLOCK 
*     STRG= STRING ITEM TO BE WORKBLOCK 
*    DISPL= BIN ITEM HOLDING DISPLACEMENT RELATIVE
*           'STRG'-START
*    BLOCK= BIN ITEM HOLDING BLOCK NUMBER WITHIN T:A
* 
ATTWB	EQU	* 
	LDKL	A10,2	INDICATE WB 
ATT	EQU	* 
	CALL	I:EVA0	ADDRESS TO NEW WB
	LDR	A7,A9	SAVE ADDRESS 
	CALL	I:EVA0	GET DISPLACEMENT 
	ADR*	A7,A9 
	CALL	I:EVA0	ADDRESS TO WB NUMBER 
	LDR*	A1,A9 
	SLL	A1,2	TIMES 4 
	ADR	A1,A13	ADDRESS TO DB 
	ADR	A1,A10	GET ADDRESS TO WB OR DB 
ATT100	EQU	*
	STR	A7,A1	STORE NEW WB/DB-ADDRESS
	RF	RETUR 
* 
	EJECT
* 
*  ATTACH A STRING VARIABLE AS DESCRIPTOR BLOCK TO
*  THE TERMINAL CONTROL AREA
*   SYNTAX:    CALL  ATTDB,STRG,DISPL,BLOCK 
*    STRG= STRING ITEM TO BE DISCRIPTOR BLOCK 
*   DISPL= BIN ITEM HOLDING DISPLACEMENT RELATIVE 
*          'STRG'-START 
*   BLOCK= BIN ITEM HOLDING BLOCK NUMBER WITHIN T:A 
* 
* 
ATTDB	EQU	* 
	SUR	A10,A10	INDICATE DB
	RB	ATT 
	EJECT
* 
*   CHANGE FILE CODE IN ECB 
*   CALL: 
*        CALL CHANFC,DATASET,FILECODE 
* 
CHANFC	EQU	*
	CF	A14,T:FDSP	GET ECB-ADDRESS
	CF	A14,I:EVA0	GET ADDRESS TO BIN.
	LC	A3,1,A9	GET FILE CODE 
	SC	A3,1,A8	STORE FILE CODE IN ECB
	RF	RETUR 
	EJECT
* 
*  SAVE POINTERS TO DB:S/WB:S IN STRING ITEM
*   SYNTAX: CALL  SAVE,DISPL,LENGTH,STRG
*   DISPL= BIN ITEM HOLDING DISPLACEMENT RELATIVE 
*          THE VERY FIRST DB:POINTER
*  LENGTH= BIN ITEM HOLDING THE NUMBER OF BYTES TO BE MOVED 
*    STRG= STRING VARIABLE TO STORE THE SAVED POINTERS IN 
* 
SAVE	EQU	*
	CALL	GETP	GET PARAMETERS 
SAV100	EQU	*
	ADR	A2,A7
	ADR	A7,A9
SAV200	EQU	*
	LCR	A1,A2
	SCR	A1,A7
	ADK	A2,1 
	ADK	A7,1 
	SUK	A6,1 
	RB(NZ)	SAV200
	RF	RETUR 
* 
*  RESTORE DB/WB-POINTERS FROM A STRING VARIABLE
*  TO THE T:A (TERMINAL CONTROL AREA) 
*   SYNTAX:  CALL  RESTOR,DISPL,LENGTH,STRG 
*   DISPL= DISPLACEMENT RELATIVE THE VERY FIRST DB-POINTER
*  LENGTH= NUMBER OF BYTES TO RESTORE 
*    STRG= STRING ITEM HOLDING POINTERS TO BE RESTORED
* 
RESTOR	EQU	*
	CALL	GETP
	LDR	A1,A2
	LDR	A2,A9	CHANGE 
	LDR	A9,A1	ADDRESSES
	RB	SAV100	START TO RESTORE 
* 
*   GET PARAMETERS FOR SAVE/RESTORE 
* 
GETP	EQU	*
	CALL	I:EVA0
	LDR*	A7,A9	START DISPLACEMENT
	CALL	I:EVA0
	LDR*	A6,A9	GET LENGTH
	CALL	I:EVA0
	LDK	A2,40
	ADR	A2,A13	GET ADDRESS TO DB-POINTER /A
	RTN	A14
	EJECT
*  GET A FREE RECORD FROM FREE-SPACE RECORD 
*  SYNTAX:  CALL GETFRE,BPOOL(IND),RPOOL(IND),NUMB
*   OUTPUT: NUMB = FOUND RECORD NUMBER (=0 IF NOT FOUND)
GETFRE	EQU	*
	CALL	GETPAR	GET PARAMETER ADDRESSES
	LD	A4,-2,A7	GET NUMBER OF FRE RECORDS
	RF(Z)	NOK	IF NONE FREE 
GET100	EQU	*
	CWR	A7,A8
	RF(E)	NOK	END OF RECORD
	LCR	A4,A7	GET BITS FOR 8 RECORDS 
	SLL	A4,8	SHIFT TO RIGHTMOST
	RF(NZ)	SEARCH	AT LEAST ONE RECORD FREE 
	ADK	A7,1	INCREMENT POINTER 
	ADK	A6,8	UPDATE RECORD NUMBER
	RB	GET100
SEARCH	EQU	*
	LDK	A5,0	INDICATE FIRST BIT IN BYTE
	LDR	A4,A4
SEA100	RF(N)	FOUND	IF FOUND 
	ADK	A5,1	INCREMENT COUNTER 
	SLL	A4,1 
	RB	SEA100
FOUND	SLL	A4,1	CLEAR BIT
	ADR	A6,A5	UPDATE RELATIVE RECORD NUMBER
FOU100	SRL	A4,1 
	SUK	A5,1	DECREMENT POINTER 
	RB(NN)	FOU100
	SRL	A4,8 
	SCR	A4,A7	STORE UPDATED BYTE 
	LC	A7,17,A9
	ECR	A7,A7
	LC	A7,18,A9	GET START RECORD NUMBER
	ADR	A6,A7	GET CURRENT RECORD NUMBER
	LDKL	A1,-1 
	ADRS	A1,A2	DECREMENT NO. OF FREE RECS. 
NOK	EQU	* 
	CALL	I:EVA0
NOK100	STR	A6,A9	STORE FOUND INDEX
RETUR	ABL	I:RT1 
	EJECT
*  SETFRE: INDICATE RECORD FREE AND UPDATE NO.OF
*          FREE RECORD COUNTER. THIS IS ONLY DONE 
*          IF CURRENT RECORD WAS BUSY 
*  SYNTAX: CALL SETFRE,BPOOL(IND),RPOOL(IND),NUMB 
*          NUMB = CURRENT RECORD NUMBER (=0 IF WRONG NUMBER)
* 
SETFRE	EQU	*
	SUR	A10,A10	INDICATE SETFRE
SET	EQU	* 
	CALL	GETPAR
	LDR	A6,A9	COPY ADDRESS 
	CALL	I:EVA0	GET ADDRESS TO REC. NO.
	LDR	A2,A7	COPY A7
	LDR*	A3,A9	GET INDEX 
	LC	A1,17,A6
	ECR	A1,A1
	LC	A1,18,A6	GET START RECORD NUMBER
	SUR	A3,A1	GET RELATIVE RECORD NO.
	CALL	SEABIT	SEARCH WANTED BIT
	LDR	A6,A6
	RB(Z)	NOK100	JUMP IF ERROR 
	LDR	A10,A10
	RF(NZ)	TEST0	IF SET0CC 
* SETFRE: TEST IF ALREADY FREE
TEST1	LDR	A4,A4 
	RB(N)	RETUR	IF ALREADY FREE
	ORKL	A4,/8000	SET RECORD FREE
	LDK	A1,1	INDICATE INCREMENT
TES100	ADS	A1,-2,A2	IN-/DE-CREMENT COUNTER
TES200	SUK	A3,1 
	RF(N)	TES300	BYTE RESTORED 
	SRC	A4,1 
	RB	TES200
TES300	SRL	A4,8	MOVE TO RIGHTMOST BYTE
	SCR	A4,A7	STORE UPDATED BYTE 
	RB	RETUR 
* 
* SETOCC: TEST IF ALREADY OCCUPIED
TEST0	EQU	* 
	LDR	A4,A4
	RB(NN)	RETUR	IF ALREADY OCCUPIED 
	SUK	A1,1	A1 = -1; INDICATE DECREMENT 
	ANKL	A4,/7FFF	INDICATE OCCUPIED
	RB	TES100
	EJECT
* SET RECORD OCCUPIED AND DECREMENT NUMBER OF 
* FREE RECORDS; THIS IS ONLY DONE IF CURRENT RECORD 
* IS FREE 
*   SYNTAX: CALL SETOCC,BPOOL(IND),RPOOL(IND),NUMB
*       NUMB = CURRENT RECORD NUMBER (= 0 AS OUTPUT IF
*                                       WRONG NUMBER) 
SETOCC	EQU	*
	LDR	A10,A14	INDICATE SETOCC
	RB	SET 
	EJECT
* 
*   MOVE CONTENTS OF BIN ITEM TO CORRESPONDING
*   16 BOOLEAN ITEMS
* 
UPDBOL	EQU	*
	CALL	I:EVA0	GET ADDRESS TO BIN ITEM
	LDR*	A1,A9	GET BIN CONTENTS
	ST	A1,-2,A9	STORE BOOLEANS 
	RB	RETUR 
* 
*   MOVE 16 BOOLEAN ITEMS TO CORRESPONDING BIN
* 
UPDBIN	EQU	*
	CALL	I:EVA0	GET ADDRESS TO BIN ITEM
	LD	A1,-2,A9	GET BOOLEANS 
	STR	A1,A9	STORE IN BIN 
	RB	RETUR 
	EJECT
* 
*   SEARCH WANTED BIT IN A CHARACTER STRING 
*    A3 = BIT INDEX 
*    A7 = CHARACTER STRING START ADDRESS
* 
SEABIT	EQU	*
SET050	SUK	A3,8 
	RF(N)	SET100 
	ADK	A7,1 
	CWR	A7,A8
	RB(NE)	SET050	CONTINUE IN NOT EOR
	LDK	A6,0	INDICATE INCORRECT REC. NO. 
	RTN	A14
* PLACED IN CURRENT BYTE
SET100	EQU	*
	ADK	A3,8 
	LCR	A4,A7
	SLL	A4,8	GET BYTE RIGHTMOST
	LDR	A1,A3	COPY A3
	RF(Z)	TEST	IF FIRST BIT
SET300	EQU	*
	SLC	A4,1 
	SUK	A1,1 
	RB(NZ)	SET300
TEST	EQU	*
	RTN	A14
	EJECT
* 
*  SET WANTED BIT IN A STRING OR BIN ITEM 
*  SYNTAX:  CALL  SETB,ITEM,INDEX 
* 
SETB	EQU	*
	SUR	A10,A10	INDICATE 'SET' 
SETB10	EQU	*
	CALL	I:EVA0	GET ADDRESS TO ITEM
	LDR	A7,A9	COPY ADDRESS 
	LDR	A8,A5	COPY ENDADDRESS
	CALL	I:EVA0	GET ADDRESS TO INDEX 
	LDR*	A3,A9	GET INDEX 
	CALL	SEABIT	SEARCH WANTED BIT
	LDR	A10,A10
	RF(N)	SETB30	IF TEST BIT 
	RF(Z)	SETB20	JUMP IF SETBIT
* CLEAR BIT 
	ANKL	A4,/7FFF	CLEAR BIT
	RB	TES200	RESTORE BYTE 
* SET BIT 
SETB20	EQU	*
	ORKL	A4,/8000	SET BIT
	RB	TES200	RESTORE BYTE 
SETB30	EQU	*
	LDK	A1,0	INDICATE FALSE
	LDR	A4,A4	TEST BIT 
	RF(NN)	SETB40	IF FALSE 
	LDK	A1,1	INDICATE TRUE 
SETB40	EQU	*
	LD	A4,2,A13	GET STACK BASE 
	SC	A1,-2,A4	STORE CR ON STACK
	RF	RET 
* 
*  CLEAR BIT IN STRING OR BIN VARIABLE
*   SYNTAX:  CALL  CLEARB,ITEM,INDEX
* 
CLEARB	EQU	*
	LDKL	A10,1	INDICATE 'CLEAR BIT'
	RB	SETB10	CONTINUE 
* 
*  TEST BIT IN STRING OR BIN VARIABLE 
*   SYNTAX:  CALL  TESTB,ITEM,INDEX 
*   OUTPUT:  CR = 0 (BIT IS FALSE)
*            CR = 1 (BIT IS TRUE) 
* 
TESTB	EQU	* 
	LDKL	A10,-1	INDICATE 'TEST BIT'
	RB	SETB10	CONTINUE 
	EJECT
* GET VOLUME NAME TO A STRING VARIABEL
*  SYNTAX: CALL GETVOL,DSET,BUFFER,VOLNAM,RETCOD
*          RETCOD = 0 IF OK, ELSE 1 
* 
GETVOL	EQU	*
	CALL	T:FDSP	GET DSET ADDRESS TO A8 
	CALL	I:EVA0	GET BUFFER ADDRESS TO A9 
	ADKL	A9,1	MAKE BUFFER ADDRESS EVEN 
	ANKL	A9,/FFFE
	ST	A9,2,A8	STORE BUFFER ADDRESS IN DSET
	LDK	A6,6	REQUESTED LENGTH =6 
	ST	A6,4,A8	=> VOLUME NAME AS OUTPUT TEST STATUS
	CALL	I:EVA0	GET ADDRESS TO VOLNAM
	LDK	A7,/80	LOAD ORDER CODE 
*      A7    ORDER CODE FOR TEST STATUS 
*      A8    DSET ADDRESS 
	LKM
	DATA	1 
	LD	A1,8,A8	LOAD RETURN CODE
	RF(NZ)	ERROR 
*     STORE THE VOLUME NAME (OUTPUT FROM TEST STATUS) 
*     IN CALLERS BUFFER VOLNAM
	LD	A1,2,A8	LOAD BUFFER ADDRESS 
	LDK	A2,6	NO OF BYTES IN VOLUME NAME
LOOP	EQU	*
	LCR	A3,A1
	SCR	A3,A9
	ADK	A1,1 
	ADKL	A9,1
	SUK	A2,1 
	RB(P)	LOOP 
UT	EQU	*
	LDK	A6,0 
VIN	CF	A14,I:EVA0 
	STR	A6,A9	STORE RETURN-CODE
RET	ABL	I:RT1 
ERROR	LDK	A6,1
	RB	VIN 
	EJECT
GETPAR	EQU	*
	CALL	I:EVA0	ADDRESS TO BPOOL 
	LDR	A7,A9	COPY ADDRESS 
	CALL	I:EVA0	ADDRESS TO RPOOL 
	LC	A8,15,A9
	ECR	A8,A8
	LC	A8,16,A9	GET OCCUPIED BYTES 
	ADR	A8,A7	GET END ADDRESS
	SUKL	A8,10 
	LDR	A2,A7	SAVE START ADDRESS 
	ADK	A7,2	ADDRESS TO FIRST BITS 
	LDK	A6,0 
	RTN	A14
	EJECT
* 
*  READ CONTROLS FROM A STRING ITEM AND STORE 
*  IN CORRESPONDING BOOLEAN AND BIN ITEMS 
*    SYNTAX: CALL  RCNTRL,BUFF,DISPL,BOOLBIN,MINL,MAXL
*        BUFF+DISPL= START ADDRESS IN STRING ITEM 
*           BOOLBIN= FIRST BIN IN SAME WB AS CURRENT BOOLS
*              MINL= BIN FOR MIN LENGTH 
*              MAXL= BIN FOR MAX LENGTH 
* 
RCNTRL	EQU	*
	SUR	A10,A10	INDICATE READING CONTROLS
CONTRL	CALL	I:EVA0	BUFFER ADDRESS 
	LDR	A8,A9
	CALL	I:EVA0	DISPLACEMENT ADDRESS 
	ADR*	A8,A9	GET START POINTER 
	CALL	I:EVA0	 
	LDR	A7,A9
	SUK	A7,2	ADDRESS TO BOOLEANS 
	CALL	I:EVA0	MINL ADDRESS 
	LDR	A6,A9
	CALL	I:EVA0	MAXL ADDRESS 
	LDR	A10,A10
	RF(Z)	READ	JUMP IF "RCNTRL"
* WRITE CONTROLS
	LDR*	A1,A7	GET BOOLEANS
	SC	A1,2,A8	STORE IN BUFFER 
	SRL	A1,8	SHIFT OUT 8 BOOLEANS
	SLL	A1,7 
	ADR*	A1,A9	GET NEOI + MAXL 
	SC	A1,1,A8	STORE IN BUFFER 
	SRL	A1,2	SHIFT IN ME + TYPE
	ANK	A1,/C0 
	ADR*	A1,A6	GET MINL
	SCR	A1,A8	STORE IN BUFFER
	RB	RET 
* READ CONTROLS 
READ	EQU	*
	LC	A1,1,A8	GET NEOI + MAXL 
	LDR	A2,A1
	ANK	A2,/7F	MASK OUT MAXL 
	STR	A2,A9	STORE MAXL 
	LCR	A2,A8
	ANK	A2,/3F	MASK OUT MINL 
	STR	A2,A6	STORE MINL 
	SRL	A1,7	NEOI TO RIGHTMOST POS.
	ANK	A1,1	MASK OUT NEOI 
	LCR	A2,A8	GET ME + TYPE + MINL 
	SRL	A2,5	SHIFT OUT MINL
	ANK	A2,6 
	ADR	A2,A1
	ECR	A2,A2
	LC	A2,2,A8	GET OTHER BITS
	STR	A2,A7	STORE BOOLEANS 
	RB	RET 
	EJECT
* 
*   WRITE CONTROLS FROM BOOLEANS AND BINS TO
*   STRING ITEM 
*    SYNTAX: CALL  WCNTRL,BUFF,DISPL,BOOLBIN,MINL,MAXL
*        BUFF+DISPL= START POINT FOR WRITINGM 
*           BOOLBIN= FIRST BIN IN SAME WB AS CURRENT BOOLEANS 
*              MINL= BIN FOR MIN LENGTH 
*              MAXL= BIN FOR MAX LENGTH 
* 
WCNTRL	EQU	*
	LDR	A10,A14	INDICATE WRITE CONTROLS
	RB	CONTRL
	EJECT
* 
*  MASK OUT WANTED BITS ACCORDING TO MASK 
*  SYNTAX:  CALL  MSKOUT,MASK,BIN 
*   MASK= BIN ITEM HOLDING THE MASK; WILL CONTAIN 
*         THE RESULT AFTER THE LOGICAL AND OPERATION
*    BIN= BIN HOLDING THE VALUE TO BE MASKED
* 
MSKOUT	EQU	*
	CALL	I:EVA0	ADDRESS TO MASK
	LDR	A6,A9
	CALL	I:EVA0	ADDRESS TO BIN 
	LDR*	A1,A9	GET CONTENTS OF BIN 
	ANRS	A1,A6	LOGICAL AND WITH MASK AND 
			STORE RESULT IN MASK 
	RB	RET 
* 
	EJECT
* 
*  ATTACH A STRING ITEM AS A FIX BUFFER 
*  TO A DATASET 
*     SYNTAX:  CALL  ATTBUF,DSET,BUFFER 
* 
ATTBUF	EQU	*
	CALL	T:FDSP	DSET-ADDRESS 
	LDKL	A1,/4000
	ORRS	A1,A8	INDICATE FIX BUFFER 
	CALL	I:EVA0	GET BUFFER ADDRESS 
	ST	A9,2,A8	STORE BUFFER ADDRESS
	SUR	A5,A9	CALCULATE LENGTH 
	ST	A5,14,A8	STORE LENGTH 
ATTRET	EQU	*
	RB	RET 
	EJECT
* 
*  TEST IF AN ITEM IS FORCED
*   BCDITEM = RIGHTMOST DIGIT IS EQUAL TO /A
*  STRGITEM = LEFTMOST BYTE IS EQUAL TO '?' 
* 
*       SYNTAX:   CALL      FORCED,ITEM 
*       OUTPUT:             CR = 0  NOT FORCED
*                           CR = 1  FORCED
* 
FORCED	EQU	*
	CALL	I:EVA0	GET ITEM ADDRESS 
	ANK	A3,/30 
	RF(Z)	ALPHA	JUMP IF STRING ITEM
*  A BCD ITEM 
	LC	A3,-1,A5
	ANK	A3,/F	GET RIGHTMOST DIGIT
	SUK	A3,/A
FOR100	EQU	*
	RF(Z)	NOTFND	JUMP IF FORCED
	RF	UT150	NOT FORCED
ALPHA	EQU	* 
	LCR	A3,A9	GET LEFTMOST CHARACTER 
	SUK	A3,'?' 
	RB	FOR100
	EJECT
* 
*  GET VALIDATION STRING
* SYNTAX: CALL GETVAL,PSTRT,PLEN,BUFFX,START,LEN
*  INPUT:  PSTRT = POOLSTART (BPOOL(W1))
*           PLEN = POOL UNIT LENGT (BIN)
* OUTPUT:  BUFFX = CURRENT POOL UNIT INDEX (BIN)
*          START = POINTER TO STRING WIN CURRENT POOL UNIT
*            LEN = LENGTh OF FOUND STRING 
*             CR = 0 IF STRING IS FOUND 
*             CR = 1 IF STRING IS NOT FOUND 
* 
GETVAL	EQU	*
	LDK	A7,FVAL	INDICATE SEARCH FOR VALIDATION 
VAL100	EQU	*
	LDR	A10,A12	SAVE PP
	LD*	A11,-8,A13 
	ADR	A11,A13	GET FCB-ADDRESS
	LDR*	A6,A11	GET ADDRESS TO ITEM
	ADKL	A6,P:BAS+2	GET START SEARCH ADDRESS 
VAL150	EQU	*
	LCR	A1,A6	GET FORMAT CODE
	ADK	A6,1	INCREMENT POINTER 
	ANK	A1,/FF 
	CWK	A1,FVAL
	RF(E)	VAL300 
	CWK	A1,FACC
	RF(E)	VAL300 
	CWK	A1,FGEN
	RF(E)	VAL300 
	CWK	A1,FDUP
	RF(E)	VAL300 
	SUK	A1,FLINK 
	RF(NZ)	VAL200	IF NOT FLINK 
*  FLINK
	LDR	A12,A6	UPDATE PP TO FLINK-ITEM 
	CALL	I:EVA0	ADDRESS TO NEXT POOL UNIT
	LDR	A12,A10	RESTORE PP 
	LDR	A6,A9	UPDATE FORMAT POINTER
	RB	VAL150	CONTINUE 
* WANTED STRING IS NOT FOUND
VAL200	EQU	*
	LDK	A6,0	INDICATE NOT FOUND
	RF	OUT 
* FVAL,FACC OR FGEN 
VAL300	EQU	*
	CWR	A1,A7
	RF(E)	OUT	JUMP IF FOUND
	LCR	A1,A6	GET COUNTER
	ADR	A6,A1	UPDATE FORMAT POINTER
	ADK	A6,1 
	RB	VAL150	CONTINUE 
* 
* 
OUT	EQU	* 
	CALL	I:EVA0	GET POOL START 
	LDR	A10,A9	SAVE POOL START 
	SUR	A5,A9	GET LENGTH 
	LDR	A11,A5	SAVE POOL LENGTH
	CALL	I:EVA0	ADDRESS TO BUFFIND 
	LDR	A7,A9	SAVE ADDRESS 
	CALL	I:EVA0	ADDRESS TO START POINTER 
	LDR	A8,A9	SAVE ADDRESS 
	CALL	I:EVA0	ADDRESS TO LENGTh
	LDR	A6,A6
	RF(Z)	NOTFND	IF NOT FOUND
	LCR	A3,A6	GET LENGTh 
	ANK	A3,/FF 
	ADK	A6,1 
	STR	A3,A9	STORE LENGTh 
	SUR	A6,A10	GET RELATIVE LENGT
	LDK	A1,0 
UT100	EQU	* 
	ADK	A1,1 
	SUR	A6,A11	SUB WIF POOL-LENGF
	RB(P)	UT100	CONTINUE IF POSITIVE 
	ADR	A6,A11	RESTORE RELATIVE POSITION 
	STR	A1,A7	STORE BUFFER UNIT NUMBER 
	STR	A6,A8	STORE START POINTER
EQUAL	EQU	* 
UT150	EQU	* 
	LDK	A1,0	INDICATE CR = 0 
UT200	EQU	* 
	ABL	SETB40	STORE CR AND RETURN 
GREAT	EQU	* 
NOTFND	EQU	*
	LDK	A1,1	INDICATE CR = 1 
	RB	UT200	STORE CR AND RETURN 
LESS	EQU	*
	LDK	A1,2 
	RB	UT200 
	EJECT
* 
*  GET ACCUMULATION STRING
*  SEE UNDER GETVAL ABOVE 
* 
GETACC	EQU	*
	LDK	A7,FACC	INDICATE ACCUMULATION STRING 
	RB	VAL100	START TO SEARCH
* 
* 
*  GET GENERATION STRING
*  SEE UNDER GETVAL ABOVE 
* 
GETGEN	EQU	*
	LDK	A7,FGEN	INDICATE GENERATION STRING 
	RB	VAL100	START TO SEARC 
* 

*  GET DUPLICATION STRING 
*  SEE UNDER GETVAL ABOVE 
* 
GETDUP	EQU	*
	LDK	A7,FDUP
	RB	VAL100
* 
	EJECT
* 
*   GET DIMENSION OF INDEXED VARIABLE AND LENGTH
* 
*      SYNTAX:   CALL     GETIND,ITEM(W1),LENGTH,DIMENSION
* 
*                         ITEM(W1)      = CURRENT ITEM
*                         LENGTH        = BIN HOLDING ITEM LENGTH 
*                         DIMENSION     = BIN HOLDING DIMENSION 
*                                         (NUMBER OF ELEMENTS)
* 
GETIND	EQU	*
	CALL	I:EVA0	ADDRESS TO ITEM
	LD	A10,-6,A14	READ DIMENSION STORED BY I:EVA 
	LDR	A7,A5	COPY END ADDRESS 
	SUR	A7,A9	CALCULATE ITEM LENGTH
	CALL	I:EVA0	ADDRESS TO LENGTH ITEM 
	STR	A7,A9	STORE LENGTH 
	CALL	I:EVA0	ADDRESS TO DIMENSION 
	STR	A10,A9	STORE IN ITEM 
	RB	ATTRET	RETURN TO CALLER 
* 
	EJECT
* 
*   COMPARE INDEX VARIABLE WITH DIMENSION OF INDEXED ITEM 
* 
*      SYNTAX:       CALL   CMPIND,INDEX,ITEM(INDEX1) 
* 
*        OUTPUT:           CR = 0  IF INDEX=OK INDEX OF ITEM
*                     CR = 1  IF INDEX > MAX. INDEX 
*                      CR = 2  IF INDEX < 0 
* 

CMPIND	EQU	*
	CALL	I:EVA0	GET ADDRESS TO INDEX 
	LDR*	A6,A9	SAVE INDEX VALUE
	CALL	I:EVA0	GET ADDRESS AND DIMENSION OF ITEM
	LDR	A6,A6
	RB(NP)	LESS	IF LESS THAN 1 
	CW	A6,-6,A14	COMPARE WITH DIMENSION
	RB(G)	GREAT	IF TOO HIGH
	RB	EQUAL	IF OK INDEX 
* 
	EJECT
* 
*      CALL WRITDK,DSET,FILECODE,BUF,LEN,RECNO
* 
*            DSET      EVENT CONTROL BLOCK
*            FILECODE  FILE NUMBER
*            BUF       BUFFER 
*            LEN       REQUESTED LENGTH 
*            RECNO     REALATIV SECTOR NO WITHIN THE FILE 
* 
WRITDK	EQU	*
	LDKL	A11,/95	ORDER CODE
	RF	READ00
	EJECT
* 
*      CALL READDK,DSET,FILECODE,BUF,LEN,RECNO
* 
*            DSET      EVENT CONTROL BLOCK
*            FILECODE  FILE NUMBER
*            BUF       BUFFER 
*            LEN       REQUESTED LENGTH 
*            RECNO     RELATIVE SECTOR NO WITHIN THE FILE 
* 
READDK	EQU	*
	LDKL	A11,/91	ORDER CODE
READ00	EQU	*
	CALL	T:FDSP	GET DSET ADDRESS TO A8 
*    GET PARAMETERS FROM PARAMETER LIST AND STORE 
*    THEM IN DSET 
	CALL	I:EVA0	FILE CODE
	LDR*	A6,A9 
	SC	A6,1,A8 
	CALL	I:EVA0	BUFFER ADDRESS 
	ST	A9,2,A8 
	CALL	I:EVA0	RECORD LENGTH
	LDR*	A6,A9 
	ST	A6,4,A8 
	CALL	I:EVA0	RECORD NO
	LDR*	A6,A9 
	ST	A6,12,A8
	CM	10,A8 
	LDR	A7,A11 
READ20	EQU	*
*      A7     ORDER CODE
*      A8     DSET ADDRESS
	LKM
	DATA	15
* 
*     CHECK ON ERROR CODE 
READ40	EQU	*
	LD	A6,8,A8 
	RB(Z)	EQUAL	SET COND CODE TO 0 ,OK 
	ANKL	A6,/2000
	RB(NZ)	GREAT	SET COND CODE TO 1  ,EOF
	RB	LESS	SET COND CODE TO 2 ,ERROR
* 
	EJECT
* 
*      CALL  CLOSEF,DSET,FILECODE,BUFF,RECNO
* 
*             DSET      EVENT CONTROL BLOCK 
*             FILECODE  FILE NUMBER 
*                  BUFF       BUFFER OF AT LEAST 80 BYTES 
*                  RECNO      LAST RECORD NUMBER (SHOULD BE ZERO) 
* 
CLOSEF	EQU	*
	LDR	A11,A14	INDICATE CLOSEF
	RF	OPENF0
CLOS10	EQU	*
	LDR*	A1,A9	GET RECORD NUMBER 
	ST	A1,60,A6	STORE RECORD NUMBER
	LDR*	A6,A10	GET FILE CODE
	SC	A6,1,A8 
	LDK	A7,/A2	LOAD ORDER CODE 
	RB	READ20
	EJECT
* 
*       CALL OPENF,DSET,FILECODE,BUF,FILE,VOLUME
* 
*              DSET      EVENT CONTROL BLOCK
*              FILECODE  FILE NUMBER
*              BUF       FILE PARAMETER BUFFER
*              FILE      FILE NAME
*              VOLUME    VOLUME NAME
* 
OPENF	EQU	* 
	SUR	A11,A11	INDICATE OPENF 
OPENF0	EQU	*
	CALL	T:FDSP	GET DSET ADDRESS TO A8 
	CALL	I:EVA0	SAVE ADDRESS TO FILE CODE
	LDR	A10,A9 
	CALL	I:EVA0	GET ADDRESS TO FPB(FILE PARAM.BUF) 
	ADKL	A9,1	AND MAKE SURE IT IS EVEN 
	ANKL	A9,/FFFE
	LDR	A6,A9	SAVE ADDRESS TO FPB
	ST	A9,2,A8	STORE THE ADDRESS IN DSET 
	LDK	A3,80	NO OF BYTES IN FPB 
	LDR	A2,A9	ADDRESS TO FPB 
OPEN00	EQU	*
	CMR	A2	STORE ZERO IN FPB 
	ADK	A2,2	INCREACE ADDRESS
	SUK	A3,2 
	RB(NZ)	OPEN00
* 
*     GET FILE NAME AND STORE IT IN FPB 
*      A3 CONTAINES FPB ADDRESS 
	CALL	I:EVA0
	LDR	A11,A11
	RB(NZ)	CLOS10	JUMP IF CLOSE
	ADK	A6,8	ADDRESS TO FILE NAME IN FPB 
	LDK	A4,8	NO OF CHAR IN FILE NAME 
OPEN20	EQU	*
	LCR	A3,A9	GET ON CHAR
	SCR	A3,A6	STORE ONE CHAR IN FPB
	ADKL	A9,1
	ADK	A6,1 
	SUK	A4,1 
	RB(NZ)	OPEN20
* 
*    GET VOLUME NAME AND STORE IT IN FPB
	CALL	I:EVA0
	ADK	A6,2	ADDRESS TO VOLUME IN FPB
	LDK	A4,6	NO OF CHAR IN VOLUME NAME 
OPEN40	EQU	*
	LCR	A3,A9
	SCR	A3,A6	STORE ONE CHAR IN FPB
	ADKL	A9,1
	ADK	A6,1 
	SUK	A4,1 
	RB(NZ)	OPEN40
	LDK	A7,/A1	LOAD ORDER CODE 
	LKM
	DATA	15
*   STORE FILE CODE IN FILE CODE BUFFER 
	LC	A3,1,A8 
	STR	A3,A10 
	RB	READ40	CHEC ON ERROR CODE 
 EJECT
* 
*   EVALUATE NUMBERS OF POOLS SPECIFIED IN CONFIGURATION
* 
*   SYNTAX:  CALL POOLA 
* 
* 
POOLA	EQU	* 
	LD	A4,P:MTAB+2	GET U:BTAB-ADDRESS
	LD	A4,2,A4	GET NUMBER OF BLOCK UNITS 
	SUK	A4,1 
	LD	A1,4,A13	GET DB-ADRESS FOR RPOOL
	LDKL	A2,/8000+19	LENGTH AND TYPE 
	ST	A2,36,A1	STORE LENGTH AND TYPE
	LDK	A3,208	LOAD START DISP. FOR RPOOL
	ST	A3,38,A1	STORE -   "   -
	ST	A4,40,A1	 STORE DIMENSION FOR RPOOL 
	ST	A4,48,A1	  -  "   -         BPOOL 
	ADK	A2,188-19	LOAD TYPE AND LENGTH FOR BPOOL 
	ST	A2,44,A1	STORE   -  "   - 
POOL10	ADK	A3,19	ADD DISP. WITH LENGTH OF RPOOL 
	SUK	A4,1 
	RB(P)	POOL10 
	ADK	A3,1 
	ANKL	A3,/FFFE	MAKE EVEN ADDRESS
	ST	A3,46,A1	ST DISPL. FOR BPOOL
POOLUT	EQU	*
	ABL	I:RT1
	EJECT
* 
*  PREPARE FOR GETFLD FROM CURRENT FIELD
*   IT IS REQUIRED THAT THE FORMAT DOES NOT 
*    CONTAIN ANY RETURN FROM SUBFORMAT
* 
*   THE ROUTINE:"ADJUST" SHOULD ALWAYS FOLLOW THIS ROUTINE
* 
*       SYNTAX:      CALL  GETFWD,BIN1,TYPE,START,SLUT
*                    BIN1 = WORK ITEM TO BE USED ALSO IN ROUTINE "ADJUST"
DataMuseum.dk

Philips Data Systems

⟦0b9ef813c⟧

Derivation

PTS(SC)

Full view
