PNDSD ROOT SET -SOURCE- 2040 15 JAN 81 22-2362 NP  92069-18153 2026 S C0122 &DBDME &DBDME              H0101 ASMB,L,C,R HED DBDME IMAGE/1000 UTILITY SUBROUTINE NAM DBDME,7 92069-16153 REV.2026 800122 * * ******************************************************************* * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR WRITTEN * CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18153 * RELOC: 92069-16153 * * PRGMR: CEJ * ALTERED: JANUARY 22, 1980 FOR SORTED CHAINS FEATURE - CEJ * * ******************************************************************* * * * * Delete Master Entry is a utility subroutine used by DBPUT and DBDEL * to remove an entry from either a manual or automatic master data set * once the record has been deemed removeable. Master deletes are spe- * cial in the case of roving synonyms. That is, if the entry to delete * is a primary which has synonyms, the first synonym on the chain must * be moved into the primary position to facilitate hashing. If this is * not the case, a zero-filled record is written to the record to be re- * moved and any synonyms must be updated. The simplest case is that * of a primary which has no synonyms. * * DBDME alters the FRT in memory but does not post it to disc since the * assumption is made that DBPUT or DBDEL will post it on a successful * completion. (Actually, for DBPUT we are merely removing an entry that * was created by DBBAM before all error checking was complete. DBBAM * itself calls us when it creates an entry and subsequently encounters * an error in trying to update any synonyms.) * * On entry, the A register is set to TRUE if the record to be deleted * is already in the record buffer, FALSE if not. An error code is passed * back to the caller in the A register, zero if successful. * * The calling sequence for DB[DME is: * * JSB DBDME * DEF *+4 return point * DEF BASE data base number from first word of * BASE parameter * DEF MNUM master data set number * DEF RECRD doubleword record number of record to be * deleted * SKP *********************************************************************** * * * Run Table for IMAGE/1000 Local machine. * * * * The Run Table is comprised of the following sections: * * * * 1) Data Base Control Block * * 2) Item Table * * 3) Data Set Control Block Table * * 4) Data Set Info Table * * A) Record Definition Table * * B) Path Table * * 5) Sort Table * * 6) Free Record Table * * * * These sections appear in the order described. Details of each * * section follow. * * * *********************************************************************** *** *** * * * Data Base Control Block - one 59 word entry per data base * * q * *** *** DBCBS DEC 59 Control Block Size DBNAM DEC 0 Data Base name - 3 words DEC 1 DEC 2 DBSCD DEC 3 Data Base Security Code (FMP) DBCRN DEC 4 Data Base Cartridge Number (FMP) DBDSN DEC 5 Data Base node number (DS/1000) DBRSN DEC 6 Data Base resource number DBICT DEC 7 Data Item Count DBITP DEC 8 Data item table pointer DBSCT DEC 9 Data set count DBSTP DEC 10 Data set control block table pointer DBSOP DEC 11 Sort table pointer DBFRP DEC 12 Free record table pointer DBLMD DEC 13 Data Base lock flag and open mode DBLFG EQU DBLMD 1st byte: lock flag DBMOD EQU DBLMD 2nd byte: open mode DBLVL DEC 14 Access level words - 3 words per level DBFRL EQU DBLVL Free record table length DBOPT DEC 15 Optimal number of DCBs DBMAX DEC 16 Maximum size of a data entry DCBWS DEC 17 DCB storage area * ZERO EQU DBNAM base of zero for future equates *** *** * * * Data Item Table - one 7-word entry per item * * * *** *** ITELN EQU ZERO+7 item table entry length ITNME EQU ZERO item name - 3 words ITINF EQU ZERO+3 item write/read level and type ITRDL EQU ITINF 1st nibble: item read level ITWRL EQU ITINF 2nd nibble: item write level ITTYP EQU ITINF 2nd byte: item type ITSET EQU ZERO+4 set count and 1st set number ITSCT EQU ITSET 1st byte: set count ITSNO EQU ITSET 2nd byte: set number ITWRC EQU ZERO+5 write/read bits and element count ITECT EQU ITWRC 2nd byte: element count ITLNG EQU ZERO+6 item length in words *** *** * * * Data Set Control Block Table - one 17 word entry per set * * * *** *** DSLNG EQU ZERO+17 table entry length DSNME EQU ZERO set name - 3 words DSCRN EQU ZERO+3 cartridge reference number DSINF EQU ZERO+4 W/R bits, set type and media length DSTYP EQU DSINF 1st byte, 2nd nibble: set type DSMDL EQU DSINF 2nd byte: media record length DSDRL EQU ZERO+5 data record length DSFPC EQU ZERO+6 field and path counts DSFCT EQU DSFPC 1st byte: # fields per entry DSPCT EQU DSFPC 2nd byte: # paths per entry DSITP EQU ZERO+7 data set info table entry pointer DSCAP EQU ZERO+8 doubleword data set capacity DSCPN EQU ZERO+10 current path info DSCCT EQU DSCPN 1st byte: search item number DSPAN EQU DSCPN 2nd byte: path # of search item DSRCN EQU ZERO+11 doubleword current record number DSBWN EQU ZERO+13 doubleword previous record number DSFWN EQU ZERO+15 doubleword next record number *** *** * * * Data Set Info Table - one Record Definition Table and one Path * * Table per data set * * * *** *** * * * Record Definition Table - one 1-byte entry per field * * * *** *** RDLNG EQU ZERO+1 entry length (number of words) RDINF EQU ZERO field info (two fields per word) RDIT1 EQU RDINF 1st byte: item # for field n RDIT2 EQU RDINF 2nd byte: item # for field n+1 *** *** * * * Path Table - one 2-word entry per path * * * *** *** PTLNG EQU ZERO+2 entry length PTINF EQU ZERO path information - item & set numbers PTSIN EQU PTINF 1st byte: detail's search item # for path PTDSN EQU PTINF 2nd byte: related set's number PTSRT EQU ZERO+1 sort item for path *** *** * * * Sort Table - one 1-word entry per item and set * * * *** *** STITS EQU ZERO beginning of item entries STSTS NOP beginning of set entries *** *** * * * Free Record Table - one 4-word entry per set * * * *** *** FRLNG EQU ZERO+4 length of entry FRRCT EQU ZERO doubleword free record count FRPTR EQU ZERO+2 doubleword first free record * * *********************************************************************** *** *** * ‰ * A EQU 0 B EQU 1 * ENT DBDME EXT .DIS,.ENTP,AIRUN,DBFWZ,DBRBL,DBRBP,DBRED,DBWRT * BASE NOP MNUM NOP RECRD NOP * * Get true parameter and return point addresses. * DBDME NOP STA SAVE Save flag in A reg. for later. NOP (This NOP necessary for .ENTP) JSB .ENTP DEF BASE * * If the record is not in the record buffer, read in the record we are * to delete. * LDA SAVE SSA,RSS JMP DME0 * JSB DBRED DEF *+4 DEF BASE,I DBRED needs: data base # DEF MNUM,I data set # DEF RECRD,I record number * SZA If any error, JMP DME4 pass it to caller. * * Now that we have the record, determine if it is a primary or synonym * from the entry type in the first word of the media record. * Entry type > 0 is a primary * Entry type < 0 is a synonym * DME0 CCA Set PRMRY flag to FALSE STA PRMRY if entry not a primary. * LDA DBRBP,I Set it to TRUE SSA,RSS if entry is a primary. ISZ PRMRY NOP * * Save off the backward and forward synonym pointers in either case. * Backward in 2nd & 3rd words of media record. Forward in 4th & 5th * words. * LDB DBRBP INB STB TEMP DLD TEMP,I DST BKWRD * ISZ TEMP ISZ TEMP DLD TEMP,I DST FRWRD * * Zero-fill the record buffer and write the all zero record to the re- * cord to be deleted. * JSB DBFWZ DEF *+3 DEF DBRBL DBFWZ needs: length of area to zero DEF DBRBP address of area to zero * JSB DBWRT DEF *+4 DEF BASE,I DBWRT needs: data base # DEF MNUM,I data set # DEF RECRD,I record number * SZA If any error, JMP DME4 pass it to caller. * * 4 Now, onto the synonyms (if any). We will deal with the case of a for- * ward synonym first, since this means the entry could have been a pri- * mary and we may need to move the first synonym and write a zero record * to its old location. * * Check the forward synonym pointer. If it's zero, go to backward syn- * onym process. If it's non-zero, determine if the deleted entry was * a primary (PRMRY = TRUE). * DLD FRWRD SZB,RSS SZA RSS JMP DME2 Forward ptr. is zero. * ISZ PRMRY RSS JMP DME1 Deleted entry not a primary. * * Now, we know the deleted entry was a primary and had synonym(s). Move * the first synonym into the primary location, making it a primary entry * type and zeroing its backward pointer. Then write a zero-filled re- * cord to its old location. * JSB DBRED We need to get the record DEF *+4 before we write it. DEF BASE,I DEF MNUM,I DEF FRWRD * SZA If any error, JMP DME4 pass it to user. * INA A one to the entry type. STA DBRBP,I ADA DBRBP STA TEMP * CLA A zero to the CLB backward pointer. DST TEMP,I * ISZ TEMP Save off new forward pointer. ISZ TEMP DLD TEMP,I DST SAVE * JSB DBWRT Write new primary record. DEF *+4 DEF BASE,I DEF MNUM,I DEF RECRD,I * SZA Pass any error code JMP DME4 to the caller. * JSB DBFWZ Fill the record buffer DEF *+3 DEF DBRBL with zeroes again. DEF DBRBP * JSB DBWRT Then write out the unused DEF *+4 record to the old DEF BASE,I synonym location. DEF MNUM,I DEF FRWRD * SZA Pass any error code JMP DME4 to the caller. * * If there is a 2ndO synonym, continue as if the deleted record has this * synonyn and was not a primary entry. Else skip to Free Record Table * updating (since there is no backward pointer). * DLD RECRD,I Make believe the bkwrd ptr. is DST BKWRD non-zero for the 2nd syn. update. * CCA But, set PRMRY to get around STA PRMRY bkwrd ptr. loop. * DLD SAVE SZB,RSS SZA RSS JMP DME3 No 2nd synonym. DST FRWRD SKP * * Forward pointer non-zero and deleted entry not a primary at this point * (or so we've set ourselves up to believe). Read in the forward pointer * record and set its backward pointer to the deleted record's backward * pointer, then write it back to disc. * DME1 JSB DBRED Read in forward synonym. DEF *+4 DEF BASE,I DEF MNUM,I DEF FRWRD * SZA If any error code, JMP DME4 pass it to caller. * LDB DBRBP Get its backward ptr. address, INB STB TEMP * DLD BKWRD and set its backward ptr. DST TEMP,I to deleted record's bkwrd ptr. * JSB DBWRT Then, write it back to disc. DEF *+4 DEF BASE,I DEF MNUM,I DEF FRWRD * SZA Pass any error code JMP DME4 to the caller. * * Now, were we really processing a non-primary record or were we faking * it? * ISZ PRMRY If a fake (PRMRY = -1) RSS we want to skip over JMP DME3 backward pointer processing. SKP * * Now, we deal with the case of a backward pointer. Check the backward * pointer. If it's zero go to the FRT update. If it's non-zero, read * in the backward pointer and set its forward pointer to the deleted * record's forward pointer. Then write it back to disc. * DME2 DLD BKWRD SZB,RSS SZA RSS JMP DME3 No backward synonym. * b640JSB DBRED Read the backward synonym DEF *+4 into the record buffer. DEF BASE,I DEF MNUM,I DEF BKWRD * SZA If any error, JMP DME4 pass code to caller. * LDB DBRBP Get address of forward ptr. ADB D3 for this entry. STB TEMP * DLD FRWRD Set its frwd ptr. to deleted DST TEMP,I entry's frwd ptr. * JSB DBWRT Then, write it back to disc. DEF *+4 DEF BASE,I DEF MNUM,I DEF BKWRD * SZA If any error JMP DME4 pass code to caller. SKP * * We've had a succesful delete. Decrement the free record count for the * master data set (first two words of the set's FRT entry) and return to * the caller. * DME3 CCA Set's FRT entry address = ADA MNUM,I (set # - 1) ALS,ALS * 4 LDB AIRUN ADB DBFRP + pointer to FRT ADA B,I (12th word of DBCB) ADA AIRUN + address of Run Table. STA TEMP * JSB .DIS DEF TEMP,I NOP * * Return to caller. * CLA DME4 JMP DBDME,I * * Constants and variables. * D3 EQU ZERO+3 PRMRY NOP TEMP NOP BKWRD BSS 2 FRWRD BSS 2 SAVE BSS 2 END C6   92069-18154 1912 S C0122 &DBFRT DBFRT SOURCE             H0101 gASMB,L,C,R HED DBFRT IMAGE/1000 UTILITY SUBROUTINE NAM DBFRT,7 92069-16154 REV.1912 790130 * * ******************************************************************* * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR WRITTEN * CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18154 * RELOC: 92069-16154 * * PRGMR: CEJ * * ******************************************************************* * * * * Find Run Table is a subroutine which searches through the Run Tables * for all open data bases for the Run Table of the data base specified * in the ibase parameter of the DBMS call. * * On a DBOPN, the entire Run Table pointer table is searched sequential- * ly for an entry pointing to the Run Table of the specified data base. * If the Run Table is found, the search is considered unsuccessful * since the user may not open the same data base twice. In addition, * on an DBOPN a successful search will return the index to the first * empty entry in the Run Table pointer table. * * On any other call, the first word of the ibase parameter is used as * an index into the Run Table pointer table. If the entry in this table * points to the proper Run Table, the call is considered succesful and * the address of the Run Table is passed back to the caller. If the entry * in the pointer table is empty or points to a Run Table not of the * specified data base the call is considered unsuccessful. * * On entry the A register is set to zero if caller is DBOPN, to minus * one if not. DBFRT returns the FOUND condition in the A register: * zero if data base found, -1 if not. * * The calling sequence from DBOPN for DBFRT is: * * CLA * JSB DBFRT * DEF *+4 * DEF IBASE IBASE parameter from DBMS call * DEF NAME data base name * DEF CRN data base CR number * * The calling sequence from any other DBMS routine for DBFRT is: * * CCA * JSB DBFRT * DEF *+2 * DEF IBASE IBASE parameter from DBMS call * ENT DBFRT EXT .CMW,.ENTP,AIRUN,DBRTM,DBRTP * A EQU 0 B EQU 1 * BASE NOP NAME NOP CRN NOP * * Get true addresses of parameters and return point. * DBFRT NOP STA SAVE NOP NOTE: This NOP is necessary for .ENTP! JSB .ENTP DEF BASE * * Initialize search parameters. * LDB BASE,I Set index/node # variable STB INDEX to first word of ibase parameter LDB DBRTP Get Run Table pointer table address STB RTPTR for search. * * If FLAG = 0 indicating DBOPN requests search, perform serial search * on Run Table pointer table. The index word of ibase is either a node * number or two blanks. * LDA SAVE SZA If DBOPN calling, JMP FRT6 STA AIRUN then set free entry index = 0 and LDA DBRTM set up for serial search. CMA,INA Entry counter = -maximum STA CNTR Run Tables. * * Perform serial search by examining each entry in the pointer table for * either an empty flag (i.e. contents of first word of entry = 0) or a * Run Table pointer. If empty, then if this is the first empty entry * found, save its index in AIRUN and continue on to next entry. If a * pointer, compare data base names, cartridge numbers, and node numbers * for a match. If they do not match continue on to next entry. If they * do match return as unsuccessful (i.e. FOUND = TRUE). * FRT1 LDA RTPTR,I Get contents of pointer table entry. SZA If a zero, JMP FRT2 : LDA DBRTM get entry's index ADA CNTR INA LDB AIRUN then if first empty entry SZB,RSS STA AIRUN save it for DBOPN to use JMP FRT5 and continue with search. * FRT2 LDB NAME If not empty, get the passed name JSB .CMW (A already points to name in Run Table) DEF D3 and compare names DEC 0 JMP FRT3 NOP If not a match JMP FRT5 continue with search. * FRT3 INA If same, compare cartridge numbers LDB A,I from CRN and Run Table CPB CRN,I JMP FRT4 A match. * LDB CRN,I If not a match, then if the user SZB did not specify a cartridge, JMP FRT5 treat the CRN as if it matched. * FRT4 INA If a match, compare node numbers LDB A,I from IBASE and Run Table. CPB NODE RSS JMP FRT5 If not a match, continue with search * CLA JMP DBFRT,I else return to DBOPN unsuccessful. * FRT5 ISZ RTPTR Bump pointer table address to next entry ISZ CNTR If more to search, JMP FRT1 continue on CCA JMP DBFRT,I else return to DBOPN successfully * * We come here when the call is from a DBMS subroutine other than DBOPN. * The first word of the ibase parameter should be the entry number of * the entry in the Run Table pointer table which holds the Run Table * pointer for the specified data base. Use the entry number - 1 as an * index into the pointer table and check the entry for validity (i.e. * non-empty pointer to proper Run Table). But first, make sure the * entry number is within [1..20]. * FRT6 CCA LDB INDEX SSB JMP DBFRT,I Number < 0, illegal param. * SZB,RSS JMP DBFRT,I Number = 0, illegal param. * CMB,INB ADB DBRTM SSB JMP DBFRT,I Number > max. db's, illegaۦl param. * ADA INDEX Address of entry in pointer table = address of ADA RTPTR pointer table + entry number - 1. * LDB A,I Get contents of entry. CCA SZB,RSS If entry empty (i.e. first word = 0) JMP DBFRT,I return unsuccessful to caller. * STB AIRUN Else, set up current Run Table CLA address as this Run Table, JMP DBFRT,I then return successful to the caller. * * Constants and variables * D3 DEC 3 * SAVE NOP INDEX NOP NODE EQU INDEX RTPTR NOP CNTR NOP END ؠ  92069-18155 1912 S C0122 &DBMST DBMST SOURCE             H0101 oASMB,L,C,R HED DBMST IMAGE/1000 UTILITY SUBROUTINE NAM DBMST,7 92069-16155 REV.1912 790130 * * ******************************************************************* * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR WRITTEN * CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18155 * RELOC: 92069-16155 * * PRGMR: CEJ * * ******************************************************************* * * * * MaSTer put is a utility subroutine used by DBPUT to determine the * proper record number for a new master data set entry and to build the * media record in the record buffer for that entry * * The calling sequence for DBMST is: * * JSB DBMST * DEF *+5 * DEF BASE data base # from ibase parameter * DEF MSNUM master data set's # * DEF READ the READ flag from DBHRD * DEF RECRD the record # from DBHRD * * * DBMST returns a condition code in the A register, zero if successful. * * DBMST must be called immediately after DBHRD or before any of the * values passed back by DBHRD have been altered. It uses the READ flag * and RECRD number returned by DBHRD to determine the new master record * number and to build the new entry's media record. When we enter the * routine we assume that the READ flag is not zero since this would * mean that a master entry already exists with the new entry's key item * value and the new entry could not be added. If the READ flag is > 0, * the new record should go into the record whose number was passed by * DBHRD in RECRD, however, that record contains a synonym for another * chain. Therefore, we must move it. If the READ flag is < 0, we have * to check the record in the record buffer it self to decide what to do. * If the record is empty, we've hit the simplest case. The new record * is put into the record whose number was passed to us with no synonyms. * If the record is non-empty, it contains the current synonym chain foot * for the new record's synonym chain. We need to find the next free re- * cord in the master (searching serially from the record number: RECRD) * and make the new record the end of the synonym chain. * * Our first action is to resolve the parameter and return point addresses. * ENT DBMST EXT .DIS,.DCO,.ENTR,AIRUN,DBFCB,DBFDS,DBFWZ,DBRBL EXT DBRBP,DBRED,DBWRT,EREAD A EQU 0 B EQU 1 * BASE NOP MSNUM NOP READ NOP RECRD NOP * DBMST NOP JSB .ENTR DEF BASE * CLA Set the primary FLAG STA FLAG to true. * * We will deal with a synonym belonging to a different chain than the * new record first. This means, move the synonym to the next (serially) * free record in the master. Then, put the new record in the synonym's * old record as a primary with "no" synonyms. * LDA READ,I SSA Is READ flag > 0? JMP MST3 No - we deal with that later. * DLD RECRD,I Yes - save this record # DST SAVE1 * JSB DBFFR Ask DBFFR to give us the next * free record in the data set. * LDA RECRD,I Did DBFFR succeed? SSA (i.e. record # non-negative?) JMP MSTE No - inform caller. * JSB DBWRT Yes - write the synonym to DEF *+4 the new record. DEF BASE,I DBWRT needs: data base # DEF MSNUM,I data set # DEF RECRD,I record number * SZA Did DBWRT encounter an error? JMP MSTR Yes - pass it to the user. * LDA DBRBP No - save off synonym's forward ADA D3 and backward synonym DLD A,I chain pointers. DST FRWRD LDA DBRBP INA DLD A,I DST BKWRD * * Update any synonyms which point to the record we just moved. * SZB,RSS Was it's backward pointer = 0? SZA RSS JMP E154 Yes - we've got a corrupt chain. * JSB DBRED No - read the backward pointer DEF *+4 DEF BASE,I DEF MSNUM,I DEF BKWRD * SZA Did DBRED encounter an error? JMP MSTR Yes - pass it to user. * LDA DBRBP No - make its forward pointer ADA D3 the synonym's new record # STA TEMP DLD RECRD,I DST TEMP,I * JSB DBWRT and write it back to disc. DEF *+4 DEF BASE,I DEF MSNUM,I DEF BKWRD * SZA Any error? JMP MSTR Yes - pass it to the user. * CPA FRWRD+1 No - was synonym's forward pointer = 0? RSS JMP MST1 CPA FRWRD JMP MST2 Yes - we are through w/synonym. * MST1 JSB DBRED No - read the forward pointer. DEF *+4 DEF BASE,I DEF MSNUM,I DEF FRWRD * SZA Any error? JMP MSTR Yes - pass it to user. * LDA DBRBP No - make it's backward pointer INA the synonym's new record #. STA TEMP DLD RECRD,I DST TEMP,I * JSB DBWRT Then, write it back out to disc. DEF *+4 DEF BASE,I DEF MSNUM,I DEF FRWRD * SZA Any error? JMP MSTR Yes - pass it to user. * MST2 DLD SAVE1 Done with synonym move. DST RECRD,I Put new entry's record # JMP MST4 back into RECRD for joint processing. SKP * * Now, we'll deal with the case of the new record belonging to an al- * ready existant synonym chain. (Remember that this case is signified * by :Qthe READ flag < 0 and the entry in the record buffer being non- * empty.) This case is handled by finding the next free record in the * data set from the current record number. The new record is flagged * as a synonym by setting the primary FLAG to FALSE (-1) and storing the * current record number (the old end of synonym chain) in the SYNYM * storage area. * * The READ flag is already known to be less than zero, so we start by * checking the entry type. The type flag is the first word of the media * record of the entry. It is non-zero if the entry is empty. * MST3 LDA DBRBP,I Is the current entry empty? SZA,RSS JMP MST4 Yes - simple case. * DLD RECRD,I No - save the record as the old DST SYNYM synonym chain foot. CCA Set the primary flag to FALSE. STA FLAG * JSB DBFFR Get the next free record * in the master set. * LDA RECRD,I Did we get it? SSA Yes - continue to joint processing. JMP MSTE No - let the caller know. SKP * * There is no special processing for the simple case of DBHRD not find- * ing a synonym for the new record's key value and not finding a synonym * in its proper primary location. So we just join all cases here. * * We have the new record's proper record number in RECRD. If it is a * synonym (primary FLAG = FALSE) we have the old synonym chain foot's * record number in SYNYM. Now all we have to do is build the new record * in the record buffer by setting its proper entry type in the first * word of the media record to: * 1 - if a primary entry (FLAG = TRUE) * -1 - if a synonym entry (FLAG = FALSE) * and if a synonym, setting the backward synonym pointer (2nd & 3rd words * of media record) to SYNYM. The remainder of the media record is all * zeroes. * MST4 JSB DBFWZ Fill the record buffer with zeroes. DEF *+3 DEF DBRBL DBFWZ needs: length of area to zero DEF DBRBP address of area to zero * CLB,INB If a primary entry, set LDA FLAG entry type to 1 SSA else set entry typ CMB,INB to -1. STB DBRBP,I * SSA,RSS If a synonym, put SYNYM JMP MSTE in new record's backward LDB DBRBP synonym chain pointer. INB STB TEMP DLD SYNYM DST TEMP,I * * Return to caller. * MSTE CLA MSTR JMP DBMST,I * * Error return point. * E154 LDA D154 Corrupt chain pointers. JMP MSTR * * Constants and variables. * D3 DEC 3 D154 DEC 154 SYNYM BSS 2 FRWRD BSS 2 BKWRD BSS 2 SAVE1 BSS 2 TEMP NOP FLAG NOP SKP * * Find Free Record is a utility subroutine for DBMST. It performs the * service of finding the next free record in a master data set (MSNUM) * by searching serially through the data set from the current record * number (in RECRD) until a free record is found or a complete wrap around * on the set has been performed. If it finds a free record, it returns * the number of that record in RECRD. If it does not find a free record, * it sets RECRD to -1. * DBFFR NOP * * Save current record number in RECRD as starting point. * DLD RECRD,I DST START * * Ask DBFCB to give us the data set's DCB. * JSB DBFCB DEF *+4 DEF BASE,I DBFCB needs: data base number DEF MSNUM,I data set number DEF MSDCB returns: DCB address * SZA Did DBFCB encounter an error? JMP MSTR Yes - return in to user. * * Ask DBFDS to get MSNUM'S DSCB pointer for us. * JSB DBFDS DEF *+5 DEF MSNUM,I DEF NUMBR DEF ENTYP DEF MSPTR * LDA NUMBR If set # came back SZA,RSS as zero JMP FFRE bad Run Table. * * GT$"et the address of the capacity in the DSCB (9th word) and save it * in MSPTR. * LDA MSPTR ADA AIRUN ADA CAPAC STA MSPTR * * Now read serially through the data set searching for an empty record. * we need only the first word of each entry since it contains the entry * type flag (will be zero for an empty record). * FFR1 JSB .DIS Increment the record #. DEF RECRD,I NOP * * Check to see if the new record number is greater than the capacity. * If so, set the record number to 1 before we read it. * DLD MSPTR,I JSB .DCO DEF RECRD,I RSS Record # = capacity. RSS Record # > capacity. JMP FFR2 Record # < capacity. * CLA CLB,INB DST RECRD,I * FFR2 DLD START JSB .DCO DEF RECRD,I If same as starting record JMP FFRE we've completely wrapped NOP around data set. * JSB EREAD Read the first word of the record. DEF *+7 DEF MSDCB,I DEF ERROR DEF ENTYP DEF D1 DEF DUMMY (merely a place holder) DEF RECRD,I * SSA Did we get an error? JMP MSTR Yes - pass the error to the user. * * Here on a successful read, check the entry type in ENTYP. If it is * zero - we've got the record we want, pass it back to the caller. * LDA ENTYP SZA JMP FFR1 * FFR4 JMP DBFFR,I * * Error return point - no empty record found. * FFRE CCB CCA DST RECRD,I JMP FFR4 * * Constants and variables * D1 DEC 1 CAPAC DEC 8 START BSS 2 ENTYP NOP ERROR NOP NUMBR NOP DUMMY EQU NUMBR MSDCB NOP MSPTR NOP END '$   92069-18156 2026 S C0122 &DBPIL &DBPIL              H0101 ASMB,L,C,R HED DBPIL IMAGE/1000 UTILITY SUBROUTINE NAM DBPIL,7 92069-16156 REV.2026 800501 * * ******************************************************************* * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR WRITTEN * CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18156 * RELOC: 92069-16156 * * PRGMR: CEJ * ALTERED: JANUARY 22, 1980 FOR SORTED CHAINS FEATURE - CEJ * * ******************************************************************* * * * * Process Item List is a subroutine which accepts the item list passed * to an IMAGE subroutine by the user's program, parses the item list into * its components and builds an information table on the items in the list * for the IMAGE subroutine. The item list is either: * * 1) A number list in which the first word contains an integer count * of the number of items in the list and each succeeding word, up * to the count number of items contains an unique item number. * 2) A name list which is a list of unique item names concatenated * together, separated by commas, and terminated by a semi-colons * or a blank. * 3) A special construct either: * "@ " meaning all items in the data set's record definition * table * or * "0 " meaning no items. * * The information returned by DBPIL is in a table where each item has * one entry and each entry is three words long and have the meaning: * * word --------------------------------- * 1 !w!k!s| ! item no. ! -> or entire word = 0 * --------------------------------- * 2 ! word length of item ! * --------------------------------- * 3 ! index into data record of set ! * --------------------------------- * * 15 14 13 8 7 0 bit * * w if set means item is writeable * k if set means item is a key item * s if set means item is a sort item * * The last entry following the last item's entry in this table contains * a zero (end of table marker). In addition, DBPIL returns the number * of key items in the list as its third parameter. * * The calling sequence for DBPIL is: * * JSB DBPIL * DEF *+4 return point * DEF IMLST item list to process * DEF DSADR address of data set's control block table * entry, relative to start of Run Table * DEF KEYS returned number of keys in list * * A status code, zero if successful, is returned in the A register. * SKP *********************************************************************** * * * Run Table for IMAGE/1000 Local machine. * * * * The Run Table is comprised of the following sections: * * * * 1) Data Base Control Block * * 2) Item Table * * 3) Data Set Control Block Table * * 4) Data Set Info Table * * A) Record Definition Table * * B) Path Table * * 5) Sort Table * * 6) Free Record Table * * ݗ * * These sections appear in the order described. Details of each * * section follow. * * * *********************************************************************** *** *** * * * Data Base Control Block - one 59 word entry per data base * * * *** *** DBCBS DEC 59 Control Block Size DBNAM DEC 0 Data Base name - 3 words DEC 1 DEC 2 DBSCD DEC 3 Data Base Security Code (FMP) DBCRN DEC 4 Data Base Cartridge Number (FMP) DBDSN DEC 5 Data Base node number (DS/1000) DBRSN DEC 6 Data Base resource number DBICT DEC 7 Data Item Count DBITP DEC 8 Data item table pointer DBSCT DEC 9 Data set count DBSTP DEC 10 Data set control block table pointer DBSOP DEC 11 Sort table pointer DBFRP DEC 12 Free record table pointer DBLMD DEC 13 Data Base lock flag and open mode DBLFG EQU DBLMD 1st byte: lock flag DBMOD EQU DBLMD 2nd byte: open mode DBLVL DEC 14 Access level words - 3 words per level DBFRL EQU DBLVL Free record table length DBOPT DEC 15 Optimal number of DCBs DBMAX DEC 16 Maximum size of a data entry DCBWS DEC 17 DCB storage area * ZERO EQU DBNAM base of zero for future equates *** *** * * * Data Item Table - one 7-word entry per item * * 1 * *** *** ITELN EQU ZERO+7 item table entry length ITNME EQU ZERO item name - 3 words ITINF EQU ZERO+3 item write/read level and type ITRDL EQU ITINF 1st nibble: item read level ITWRL EQU ITINF 2nd nibble: item write level ITTYP EQU ITINF 2nd byte: item type ITSET EQU ZERO+4 set count and 1st set number ITSCT EQU ITSET 1st byte: set count ITSNO EQU ITSET 2nd byte: set number ITWRC EQU ZERO+5 write/read bits and element count ITECT EQU ITWRC 2nd byte: element count ITLNG EQU ZERO+6 item length in words *** *** * * * Data Set Control Block Table - one 17 word entry per set * * * *** *** DSLNG EQU ZERO+17 table entry length DSNME EQU ZERO set name - 3 words DSCRN EQU ZERO+3 cartridge reference number DSINF EQU ZERO+4 W/R bits, set type and media length DSTYP EQU DSINF 1st byte, 2nd nibble: set type DSMDL EQU DSINF 2nd byte: media record length DSDRL EQU ZERO+5 data record length DSFPC EQU ZERO+6 field and path counts DSFCT EQU DSFPC 1st byte: # fields per entry DSPCT EQU DSFPC 2nd byte: # paths per entry DSITP EQU ZERO+7 data set info table entry pointer DSCAP EQU ZERO+8 doubleword data set capacity DSCPN EQU ZERO+10 current path info DSCCT EQU DSCPN 1st byte: search item number DSPAN EQU DSCPN 2nd byte: path # of search item DSRCN EQU ZERO+11 doubleword current record number DSBWN EQU ZERO+13 doubleword previous record number DSFWN EQU ZERO+15 doubleword next record number *** *** * * * Data Set Info Table - one Record Definition Table and one Path * * Table per data set * * * *** *** * * * Record Definition Table - one 1-byte entry per field * * * *** *** RDLNG EQU ZERO+1 entry length (number of words) RDINF EQU ZERO field info (two fields per word) RDIT1 EQU RDINF 1st byte: item # for field n RDIT2 EQU RDINF 2nd byte: item # for field n+1 *** *** * * * Path Table - one 2-word entry per path * * * *** *** PTLNG EQU ZERO+2 entry length PTINF EQU ZERO path information - item & set numbers PTSIN EQU PTINF 1st byte: detail's search item # for path PTDSN EQU PTINF 2nd byte: related set's number PTSRT EQU ZERO+1 sort item for path *** *** * * * Sort Table - one 1-word entry per item and set * * * *** *** STITS EQU ZERO beginning of item entries STSTS NOP beginning of set entries *** *** * * * Free Record Table - one 4-word entry per set * * * *** *** FRLNG EQU ZERO+4 length of entry FRRCT EQU ZERO doubleword free record count FRPTR EQU ZERO+2 doubleword first free record * * *********************************************************************** *** *** * * EXT .ENTR,AIRUN,DBCIX,DBFDI,DBRBP,NAMR ENT DBPIL,TEMPX A EQU 0 B EQU 1 * IMLST NOP DSADR NOP KEYS NOP * * Get true addresses of parameters and return point. * DBPIL NOP JSB .ENTR DEF IMLST * * Initialize process's parameters. * PIL1 CLA Zero to # of keys STA KEYS,I LDA TEMPX Set up information table address STA TABAD for loop. * * Determine if a special contruct we recognize is given. If so, branch * to the appropriate processing location. If not, assume the list is * of numbers or names. * LDA IMLST,I SSA If negative first word - JMP E101 illegal item list * CPA /@ If an "@ " JMP PIL11 process entire record definition table * CPA /0 If an "0 " or an integer zero JMP PIL14 process no items SZA,RSS JMP PIL14 * AND HIBYT Else, if first byte of word is zero - SZA,RSS this is a number list. CMA Set number flag to TRUE. STA NFLAG Else, set number flag to FALSE. * * Get # of fields/entry (i.e. # of items/data record) in data set and * save. If we are processing a number list, make sure the count spe- * cified by the user is within the range 0 < item count <= # fields/entry. * LDB AIRUN Get true address of data set's entry ADB DSADR,I in Run Table. ADB DSFCT Increment to # fields/entry word. LDA B,I Pick up number - it is in the AND HIBYT first byte of this word. ALF,ALF STA #F/E * LDB NFLAG If a number list SSB,RSS JMP PIL2 LDB IMLST,I CMB see if count okay. STB CONTR INB ADB A (i.e. count <= # fields/entry) SSB JMP E101 No - illegal item list JMP PIL3 * * For a name list, we will use NAMR to parse the string as we need a * name. So we need to set up for NAMR. This means getting the byte * count in the string and setting the starting byte to one. To get the * byte count, we will search each byte in the string until we find a * blank or semi-colon, incrementing the byte count by one for each byte * not matching an ending character. * PIL2 CLA Initialize byte count to zero. STA BCNT INA And starting byte to one. STA BSTRT * LDA #F/E Set maximum byte count to CLB -(# items in set * 7) MPY D7 CMA,INA This is 6 bytes per name STA BMAX plus trailing ",", ";", or " ". * LDB IMLST Get address of item list. PIL21 CCA Set first byte in word flag. STA FIRST LDA B,I Get first byte. ALF,ALF * PIL22 AND LOBYT CPA SEMI If a semi-colon JMP PIL24 CPA ABLNK or a blank JMP PIL24 we are done. * ISZ BCNT Else, increment byte count ISZ BMAX If byte count exceeds the maximum, RSS JMP E101 a bad item list. * ISZ FIRST If we were on first byte JMP PIL23 LDA B,I get second byte in word. JMP PIL22 * PIL23 INB Else get next word and JMP PIL21 process its fixrst byte. * PIL24 LDA BCNT At end, if byte count SZA,RSS is zero, JMP E101 a bad item list. JMP PIL4 * * BEGIN MAIN LOOP FOR NUMBER OR NAME LIST * This section of code picks up each item in the list, gets its item * table entry, item number and length, and determines if the item is * writeable. Then it calculates the item's index into the data record * of the set and determines if the item is a key. With each bit of in- * formation, the information table is slowly built. * PIL3 LDB NFLAG If a number list SSB,RSS JMP PIL4 ISZ CONTR If no more items in list, RSS JMP PIL10 we are done. ISZ IMLST LDA IMLST,I Else, pick up next item number STA ITEM and save it. JMP PIL5 * PIL4 JSB NAMR Else a name list - DEF *+5 call NAMR to get DEF ITEM next name. DEF IMLST,I DEF BCNT DEF BSTRT * SSA If no more names JMP PIL10 we are done. * PIL5 JSB DBFDI Call DBFDI to get item's item DEF *+5 table entry address relative to DEF ITEM beginning of Run Table. DEF NUMBR DEF FLAG DEF DIADR * LDB NUMBR If number returned is SZB,RSS equal to zero - JMP E101 illegal item list. * LDA FLAG If item inaccessible SSA,RSS (i.e. FLAG > 0) SZA,RSS then the item list is invalid RSS JMP E101 * * Search information table for an identical item number. If a match is * found, item list is illegal. * LDB TEMPX PIL6 CPB TABAD If at end of table, JMP PIL7 everything is fine. * LDA B,I If item # in this entry in table AND LOBYT same as the item # we are CPA NUMBR processing - JMP E101 illegal item list. ADB D3 Else t5)ry next entry until JMP PIL6 end of meaningful data in table. * PIL7 LDA NUMBR Get item # into A reg. LDB FLAG If accessibility flag from DBFDI is < 0 SSB item is writeable, set w bit in IOR WRITE item # word of information table entry. STA TABAD,I * LDB DIADR Get length of item from ADB AIRUN ADB ITLNG item's item table entry. LDB B,I LDA TABAD INA Store it in the 2nd word of the STB A,I information table entry. * * Call DBCIX to compute the index into the data set's data record for * this item. * JSB DBCIX DEF *+4 DEF NUMBR DEF DSADR,I DEF INDEX * * If INDEX < 0, item could not be found in record definition table - * Illegal item list!! * LDA INDEX SSA JMP E101 * * Else okay, put index into third word of information table. * LDB TABAD ADB D2 STA B,I * * Determine if item is a key item. * JSB DBIFK * * A register is returned <0 if item a key, >0 if item a sort item, else * zero. If item a key set key bit in information table and increment * the key item count. If item is a sort item, set sort bit in information * table. * SZA,RSS JMP PIL9 * SSA,RSS JMP PIL8 * LDA TABAD,I Item is a key item. IOR KEY STA TABAD,I ISZ KEYS,I JMP PIL9 * PIL8 LDA TABAD,I Item is a sort item. IOR SORT STA TABAD,I * PIL9 LDA TABAD Get address of next entry ADA D3 in TEMPX table STA TABAD JMP PIL3 and continue with next item. * * We come here when the item list processing is done successfully. * PIL10 CLB Put a zero item number word as the STB TABAD,I final entry in the information table. JMP PILF * * We come here when the special construct "@ " is givenR in the item list. * Get entire record definition table and transform it into an item num- * ber list. Then, branch up to item number list processing. * * The item list we build will occupy the low 128 words of TEMPX and there- * fore starts at TEMPX+254. We use TEMPX in this way to save space since * the item list would cost us a hard coded 128 words. * PIL11 LDB DSADR,I Get data set entry true address ADB AIRUN ADB DSFCT Increment to fields/entry count. LDA B,I Get the count from the first byte of this word ALF,ALF AND LOBYT STA LIST,I and put into item list. CMA,INA Negate it and save as loop counter. STA CONTR LDA LIST Get list address and bump INA STA TEMP2 then save for loop. * INB Increment B to the info table pointer LDA B,I and get its true address. ADA AIRUN STA IFADR * * Pull each byte out of the record definition table, make it into a word * and put it into the list. * PIL12 LDA IFADR,I Get first byte's item #. ALF,ALF AND LOBYT STA TEMP2,I and put into item number list. ISZ TEMP2 * ISZ CONTR If more to go, RSS continue with second byte. JMP PIL13 Else we are done. * LDA IFADR,I AND LOBYT STA TEMP2,I ISZ TEMP2 * ISZ CONTR If last field we are done, RSS JMP PIL13 ISZ IFADR else bump RDT address JMP PIL12 and continue with first byte of this word. * PIL13 LDA LIST List is built STA IMLST put it in the item list parameter JMP PIL1 and jump to number list processing. * * We come here when the special construct "0 " or an item count of zero * is given in the item list. Put a zero entry in the information table. * PIL14 CLA STA TEMPX,I * * Exit points. * PILF CLA ' No error - error code = 0. RSS E101 LDA D101 Error 101 - illegal item list JMP DBPIL,I * * Constants and variables * D2 EQU ZERO+2 D3 EQU ZERO+3 D101 DEC 101 LOBYT OCT 377 KEY OCT 040000 SORT OCT 020000 WRITE OCT 100000 HIBYT OCT 177400 * /@ OCT 040040 /0 OCT 030040 SEMI OCT 000073 ABLNK OCT 000040 * TABAD NOP NFLAG NOP #F/E NOP FLAG NOP DIADR NOP IFADR NOP NUMBR NOP ITEM BSS 10 TEMP2 NOP INDEX NOP CONTR NOP FIRST NOP BCNT NOP BMAX NOP BSTRT NOP * TEMPX DEF *+1 NOTE: LIST is used to build an item list BSS 382 from the RDT. Do not shorten TEMPX without LIST DEF TEMPX+254 exploring the consequences on LIST. SKP * * IF Key is a subroutine which searches the data set control block and * path table of the specified data set to determine if the specified * item is a key item or a sort item for the data set. DBIFK signifies * that the item is a key by setting the key flag (A reg) to <0, that * the item is a sort item by setting the A reg to >0. If the item is * not a key or sort item, A reg is set to 0. If the item is a key and * a sort item, the key reference takes precedence and the A reg is set * to <0. * DBIFK NOP * * Initialize search parameters. * * LDB NUMBR Move the item number from the 2nd BLF,BLF byte of this word into the 1st byte. STB KBYTE (for easier comparison of key items) * * Get data set type from data set's entry. * LDB AIRUN Get true address of data set's entry. ADB DSADR,I ADB DSTYP Increment to word containing type, LDA B,I get that word - ALF type is in 10th & 11th bits. SSA If type = 2, this is a detail. JMP IFK1 * ADB D6 Else type = 0 or 1, both are masters. LDA B,I A master's key item is in control block. AND HIBYT First byte of 11thHFB word. CPA KBYTE Are they the same? JMP IFK3 Yes - set flag then return JMP IFK4 No - clear flag then return. * * Detail data set - get path table address and # paths/entry. * IFK1 ADB D2 # paths is in 2nd byte of 7th word LDA B,I of the control block. AND LOBYT SZA,RSS If # paths = 0, there are no keys, JMP IFK4 just return. * CMA,INA Else, negate the path count STA CNTR2 for use as a loop counter. * LDA B,I # fields/entry is in 1st byte of 7th word. ALF,ALF (# fields/entry + 1) / 2 AND LOBYT is the length of the record INA definition table in the info table. ARS * INB Pointer to info table is in 8th word LDB B,I of the control block. Get its true address ADB AIRUN add the length of the RDT ADB A = address of path table. * CLA Set sort flag to zero. STA SFLAG * * BEGIN MAIN LOOP * IFK2 LDA B,I For each entry in path table, AND HIBYT if item # in entry = CPA KBYTE specified item # then JMP IFK3 we have a key. INB if item # in sort field = LDA B,I specified item # then CPA NUMBR STA SFLAG we have a sort item ISZ CNTR2 RSS JMP IFK4 Else, not a key INB JMP IFK2 * * Exit points. * IFK3 CCA,RSS If the item was a key set A to -1 IFK4 LDA SFLAG else if the item was a sort item JMP DBIFK,I set A positive, else set A to zero. * * Constants and variables * D6 EQU ZERO+6 D7 EQU ZERO+7 CNTR2 NOP SFLAG NOP KBYTE NOP END T H  92069-18157 1912 S C0122 &HASH HASH SOURCE             H0101 [9ASMB,L,C,R HED HASH SUBROUTINE FOR IMAGE/1000 NAM HASH,7 92069-16157 REV.1912 790130 * * ******************************************************************* * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR WRITTEN * CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18157 * RELOC: 92069-16157 * * PRGMR: CEJ * * ******************************************************************* * * * * Hash is a doubleword integer function which accepts a key item value * (either real, integer, or character string) and transforms the value * into a doubleword positive integer. Hash performs the following func- * tion. * * 1) Running function value = first doubleword in value. If odd # of * words in value, pad first word of Running function value with * nulls to make item an integeral number of doublewords long. * 2) Shift Running function value left logically by 1. * 3) If no words remaining in item value then go to 9. * 4) Doubleword = last remaining doubleword of item value (work with * doublewords beginning at the right end and working left from here * on out). * 5) Rotate Running function value left circular by: * (MOD(Doubleword,31) + 1). * 6) Running function value = Running function value + Doubleword. * 7) Go to 4. * 8) Shift function value logically right by 1 (make sure value is * positive). * 9) Return - function value in A & B registers. * * The calling sequence for HASH is: * * JSB HASH * DEF *+3 return point * DEF LENTH item length in words * DEF VALUE item value * EXT .DAD,.ENTR ENT HASH A EQU 0 B EQU 1 * LENTH NOP A VALUE NOP * * Get true parameter and return addresses * HASH NOP JSB .ENTR DEF LENTH * * Determine doubleword counter with item length. * LDA LENTH,I INA # of doublewords = # of words ARS plus one divided by two. CMA,INA Negate for easy loop counting. STA #DBWS * * Calculate address of last doublewrod in item. * LDA VALUE Last doubleword address = ADA LENTH,I address of beginning of item plus ADA M2 length of item minus two. STA LAST * * Get first doubleword in item. If odd # of words in item, compensate * for the missing word by padding the item with preceding nulls. * LDA LENTH,I If odd # words SLA,RSS (least significant bit set) JMP HASH3 CLA set first word of first doubleword LDB VALUE,I to zero and second word to first JMP HASH4 word of item value. * HASH3 DLD VALUE,I Else, use what is there. * * Logically shift the doubleword value left 1 bit. * HASH4 CLE,ELB E<-bit 15 of B,bit 0 of B<-0 ELA bit 0 of A<-E=bit 15 of B * * This becomes the running function value. * DST RSULT * * ENTER MAIN LOOP HERE * See if any doublewords left in item. * HASH5 ISZ #DBWS RSS JMP HASH7 If not, we are almost done. * * Get the rightmost remaining doubleword in item. (From here on out, * all doublewords are picked up from the end of the item working towards * the beginning.) * LDA LAST LDB A,I INA LDA A,I * * Calculate MOD of the doubleword by 31. * * This code is somewhat cryptic, but performs the following: * * Get the 20 most significant bits of the doubleword and * make them the 20 least significant bits, extending the sign. * Divide them by 31. * Save the remainder in the B register. * Get the remaining 12 least significant bits of the doubleword * and concatenate them onto the remainder in the B register as * the 12 least significant bits. * Divide this by 31. * If the remainder in the B register is now negative add 31 to it * to get the true MOD. * * The above order of processing is followed because, in the case of a * doubleword whose absolute maginitude is larger than 2**19-1, the DIV * instruction might not perform properly since the quotient could be * larger than 2**15-1. * ASR 12 Shift out least significant 12 bits. DIV D31 First divide. * LDA LAST Get the least significant INA 12 bits back again. LDA A,I (We just discard the quotient.) ALF * ASR 4 Concatenate with the remainder. DIV D31 Second divide. SSB ADB D31 B = true MOD. * * Get the rotate count by adding one to the above computed MOD. * INB STB RCNT * Rotate the running function value left circular by MOD + 1. * * This code is also somewhat cryptic, but performs the following: * * If (RCNT > 16) * Then Begin: * RCNT := RCNT - 16 * Swap high and low order words of running value. * End * Rotate running value left circular by RCNT. * LDA RCNT LDB RSULT+1 B = 2nd word of running value. ADA M17 See if RCNT <= 16. SSA,INA JMP HASH6 yes - simple case of rotate * STA RCNT no - swap high & low order words. LDA RSULT A = 1st word of running value STB RSULT Put 2nd word into first word area. LDB A B = new 2nd word of running value. LDA RCNT Get remainder of ((MOD + 1) - 16). * HASH6 AND LOFOR Only the low 4 bits of RCNT are meaningful. IOR RRL16 Form the rotate instruction. STA INSTR Put it into the Run Time code. LDA RSULT A = first word of running value. INSTR ABS *-* <> * * Add in the doubleword used in the MOD and this becomes the new running * function value. * JSB .DAD DEF LAST,I DST RSULT * * Get address of next to last used doubleword in item and repeat for each * doubleword in item. * LDA LAST ADA M2 STA LAST JMP HASH5 * * When loop is finished, shift the result right logically one bit to * clear sign bit (result must be positive) and return. * HASH7 DLD RSULT CLE,ERA ERB JMP HASH,I * * Constants and variables * M17 DEC -17 M2 DEC -2 D31 DEC 31 LOFOR OCT 000017 * RSULT BSS 2 RRL16 RRL 16 Used to create Run Time rotate instruction. #DBWS NOP LAST NOP RCNT NOP END 7  92069-18158 2026 S C0122 &DBCIX &DBCIX              H0101 ASMB,L,C,R HED DBCIX IMAGE/1000 UTILITY SUBROUTINE NAM DBCIX,7 92069-16158 REV.2026 800122 * * ******************************************************************* * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR WRITTEN * CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18158 * RELOC: 92069-16158 * * PRGMR: CEJ * ALTERED: JANUARY 22, 1980 FOR SORTED CHAINS FEATURE - CEJ * * ******************************************************************* * * * * Compute IndeX computes the index of a data item value within a data * set's data record. This index is relative to the beginning of the * data record. The index is computed by: * * Index = 0 + word length of all items in record previous to specified * data item. * * The calling sequence for DBCIX is: * * JSB DBCIX * DEF *+4 return point * DEF ITEM data item number * DEF DSADR address of data set' data set control block * table entry relative to start of Run Table * DEF INDEX returned data item's index, <0 if item * not in set's Record Definition Table * SKP *********************************************************************** * * * Run Table for IMAGE/1000 Local machine. * * * * The Run Table is comprised of the following sections: * * * * 1) Data Base Control Block * * 2) Item Table * * 3) Data Set Control Block Table * * 4) Data Set Info Table * * A) Record Definition Table * * B) Path Table * * 5) Sort Table * * 6) Free Record Table * * * * These sections appear in the order described. Details of each * * section follow. * * * *********************************************************************** *** *** * * * Data Base Control Block - one 59 word entry per data base * * * *** *** DBCBS DEC 59 Control Block Size DBNAM DEC 0 Data Base name - 3 words DEC 1 DEC 2 DBSCD DEC 3 Data Base Security Code (FMP) DBCRN DEC 4 Data Base Cartridge Number (FMP) DBDSN DEC 5 Data Base node number (DS/1000) DBRSN DEC 6 Data Base resource number DBICT DEC 7 Data Item Count DBITP DEC 8 Data item table pointer DBSCT DEC 9 Data set count DBSTP DEC 10 Data set control block table pointer DBSOP DEC 11 Sort table pointer DBFRP DEC 12 Free record table pointer DBLMD DEC 13 Data Base lock flag and open mode DBLFG EQU DBLMD 1st byte: lock flag DBMOD EQU DBLMD 2nd byte: open mode DBLVL DEC 14 Access level words - 3 words per level DBFRL EQOU DBLVL Free record table length DBOPT DEC 15 Optimal number of DCBs DBMAX DEC 16 Maximum size of a data entry DCBWS DEC 17 DCB storage area * ZERO EQU DBNAM base of zero for future equates *** *** * * * Data Item Table - one 7-word entry per item * * * *** *** ITELN EQU ZERO+7 item table entry length ITNME EQU ZERO item name - 3 words ITINF EQU ZERO+3 item write/read level and type ITRDL EQU ITINF 1st nibble: item read level ITWRL EQU ITINF 2nd nibble: item write level ITTYP EQU ITINF 2nd byte: item type ITSET EQU ZERO+4 set count and 1st set number ITSCT EQU ITSET 1st byte: set count ITSNO EQU ITSET 2nd byte: set number ITWRC EQU ZERO+5 write/read bits and element count ITECT EQU ITWRC 2nd byte: element count ITLNG EQU ZERO+6 item length in words *** *** * * * Data Set Control Block Table - one 17 word entry per set * * * *** *** DSLNG EQU ZERO+17 table entry length DSNME EQU ZERO set name - 3 words DSCRN EQU ZERO+3 cartridge reference number DSINF EQU ZERO+4 W/R bits, set type and media length DSTYP EQU DSINF 1st byte, 2nd nibble: set type DSMDL EQU DSINF 2nd byte: media record length DSDRL EQU ZERO+5 data record length DSFPC EQU ZERO+6 field and path counts DSFCT EQU DSFPC 1st byte: # fields per entry DSPCT EQU DSFPC 2nd byte: # paths per entry DSITP EQU ZERO+7 data set info table entry pointer DSCAP EQU ZERO+8 doubleword data set capacity DSCPN EQU ZERO+10 current path info DSCCT EQU DSCPN 1st byte: search item number DSPAN EQU DSCPN 2nd byte: path # of search item DSRCN EQU ZERO+11 doubleword current record number DSBWN EQU ZERO+13 doubleword previous record number DSFWN EQU ZERO+15 doubleword next record number *** *** * * * Data Set Info Table - one Record Definition Table and one Path * * Table per data set * * * *** *** * * * Record Definition Table - one 1-byte entry per field * * * *** *** RDLNG EQU ZERO+1 entry length (number of words) RDINF EQU ZERO field info (two fields per word) RDIT1 EQU RDINF 1st byte: item # for field n RDIT2 EQU RDINF 2nd byte: item # for field n+1 *** *** * * * Path Table - one 2-word entry per path * * * *** *** PTLNG EQU ZERO+2 entry length PTINF EQU ZERO path information - item & set numbers PTSIN EQU PTINF 1st byte: detail's search item # for path PTDSN EQU PTINF 2nd byte: related set's number PTSRT EQU ZERO+1 sort item for path *** *** * y * * Sort Table - one 1-word entry per item and set * * * *** *** STITS EQU ZERO beginning of item entries STSTS NOP beginning of set entries *** *** * * * Free Record Table - one 4-word entry per set * * * *** *** FRLNG EQU ZERO+4 length of entry FRRCT EQU ZERO doubleword free record count FRPTR EQU ZERO+2 doubleword first free record * * *********************************************************************** *** *** * * EXT .ENTR,AIRUN,DBFDI ENT DBCIX A EQU 0 B EQU 1 * ITEM NOP DSADR NOP INDEX NOP * * Get true addresses of parameters and return points. * DBCIX NOP JSB .ENTR DEF ITEM * * Initialize computation parameters. * CLA STA TOTAL Set internal index to zero. CMA STA INDEX,I Set index to -1. * * Get number of items in data set's data record and true address of * data set's record definition table. * LDB DSADR,I Get true address of data set's entry. ADB AIRUN * ADB DSFCT Increment to field count LDA B,I # fields/entry is first byte ALF,ALF of this word. AND LOBYT CMA,INA Negate it and save for later. STA CONTR * INB Increment to info table pointer LDWCA B,I Calculate info table's address ADA AIRUN STA IFADR * * ENTER MAIN LOOP * Now, for each field (item) in the data set's entry, up until the spe- * cified item, add the field's word length to get the specified item's * index into the data record. * CIX1 CCA Set working with first byte flag. STA FIRST LDA IFADR,I Get first item in info table entry ALF,ALF in first byte of this word. AND LOBYT * CIX2 CPA ITEM,I If this is the specified item, JMP CIX4 we are done. STA ITMNO Else, save item number. * JSB DBFDI Call DBFDI to get data item's entry DEF *+5 address in item table DEF ITMNO DEF NUMBR DEF FLAG DEF DIADR * LDA NUMBR If item # returned = 0, SZA,RSS return to caller unsuccessful. JMP DBCIX,I (Run Table corrupt!!) * LDA DIADR Else, get true address of item ADA AIRUN table entry. ADA ITLNG Bump to length word. LDB A,I Get length from entry ADB TOTAL and add to TOTAL. STB TOTAL * ISZ CONTR Repeat above processing for RSS next item, if one JMP DBCIX,I ISZ FIRST this time item is in 2nd byte JMP CIX3 LDA IFADR,I of entry in info table. AND LOBYT JMP CIX2 * CIX3 ISZ IFADR After processing both items in word, JMP CIX1 bump to next word and continue processing. * * Come here when index completely computed (i.e. item found in record * definition table). * CIX4 LDA TOTAL Set returned index. STA INDEX,I JMP DBCIX,I and return. * * Constants and variables * LOBYT OCT 377 * FIRST NOP CONTR NOP IFADR NOP ITMNO NOP NUMBR NOP FLAG NOP TOTAL NOP DIADR NOP END *($$*   92069-18159 1912 S C0122 &DBFWZ DBFWZ SOURCE             H0101 rASMB,L,C,R HED DBFWZ IMAGE/1000 UTILITY SUBROUTINE NAM DBFWZ,7 92069-16159 REV.1912 790130 * * ******************************************************************* * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR WRITTEN * CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18159 * RELOC: 92069-16159 * * PRGMR: CEJ * * ******************************************************************* * * * * Fill With Zeroes is a utility subroutine for the DBMS which zeroes * an area in core. * * The calling sequence for DBFWZ is: * * JSB DBFWZ * DEF *+3 return point * DEF LENTH length of area to zero-fill (in words) * DEF ADDRS address of area to zero-fill * ENT DBFWZ EXT .ENTR * A EQU 0 B EQU 1 * LENTH NOP ADDRS NOP * * Get true parameter and return point addresses. * DBFWZ NOP JSB .ENTR DEF LENTH * * Negate the word length to use as a loop counter. * LDA LENTH,I SSA,RSS If length <= 0, SZA,RSS JMP DBFWZ,I just return. CMA,INA STA LENTH * * Get the address of the area to zero-fill in the A register so that we * can increment it without affecting the caller's parameter. * LDA ADDRS,I * * Loop on each word in the area, setting it to zero. * CLB FWZ1 STB A,I INA ISZ LENTH When out of words, JMP FWZ1 JMP DBFWZ,I just return to caller. END oy    92069-18160 1912 S C0122 &DBRED DBRED SOURCE             H0101 qWASMB,L,C,R HED DBRED IMAGE/1000 UTILITY SUBROUTINE NAM DBRED,7 92069-16160 REV.1912 790130 * * ******************************************************************* * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR WRITTEN * CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18160 * RELOC: 92069-16160 * * PRGMR: CEJ * * ******************************************************************* * * * * REaD entry performs an FMP read on the record of the data set in the * data base specified by the three input parameters and places the record * in the record buffer. * * The calling sequence for DBRED is: * * JSB DBRED * DEF *+4 return point * DEF BASE data base # (1st word of ibase parameter) * DEF SET data set # * DEF RECRD doubleword record number * EXT .ENTR,DBFCB,DBRBL,DBRBP,EREAD ENT DBRED A EQU 0 B EQU 1 * BASE NOP SET NOP RECRD NOP * * Get true addresses of parameters and return point * DBRED NOP JSB .ENTR DEF BASE * * Call DBFCB to set up a DCB for the FMP call. * JSB DBFCB DEF *+4 DEF BASE,I base number DEF SET,I set number DEF DCBAD returned DCB address * * If DBFCB ran into an error, pass it back to caller. * SZA JMP DBRED,I * * Perform an FMP EREAD call on returned DCB with given doubleword record * number and reading record into record buffer. * JSB EREAD DEF *+7 DEF DCBAD,I DEF ERROR If any error occurs, error code automatically DEF DBRBP,I put in A by EREAD. DEF DBRBL set record length to possible longest record    DEF LENTH returned length DEF RECRD,I * SSA,RSS CLA JMP DBRED,I Return immediately after call. * * Constants and variables * LENTH NOP ERROR NOP DCBAD NOP END dS   92069-18161 1912 S C0122 &DBWRT DBWRT SOURCE             H0101 yASMB,L,C,R HED DBWRT IMAGE/1000 UTILITY SUBROUTINE NAM DBWRT,7 92069-16161 REV.1912 790130 * * ******************************************************************* * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR WRITTEN * CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18161 * RELOC: 92069-16161 * * PRGMR: CEJ * * ******************************************************************* * * * * WRiTe entry performs an FMP EWRIT and POST on the record of the data * set in the data base specified by the three input parameters from the * record in the record buffer. * * The calling sequence for DBWRT is: * * JSB DBWRT * DEF *+4 return point * DEF BASE data base # (1st word of ibase parameter) * DEF SET data set number * DEF RECRD doubleword record number * EXT .ENTR,DBFCB,DBRBP,POST,EWRIT ENT DBWRT A EQU 0 B EQU 1 * BASE NOP SET NOP RECRD NOP * * Get true addresses of parameters and return point. * DBWRT NOP JSB .ENTR DEF BASE * * Call DBFCB to set up DCB for FMP calls. * JSB DBFCB DEF *+4 DEF BASE,I DEF SET,I DEF DCBAD * * If DBFCB ran into an error, just return. * SZA JMP WRT1 * * Perform FMP EWRIT call on returned DCB with given doubleword record * number from record buffer. * JSB EWRIT DEF *+6 DEF DCBAD,I DEF ERROR DEF DBRBP,I DEF D0 Length of zero writes one record. DEF RECRD,I * SSA If any error return immediately. JMP WRT1 * JSB POST Else, post record to disc. DEF *+2 D@  EF DCBAD,I * SSA,RSS CLA WRT1 JMP DBWRT,I Return point. * * Constants and variables * D0 DEC 0 DCBAD NOP ERROR NOP END 23    92069-18162 2026 S C0122 &DBFCB &DBFCB              H0101 ASMB,L,C,R HED DBFCB IMAGE/1000 UTILITY SUBROUTINE NAM DBFCB,7 92069-16162 REV.2026 800122 * * ******************************************************************* * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR WRITTEN * CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18162 * RELOC: 92069-16162 * * PRGMR: CEJ * ALTERED: JANUARY 22, 1980 FOR SORTED CHAINS FEATURE - CEJ * * ******************************************************************* * * * * Find dCB is a subroutine which sets up a data set DCB for an FMP call. * * DBFCB does a serial search on the DCB pointer table comparing the com- * bination data base/data set number passed to it by the caller to that * which is currently associated with the DCBs. If a match is found, the * address fo the DCB which matches is passed back to the caller. In the * process of the search, DBFCB also saves the address of the first DCB * it found which is unused and the first which is assigned to another * data base. If no match is found, then if an unused DCB was found, the * data set specified by the number passed to DBFCB is opened in the DCB * and the DCB assigned to it. If no unused DCB was found, but a DCB * assigned to another data base was, DBFCB closes the data set in the * DCB and opens the desired data set in it. If no DCB was found which * was assigned to another data base, DBFCB takes the last DCB in the * table, closes it and reuses the DCB for the desired data set. DBFCB * then returns the assigned DCB's address to the caller. * * Should an FMP error occur while DBFCB was attempting to assign an DCB * to a data set, DBFCB halts execution and returns the FMP error code * to the caller. * * The calling seque(nce for DBFCB is: * * JSB DBFCB * DEF *+4 return point * DEF BASE data base number * DEF SET data set number * DEF DCBAD returned DCB address * * Any FMP error code DBFCB encounters is returned in the A register. * SKP *********************************************************************** * * * Run Table for IMAGE/1000 Local machine. * * * * The Run Table is comprised of the following sections: * * * * 1) Data Base Control Block * * 2) Item Table * * 3) Data Set Control Block Table * * 4) Data Set Info Table * * A) Record Definition Table * * B) Path Table * * 5) Sort Table * * 6) Free Record Table * * * * These sections appear in the order described. Details of each * * section follow. * * * *********************************************************************** *** *** * * * Data Base Control Block - one 59 word entry per data base * *  * *** *** DBCBS DEC 59 Control Block Size DBNAM DEC 0 Data Base name - 3 words DEC 1 DEC 2 DBSCD DEC 3 Data Base Security Code (FMP) DBCRN DEC 4 Data Base Cartridge Number (FMP) DBDSN DEC 5 Data Base node number (DS/1000) DBRSN DEC 6 Data Base resource number DBICT DEC 7 Data Item Count DBITP DEC 8 Data item table pointer DBSCT DEC 9 Data set count DBSTP DEC 10 Data set control block table pointer DBSOP DEC 11 Sort table pointer DBFRP DEC 12 Free record table pointer DBLMD DEC 13 Data Base lock flag and open mode DBLFG EQU DBLMD 1st byte: lock flag DBMOD EQU DBLMD 2nd byte: open mode DBLVL DEC 14 Access level words - 3 words per level DBFRL EQU DBLVL Free record table length DBOPT DEC 15 Optimal number of DCBs DBMAX DEC 16 Maximum size of a data entry DCBWS DEC 17 DCB storage area * ZERO EQU DBNAM base of zero for future equates *** *** * * * Data Item Table - one 7-word entry per item * * * *** *** ITELN EQU ZERO+7 item table entry length ITNME EQU ZERO item name - 3 words ITINF EQU ZERO+3 item write/read level and type ITRDL EQU ITINF 1st nibble: item read level ITWRL EQU ITINF 2nd nibble: item write level ITTYP EQU ITINF 2nd byte: item type ITSET EQU ZERO+4 set count and 1st set number ITSCT EQU ITSET 1st byte: set count ITSNO EQU ITSET 2nd byte: set number ITWRC EQU ZERO+5 write/read bits and element count ITECT EQU ITWRC 2nd byte: element count ITLNG EQU ZERO+6 item length in words ***  *** * * * Data Set Control Block Table - one 17 word entry per set * * * *** *** DSLNG EQU ZERO+17 table entry length DSNME EQU ZERO set name - 3 words DSCRN EQU ZERO+3 cartridge reference number DSINF EQU ZERO+4 W/R bits, set type and media length DSTYP EQU DSINF 1st byte, 2nd nibble: set type DSMDL EQU DSINF 2nd byte: media record length DSDRL EQU ZERO+5 data record length DSFPC EQU ZERO+6 field and path counts DSFCT EQU DSFPC 1st byte: # fields per entry DSPCT EQU DSFPC 2nd byte: # paths per entry DSITP EQU ZERO+7 data set info table entry pointer DSCAP EQU ZERO+8 doubleword data set capacity DSCPN EQU ZERO+10 current path info DSCCT EQU DSCPN 1st byte: search item number DSPAN EQU DSCPN 2nd byte: path # of search item DSRCN EQU ZERO+11 doubleword current record number DSBWN EQU ZERO+13 doubleword previous record number DSFWN EQU ZERO+15 doubleword next record number *** *** * * * Data Set Info Table - one Record Definition Table and one Path * * Table per data set * * * *** *** * * * Record Definition Table - one 1-byte entry per field * * * *** *** RDLNG EQU ZERO+1 entry length (number of words) RDIN˞F EQU ZERO field info (two fields per word) RDIT1 EQU RDINF 1st byte: item # for field n RDIT2 EQU RDINF 2nd byte: item # for field n+1 *** *** * * * Path Table - one 2-word entry per path * * * *** *** PTLNG EQU ZERO+2 entry length PTINF EQU ZERO path information - item & set numbers PTSIN EQU PTINF 1st byte: detail's search item # for path PTDSN EQU PTINF 2nd byte: related set's number PTSRT EQU ZERO+1 sort item for path *** *** * * * Sort Table - one 1-word entry per item and set * * * *** *** STITS EQU ZERO beginning of item entries STSTS NOP beginning of set entries *** *** * * * Free Record Table - one 4-word entry per set * * * *** *** FRLNG EQU ZERO+4 length of entry FRRCT EQU ZERO doubleword free record count FRPTR EQU ZERO+2 doubleword first free record * * *********************************************************************** *** *** * * t EXT .ENTR,AIRUN,DBDCP,DBDMX,DBDSZ,OPEN ENT DBFCB A EQU 0 B EQU 1 * BASE NOP SET NOP DCBAD NOP * * Get true adress of parameters and return point * DBFCB NOP JSB .ENTR DEF BASE * * Initialize search parameters. * CLA STA UNUSD Zero unused and non-base DCB address STA NBASE save areas. * LDA BASE,I Put data base number in high ALF,ALF order byte of BASE. STA BASE * LDA DBDMX Loop counter = negative number of CMA,INA STA CONTR entries in DCB pointer table. LDA DBDCP Get DCB pointer table address STA NEXT * LDA BASE Set up the combination IOR SET,I base/set number. STA NUMBR * * BEGIN SEARCH * The first word of each two word entry in the DCB pointer table defines * which data base/data set combination the DCB currently belongs to. * Search each entry in the table for a match to the combination base/set * passed by the caller in NUMBR, saving the address of the first unused * DCB and the first DCB assigned to a data base other than the current * one. * FCB1 LDA NEXT,I Get base/set number from DCB pointer SZA,RSS table entry, if zero - there is no JMP FCB3 DCB pointer in this entry. * CPA NUMBR Compare number to the one given. JMP FCB6 Same - DCB found. * INA,SZA Different - if this entry first empty JMP FCB2 entry (-1 in number) found, LDB UNUSD save its address in UNUSD. SZB JMP FCB3 LDB NEXT STB UNUSD JMP FCB3 * FCB2 AND HIBYT Or if this entry first assigned CPA BASE to a different data base, RSS save its address in NBASE. JMP FCB21 * LDA NEXT Else save address as last STA LAST DCB for this base in table. JMP FCB3 * FCB21 LD(9B NBASE SZB JMP FCB3 LDB NEXT STB NBASE * FCB3 ISZ NEXT Continue on with search until ISZ NEXT a match is found or the ISZ CONTR end of the table is found. JMP FCB1 * * We fall through search to this point if no match occurred. Set up a * DCB for the desired data set in either 1) the first unused DCB, 2) the * first DCB assigned to a different data base, or 3) the last DCB (in * that order). * LDA UNUSD If an unused entry - SZA,RSS use it else, * LDA NBASE If a DCB assigned to a different data base, SZA,RSS use it, * LDA LAST else, use the last allocated DCB. STA NEXT * * Now that we have the DCB, let's open the data set in it. First we * have to get the data set information from the Run Table. * CCA Get true address of data set's ADA SET,I control block = CLB (data set # - 1 ) * DSLNG + MPY DSLNG LDB AIRUN address of data set control block table + ADB DBSTP ADA B,I ADA AIRUN address of Run Table. * * Set up FMP OPEN call * STA OPNAM Put address of name into call. ADA DSCRN Put address of CRN into call. STA OPCRN LDB AIRUN Put negative security code into call. ADB DBSCD STB OPSCD LDA NEXT Finally, put DCB address into call. INA LDA A,I STA OPDCB * * Perform FMP OPEN call * JSB OPEN DEF *+8 OPDCB ABS *-* DEF ERROR OPNAM ABS *-* DEF D3 Open file in update, non-exclusive mode. OPSCD ABS *-* OPCRN ABS *-* DEF DBDSZ * SSA,RSS If any error, JMP FCB5 CCB set DCB to unused STB NEXT,I JMP FCB7 and return unsuccessful to caller. * FCB5 LDA NUMBR else put base/set number into STA NEXT,I DCB enL:0.*try in pointer table. * * We rejoin processing with found DCB. Set up the return parameters * and return. * FCB6 ISZ NEXT Put DCB address in return parameter DCBAD. LDB NEXT,I STB DCBAD,I CLA Zero to error code. FCB7 JMP DBFCB,I Return. * * Constants and variables. * D3 EQU ZERO+3 HIBYT OCT 177400 * UNUSD NOP NBASE NOP NEXT NOP LAST NOP ERROR EQU LAST * NUMBR NOP CONTR NOP END 0   92069-18163 2026 S C0122 &DBFDS &DBFDS              H0101 ASMB,L,C,R HED DBFDS & DBFDI IMAGE/1000 UTILITY SUBROUTINES NAM DBFDS,7 92069-16163 REV.2026 800122 * * ******************************************************************* * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR WRITTEN * CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18163 * RELOC: 92069-16163 * * PRGMR: CEJ * ALTERED: JANUARY 22, 1980 FOR SORTED CHAINS FEATURE - CEJ * * ******************************************************************* * * * * Find Data Set is a subroutine which searches the data set control block * table in the currently active Run Table for a set to determine its * number, entry address, and the accessibility of the set. * * The set whose table entry is to be found is passed to DBFDS as either * a set name or set number. If a set name, it must be six characters * long padded with trailing blanks if necessary. When the set is spe- * cified by number the number is used to calculate the set's entry ad- * dress as follows: * * Entryaddress = (Set Control Block Table address) + * ((Set number - 1) * DSLNG) * * When the set is specified by name, a binary search of the set control * block table is performed using the set sort table and comparing the * set name given with the name in the set control block table entry. * If a match is found, the set's entry address is the address of the entry * that matched. * * Once the set's entry is found, the entry is checked for the write and/ * or read bit set and a flag is set to indicate whether both, one, or * neither are set. DBFDS then returns to the user with the set number, * entry address and accessibility flag. If the set was not found in thue * set control block table, the set number is set to zero before DBFDS * returns. * * The calling sequence for DBFDS is: * * JSB DBFDS * DEF *+5 return point * DEF SET set name or number * DEF NUMBR returned set number or zero * DEF FLAG returned accessibility flag: * <0 if set writeable * =0 if set readable * >0 if set inaccessible * DEF DSADR returned set table entry address * SKP *********************************************************************** * * * Run Table for IMAGE/1000 Local machine. * * * * The Run Table is comprised of the following sections: * * * * 1) Data Base Control Block * * 2) Item Table * * 3) Data Set Control Block Table * * 4) Data Set Info Table * * A) Record Definition Table * * B) Path Table * * 5) Sort Table * * 6) Free Record Table * * * * These sections appear in the order described. Details of each * * section follow. * * * **********************************************h************************* *** *** * * * Data Base Control Block - one 59 word entry per data base * * * *** *** DBCBS DEC 59 Control Block Size DBNAM DEC 0 Data Base name - 3 words DEC 1 DEC 2 DBSCD DEC 3 Data Base Security Code (FMP) DBCRN DEC 4 Data Base Cartridge Number (FMP) DBDSN DEC 5 Data Base node number (DS/1000) DBRSN DEC 6 Data Base resource number DBICT DEC 7 Data Item Count DBITP DEC 8 Data item table pointer DBSCT DEC 9 Data set count DBSTP DEC 10 Data set control block table pointer DBSOP DEC 11 Sort table pointer DBFRP DEC 12 Free record table pointer DBLMD DEC 13 Data Base lock flag and open mode DBLFG EQU DBLMD 1st byte: lock flag DBMOD EQU DBLMD 2nd byte: open mode DBLVL DEC 14 Access level words - 3 words per level DBFRL EQU DBLVL Free record table length DBOPT DEC 15 Optimal number of DCBs DBMAX DEC 16 Maximum size of a data entry DCBWS DEC 17 DCB storage area * ZERO EQU DBNAM base of zero for future equates *** *** * * * Data Item Table - one 7-word entry per item * * * *** *** ITELN EQU ZERO+7 item table entry length ITNME EQU ZERO item name - 3 words ITINF EQU ZERO+3 item write/read level and type ITRDL EQU ITINF 1st nibble: item read level ITWRL EQU ITINF 2nd nibble: item write level ITTYP EQU ITINF 2nd byte: item type ITSET EQU ZERO+4 set count and 1st set number ITSCT EQU ITSET 1st byte: set count ITSNO EQU ITSET 2nd byte: set number ITWRC EQU ZERO+5 write/read bits and element count ITECT EQU ITWRC 2nd byte: element count ITLNG EQU ZERO+6 item length in words *** *** * * * Data Set Control Block Table - one 17 word entry per set * * * *** *** DSLNG EQU ZERO+17 table entry length DSNME EQU ZERO set name - 3 words DSCRN EQU ZERO+3 cartridge reference number DSINF EQU ZERO+4 W/R bits, set type and media length DSTYP EQU DSINF 1st byte, 2nd nibble: set type DSMDL EQU DSINF 2nd byte: media record length DSDRL EQU ZERO+5 data record length DSFPC EQU ZERO+6 field and path counts DSFCT EQU DSFPC 1st byte: # fields per entry DSPCT EQU DSFPC 2nd byte: # paths per entry DSITP EQU ZERO+7 data set info table entry pointer DSCAP EQU ZERO+8 doubleword data set capacity DSCPN EQU ZERO+10 current path info DSCCT EQU DSCPN 1st byte: search item number DSPAN EQU DSCPN 2nd byte: path # of search item DSRCN EQU ZERO+11 doubleword current record number DSBWN EQU ZERO+13 doubleword previous record number DSFWN EQU ZERO+15 doubleword next record number *** *** * * * Data Set Info Table - one Record Definition Table and one Path * * Table per data set * * * *** *** *  * * Record Definition Table - one 1-byte entry per field * * * *** *** RDLNG EQU ZERO+1 entry length (number of words) RDINF EQU ZERO field info (two fields per word) RDIT1 EQU RDINF 1st byte: item # for field n RDIT2 EQU RDINF 2nd byte: item # for field n+1 *** *** * * * Path Table - one 2-word entry per path * * * *** *** PTLNG EQU ZERO+2 entry length PTINF EQU ZERO path information - item & set numbers PTSIN EQU PTINF 1st byte: detail's search item # for path PTDSN EQU PTINF 2nd byte: related set's number PTSRT EQU ZERO+1 sort item for path *** *** * * * Sort Table - one 1-word entry per item and set * * * *** *** STITS EQU ZERO beginning of item entries STSTS NOP beginning of set entries *** *** * * * Free Record Table - one 4-word entry per set * * * *** *** FRLNG EQU ZERO+4 length of entry FRRCT EQU ZERO doubleword free record count FRPTR EQU ZERO+2 doubleword first free record * * *********************************************************************** *** *** * * ENT DBFDI,DBFDS EXT .CMW,.ENTR,AIRUN A EQU 0 B EQU 1 * SET NOP NUMBR NOP FLAG NOP DSADR NOP * * Get true addresses of parameters and return point. * DBFDS NOP JSB .ENTR DEF SET * * Initialize search parameters. * LDA AIRUN Get # of sets in data base ADA DBSCT as upper bound for set # LDB A,I or binary search index. STB HIGH * INA Get address of set table for LDB A,I binary search (this is relative STB TABAD to start of Run Table). * INA Set sort table address = LDB A,I pointer to Sort Table ADA M4 ADB A,I + number of items in data base ADB AIRUN + address of Run Table. STB STADR * LDA DSLNG Data Set Control Block Table STA ENTLN entry length. LDA DSINF W & R bits in 5th word STA WRBTS of DSCB entry. * * Initialize return parameters. * (DBFDI joins with DBFDS at this point.) * JOIN CLA STA NUMBR,I Set number to zero (not found). INA Set accessiblity flag > 0 STA FLAG,I (set inaccessible). * * Determine if name or number was given. If a number, the high order * byte with be zero, if a name, non-zero. In either case, if the sign * bit is set, the parameter is erroneous. * LDA SET,I Get high order byte of first AND HIBYT word of SET. SSA If sign bit set, JMP DBFDS,I return unsuccessful to caller. SZA If byte non-zero, JMP FDS1 perform search on name. * * We come here when a number is given. Make sure the number falls * within the bounds of 1 <= SET <= upper bound (HIGH). Then, use the * number as an index into the table to get the set's (or item's) entry * address. * LDA SET,I Get number again. SZA,RSS If zero, JMP DBFDS,I return unsuccessful to caller. CMA,INA If > # sets (or items) in data base, ADA HIGH SSA JMP DBFDS,I return unsuccessful to caller. * LDA SET,I Else all okay, STA NUMBR,I put number in return parameter. * ADA M1 Calculate entry address = CLB (number - 1) * MPY ENTLN entry length (ENTLN) + ADA TABAD table address, STA DSADR,I JMP FDS5 then go check accessibility. * * We come here when a name is given. A simple binary search of the * Set Control Block Table (or Item Table) is performed using the Sort * Table as a sorted binary tree and using the name given and the name * in the table entry as the object of comparison. * FDS1 CLA Initialize search parameters: STA LOW 0->LOW LDA HIGH # sets (or items) in base + 1 -> HIGH INA STA HIGH ARS Get first index into Sort Table = STA INDEX HIGH / 2. * * BEGIN MAIN LOOP HERE * The following is the actual binary search. The search is performed * on the Sort Table. The entries of the Sort Table contain set (or item) * numbers. When an entry of the table is chosen by the algorithm, the * number it contains is used to calculate the true address of the set's * (or item's) table entry (i.e. not relative to the start of the Run * Table but rather that relative address plus the address of the Run * Table). The comparison of the set (or item) names is then done. * FDS2 ADA STADR A = sort table entry = ADA M1 sort table address + INDEX - 1. LDA e>A,I STA SANUM SANUM = set (or item) number * ADA M1 Determine entry index in Table. CLB MPY ENTLN ADA TABAD SAENT = address of set's (or item's) entry STA SAENT relative to beginning of Run Table. * ADA AIRUN A = true address of set's entry. * LDB SET Compare set names. JSB .CMW DEF D3 DEC 0 JMP FDS4 A match! JMP FDS3 entry name < given name * CCA entry name > given name ADA INDEX Calculate next (lower) index to use. CMA,INA ADA LOW If this is lowest SSA,RSS return unsuccessful to caller. JMP DBFDS,I * LDA INDEX Else this index becomes the HIGH STA HIGH LDB LOW and INDEX = CMB,INB INDEX - ADA B (HIGH - LOW) / 2. ARS CMA,INA ADA INDEX STA INDEX JMP FDS2 Try this entry. * FDS3 LDA INDEX entry name < given name INA Calculate next (higher) index to use. CMA ADA HIGH If this is highest, SSA return unsuccessful to caller. JMP DBFDS,I * LDA INDEX Else this index becomes the LOW and STA LOW CMA,INA INDEX = ADA HIGH INDEX + ARS (HIGH - LOW) / 2. ADA INDEX STA INDEX JMP FDS2 Try this entry. * * When (if) found, put number and relative entry address in return * parameters. * FDS4 LDA SANUM STA NUMBR,I LDA SAENT STA DSADR,I * * Join number and name processing here to determine accessibility of * set (or item). * FDS5 ADA AIRUN Get true address of entry. ADA WRBTS Bump to word containing W & R bits LDA A,I and pick it up. * SSA If sign bit set, JMP FDS7 set or item is witeable RAL else if next to sign bit is set SSA JMP FDS6 it is readable JMP DBFDS,I else it is inaccessible. * FDS6 CLB,RSS FLAG = 0 means set (or item) readable FDS7 CCB FLAG < 0 means set (or item) writeable STB FLAG,I Set flag JMP DBFDS,I and return. * * Constants and variables. * M4 DEC -4 M1 DEC -1 D3 EQU ZERO+3 HIBYT OCT 177400 * HIGH NOP LOW NOP INDEX NOP * TABAD NOP STADR NOP SANUM NOP SAENT NOP ENTLN NOP WRBTS NOP SKP * * Find Data Item is a subroutine which searches the item table in the * currently active Run Table for an item to determine its number, entry * address (relative to beginning of Run Table) and whether or not the * item is accessible. * * The item whose entry is to be found is passed to DBFDI as either an * item name or item number. If an item name it must be six characters * long padded with trailing blanks if necessary. When the item is speci- * fied by number, the number is used to calculate the item entry address * as follows: * * Entry-address=(item table address + ((item # - 1) * 7)) * * When the item is specified by name, a binary search of the item table * is performed useing the item sort table and comparing the item name * given with the name in the item table entry. If a match is found, the * entry address is the address of the entry that matched. * * Once the item's entry is found, the entry is checked for the write * and/or read bit set and a flag is set to indicate whither both, one, * or neither is set. DBFDI then returns to the user with the item number, * entry address, and mode of acces. If the item was not found in the * item table, the item number is set to zero before DBFDI returns. * * The calling sequence for DBFDI is: * * JSB DBFDI * DEF *+5 * DEF ITEM item name array or number * DEF ITNO returned item # if found, else 0 * DEF ITFLG returned accessibility flag: * <0 if item writeable * =0 if item readable * >0 if item inaccessible * DEF DIADR returned item table entry address relative * to beginning of the Run Table * * * Since the algorithms of DBFDS and DBFDI are identical, DBFDI is entered * only to set up the search parameters that are specific to data items, * move the parameter and return point addresses to the DBFDS entry point * then, DBFDI joins DBFDS for actual table entry calculation. * SKP * ITEM NOP ITNO NOP ITFLG NOP DIADR NOP * * Get true parameter and return point addresses. * DBFDI NOP JSB .ENTR DEF ITEM * * Initialize search parameters. * LDA AIRUN Get # of items in data base as ADA DBICT upper bound for item number LDB A,I or binary search index. STB HIGH * INA Get address of item table for LDB A,I binary search (this is STB TABAD relative to start of Run Table). * ADA D3 Item sort table address = LDB A,I pointer to Sort Table ADB AIRUN + address of Run Table. STB STADR * LDA ITELN Item Table entry length. STA ENTLN LDA ITWRC W & R bits in 6th word of STA WRBTS Item Table entry. * * Make DBFDS look like the entry point and join the DBFDS process. * LDA ITEM Parameters: STA SET LDA ITNO STA NUMBR LDA ITFLG STA FLAG LDA DIADR STA DSADR * LDA DBFDI Return point: STA DBFDS * JMP JOIN END END$ B@< * * SKP ********************************************************************** *** *** * Standard DS/1000 equates * *** *** #STR DEC 0 #SEQ DEC 1 #SRC DEC 2 #DST DEC 3 #EC1 DEC 4 #EC2 DEC 5 #ENO DEC 6 #REP DEC 7 *** *** ********************************************************************** ********************************************************************** * * * DS/1000 RDBA Communications consist of two descriptive buffers: * * 1) Request buffer * * 2) Reply buffer * * The reply buffer we are concerned with is as described below. * * * ********************************************************************** *** *** * * * Reply buffer - one buffer of either 17 or 18 words per RDBA call * * * *** * RBSTR EQU #STR DS 1000 stream word RBSEQ EQU #SEQ DS/1000 sequence number RBSRC EQU #SRC DS/1000 source node number RBDST EQU #DST DS/1000 destination node number RBEC1 EQU #EC1 DS/1000 1st error code word RBEC2 EQU #EC2 DS/1000 2nd error code word RBEC3 EQU #ENO DS/1000 error node number upon an error RBSTA EQU #REP RDBA call status array RBNUM EQU #REP+10 RDBA data base number for DBOPN *** *** ********************************************************************** ENT RDEXT EXT #NODE,.ENTR,D65SV * A EQU 0 B EQU 1 * RPBUF NOP RPLEN NOP DABUF NOP DALEN NOP ERROR NOP * * Get true parameter and return point addresses. * RDEXT NOP JSB .ENTR DEF RPBUF * * Get the address of the reply buffer in the B register and set the re- * ply bit in the stream word (bit 14 of 1st word of reply buffer). * LDB RPBUF LDA B,I IOR REPLY STA B,I * * Bump B register to the error code words (5 through 7) of the reply and * put the 2 words passed to us in ERROR into the first two words of the * ECOD space in the reply buffer. * ADB RBEC1 LDA ERROR,I STA B,I  INB LDA ERROR INA LDA A,I STA B,I * * If there was an error, the A register is now non-zero. Set the node * number in the 7th word of the reply (3rd error code word) in this case * and if the error code is ASCII, i.e. first word of ERROR is non-zero, * we need to set bit 15 of the 7th word also. * INB SZA,RSS JMP EXT1 No error - set ECOD3 to zero. * LDA ERROR SZA LDA BIT15 IOR #NODE EXT1 STA B,I * * Call D65SV to send the reply. * JSB D65SV DEF *+5 DEF RPBUF,I DEF RPLEN,I DEF DABUF,I DEF DALEN,I RSS Error return, skip bump of return point. * ISZ RDEXT JMP RDEXT,I * * Constants and variables. * REPLY OCT 040000 BIT15 OCT 100000 END RDEXT S  92069-18169 1912 S C0122 &DBCRT DBCRT SOURCE             H0101 eASMB NAM DBCRT,7 92069-16169 REV.1912 790315 * * ****************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR * WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18169 * RELOC: 92069-16169 * * * CALLING SEQUENCE: * CALL DBCRT(IROOT,IDCB,IMODE,ISTAT) * * WHERE: * * IROOT * IS THE ADDRESS OF THE ROOT FILE * * IDCB * IS A FMP FILE CONTROL BLOCK * * IMODE * IS THE PURGE MODE INDICATOR * 0 IMPLIES "NO PURGE" OF DATA SET FILES * 1 IMPLIES "PURGE" THE DATA SET FILES * * ISTAT * IS AN ARRAY OF AT LEAST FOUR WORDS IN WHICH A STATUS CODE, ZERO * IF SUCCESSFUL, IS RETURNED IN THE FIRST ELEMENT. IF UNSUCCESS- * FUL, THE NAME OF THE DATA SET ON WHICH THE ERROR IS ENCOUNTERED * IS RETURNED IN THE SECOND THROUGH FOURTH ELEMENTS. * ENT DBCRT * EXT PURGE,.ENTR,.MVW,ECREA,ECLOS,EWRIT EXT SIZE EXT .DMP,.DDI,.DIN,.DDS,.DIS * * * SKP * * * * * * IROOT BSS 1 ADDRESS OF ROOT FILE IDCB BSS 1 FMP FILE CONTROL BLOCK IMODE BSS 1 PURGE MODE FLAG * 0 IMPLIES "NO PURGE" * 1 IMPLIES "PURGE" ISTAT BSS 1 STATUS ARRAY * DBCRT NOP JSB .ENTR GET PARMETERS DEF IROOT * LDA IROOT,I SAVE THE SECURITY CODE ADA DBSCD STA ISC * ADA DBSCT SAVE SET TABLE COUNT LDB A,I CMB,INB STB SCNT * INA SAVE SET TABLE POINTER LDB A,I ADB IROOT,I STB DSET * ADA .2 SAVE FREE RECORD TABLE POINTER. LDB A,I ADB IROOT,I STB FRTPT * * * INITIALIZE INFORMATION NEEDED FOR FMP CALLS * * DBC10 LDB DSET GET CARTRIDGE NUMBER ADB DSCRN STB ICR * INB GET RECORD LENGTH LDA B,I RECORD LENGTH = AND B377 MEDIA LENGTH + INB DATA LENGTH ADA B,I * STA RLGT2 SAVE RECORD LENGTH AS A DOUBLE WORD STA ISIZ4 SAVE THE RECORD SIZE FOR ECREA * ADB DSCAP GET SIZE OF FILE IN SECTORS. DLD B,I DST FLGTH SAVE NUMBER OF RECORDS IN FILE * JSB SIZE DEF *+4 DEF FLGTH DEF RLGT2 DEF ISTAT,I * SOC CHECK FOR OVERFLOW JMP ERR30 * JSB .DIN SOC CHECK FOR OVERFLOW JMP ERR30 * SLB CHECK FOR EVEN BLOCK COUNT JSB .DIN * SOC CHECK FOR OVERFLOW JMP ERR30 * DST ISIZE SAVE THE BLOCK SIZE * * * * * * ZERO BUFFER * * * LDB RLGT2 SET CNT TO # WORDS IN RECORD CMB,INB STB CNT * LDB ABUFF GET ADDRESS TO BUFFER CLA DBC20 STA B,I ZERO BUFFER INB ISZ CNT JMP DBC20 * * * SET FLAG TO INDICATE DATA SET TYPE * * CLB LDA DSET GET THE DATA SET TYPE ADA DSINF LDA A,I ALF SIGN BIT SET AFTER ROTATE SSA IF DATA SET A DETAIL. CCB IF DETAIL SET FLAG = -1 STB FLAG * * * * * DELETE FILE WHEN NECESSARY * * * LDA IMODE,I SZA,RSS JMP DBC30 * JSB PURGE DEF *+6 DEF IDCB,I DEF ISTAT,I DEF DSET,I ISC ABS *-* ICR ABS *-* * CPA M6 JMP DBC30 SSA JMP ERRX * * * CREATE THE FILE * * DBC30 JSB ECREA DEF *+8 8DEF IDCB,I DEF ISTAT,I DEF DSET,I DEF ISIZE DEF .2 DEF ISC,I DEF ICR,I * SSA JMP ERRX * CLA CLB,INB DST NUM * * * REINITIALIZE THE FREE SPACE POINTERS FOR THIS DATA SET. * * DLD FLGTH FIRST DOUBLEWORD = DST FRTPT,I # OF FREE RECORDS = ISZ FRTPT CAPACITY OF DATA SET. ISZ FRTPT * CLB SECOND DOUBLEWORD = LDA FLAG ZERO IF A MASTER SET SSA ELSE ONE. INB CLA DST FRTPT,I ISZ FRTPT ISZ FRTPT SKP * * * * * * INITIALIZE THE DATA SET RECORDS TO ZERO * CHAIN THE FREE SPACE POINTERS IN THE DETAIL * DATA SETS * * * * DBC40 LDA FLAG SSA,RSS IF MASTER DON'T MODIFY MEDIA JMP DBC50 * DLD NUM OTHERWISE POINT TO NEXT RECORD JSB .DIN DST ABUF2 * DBC50 JSB WRITE SSA JMP ERRX * JSB .DIS DOUBLE INCREMENT RECORD COUNT DEF NUM NOP * JSB .DDS DOUBLE DECREMENT AND SKIP DEF FLGTH JMP DBC40 * CLA PUT A ZERO IN THE MEDIA RECORD OF LAST CHAIN CLB DST ABUF2 * JSB .DDS DEF NUM NOP * JSB WRITE SSA JMP ERRX * JSB ECLOS CLOSE THE DATA FILE DEF *+3 DEF IDCB,I DEF ISTAT,I * SSA JMP ERRX * LDA DSET GET NEXT DATA SET TABLE ENTRY ADA DSLNG STA DSET * ISZ SCNT ARE THERE MORE DATA SETS? JMP DBC10 YES, GO PROCESS THEM CLA NO, EXIT WITH NO ERROR STA ISTAT,I EXIT JMP DBCRT,I * * * ERR30 LDA .N30 SET ERROR CODE TO -30 STA ISTAT,I * ERRX LDA DSET ERROR, PUT DATA SET NAME LDB ISTAT IN STATUS ARRAY. INB JSB .MVW Y# DEF .3 DEC 0 JMP EXIT RETURN * * .N30 DEC -30 SKP * * * * WRITE FILE ROUTINE * * * * WRITE NOP JSB EWRIT DEF *+6 DEF IDCB,I DEF ISTAT,I DEF BUFF DEF .0 DEF NUM JMP WRITE,I SKP * * * * * DATA DECLARATION * * * * * * A EQU 0 B EQU 1 * * DBSCD DEC 3 OFFSET INTO ROOT FILE FOR DATA BASE SECURITY CODE DBSCT DEC 6 + 3 = ROOT FILE OFFSET FOR DB SET COUNT * * DSCRN EQU DBSCD DATA SET OFFSET FOR DATA SET CARTRIDGE DSINF DEC 4 DATA SET OFFSET FOR TYPE AND MEDIA DSCAP EQU DBSCD + 5 = DATA SET OFFSET FOR CAPACITY DSLNG DEC 17 LENGTH OF SET TABLE ENTRY * * B377 OCT 377 MASK FOR RIGHT BYTE .128D DEC 0 DOUBLE WORD 128 DEC 128 .0 EQU .128D M6 DEC -6 .2 DEC 2 .3 EQU DBSCD * * * * SCNT BSS 1 NEGETIVE SET COUNT DSET BSS 1 ADDRESS OF CURRENT SET FRTPT BSS 1 ADDRESS OF FREE RECORD TABLE CNT BSS 1 FLAG BSS 1 FLAG TO INDICATE SET TYPE NUM BSS 2 HOLDS CURRENT RECORD NUMBER. FLGTH BSS 2 FILE CAPACITY RLGTH DEC 0,0 DOUBLE WORD RECORD LENGTH RLGT2 EQU RLGTH+1 ISIZE DEC 0,0,0,0 ISIZ4 EQU ISIZE+3 * ABUFF DEF BUFF BUFF BSS 2048 ABUF2 EQU BUFF+1 * BSS 0 END   92069-18170 1912 S C0122 &CATR CATR SOURCE             H0101 ZAASMB NAM CATR,7 92069-16170 REV.1912 770601 * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * SOURCE: 92069-18170 * RELOC: 92069-16170 * * ************************************************************* * ENT CATR EXT SGET,.PACK,.ENTR ****************************** * * * ASCII TO REAL CONVERSION * * * ****************************** * * * CALLING SEQUENCE: * * A=CATR(IARRY,J,K,ISTAT) * * WHERE: IARRY IS SINGLE DIMENSION ARRAY OF CHARACTERS * CONTAINING THE NUMBER TO BE CONVERTED. TWO CHARS * PER WORD. * * J IS THE NUMBER OF THE FIRST CHARACTER IN THE * STRING. * * K IS THE NUMBER OF THE LAST CHARACTER IN THE STRING * * ISTAT IS SET TO 0 FOR GOOD CONVERSION AND -1 FOR * INVALID CONVERSION. * * BUFR NOP J NOP JLAST NOP ISTAT NOP CATR NOP JSB .ENTR DEF BUFR CLB STB EXP ZERO STB MANT1 ALL STB MANT2 COMPONENTS STB EXPON OF NUMBER STB SIGN STB TEMP3 SET 'NUMBER' FLAG FALSE STB ISTAT,I CLEAR ERROR FLAG CCB SET 'DECIMAL POINT' STB DPFLG FLAG FALSE LDA J,I SET STA CHRCT CHAR COUNTER JSB GETCR GET A CHAR JMP NUMER CPA .43 (+)? JMP NUMC0 YES! CPA .45 (-)? JMP NUM16 YES! JMP NUMC1 NO! NUMC0 JSB GETCR GET A CHAR JMP NUMER NO CHAR ERROR! NUMC1 CPA .46 DECIMAL POINT? ISZ DPFLG YES, SET FLAG TRUE JMP NUMC2 NO CLA INITIALIZE POST-DECIMAL DIGIT STA EXPON DIGIT COUNTER TO ZERO JMP NUMC3+1 FETCH A CHARACTER * NUM16 CCB STB SIGN SET FOR NEGATIVE NUMBER JMP NUMC0 * NUMC2 JSB DIGCK DIGIT? JMP NUMC7 NO ISZ EXPON YES, COUNT DIGIT ALF,ALF LEFT-JUSTIFY ALF,RAR DIGIT AND STA TEMP4 SAVE IT JSB MBY10 MULTIPLY PREVIOUS NUMBER BY 10 LDB EXP SZB ZERO EXPONENT? JMP NUMC4 NO LDA .4 YES, SET STA EXP EXPONENT TO 4 LDA TEMP4 LOAD CLB NUMBER NUMC3 JSB NORML NORMALIZE THE NUMBER ISZ TEMP3 SET 'NUMBER OCCURRED' FLAG JSB GETCR ANOTHER CHARACTER? JMP NUM12 NO JMP NUMC1 YES NUMC4 ADB M4 COMPUTE CMB EXPONENT LDA TEMP4 BIAS AND STB TEMP4 SAVE IT CLB NUMC5 ISZ TEMP4 DIGIT POSITIONED? JMP NUMC6 NO CLE YES, ADD IN ADB MANT2 LOW PART CLO OF NUMBER SEZ OVERFLOW? INA YES, BUMP (A) ADA MANT1 ADD IN HIGH PART OF NUMBER SOS OVERFLOW? JMP NUMC3 NO CLE,ERA YES, ROTATE ERB DOWN AND ISZ EXP BUMP NOP EXPONENT JMP NUMC3 NUMC6 CLE,ERA SHIFT ERB DIGIT JMP NUMC5 RIGHT NUMC7 CLB DECIMAL POINT STB TEMP4 CPB TEMP3 OR DIGIT FOUND? JMP NUMER NO, EXIT VIA ERROR CPA E YES, 'E' ? RSS YES JMP NUM12 NO, NO EXPONENT PART JSB GETCR JMP NUMER CPA .43 '+' ? JMP NUMC8 YES CPA .45 NO, '-' ? CCA,RSS YES  JMP NUMC9 NO STA TEMP4 NOTE MINUS SIGN NUMC8 JSB GETCR JMP NUMER NUMC9 JSB DIGCK DIGIT? JMP NUMER NO STA TEMP3 YES, SAVE IT JSB GETCR JMP NUM10 SECOND JSB DIGCK DIGIT? JMP NUM10 NO LDB TEMP3 YES BLS,BLS MULTIPLY ADB TEMP3 PRIOR DIGIT BLS BY 10 ADA 1 ADD NEW DIGIT STA TEMP3 SAVE EXPONENT JSB GETCR JMP NUM10 THIRD JSB DIGCK DIGIT? RSS NO JMP NUMER YES NUM10 LDA TEMP3 LOAD EXPONENT ISZ TEMP4 POSITIVE? CMA,INA YES, COMPLEMENT IT RSS NO NUM12 CLA CLEAR IF NO EXPONENT PART ISZ DPFLG DECIMAL POINT? ADA EXPON YES, CORRECT EXPONENT SZA,RSS ZERO EXPONENT? JMP NUM14 YES SKP SSA NO, NEGATIVE EXPONENT? JMP NUM13 NO CMA,INA YES, SET STA EXPON COUNTER JSB DBY10 DIVIDE NUMBER BY 10 ISZ EXPON DONE? JMP *-2 NO JMP NUM14 YES NUM13 STA EXPON SET COUNTER JSB MBY10 MULTIPLY BY 10 ISZ EXPON DONE? JMP *-2 NO NUM14 LDA MANT1 YES, LOAD LDB MANT2 NUMBER ISZ SIGN POSITIVE? JMP NUM15 YES CMA NO, CMB,INB,SZB,RSS COMPLEMENT INA IT NUM15 JSB .PACK PACK NUMBER INTO (A) AND (B) EXP BSS 1 EXPONENT JMP CATR,I * NUMER CCB STB ISTAT,I SET ERROR FLAG JMP CATR,I SKP ********************************** * * * MULTIPLY UNPACKED NUMBER BY 10 * * * ********************************** MBY10 NOP LDA MANT1 RETURN ON SZA,RSS ZERO JMP MBY10,I MANTISSA LDB EXP MULTIPLY ADB .3 7@BY STB EXP 8 LDB MANT2 LOAD MANTISSA CLE,ERA DIVIDE ERB BY CLE,ERA 4 ERB,CLE ADB MANT2 DOUBLE SEZ ADD TO INA PRODUCE ADA MANT1 1.25 * MANTISSA SSA,RSS CORRECT JMP *+5 CLE,ERA ON ERB ISZ EXP OVERFLOW NOP STA MANT1 STB MANT2 JMP MBY10,I ******************************** * * * DIVIDE UNPACKED NUMBER BY 10 * * * ******************************** DBY10 NOP MULTIPLY BY DOUBLE-LENGTH TENTH LDA MANT1 RETURN SZA,RSS ON ZERO JMP DBY10,I MANTISSA LDB M2 ADD EXPONENT OF ADB EXP 'TENTH' TO STB EXP MANTISSA EXPONENT LDA MANT2 JUSTIFY CLE,ERA LOWER MANTISSA MPY TENTH MULITPLY BY ONE-TENTH (63416) CLE,ELA SHIFT ELB,CLE BACK ADA 1 ADD IN LOWER MANTISSA* SEZ TENTH*(2)-16 INB AND ROUND STB MANT2 TO 16 BITS LDA MANT1 DO MPY TENTH SAME FOR CLE HIGH ADA 1 MANTISSA ADA MANT2 (EFFECTIVELY) SUM SEZ DOUBLE-LENGTH INB PRODUCTS STB MANT1 EXCHANGE STA 1 (A) AND (B) LDA MANT1 REGISTERS JSB NORML NORMALIZE RESULT JMP DBY10,I ******************************* * * * NORMALIZE (A), (B) AND EXP * * * ******************************* NORML NOP STA TEMP3 SET LEFT-SHIFT CLA COUNTER STA FERR TO ZERO LDA TEMP3 SZA,RSS ON SZB ZERO JMP NORM3 CLEAR STA EXP EVERYTHING STA MANT1 STORE NORM1 STB MANT2 MANTISSA JMP NORML,I AND RETURN NORM2 ISZ FERR COUNT LEFT SHIFTS NORM3 CLE,ELB ROTATE (A) AND ELA (B) LEFT INTO (E) SEZ,SSA,RSS TWO HIGHEST BITS 0? JMP NORM2 YES, + UNNORMALIZED SEZ,SSA NO, TWO HIGHEST BITS 1? JMP NORM2 YES, - UNNORMALIZED ERA SHIFT TO ERB,CLE NORMALIZE MANTISSA STA MANT1 NO, LDA FERR COMPUTE CMA,INA CORRECTED ADA EXP EXPONENT STA EXP VALUE LDA MANT1 JMP NORM1 ******************* * * * CHECK FOR DIGIT * * * ******************* ****************************** * * * GET CHAR FROM INPUT BUFFER * * * ****************************** GETCR NOP JSB SGET GET DEF *+4 DEF BUFR,I A DEF CHRCT CHAR DEF CHAR FROM BUFFER LDA CHAR LDB CHRCT IS ADB M1 CPB JLAST,I END OF STRING? JMP GETCR,I YES! CPA B40 SPACE? JMP GET1 YES! ISZ GETCR NO! ISZ CHRCT JMP GETCR,I EXIT * GET1 ISZ CHRCT GET NEXT CHAR JMP GETCR+1 SKP DIGCK NOP CHARACTER IN (A) LDB 0 ADB D72 ASCII 72B SSB,RSS OR GREATER? JMP DIGCK,I YES, RETURN WITH CHARACTER ADB .10 NO, ASCII 60B SSB OR GREATER? JMP DIGCK,I NO ISZ DIGCK YES, SET 'SUCCESS' EXIT, LDA 1 LOAD DIGIT INTO (A), JMP DIGCK,I AND RETURN MANT1 BSS 1 MANT2 BSS 1 EXPON BSS 1 TEMP3 BSS 1 TEMP4 BSS 1 CHRCT BSS 1 FERR BSS 1 CHAR BSS 1 DPFLG BSS 1 SIGN BSS 1 .3 DEC 3 .4 DEC 4 .10 DEC 10 .43 DEC 43 .45 DEC 45 .46 DEC 46 M1 DEC -1 d$"M2 DEC -2 M4 DEC -4 D72 OCT -72 B40 OCT 40 TENTH OCT 63146 E OCT 105 END 6$   92069-18171 1912 S C0122 &CRTA CRTA SOURCE             H0101 [AFTN SUBROUTINE CRTA(REAL,IBUF),92069-16171 REV. 1912 781026 C C C***************************************************************** C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED C NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR C TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH OUT THE PRIOR C WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. C****************************************************************** C C C SOURCE: 92069-18171 C RELOC: 92069-16171 C C C****************************************************************: C C C C C INTEGER IBUF(6) C THIS ROUTINE CONVERTS A REAL NUMBER INTO A 12 BYTE BUFFER C C CALLING SEQUENCE: C C CALL CRTA(REAL,IBUF) C C WHERE: C C REAL C IS A SINGLE PRECISION REAL NUMBER C C IBUF C IS A 6 WORD BUFFER C C C C C C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ C COMMON IS NOT NEEDED C C C C C C C C C BEGIN C C DESCRIBE THE SIZE OF THE BUFFER C CALL CODE(13) C C WRITE THE FORMAT INTO THE BUFFER C WRITE(IBUF,7000)REAL 7000 FORMAT(G13.5) RETURN END   92069-18172 1912 S C0122 &CATI CATI SOURCE             H0101 S8ASMB NAM CATI,7 92069-16172 REV.1912 770601 * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * SOURCE: 92069-18172 * RELOC: 92063-16172 * * ************************************************************* * SPC 1 * CALL CATI(IFLD,IBYT,ILTH,INT,ISTAT) * * CONVERT A NUMERIC ASCII FIELD OF LENGTH * "ILTH" BEGINNING AT "IBYT" OF "IFLD" * TO AN INTEGER "INT" * * CONVERSION IS TERMINATED BY A NON-NUMERIC * CHARACTER OR EXHAUSTION OF "ILTH" * * NUM-CHAR = BLANK,+,-,NUMBER . * * "ISTAT" 0 => NORMAL * -1 => OVERFLOW OR NON-ASCII SPC 1 EXT .ENTR ENT CATI SPC 1 A EQU 0 B EQU 1 SPC 1 IFLD BSS 1 BUFFER ADDRESS (WORD) IBYTE BSS 1 REL. NUM. FIELD ADDRESS (BYTE) ILTH BSS 1 CHARACTER IN IFLD INT BSS 1 BINARY INTEGER RETURNED ISTAT BSS 1 STATUS CATI NOP ENTER AND GET JSB .ENTR ARGUMENT DEF IFLD ADDRESSES SPC 1 LDA IBYTE,I STA IEND ADA ILTH,I STA ILTH SPC 1 CLO CLA STA INT,I ALL BLANK FIELD => 0 STA SIGN STA SAVE JSB GETC GET A CHARACTER CPA =B53 + SIGN? JMP C1 YES CPA =B55 - SIGN? CCB,RSS YES JMP C5 NO STB SIGN SPC 1 C1 JSB GETC GET A NUMBER C5 JSB CHECK CHECK IT STA INT,I LDA SAVE ADA A ST-  A B ADA A ADA A ADA B ADA INT,I STA SAVE JMP C1 SPC 1 SAVE BSS 1 SIGN BSS 1 IEND BSS 1 SPC 1 DONE CLA SET SOC STATUS ERR CCA STA ISTAT,I LDA SAVE LDB SIGN INSERT THE SZB SIGN CMA,INA STA INT,I JMP CATI,I EXIT SPC 1 GETC NOP GETC1 LDB IEND CPB ILTH IF DONE JMP DONE THEN EXIT ADB M1 GET AND CLE,ERB ISOLATE THE ADB IFLD BYTE POINTED LDA B,I AT BY IBYT SEZ,RSS ALF,ALF AND B377 ISZ IEND CPA =B40 JMP GETC1 JMP GETC,I SPC 1 CHECK NOP ADA =B177720 CHECK FOR SSA ASCII NUMBER JMP ERR ( >57B, ADA M10 <72B) SSA,RSS JMP ERR ADA .10 JMP CHECK,I * M1 DEC -1 .10 DEC 10 M10 DEC -10 B377 OCT 377 END   92069-18173 1912 S C0122 &DCATI DCATI SOURCE             H0101 x\FTN SUBROUTINE DCATI(IBUF,ISTRT,IEND,DNUM),92069-16173 REV.1912 781219 C C C***************************************************************** C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED C NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR C TRANSLATED TO ANOTHER PROGRAM LANGUAGE WIOTH OUT THE PRIOR C WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. C****************************************************************** C C C SOURCE: 92069-18173 C RELOC: 92069-16173 C C C ABASTRACT: C C DCATI CONVERTS AN ASCII STRING NO LONGER THAN TEN CHARACTERS C TO A DOUBLE WORD INTEGER. THE STRING MUST NOT CONTAIN A SIGN. C C CALLING SEQUENCE: C C CALL DCATI(IBUF,ISTRT,IEND,DNUM) C C WHERE: C C IBUF C IS THE ASCII STRING C C ISTRT C IS THE BYTE OFFSET C C IEND C IS THE BYTE OFFSET OF THE END OF THE STRING C C DNUM C IS A TWO WORD BUFFER WHICH WILL CONTAIN THE DOUBLE C WORD INTEGER WHEN DCATI EXITS C C ON EXIT: C C DNUM CONTAINS A DOUBLE WORD INTEGER C C C C C****************************************************************: C INTEGER IZERO(2),ITEN(2),ICHAR(2) REAL ZERO,TEN,CHAR EXTERNAL DAD,DMP INTEGER IMAX(5) C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ EQUIVALENCE (ZERO,IZERO),(TEN,ITEN),(CHAR,ICHAR) DATA IZERO/0,0/ DATA ITEN/0,10/ DATA ICHAR/0,0/ DATA IMAX/2H21,2H47,2H48,2H36,2H47/ C C C C C C ICHAR(1) = 0 DNUM = ZERO IF(ISTRT .GT. IEND) GOTO 40 I = IEND - ISTRT + 1 IF (I .GT. 10) GOTO 40 IF(I .LT. 10) GOTO 20 IF(JSCOM(IBUF,ISTRT,IEND,IMAX,1) .LE. 0) GOTO 20 DNUM = DBLEI(-1) GOTO 40 C C LOOP TO CONVERT INTEGER C 20 CONTINUE DO 30 I= ISTRT,IEND CALL SGET(IBu  UF,I,ICHAR(2) ) ICHAR(2) = ICHAR(2) - 60B IF ( (ICHAR(2) .LT. 0) .OR. (ICHAR(2) .GT. 9))GOTO 40 DNUM = DAD ( DMP(DNUM,TEN), CHAR) 30 CONTINUE 40 RETURN END   92069-18174 1912 S C0122 &CITA CITA SOURCE             H0101 U8ASMB NAM CITA,7 92069-16174 REV.1912 770601 * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * SOURCE: 92069-18174 * RELOC: 92069-16174 * * ************************************************************* * SPC 1 EXT .ENTR ENT CITA SPC 1 A EQU 0 B EQU 1 SPC 1 * CALL CITA(INT,IA) * * CONVERT AN INTEGER (INT) TO ITS * DECIMAL EQUIVALENT IN ASCII * FORMAT IN THE 3 WORD ARRAY (IA) SPC 1 INT BSS 1 IA BSS 1 CITA NOP ENTER AND JSB .ENTR GET ARGUMENT DEF INT ADDRESSES LDA TA SET UP NUMBER TABLE STA IPICK POINTER LDA INT,I GET THE INTEGER LDB MINUS GENERATE SSA THE SIGN CMA,INA,RSS AND THE LDB BLANK FIRST NUMBER JSB ONEN STB IA,I CLB GENERATE JSB ONEN THE NEXT BLF,BLF TWO NUMBERS JSB ONEN ISZ IA STB IA,I CLB GENERATE JSB ONEN THE LAST BLF,BLF TWO NUMBERS ADB =B60 ADB A ISZ IA STB IA,I JMP CITA,I SPC 1 ONEN NOP ENTER CONVERSION ROUTINE ADB =B60 ON1 ADA IPICK,I SSA JMP ON2 INB JMP ON1 ON2 CMA,INA ADA IPICK,I CMA,INA ISZ IPICK JMP ONEN,I SPC 1 TA DEF NBUF NBUF DEC -10000 DEC -1000 DEC -100 DEC -10 BLANK OCT 20000 MINUS OCT 26400 SPC 1 ^n   IPICK BSS 1 END 8   92069-18175 1912 S C0122 &DCITA DCITA SOURCE             H0101 z\FTN SUBROUTINE DCITA(DNUM,IBUF),92069-16175 REV.1912 781026 C C C***************************************************************** C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED C NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR C TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH OUT THE PRIOR C WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. C****************************************************************** C C C SOURCE: 92069-18175 C RELOC: 92069-16175 C C C****************************************************************: C C C C C INTEGER IBUF(5) C C C***************************************************************** C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS RESERVED C NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR C TRANSLATED TO ANOTHER PROGRAM LANGUAGE WIOTH OUT THE PRIOR C WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. C****************************************************************** C C C LISTING: XXXXX-XXXXX C SOURCE: XXXXX-XXXXX C RELOC: XXXXX-XXXXX C C C ABSTRACT: C C DCITA CONVERTS THE ABSOULE VALUE OF A DOUBLE WORD INTEGER TO IT'S C ASCII EQUICALENT. C C CALLING SEQUENCE: C C CALL DCITA(DNUM,IBUF) C C WHERE: C C DNUM C IS A DOUBLE WORD INTEGER C C IBUF C IS A FIVE WORD BUFFER C C ON EXIT: C C IBUF CONTAINS A TEN CHARACTER ASCII EQUIVALENT OF DNUM, C ZERO FILLED TO THE LEFT. C C****************************************************************: C INTEGER IZERO(2),ITEN(2),ICHAR(2) REAL ZERO,TEN,CHAR,TEMP EXTERNAL DCO,DMP,DDI,DSB EQUIVALENCE (ZERO,IZERO),(TEN,ITEN),(CHAR,ICHAR) DATA IZERO/0,0/ DATA ITEN/0,10/ DATA ICHAR/0,0/ C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$780711 C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$780711 C C C C C C DDNUM = DNUM =   DO 10 I = 1,5 IBUF(I) = 2H00 10 CONTINUE C C BE SURE THERE THIS IS NOT A NEGETIVE NUMBER C IF(DCO(DDNUM,ZERO)) 11,15,15 C C NUMBER IS NEGETIVE, RETURN ERROR C 11 CONTINUE DDNUM = DNG(DDNUM) C C LOOP FOR CONVERSIONS C 15 CONTINUE DO 40 I= 10,1,-1 IF( DCO(DDNUM,ZERO) ) 50,50,20 20 CONTINUE TEMP = DDI(DDNUM,TEN) CHAR = DSB(DDNUM,DMP(TEMP,TEN) ) DDNUM = TEMP CALL SPUT(IBUF,I,ICHAR(2) + 60B ) 40 CONTINUE 50 RETURN END ?   92069-18176 1912 S C0122 &NODE NODE SOURCE             H0101 \=ASMB NAM NODE,7 92069-16176 REV.1912 781117 * * ****************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WIOTH OUT THE PRIOR * WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18176 * RELOC: 92069-16176 * * *****************************************************************: * * * * * EXT #CNOD,#NODE,.ENTR ENT ICNOD,NODE * * * * * ICNOD NOP JSB .ENTR DEF ICNOD * LDA #CNOD JMP ICNOD,I * * * * * * NODE NOP JSB .ENTR DEF NODE * LDA #NODE JMP NODE,I END   92069-18177 2013 S C0122 &STPLU              H0101 ASMB NAM STPLU,7 92069-16177 REV.2013 790322 * * ****************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR * WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18177 * RELOC: 92069-16177 * * *****************************************************************: * * ******************************************************************* * STPLU STORES THE LU PASSED INTO IT AT PAU.E, SO THAT ALL STOP * AND PAUSE MESSAGES WILL GO TO THE LU SPECIFIED. ******************************************************************** ENT STPLU EXT .ENTR EXT PAU.E LU NOP STPLU NOP JSB .ENTR DEF LU LDA LU,I STA PAU.E JMP STPLU,I END qH  92069-18178 2013 S C0122 &TPHDR              H0101 FTN4 BLOCK DATA TPHDR,92069-16178 REV.2013 790413 C***************************************************************** C C C***************************************************************** C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. C NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR C TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR C WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. C****************************************************************** C C C SOURCE: 92069-18178 C RELOC: 92069-16178 C C C****************************************************************: C C C THIS BLOCK DATA SUBPROGRAM ALLOCATES SPACE FOR THREE THINGS: C 1) THE TAPE HEADER THAT TAPEW AND TAPER USE TO HANDLE EOT. C 2) THE DCB THAT THEY USE TO WRITE AND READ THE DATA. C 3) THE DCB SIZE (UNUSED BY TAPER AND TAPEW). C C MODULES THAT REFERENCE TPHDR ARE AS FOLLOWS: C A) DBST2 C B) DBRS2 C C) TAPEW C D) TAPER C F) DBULX AND ALL ITS SEGMENTS C G) DBLOX AND ALL ITS SEGMENTS. C C**************************************************************** INTEGER HDR(24),TDCB(144),TDSZ,P5(6) COMMON /TPHDR/HDR,TDCB,TDSZ,P5 DATA TDSZ/144/ DATA HDR/24*2H / DATA P5/6*0/ END   92069-18179 2013 S C0122 &NWFIL              H0101 FTN4 SUBROUTINE NWFIL(LU1,IERR,IDCB,IDCBSZ,NAMR,JBLK,ITYPE,IABORT) +,92069-16179 REV.2013 790316 C C C***************************************************************** C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. C NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR C TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR C WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. C****************************************************************** C C C SOURCE: 92069-18179 C RELOC: 92069-16179 C C C****************************************************************: C C C********************************************************************* C NWFIL CREATES A NEW FILE NAMED NAMR, OF SIZE ISIZE, AND TYPE ITYPE. C C IABORT = 'AB' TO RETURN NEGATIVE ERROR ON DUPLICATE FILE. C = ANYTHING ELSE TO ATTEMPT PURGE OF DUPLICATE FILE BEFORE CREATE. C C NAMR = C 1)1ST TWO CHARACTERS OF NAMR C 2)2ND TWO CHARS C 3)3RD TWO CHARS C 4)3 C 5)SECURITY CODE C 6)CARTRIDGE NUMBER C C BLK = DOUBLE INTEGER SIZE OF THE NEW FILE ON DISC. C JBLK = DOUBLE INTEGER SIZE OF FILE REQUESTED BY CALLING PROGRAM, C AND DOUBLE INTEGER SIZE OF RECORD IN JBLK(3) AND JBLK(4). C********************************************************************** C PARAMETER DECLARATIONS C INTEGER LU1,IERR,IDCB(1),IDCBSZ,NAMR(1),JBLK(1),ITYPE,IABORT REAL BLK C DOUBLE INTEGER BLK C******************************************************************** C MAKE SURE ITS A NAMR PARAMETER, GET ISECU AND ICR C IF (NAMR(4) .NE. 3) CALL DBER2(LU1,7777,NAMR,6HNWFIL ,2HAB) ISECU=NAMR(5) ICR=NAMR (6) C****************************************************************** C SEE IF YOU SHOULD SKIP THE PURGE. C IF (IABORT .EQ. 2HAB) GO TO 100 CALL PURGE(IDCB,IERR,NAMR,ISECU,ICR) IF (IERR .EQ. -6) GO TO 100 IF (IERR .LT. 0) GOTO 200 C*******************************************************5C  ********** C CREATE THE NEW FILE WITH INFO PASSED IN. C 100 CALL ECREA(IDCB,IERR,NAMR,JBLK,ITYPE,ISECU,ICR,IDCBSZ,BLK) IF (IERR .GE. 0) IERR=0 200 CALL DBER2(LU1,IERR,NAMR,6HNWFIL ,2HXX) RETURN END  " 92069-18180 2013 S C0122 &SQUSH              H0101 FTN4 SUBROUTINE SQUSH(BUFR,LENGTH) +,92069-16180 REV.2013 790316 C C C***************************************************************** C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. C NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR C TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR C WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. C****************************************************************** C C C SOURCE: 92069-18180 C RELOC: 92069-16180 C C C****************************************************************: C C C******************************************************************* C SQUSH DELETES ALL THE BLANKS FROM THE BUFR PASSED IN TO IT, C THEN PADS BUFR WITH BLANKS AT THE END. C RETURNS THE ANSWER IN BUFR. C C BUFGET = NEXT POSITION TO GET NEXT CHAR FROM. C BUFPUT = NEXT OPEN POSITION TO PUT THE NEXT CHAR IN. C C******************************************************************* INTEGER BUFR(1),LENGTH INTEGER BUFGET INTEGER BUFPUT INTEGER CHARS INTEGER TEMP C************************************************************* C INIT VARIABLES. C CHARS=2*LENGTH BUFPUT=1 C************************************************************* C GET RID OF ALL THE BLANKS C DO 15 BUFGET=1,CHARS CALL SGET(BUFR,BUFGET,TEMP) IF (TEMP .EQ. 40B) GO TO 15 CALL SPUT(BUFR,BUFPUT,TEMP) BUFPUT=BUFPUT+1 15 CONTINUE C************************************************************** C PAD BUFR AT END WITH BLANKS. C DO 25 J=BUFPUT,CHARS CALL SPUT(BUFR,J,40B) 25 CONTINUE RETURN END  " 92069-18181 2013 S C0122 &FF              H0101 L0FTN4 SUBROUTINE FF(LU1,TAPE,BUFR,BUFSZ,IERR) +,92069-16181 REV.2013 790322 C C C***************************************************************** C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. C NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR C TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR C WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. C****************************************************************** C C C SOURCE: 92069-18181 C RELOC: 92069-16181 C C C****************************************************************: C C C********************************************************** C FF DOES A FAST FORWARD ON THE TAPE DEVICE TO THE NEXT C LOGICAL FILE MARK. THIS CONSISTS OF A 0-LENGTH RECORD ON C A TYPE 3 FILE, OR A -1 LENGTH RECORD ON THE TAPE. C************************************************************ INTEGER LU1,TAPE(1),BUFR(1),BUFSZ,IERR LOGICAL EOF 100 CALL TAPER(LU1,TAPE,BUFR,BUFSZ,LEN,EOF,IERR) IF (IERR .NE. 0) RETURN IF (EOF) GO TO 200 GO TO 100 C********************************************************* C HIT AN EOF. C 200 CONTINUE IERR=0 EOF=.FALSE. RETURN END  # 92069-18182 2013 S C0122 &NEWFL              H0101 rASMB NAM NEWFL,7 92069-16182 REV.2013 790126 ************************************************************* * * ****************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR * WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18182 * RELOC: 92069-16182 * * *****************************************************************: * * * NEWFL JUST PICKS UP ITS PARAMETERS AND CALLS DBCRT. ITS * WRITTEN IN ASMB ONLY BECAUSE IT USES AN EXTERNAL REFERENCE TO * AIRUN (THE ADDRESS OF THE RUN TABLE) AND THIS WAS NOT AVAILABLE * TO A FTN4 PROGRAM. **************************************************************** ENT NEWFL EXT AIRUN ADDRESS OF RUN TABLE AFTER DBOPN CALL EXT DBCRT EXT .ENTR ******************************************************************* LU1 NOP IDCB NOP IMODE NOP ISTAT NOP NEWFL NOP JSB .ENTR DEF LU1 JSB DBCRT DEF RTN DEF AIRUN DEF IDCB,I DEF IMODE,I DEF ISTAT,I RTN NOP JMP NEWFL,I END S $ 92069-18183 2013 S C0122 &SOT              H0101 WqFTN4 SUBROUTINE SOT(LU1,TAPE,P5,IERR) +,92069-16183 REV.2013 790413 C C C***************************************************************** C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. C NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR C TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR C WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. C****************************************************************** C C C SOURCE: 92069-18183 C RELOC: 92069-16183 C C C****************************************************************: C C C************************************************************* C SOT VERIFIES THAT THE TAPE IS AT START OF TAPE. C IF SO, IT RETURNS. C IF NOT, IT PROMPTS THE USER. C************************************************************* INTEGER LU1,TAPE,P5,IERR INTEGER RESPON INTEGER NUM(4) DATA NUM/2HNN,2HNN,2HNN,2H _/ 500 IA=ISOT(TAPE) IF (IA .LT. 0) RETURN CALL REIO(2,LU1,10H TAPE LU _,-10) CALL CNUMD(TAPE,NUM) CALL REIO(2,LU1,NUM(2),-6) CALL REIO(2,LU1,25H IS NOT AT START OF TAPE.,-25) CALL READY(LU1,RESPON,IERR) IF (IERR .LT. 0) RETURN GO TO 500 END k % 92069-18184 2013 S C0122 &DBER2              H0101 }eFTN SUBROUTINE DBER2(LU1,IERR,NAMR,MESS,ABORT) +,92069-16184 REV.2013 790927 C C C***************************************************************** C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. C NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR C TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR C WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. C****************************************************************** C C C SOURCE: 92069-18184 C RELOC: 92069-16184 C C C****************************************************************: C C C******************************************************* C DBER2 PRINTS OUT AN ERROR MESSAGE. C C THE FORM OF THE ERROR MESSAGE IS AS FOLLOWS: C C ERROR NUMBER XXXXX FOR YYYYY ZZZZZZ C WHERE XXXXX IS THE ERROR NUMBER C YYYYY IS EITHER "LU" OR "FILE" C ZZZZZZ IS EITHER THE LU NUMBER OR THE FILE NAME. C C IF NAMR IS "XXXXXX" UPON ENTRY, THE ERROR MESSAGE IS AS FOLLOWS: C ERROR NUMBER XXXXX C C THE NAMR PASSED IN IS ONE OF THE FOUR FOLLOWING TYPES: C 1) 6HXXXXXX C 2) AN LU NUMBER FOR AN FMP ERROR C 3) A FILE NAME FOR AN FMP ERROR OR A DATA BASE ERROR. C 4) A FILE OR ITEM NUMBER FOR A DATA BASE NUMBER. C C AFTER THIS: C IF ABORT=AB, IT DOES A STOP C IF ABORT=XX, IT RETURNS. C ELSE IT CALLS IN THE SEGMENT NAMED BY ABORT. C C******************************************************* INTEGER LU1,IERR,MESS(1),ABORT INTEGER NAMR(1) INTEGER NAMR1(3) INTEGER NOSEG(8 ),NOSGL DOUBLE PRECISION NAMR3(1) EQUIVALENCE (NAMR1,NAMR3) DOUBLE PRECISION ERROR(6) DATA ERROR/6HERROR ,6HNUMBER,6H000000,6H FOR ,6H ,6H / DATA NOSEG/2H S,2HEG,2HME,2HNT,2H M,2HIS,2HSI,2HNG/ DATA NOSGL/8 / C********************************************************** C IF (IERR .EQ. 0) RETURN IERR2=IABS(IERR) C*************************************************************** C PUT THE THREE "  WORDS OF NAMR INTO NAMR3 (NAMR1 EQU NAMR3). C NAMR1=NAMR NAMR1(2)=NAMR(2) NAMR1(3)=NAMR(3) C***************************************************************** C CONVERT THE ERROR NUMBER AND INSERT INTO MESSAGE. INSERT THE C NAMR INTO THE MESSAGE. C CALL REIO(2,LU1,2H _,1) CALL CNUMD(IERR2,ERROR(3)) ERROR(5)=6H FILE ERROR(6)=NAMR3 C************************************************************* C ON AN FMP ERROR WHERE THE NAMR PASSED IN IS AN LU NUMBER. C IF(NAMR .GE. 64) GOTO 10 CALL CNUMD(NAMR,ERROR(6)) IF(IERR2 .LT. 100) ERROR(5) = 6H LU C*************************************************************** C SEE HOW MANY WORDS OF THE MESSAGE TO PRINT OUT. C 10 CONTINUE LEN=18 IF (NAMR3 .EQ. 6HXXXXXX) LEN=9 CALL REIO(2,LU1,ERROR,LEN) C********************************************************* C SEE ABOUT ABORTING OR RETURNING. C 9000 IF (ABORT .EQ. 2HXX) RETURN IF (ABORT .EQ. 2HAB) STOP CALL SEGLD(ABORT,IERR) CALL REIO(2,LU1,NOSEG,NOSGL) CALL REIO(2,LU1,ABORT,3) STOP END   ' 92069-18185 2013 S C0122 >PRM              H0101 FTN4 SUBROUTINE GTPRM(LU,LU1,TAPE,ROOT,LVLWD,P5,STRING,LENGTH,IERR) +,92069-16185 REV.2013 790313 INTEGER LU,LU1(1),TAPE(1),ROOT(1),LVLWD(1),P5(1) INTEGER STRING(1),LENGTH,IERR C C C***************************************************************** C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. C NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR C TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR C WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. C****************************************************************** C C C SOURCE: 92069-18185 C RELOC: 92069-16185 C C C****************************************************************: C C C****************************************************** C SUBR TO RETURN FIVE PARAMETERS TO THE CALLING PROCEDURE, C ONE EACH IN EACH OF ITS FORMAL PARAMETER POSITIONS. IT ASSUMES C THAT EACH ACTUAL PARAMETER IS A 6-WORD ARRAY AND RETURNS THE C PARAMETER IN THE FOLLOWING FORMAT: C 1. INTEGER VALUE OR FIRST TWO CHARACTERS C 2. 0 OR SECOND TWO CHARACTERS. C 3. 0 OR THIRD TWO CHARACTERS. C 4. TYPE OF PARAMETER (0=NONE,1=INTEGER,3=NAMR) C 5. INTEGER SECURITY CODE, IF NAMR PARAMETER. C 6. INTEGER CARTRIDGE REFERENCE NUMBER, IF NAMR PARAMETER. C********************************************************** INTEGER DFLT C*********************************************************** C GET THE CONSOLE LU INTO INTO LU1. C SUBROUTINE PRAM RETURNS SUCCESSIVE PARAMETERS ACCORDING TO C THE FORMAT DESCRIBED ABOVE. C USE THE SCHEDULING LU TO LOG ERROR MESSAGES HERE. ISTRC=1 LNGTH2=2*LENGTH CALL PRAM(LU,STRING,LNGTH2,ISTRC,LU1) DFLT=LU CALL CKLU1(LU,LU1,DFLT,IERR) IF (IERR .LT. 0) RETURN C************************************************************* C GET THE LU OR NAMR OF THE BACKUP DEVICE. C FROM HERE ON, USE LU1 AS THE CONSOLE LU. CALL PRAM(LU1,STRING,LNGTH2,ISTRC,TAPE) DFLT=8 CALL CKLU8(LU1,TAPE,DF  LT,IERR) IF (IERR .LT. 0) RETURN C************************************************************* C GET THE ROOT FILE NAMR. CALL PRAM(LU1,STRING,LNGTH2,ISTRC,ROOT) CALL CKROO(LU1,ROOT,IERR) IF (IERR .LT. 0) RETURN C************************************************************ C GET THE LEVEL WORD. CALL PRAM(LU1,STRING,LNGTH2,ISTRC,LVLWD) CALL CKLVL(LU1,LVLWD,IERR) IF (IERR .LT. 0) RETURN C************************************************************ C GET THE FIFTH PARAMETER CALL PRAM(LU1,STRING,LNGTH2,ISTRC,P5) CALL CKP51(LU1,P5,IERR) IF (IERR .LT. 0) RETURN C*********************************************************** C RETURN AND END C IERR=0 RETURN END >u  !( 92069-18186 2013 S C0122 &PRAM              H0101 [FTN4 SUBROUTINE PRAM(LU1,STRING,LENGTH,ISTRC,ARRAY) +,92069-16186 REV.2013 790319 C C C***************************************************************** C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. C NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR C TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR C WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. C****************************************************************** C C C SOURCE: 92069-18186 C RELOC: 92069-16186 C C C****************************************************************: C C C************************************************************* C PRAM RETURNS A 6-WORD ARRAY CONTAINING INFORMATION ABOUT C SUCCESSIVE PARAMETERS IN STRING. THE ARRAY LOOKS LIKE THIS: C 1. INTEGER VALUE OR FIRST TWO CHARS. C 2. 0 OR SECOND TWO CHARS. C 3. 0 OR THIRD TWO CHARS. C 4. TYPE OF PARAMETER(0=NONE,1=INTEGER,3=NAMR) C 5. INTEGER SECURITY CODE. C 6. INTEGER CARTRIDGE REFERENCE NUMBER. C THIS SUBR ASSUMES THAT ISTRC IS INCRED AUTOMATICALLY BY THE C SYSTEM SUBR CALLED NAMR AND IS PASSED IN TO IT UNALTERED FOR C EACH SUCCESSIVE CALL. C************************************************************* INTEGER STRING,LENGTH,ISTRC,ARRAY DIMENSION STRING(1),ARRAY(1) DIMENSION IPBUF(10) C********************************************************* DO 5 J =1,6 5 ARRAY(J) = 0 C THE SYSTEM SUBR NAMR RETURNS A 10-WORD ARRAY. SEE THE C DOS/RTE RELOC LIBRARY MANUAL FOR DETAILS. CALL NAMR(IPBUF,STRING,LENGTH,ISTRC) C************************************************************ C BRANCH ACCORDING TO THE TYPE OF THE PARAMETER. C 0= NO PARAMETER C 1= NUMERIC PARAMETER C (BIT 0=1 AND BIT 1=1) = ASCII PARAMETER IFLAG = IPBUF(4) IF (IFLAG .EQ. 0) GO TO 10 IF (IFLAG .EQ. 1) GO TO 20 IFLAG= IFLAG .AND. 3 IF (IFLAG .EQ. 3) GO TO 30 C************************************************************* C PROCESS oe  INTERNAL ERROR THAT SHOULDNT HAVE HAPPENED. C CALL DBER2(LU1,7777,6HXXXXXX,6HPRAM ,2HAB) C************************************************************* C PROCESS NO PARAMETER. C********************************************************* C PROCESS INTEGER PARAMETER. 20 ARRAY=IPBUF ARRAY(4)=1 RETURN C********************************************************** C PROCESS NAMR PARAMETER. 30 DO 40 I =1,6 40 ARRAY(I) = IPBUF(I) ARRAY(4) = 3 C** THIS ROUTINE ALWAYS RETURNS NUMERIC SEC CODE AND CARTRIDGE C** REFERENCE NUMBER. 10 RETURN C*********************************************************** END A  ") 92069-18187 2013 S C0122 &CKLU1              H0101 jFTN4 SUBROUTINE CKLU1(LU,LU1,DFLT,IERR) +,92069-16187 REV.2013 790316 C C C***************************************************************** C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. C NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR C TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR C WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. C****************************************************************** C C C SOURCE: 92069-18187 C RELOC: 92069-16187 C C C****************************************************************: C C C********************************************************** C SUBR TO CHECK THAT LU1 IS A VALID INTERACTIVE CONSOLE LU. C IF NO PARAMETER IS PASSED IN, IT DEFAULTS LU1 TO DFLT. C LU= ERROR LOG DEVICE C LU1=6-WORD ARRAY YOU'RE CHECKING. C DFLT= DEFAULT VALUE TO STUFF INTO LU1 IF NO PARAMETER THERE. C IERR= ERROR LOG IF ERROR OCCURS IN THE SUBR. C********************************************************** INTEGER LU,LU1(1),DFLT,IERR LOGICAL IFTTY INTEGER ERR1(17) DATA ERR1/2H C,2HON,2HSO,2HLE,2H L,2HU ,2HNO,2HT ,2HIN,2HTE, & 2HRA,2HCT,2HIV,2HE:,2H ,2H ,2H / C*********************************************************** C BRANCH ON THE TYPE OF PARAMETER PASSED IN(0=NONE,1=INT,3=NAMR) IERR = 0 IFLAG = LU1(4) IF (IFLAG .EQ. 0) GO TO 10 IF (IFLAG .EQ. 1) GO TO 20 IF (IFLAG .EQ. 3) GO TO 30 C*********************************************************** C PROCESS INTERNAL ERROR THAT SHOULDNT HAVE HAPPENED. C CALL DBER2(LU1,7777,6HXXXXXX,6HCKLU1 ,2HAB) C************************************************************* C PROCESS NO PARAMETER PASSED IN. DEFAULT TO VALUE IN DFLT. 10 LU1=DFLT LU1(4) = 1 RETURN C************************************************************ C PROCESS INTEGER PARAMETER PASSED IN. CHECK FOR INTERACTIVE. C IF ITS INTERACTIVE, LU1 IS LOADED PROPERLY SO RETURN. 205   CONTINUE IF(IFTTY(LU1))40,25 25 CALL CNUMD(LU1,ERR1(15)) GOTO 35 30 ERR1(15) = LU1 ERR1(16) = LU1(2) ERR1(17) = LU1(3) 35 CALL REIO(2,LU,ERR1,17) IERR = -241 CALL DBER2(LU,241,6HXXXXXX,6HCKLU1 ,2HXX) LU1=LU 40 RETURN END Y  #* 92069-18188 2013 S C0122 &CKLU8              H0101 qFTN4 SUBROUTINE CKLU8(LU1,TAPE,DFLT,IERR) +,92069-16188 REV.2013 790126 C C C***************************************************************** C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. C NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR C TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR C WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. C****************************************************************** C C C SOURCE: 92069-18188 C RELOC: 92069-16188 C C C****************************************************************: C C C********************************************************** C SUBR TO CHECK ON THE BACKUP TAPE DEVICE. IF NO PARAMETER C WAS PASSED IN FOR PARAMETER 2, IT DEFAULTS TO DFLT. C********************************************************** INTEGER LU1,TAPE,DFLT,IERR DIMENSION TAPE(1) INTEGER EQT23,RING2 DATA EQT23/11400/,RING2/4B/ C********************************************************* C BRANCH ON THE TYPE OF THE PARAMETER(0=NONE,1=INTEGER,3=NAMR) ITYPE = TAPE(4) IERR = 0 IF (ITYPE .EQ. 0) GO TO 10 IF (ITYPE .EQ. 1) GO TO 20 IF (ITYPE .EQ. 3) RETURN C************************************************************* C PROCESS INTERNAL ERROR THAT SHOULDN'T HAVE HAPPENED. C CALL DBER2(LU1,7777,6HXXXXXX,6HCKLU8 ,2HAB) C************************************************************* C PROCESS NO PARAMETER PASSED IN. 10 TAPE=DFLT TAPE(4)=1 RETURN C************************************************************* C FOR NOW, ASSUME THAT ANY NUMBER SPECIFIED IS OK. C 20 RETURN END  $* 92069-18189 2013 S C0122 &CKR00              H0101 ioFTN4 SUBROUTINE CKROO(LU1,ROOT,IERR) +,92069-16189 REV.2013 790316 C C C***************************************************************** C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. C NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR C TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR C WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. C****************************************************************** C C C SOURCE: 92069-18189 C RELOC: 92069-16189 C C C****************************************************************: C C C************************************************************** C SUBR TO CHECK THAT THE ROOT FILE NAMR PASSED IN IS REALLY AN C ASCII STRING. IT DOES NOT OPEN OR CHECK THE FILE. C*************************************************************** INTEGER LU1,ROOT(6),IERR REAL REG INTEGER STRING(40),TYPE,IA(2) C EQUIVALENCE (REG,IA),(IA(2),IB) C C*************************************************************** C IF THE TYPE IS ASCII, NORMAL RETURN. ELSE RETURN ERROR. C 5 CONTINUE IERR = 0 TYPE = ROOT(4) IF (TYPE .EQ. 0) GO TO 10 IF (TYPE .EQ. 1) GO TO 20 IF (TYPE .EQ. 3) GO TO 30 C************************************************************ C PROCESS INTERNAL ERROR. C CALL DBER2(LU1,7777,6HXXXXXX,6HCKROO ,2HAB) C************************************************************* C PROCESS NO PARAMETER BY PROMPTING THE USER AT THE CONSOLE LU. C READ THE PARAMETER, CALL PRAM TO FILL THE NAMR ARRAY, THEN C LOOP BACK TO THE BRANCH POINT TO PROCESS THE NEW ENTRY. C 10 CONTINUE CALL REIO(2,LU1,18H ROOT FILE NAMR? _,-18) REG = REIO(1,LU1+400B,STRING,40) LNGTH2=2*IB ISTRC1=1 CALL PRAM(LU1,STRING,LNGTH2,ISTRC1,ROOT) GO TO 5 C************************************************************* C PROCESS AN INTEGER PARAMETER AS AN ERROR. C 20 CONTINUE CALL REI  O(2,LU1,26H INCORRECT ROOT FILE NAME.,-26) IERR=-243 CALL DBER2(LU1,IERR,6HXXXXXX,6HCKROO ,2HXX) RETURN C************************************************************* C IF ITS A NAMR PARAMETER PUT NEGATIVE SEC CODE INTO IT AND RETURN C 30 ROOT(5) = -(IABS(ROOT(5))) RETURN END .B  %, 92069-18190 2013 S C0122 &CKLVL              H0101 FTN4 SUBROUTINE CKLVL(LU1,LVLWD,IERR) +,92069-16190 REV.2013 790928 C C C***************************************************************** C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. C NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR C TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR C WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. C****************************************************************** C C C SOURCE: 92069-18190 C RELOC: 92069-16190 C C C****************************************************************: C C C************************************************************** C CKLVL CHECKS THAT THE LEVEL WORD PASSED IN IS REALLY AN C ASCII STRING, AND NOT AN INTEGER VALUE. IF NO PARAMETER WAS C PASSED IN, CKLVL QUERIES THE USER AT CONSOLE LU, READS IN THE LEVEL C WORD, AND THEN CHECKS THAT ITS AN ASCII STRING. C*************************************************************** INTEGER LU1,LVLWD(6),IERR INTEGER IA(2) EQUIVALENCE(REG,IA),(IA(2),IB) C*************************************************************** C IF THE TYPE IS ASCII, NORMAL RETURN. ELSE RETURN ERROR. C 5 CONTINUE LVL = LVLWD(4) IERR = 0 IF (LVL .EQ. 0) GO TO 10 IF (LVL .EQ. 1) GO TO 20 IF (LVL .EQ. 3) GO TO 30 C************************************************************ C PROCESS INTERNAL ERROR. C CALL DBER2(LU1,7777,6HXXXXXX,6HCKLVL ,2HAB) C************************************************************* C PROCESS NO PARAMETER BY PROMPTING THE USER AT THE CONSOLE LU. C READ THE PARAMETER, CALL PRAM TO FILL THE LVLWD ARRAY, THEN C LOOP BACK TO THE BRANCH POINT TO PROCESS THE NEW ENTRY. C C IF THE USER ENTERS AN IMMEDIATE CARRIAGE RETURN, LEAVE BLANKS C FOR THE LEVEL WORD. C 10 CONTINUE LVLWD=2H LVLWD(2)=2H LVLWD(3)=2H LVLWD(4)=3 CALL REIO(2,LU1,28H HIGHEST LEVEL CODE WORD ? _,-28) REG = REIO(1,Le9  U1+400B,STRING,40) LNGTH2=2*IB C C CKECK IF ALL BLANKS WERE ENTERED C IF (LNGTH2 .EQ. 0) RETURN IF (JSCOM(STRING,1,LNGTH2,6H ,1,IERR) .EQ.0) RETURN ISTRC=1 CALL PRAM(LU1,STRING,LNGTH2,ISTRC,LVLWD) GO TO 5 C************************************************************* C PROCESS AN INTEGER PARAMETER AS AN ERROR. C 20 CONTINUE CALL REIO(2,LU1,29H THE LEVEL WORD IS NOT ASCII.,-29) IERR=-211 CALL DBER2(LU1,IERR,6HXXXXXX,6HCKLVL ,2HXX) RETURN C************************************************************* C PROCESS A NAMR PARAMETER AS OK. C 30 RETURN END   &- 92069-18191 2013 S C0122 &CKP51              H0101 foFTN4 SUBROUTINE CKP51(LU1,P5,IERR) +,92069-16191 REV.2013 790402 C C C***************************************************************** C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. C NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR C TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR C WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. C****************************************************************** C C C SOURCE: 92069-18191 C RELOC: 92069-16191 C C C****************************************************************: C C C************************************************************** C CKP51 CHECKS THAT THE ABORT WORD PASSED IN IS REALLY AN C ASCII STRING, OR AN INTEGER VALUE. IF NO PARAMETER WAS C PASSED IN, CKP51 QUERIES THE USER AT CONSOLE LU, READS IN THE ABORT C WORD, AND THEN CHECKS THAT ITS ASCII OR INTEGER. C*************************************************************** INTEGER LU1,P5(1),IERR C*************************************************************** C IF THE TYPE IS ASCII, NORMAL RETURN. ELSE RETURN ERROR. C C PROCESS AN INTEGER PARAMETER AS AN ERROR. C 5 CONTINUE IERR = 0 ITYPE = P5(4) IF (ITYPE .EQ. 0) GO TO 10 IF (ITYPE .EQ. 1) GO TO 3000 IF (ITYPE .EQ. 3) GO TO 30 C************************************************************ C PROCESS INTERNAL ERROR. C CALL DBER2(LU1,7777,6HXXXXXX,6HCKP51 ,2HAB) C************************************************************* C PROCESS NO PARAMETER BY PROMPTING THE USER AT THE CONSOLE LU. C READ THE PARAMETER, CALL PRAM TO FILL THE NAMR ARRAY, THEN C LOOP BACK TO THE BRANCH POINT TO PROCESS THE NEW ENTRY. C C 10 CONTINUE CALL REIO(2,LU1,39H OVERWRITE EXISTING FILES(YES OR NO)? _,-39) CALL REIO(1,LU1+400B,ITEMP,1) IF((ITEMP .NE. 2HYE) .AND. (ITEMP .NE. 2HNO)) GOTO 10 P5=2HAB IF (ITEMP .EQ. 2HYE) P5=2HCO P5(4)=3 RETURN C***a  ********************************************************** C CHECK A NAMR PARAMETER FOR VALIDITY. C 30 CONTINUE IF ((P5 .EQ. 2HAB) .OR. (P5 .EQ. 2HCO)) RETURN C*********************************************************** C BAD ABORT WORD IN THE RUN STRING. C 3000 CONTINUE CALL REIO(2,LU1,20H ILLEGAL ABORT WORD.,-20) IERR=-248 CALL DBER2(LU1,IERR,6HXXXXXX,6HCKP51 ,2HXX) RETURN END  '. 92069-18192 2013 S C0122 &OPEN1              H0101 pFTN4 SUBROUTINE OPEN1(LU1,NAMR,DCB1,DCB1SZ,IERR) +,92069-16192 REV.2013 790413 C C C***************************************************************** C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. C NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR C TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR C WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. C****************************************************************** C C C SOURCE: 92069-18192 C RELOC: 92069-16192 C C C****************************************************************: C C C************************************************************* C OPEN1 EXCLUSIVELY OPENS NAMR TO DCB1 AS A TYPE 1 FILE WITH C BINARY DATA. IF AN ERROR OCCURS, OPEN1 C PRINTS AN ERROR MESSAGE ON LU1, SETS IERR NEGATIVE, AND RETURNS. C************************************************************** INTEGER LU1,NAMR(1),DCB1(1),DCB1SZ,IERR C************************************************************** C OPEN THE FILE. ISECU=NAMR(5) ICR= NAMR(6) IOPTN=104B CALL OPENF(DCB1,IERR,NAMR,IOPTN,ISECU,ICR,DCB1SZ) IF (IERR .GE. 0) IERR=0 CALL DBER2(LU1,IERR,NAMR,6HOPEN1 ,2HXX) RETURN END  (. 92069-18193 2013 S C0122 &TAPEW              H0101 nFTN4 SUBROUTINE TAPEW(LU1,TAPE,BUFR,BUF1,IERR) +,92069-16193 REV.2013 790413 C C C***************************************************************** C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. C NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR C TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR C WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. C****************************************************************** C C C SOURCE: 92069-18193 C RELOC: 92069-16193 C C C****************************************************************: C C C******************************************************************** C TAPEW WRITES DATA TO TAPE FROM BUFR. TAPEW ASSUMES THAT TDCB C (IN NAMED COMMON) IS OPEN TO TAPE AS A TYPE 0 FILE IF TAPE IS A MAG C TAPE LU, OR AS A TYPE 1 FILE IF TAPE IS A DISC FILE. C C TAPEW CHECKS FOR AN EOF AT THE END OF EACH WRITE, AND PROMPTS THE C USER TO MOUNT A NEW TAPE AT EOT, OR ABORTS AT THE END OF A TYPE 1 C FILE. C IF AN EOT OCCURS, THE RECORD IS WRITTEN ON THIS TAPE, NOT THE C NEW TAPE. THEN TAPEW WRITES AN EOF ON THE TAPE AND CALLS EOTWR C TO PROMPT FOR A NEW TAPE. C********************************************************************* C NAMED COMMON DECLARATIONS C INTEGER HDR(24),TDCB(144),TDSZ,P5(6) COMMON/TPHDR/HDR,TDCB,TDSZ,P5 C******************************************************************** C FORMAL PARAMETERS. C INTEGER LU1,TAPE(1),BUFR(1),BUF1,IERR C****************************************************************** C INTEGER BUFL BUFL=BUF1 C********************************************************************* C BRANCH TO 5000 IF THE USER SET THE BREAK BIT. C IF (IFBRK(IDUMY)) 5000,300 C********************************************************************* C FOR A 0-LENGTH RECORD TO A TAPE LU, HAVE TO WRITE AN EOF(LENGTH -1) C 300 IF ((BUFL .EQ. 0) .AND. (TAPE(4) .EQ. 1)) BUFL=-1 C***********************a  ****************************************** C WRITE BUFR TO TAPE USING TDCB. C CALL EWRIT(TDCB,IERR,BUFR,BUFL) C******************************************************** C TRAP OUT AN EOF ON A TYPE 3 FILE. C IF (IERR .EQ. -33) GO TO 4000 CALL DBER2(LU1,IERR,TAPE,6HTAPEW ,2HXX) IF (TAPE(4) .NE. 1) RETURN C***************************************************************** C SPECIAL CHECK FOR AN EOT ON THE TAPE DEVICE. C 2000 IA=IEOT(TAPE) IF (IA .GE. 0) RETURN C************************************************************ C END OF TAPE ON A TAPE DEVICE. C WRITE EOF ON THIS TAPE(THE RECORD HAS BEEN WRITTEN OVER THE EOT MARK). C CALL EOTWR TO REQUEST NEW TAPE. C RETURN,KNOWING THAT THE NEW TAPE IS READY FOR NEXT WRITE. C CONTINUE CALL EWRIT(TDCB,IERR,IDUMY,-1) CALL DBER2(LU1,IERR,TAPE,6HTAPEW ,2HXX) IF (IERR .LT. 0) RETURN CALL EOTWR(LU1,TAPE,HDR,TDCB,TDSZ,P5,IERR) RETURN C********************************************************* C TRAP FOR THE EOF ON A TYPE 3 FILE. C PERFORM THESE STEPS: C 1) CALL EOFWR TO CLOSE THE CURRENT FILE, THEN REQUEST AND OPEN C THE NEW FILE, WRITE A TAPE HEADER. C 2) GO TO THE TOP TO WRITE THE DATA RECORD INTO THE NEW FILE. C 4000 CONTINUE IF (TAPE(4) .NE. 3) CALL DBER2(LU1,7777,6HXXXXXX,6HTAPEW ,2HAB) CALL EOFWR(LU1,TAPE,HDR,TDCB,TDSZ,P5,IERR) IF (IERR .NE. 0) RETURN GO TO 300 C****************************************************************** C USER SET THE BREAK BIT. C 5000 CALL DBER2(LU1,247,6HXXXXXX,6HTAPEW ,2HXX) IERR=-247 RETURN END  )0 92069-18194 2013 S C0122 &EOTWR              H0101 FTN4 SUBROUTINE EOTWR(LU1,TAPE,HDR,TDCB,TDSZ,P5,IERR) +,92069-16194 REV.2013 790416 C C C***************************************************************** C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. C NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR C TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR C WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. C****************************************************************** C C C SOURCE: 92069-18194 C RELOC: 92069-16194 C C C****************************************************************: C C C************************************************************* C EOTWR HANDLES AN EOT FOR A MAG TAPE LU. C C EOTWR ASSUMES THAT THE HEADER PASSED IN IN HDR STILL HAS THE C REEL NUMBER OF THE OLD TAPE REEL IN HDR(21). C C IF P5=AB, A NEGATIVE ERROR IS RETURNED IN IERR. C IF P5 .NE. AB, THE USER IS PROMPTED ON LU1 TO MOUNT A NEW TAPE. C************************************************************** C FORMAL PARAMETERS C INTEGER LU1,TAPE(1),HDR(1),TDCB(1),TDSZ,P5,IERR C******************************************************** C LOCAL VARIABLES. C INTEGER RESPON INTEGER MESS1(25),NUM(3) DATA MESS1/2H S,2HAV,2HE ,2HTA,2HPE,2H O,2HN ,2HLO,2HGI, & 2HCA,2HL ,2HDE,2HVI,2HCE,2H X,2HXX,2HXX,2HX ,2HAS, & 2H A,2HAA,2HAA,2HA ,2HNN,2HN / C************************************************************** C IF (TAPE(4) .NE. 1) CALL DBER2(LU1,7777,6HXXXXXX,6HEOTWR ,2HAB) IF (P5 .EQ. 2HAB) GO TO 9000 C************************************************************ C REQUEST NEW TAPE BE MOUNTED. C CALL REIO(2,LU1,2H ,1) CALL REIO(2,LU1,2H ,1) C C CONVERT LU NUMBER TO ASCII AND PUT IT IN THE MESSAGE C CALL CNUMD(TAPE,NUM) CALL SMOVE(NUM,1,6,MESS1,30) C C GET THE HEADER AND PUT IT IN THE MESSAGE C CALL SMOVE(HDR,17,22,MESS1,40) C C CONVERT THE REEL NUMBER AND PUT IT I  N THE HEADER C CALL CNUMD(HDR(21),NUM) CALL SMOVE(NUM,4,6,MESS1,47) CALL REIO(2,LU1,MESS1,25) CALL REIO(2,LU1,2H ,1) C C TELL THEM TO MOUNT NEXT TAPE C 2525 CONTINUE CALL REIO(2,LU1,36H MOUNT NEXT REEL ON LOGICAL DEVICE _,-36) CALL CNUMD(TAPE,NUM) CALL REIO(2,LU1,NUM,3) C C GET RESPONSE C CALL READY(LU1,RESPON,IERR) IF (IERR .LT. 0) GO TO 9000 C************************************************************* C BY HERE, YOU KNOW THE USER HAS MOUNTED NEW TAPE AND TYPED YES. C CHECK THAT THE NEW TAPE IS ALL SET TO GO. C CALL TLOCL(LU1,TAPE,IERR) IF (IERR .LT. 0) RETURN CALL RING(LU1,TAPE,2HXX,IERR) IF (IERR .LT. 0) RETURN C*********************************************************** C CHECK THAT YOU'RE AT LOAD POINT. C CALL SOT(LU1,TAPE,P5,IERR) IF (IERR .LT. 0) GO TO 9000 C*************************************************** C BY HERE, YOU KNOW THAT NEW TAPE HAS BEEN MOUNTED. C 3000 CONTINUE IERR=0 HDR(21)=HDR(21)+1 CALL EWRIT(TDCB,IERR,HDR,24) CALL DBER2(LU1,IERR,TAPE,6HEOTWR ,2HXX) RETURN C************************************************************ C ABORT AT EOT. C 9000 CONTINUE CALL REIO(2,LU1,25H ABORTING AT END OF TAPE.,-25) CALL DBER2(LU1,236,6HXXXXXX,6HEOTWR ,2HXX) C REWIND THE TAPE AND DESTROY IT.(USER MAY HAVE REMOVED IT.) IERR=-236 RETURN END M  *1 92069-18195 2013 S C0122 &EOFWR              H0101 FTN4 SUBROUTINE EOFWR(LU1,TAPE,HDR,TDCB,TDSZ,P5,IERR) +,92069-16195 REV.2013 800107 C C C***************************************************************** C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. C NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR C TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR C WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. C****************************************************************** C C C SOURCE: 92069-18195 C RELOC: 92069-16195 C C C****************************************************************: C C C**************************************************************** C EOFWR HANDLES AN EOF ON A WRITE TO A TYPE 3 FILE. C EOFWR DOES THESE STEPS: C 1) CALLS ELOCF TO DETERMINE THE NEXT AVAILABLE RECORD (EOFWR C ASSUMES THAT ELOCF RETURNS THE NEXT AVAILABLE RECORD IF THE C LAST WRITE RETURNED AN ERROR I.E. THAT THE LAST THING EWRIT DOES C IS UPDATE THE INFORMATION ON THE RECORD NUMBER). C 2) POSITIONS THE FILE TO THE NEXT AVAILABLE RECORD. C 3) WRITES AN EOF MARK IN THIS POSITION, AND CLOSES THE FILE. C 4) PROMPTS THE USER FOR ANOTHER FILE NAME. C 5) CREATES A NEW FILE WITH THE NAME AND CARTRIDGE SPECIFIED THAT C TAKES UP THE ENTIRE REST OF THE CARTRIDGE (A DIFFERENT CARTRIDGE C THAN THE PREVIOUS ONE SINCE THERE'S NO ROOM LEFT ON THAT ONE.) C 6) OPENS THE FILE AND WRITES A TAPE HEADER INTO THE FILE. C***************************************************************** INTEGER LU1,TAPE(1),HDR(1),TDCB(1),TDSZ,P5,IERR C***************************************************************** C LOCAL VARIABLES. C INTEGER IREC(2) INTEGER FILE(20) DOUBLE PRECISION MESS1(6) INTEGER MESS2(18) EQUIVALENCE(MESS1,MESS2) C****************************************************************** C DATA STATEMENTS DATA MESS1/6H SAVE ,6HFILE ,6H ,6H AS ,6H ,6H / C*****************************************6************************* IF (TAPE(4) .NE. 3) CALL DBER2(LU1,7777,6HXXXXXX,6HEOFWR ,2HXX) IF (P5 .EQ. 2HAB) GO TO 9000 C******************************************************************* C CALL ELOCF TO GET WHERE THE LAST WRITE WAS ATTEMPTED. C CALL ELOCF(TDCB,IERR,IREC) CALL DBER2(LU1,IERR,TAPE,6HEOFWR ,2HXX) C***************************************************************** C POSITION THE FILE TO WHERE THE WRITE SHOULD HAVE OCCURRED. C CALL RWNDF(TDCB,IERR) CALL EPOSN(TDCB,IERR,IREC,1) CALL DBER2(LU1,IERR,TAPE,6HEOFWR ,2HXX) C************************************************************ C WRITE OUT AN EOF. C CALL EWRIT(TDCB,IERR,IDUMMY,-1) CALL DBER2(LU1,IERR,TAPE,6HEOFWR ,2HXX) CALL POST(TDCB,IERR) CALL ECLOS(TDCB,IERR) CALL DBER2(LU1,IERR,TAPE,6HEOFWR ,2HXX) IF (IERR .LT. 0) RETURN C****************************************************************** C TELL USER TO REMEMBER THE OLD FILE. C MESS2(7)=TAPE(1) MESS2(8)=TAPE(2) MESS2(9)=TAPE(3) MESS2(13)=HDR(9) MESS2(14)=HDR(10) MESS2(15)=HDR(11) CALL CNUMD(HDR(21),MESS2(16)) CALL REIO(2,LU1,MESS1,18) C******************************************************************* C REQUEST THE NEXT FILE NAME. C 1000 CALL REIO(2,LU1,35H NEXT STORAGE FILE(AB TO ABORT) ? _,-35) CALL REIO(1,LU1+400B,FILE,20) CALL ABREG(IA,IB) LNGTH2=2*IB IF ((LNGTH2 .EQ. 2) .AND. (FILE(1) .EQ. 2HAB)) GO TO 9000 ISTRC1=1 CALL PRAM(LU1,FILE,LNGTH2,ISTRC1,TAPE) IF (TAPE(4) .EQ. 3) GO TO 2000 CALL REIO(2,LU1,28H PLEASE SPECIFY A FILE NAME.,-28) GO TO 1000 C************************************************************** C HAVE A GOOD FILE NAME. MAKE A NEW FILE AND OPEN IT. C 2000 CONTINUE CALL NWFIL(LU1,IERR,TDCB,TDSZ,TAPE,DBLEI(-1),3,P5) IF (IERR .LT. 0) GO TO 1000 IOPTN=100B CALL OPENF(TDCB,IERR,TAPE,IOPTN,:  TAPE(5),TAPE(6),TDSZ) IF (IERR .GT. 0) IERR=0 CALL DBER2(LU1,IERR,TAPE,6HEOFWR ,2HXX) IF (IERR .LT. 0) GO TO 1000 C*************************************************************** C WRITE OUT A TAPE HEADER ON THE NEW FILE. C HDR(21)=HDR(21)+1 CALL EWRIT(TDCB,IERR,HDR,24) CALL DBER2(LU1,IERR,TAPE,6HEOFWR ,2HXX) RETURN C***************************************************************** C ABORT POINT. C 9000 CONTINUE IERR=-235 CALL REIO(2,LU1,25H ABORTING AT END OF FILE.,-25) CALL DBER2(LU1,235,6HXXXXXX,6HEOFWR ,2HXX) RETURN END N +3 92069-18196 2013 S C0122 &TAPER              H0101 qFTN4 SUBROUTINE TAPER(LU1,TAPE,BUFR,BUFSZ,LEN,EOF,IERR) +,92069-16196 REV.2013 790126 C C C***************************************************************** C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. C NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR C TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR C WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. C****************************************************************** C C C SOURCE: 92069-18196 C RELOC: 92069-16196 C C C****************************************************************: C C C************************************************** C TAPER READS A MAG TAPE AND PUTS THE DATA INTO BUFR. C IT RETURNS THE LENGTH READ IN LEN, AND RETURNS EOF C AS TRUE IF A LOGICAL EOF IS ENCOUNTERED. C ON ERRORS, IT RETURNS WITH NEGATIVE IN IERR. C C TAPER ASSUMES THE FOLLOWING: C 1) A LOGICAL EOF ON THE TAPE DEVICE IS A -1 LENGTH RECORD. C 2) A LOGICAL EOF ON A TYPE 3 FILE IS A 0-LENGTH RECORD. C 3) A TRUE EOF ON THE TAPE DEVICE IS SET BY THE EOT MARK ON THE TAPE. C 4) A TRUE EOF ON THE TYPE 3 FILE IS A -1 LENGTH RECORD. C************************************************** C NAMED COMMON DECLARATIONS. C INTEGER HDR(24),TDCB(144),TDSZ,P5(6) COMMON/TPHDR/HDR,TDCB,TDSZ,P5 C******************************************************** C FORMAL PARAMETERS. C INTEGER LU1,TAPE(1),BUFR(1),BUFSZ,LEN,IERR LOGICAL EOF C********************************************************** C LOCAL VARIABLES. C INTEGER TEMP(30) INTEGER RESPON C******************************************************** C READ IN BUFFER FROM THE STORAGE DEVICE. C 350 CALL EREAD(TDCB,IERR,BUFR,BUFSZ,LEN) C************************************************************* C TRAP OUT AN EOF ON A TYPE 3 FILE. C ITYPE = TAPE(4) IF ((LEN .EQ. -1) .AND. (ITYPE .EQ. 3)) GO TO 5000 CALL DBER2(LU1,IERR,TAPE,6HTAPER ,2HXX) IF (IE  RR .LT. 0) RETURN C****************************************************************** C ON A TAPE UNIT ,SEE IF YOU HIT A TRUE EOT. C IF (ITYPE .EQ. 3) GO TO 2000 IA=IEOT(TAPE) IF (IA .LT. 0) GO TO 6000 C*********************************************************** C TEST FOR A LOGICAL EOF MARK. C (0-LENGTH RECORD FOR TYPE 3 FILE, -1 LENGTH FOR A TYPE 0 FILE). C 2000 CONTINUE 300 IF (LEN .EQ. 0) GO TO 3000 IF ((LEN .EQ. -1) .AND. (ITYPE .EQ. 1)) GO TO 3000 C******************************************************** C NORMAL RETURN POINT.TEST IF USER SET A BREAKPOINT. C IF (IFBRK(IDUMY)) 7000,3500 C*********************************************************** C LOGICAL EOF WAS ENCOUNTERED. C 3000 CONTINUE EOF=.TRUE. IERR=0 3500 RETURN C*************************************************************** C HIT A REAL EOF ON THE TYPE 3 FILE. C REMEMBER, RECORD HAS TO BE WRITTEN TO NEW TAPE. (12-12-78) C 5000 CALL EOFRE(LU1,TAPE,HDR,TDCB,TDSZ,P5,IERR) IF(IERR .GE. 0) GO TO 350 RETURN C************************************************************ C HIT A REAL EOT ON THE TAPE DEVICE. C PROCESS THE EOT, REMEMBERING THAT THE DATA IN BUFR IS GOOD DATA. C 6000 CALL EOTRE(LU1,TAPE,HDR,TDCB,TDSZ,P5,IERR) IF (IERR .LT. 0) RETURN GO TO 300 C*************************************************************** C HANDLE A USER SET BREAKPOINT. C 7000 CONTINUE IERR = -247 CALL DBER2(LU1,IERR,6HXXXXXX,6HTAPER ,2HXX) RETURN END n>  ,3 92069-18197 2013 S C0122 &EOFRE              H0101 {FTN4 SUBROUTINE EOFRE(LU1,TAPE,HDR,TDCB,TDSZ,P5,IERR) +,92069-16197 REV.2013 790511 C C C***************************************************************** C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. C NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR C TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR C WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. C****************************************************************** C C C SOURCE: 92069-18197 C RELOC: 92069-16197 C C C****************************************************************: C C C************************************************************ C EOFRE HANDLES AN EOF ON A TYPE 3 FILE. C EOFRE DOES THESE THINGS: C 1) REQUESTS THE USER TO ENTER THE NEXT STORAGE FILE NAME. C 2) OPENS THE FILE C 3) CHECKS THE TAPE HEADER INCLUDING THE REEL NUMBER. C 4) RETURNS. C*********************************************************** C FORMAL PARAMETERS. C INTEGER LU1,TAPE(1),HDR(1),TDCB(1),TDSZ,P5(1),IERR C************************************************************* C LOCAL PARAMETERS. C INTEGER FILE(24) INTEGER IA(2) EQUIVALENCE (REG,IA),(IA(2),IB) C************************************************************** C PRINT OUT MESSAGES. C CALL REIO(2,LU1,14H END OF FILE _,7) CALL REIO(2,LU1,TAPE,3) 1000 CALL REIO(2,LU1,34H NEXT STORAGE FILE(AB TO ABORT)? _,17) REG = REIO(1,LU1+400B,FILE,20) LNGTH2=2*IB IF ((LNGTH2 .EQ. 2) .AND. (FILE .EQ. 2HAB)) GO TO 9000 C**************************************************************** C PARSE THE FILE NAME USER JUST ENTERED. C ISTRC=1 CALL PRAM(LU1,FILE,LNGTH2,ISTRC,TAPE) IF (TAPE(4) .EQ. 3) GO TO 2000 CALL REIO(2,LU1,26H PLEASE ENTER A FILE NAME.,13) GO TO 1000 C*********************************************************** C HAVE A VALID ASCII STRING FOR FILE. OPEN THE FILE. C 2000 CALL ECLOS(TDCB,IERR) 6   CALL OPENF(TDCB,IERR,TAPE,0,TAPE(5),TAPE(6),TDSZ) IF (IERR .GT. 0) IERR=0 CALL DBER2(LU1,IERR,TAPE,6HEOFRE ,2HXX) IF (IERR .LT. 0) GO TO 1000 C*********************************************************** C CHECK THE TAPE HEADER IN THE NEW FILE. C CALL EREAD(TDCB,IERR,FILE,24,LEN) CALL DBER2(LU1,IERR,TAPE,6HEOFRE ,2HXX) IF (IERR .LT. 0) GO TO 1000 CALL CKTHD(LU1,HDR,FILE,IERR) IF (IERR .LT. 0) GO TO 1000 RETURN C************************************************************* C ABORT POINT. C 9000 CONTINUE CALL REIO(2,LU1,25H ABORTING AT END OF FILE.,-25) IERR=-235 CALL DBER2(LU1,IERR,6HXXXXXX,6HEOFRE ,2HXX) RETURN END   -4 92069-18198 2013 S C0122 &EOTRE              H0101 FTN4 SUBROUTINE EOTRE(LU1,TAPE,HDR,TDCB,TDSZ,P5,IERR) +,92069-16198 REV.2013 790416 C C C***************************************************************** C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. C NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR C TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR C WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. C****************************************************************** C C C SOURCE: 92069-18198 C RELOC: 92069-16198 C C C****************************************************************: C C C******************************************************************* C EOTRE HANDLES AN EOT AFTER THE EVENT OCCURS. C IF AN ERROR OCCURS DURING EXECUTION OF EOTRE, IT RETURNS LEAVING C THE IERR UNTOUCHED. C IF EOTRE HANDLES THE EOT PROPERLY, IT SETS IERR=0 AND RETURNS. C C IF YOU'RE READING A TYPE 0 FILE POINTING TO A MAG TAPE DEVICE, EOTRE: C 1) CHECKS P5 AND IF P5=AB IT RETURNS LEAVING THE NEGATIVE IERR. C 2) IF P5 .NE. AB, EOTRE REQUESTS THAT A NEW TAPE BE MOUNTED. C 3) AFTER THE USER MOUNTS THE TAPE AND RESPONDS YES, EOTRE CHECKS C THE HEADER AT THE BEGINNING OF THE NEW TAPE. C 4) IF THE HEADER IS INCORRECT, EOTRE RETURNS LEAVING NEGATIVE IERR. C 5) IF THE HEADER IS CORRECT, EOTRE SETS IERR=0 AND RETURNS. C C NOTE THAT HDR(21) HOLDS THE NEXT REEL NUMBER ABOUT TO BE MOUNTED, C NOT THE REEL NUMBER THAT JUST FINISHED. C C*********************************************************************** C FORMAL PARAMETER DECLARATIONS. C INTEGER LU1,TAPE(1),HDR(1),TDCB(1),TDSZ,P5,IERR C****************************************************************** C LOCAL VARIABLES. C INTEGER TEMP(24) INTEGER RESPON DOUBLE PRECISION MESS1(3),MESS2(8) C*********************************************************** C MESSAGES. C DATA MESS1/6HEND OF,6H REEL ,6H000000/ DATA MESS2/6HMOUNT ,6HTAPE ,6H000000,6H000000, +6H ON 0  LO,6HGICAL ,6HDEVICE,6H000000/ C**************************************************************** C ABORT IF THE STORAGE DEVICE IS A TYPE 3 FILE. C IF (TAPE(4) .NE. 1) CALL DBER2(LU1,7777,6HXXXXXX,6HEOTRE ,2HAB) C***************************************************************** C SET UP THE MESSAGES WITH THE PROPER VALUES. C CALL CNUMD(TAPE,MESS2(8)) CALL CNUMD(HDR(21)-1,MESS1(3)) CALL CNUMD(HDR(21),MESS2(4)) MESS2(3)=ROOT C****************************************************************** C REQUEST NEW TAPE BE MOUNTED. C 4000 CALL REIO(2,LU1,2H _,1) CALL REIO(2,LU1,MESS1,9) C**************************************************************** 4015 CALL REIO(2,LU1,2H _,1) CALL REIO(2,LU1,MESS2,24) CALL READY(LU1,RESPON,IERR) IF (IERR .LT. 0) GO TO 8000 C*************************************************************** C MAKE SURE TAPE IS READY AND ON-LINE. C CALL TLOCL(LU1,TAPE,IERR) IF (IERR .EQ. 0) GO TO 4100 GO TO 4015 C*************************************************************** C READ THE NEW REELHEADER. C 4100 CONTINUE CALL EREAD(TDCB,IERR,TEMP,24,LEN) CALL DBER2(LU1,IERR,TAPE,6HEOTRE ,2HXX) IF (IERR .LT. 0) RETURN C************************************************************* C CHECK THE NEW REELHEADER. C CALL CKTHD(LU1,HDR,TEMP,IERR) IF (IERR .LT. 0) GO TO 4015 RETURN C*************************************************************** C USER RESPONSE SAYS TO ABORT. C 8000 CALL REIO(2,LU1,25H ABORTING AT END OF TAPE.,-25) IERR=-236 CALL DBER2(LU1,IERR,6HXXXXXX,6HEOTRE ,2HXX) RETURN END  .5 92069-18199 2013 S C0122 &READY              H0101 wFTN4 SUBROUTINE READY(LU1,RESPON,IERR) +,92069-16199 REV.2013 790205 C C C***************************************************************** C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. C NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR C TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR C WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. C****************************************************************** C C C SOURCE: 92069-18199 C RELOC: 92069-16199 C C C****************************************************************: C C C******************************************************** C READY PROMPTS THE USER FOR A RESPONSE. C********************************************************* INTEGER LU1,RESPON,IERR C*********************************************************** 1000 CALL REIO(2,LU1,21H READY (YES OR NO)? _,-21) CALL REIO(1,LU1+400B,RESPON,1) IF (RESPON .EQ. 2HNO) GO TO 8000 IF (RESPON .EQ. 2HYE) GO TO 9000 CALL REIO(2,LU1,38H ENTER YES TO CONTINUE OR NO TO ABORT.,19) GO TO 1000 C********************************************************** C ABORT POINT RETURNS NEGATIVE ERROR. C 8000 IERR=-1 RETURN C************************************************************ C CONTINUATION POINT. C 9000 IERR=0 RETURN END K /5 92069-18200 2013 S C0122 &TLOCL              H0101 uFTN4 SUBROUTINE TLOCL(LU1,TAPE,IERR) +,92069-16200 REV.2013 791124 C C C***************************************************************** C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. C NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR C TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR C WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. C****************************************************************** C C C SOURCE: 92069-18200 C RELOC: 92069-16200 C C C****************************************************************: C C C***************************************************** C TLOCL DOES THE FOLLOWING: C 1) ERROR 210 IF TAPE IS NOT A TAPE DEVICE. C 2) ERROR 231 IF TAPE OFF-LINE. C 3) OTHERWISE RETURNS NORMALLY. C******************************************************* C FORMAL PARAMETER DECLARATIONS. C INTEGER LU1,TAPE,IERR C********************************************************* C TEST THAT TAPE IS TRULY A TAPE DEVICE (CHECK THAT THE DRIVER C TYPE IS BETWEEN 20 AND 27 INCLUSIVELY). C CALL EXEC(13+100000B,TAPE,ISTA1,ISTA2) GO TO 9000 1 ITEST=IAND(ISTA1,37400B)/256 IF ((ITEST .GE. 20B) .AND. (ITEST .LE. 27B)) GO TO 900 C******************************************************* C TAPE IS NOT A TAPE DEVICE. C CALL REIO(2,LU1,40H SPECIFIED STORAGE UNIT IS NOT LEGAL. ,20) IERR=-210 GOTO 950 C********************************************************* C MAKE SURE TAPE IS ON-LINE. C 900 IERR=LOCAL(TAPE) IF (IERR .GE. 0) IERR=0 IF (IERR .EQ. 0) RETURN CALL REIO(2,LU1,21H TAPE LU IS OFF-LINE.,-21) IERR=-231 950 CALL DBER2(LU1,IERR,6HXXXXXX,6HTLOCL ,2HXX) RETURN C************************************************************* C RTE REJECTED THE EXEC CALL. C 9000 CONTINUE CALL REIO(2,LU1,13H BAD TAPE LU.,-13) IERR = -210 GOTO 950 END    07 92069-18201 2013 S C0122 &COMP              H0101 RFTN4 SUBROUTINE COMP(LU1,BUF1,BUF2,LENGTH,IERR) +,92069-16201 REV.2013 790316 C C C***************************************************************** C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. C NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR C TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR C WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. C****************************************************************** C C C SOURCE: 92069-18201 C RELOC: 92069-16201 C C C****************************************************************: C C C************************************************************ C COMP COMPARES TWO BUFFERS AND RETURNS 0 IN IERR IF THEY C MATCH, ELSE IERR HAS NEGATIVE J, WHERE J IS THE FIRST WORD C IN WHICH THEY DIFFER. C************************************************************* INTEGER LU1,BUF1(1),BUF2(1),LENGTH,IERR DO 10 J=1,LENGTH IF (BUF1(J) .NE. BUF2(J)) GO TO 1000 10 CONTINUE IERR=0 RETURN C********************************************************* C RETURN POINT WHEN BUFFERS DIFFER C 1000 IERR=-J RETURN END  17 92069-18202 2013 S C0122 &FILEH              H0101 v|FTN4 SUBROUTINE FILEH(LU1,TAPE,NAMR,DCB2,DCB2SZ,J,IERR) +,92069-16202 REV.2013 790413 C C C***************************************************************** C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. C NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR C TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR C WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. C****************************************************************** C C C SOURCE: 92069-18202 C RELOC: 92069-16202 C C C****************************************************************: C C C*********************************************************** C FILEH WRITES A FILE HEADER TO TAPE. C IT USES THE INFORMATION IN NAMR TO OPEN THE FILE, THEN C CALLS ELOCF TO DETERMINE THE TYPE, SIZE, AND RECORD SIZE C OF THE FILE. C C JSEC= 2-WORD INTEGER WITH NUMBER OF SECTORS IN FILE NAMR. C JBLK= 2-WORD INTEGER WITH NUMBER OF BLOCKS IN FILE (JSEC/2). C C*********************************************************** INTEGER LU1,TAPE(1),NAMR(1),DCB2(1),DCB2SZ,J,IERR COMPLEX STRING(6) INTEGER S(24) INTEGER IREC(2),IRB(2),JSEC(2),JBLK(2) REAL BLK EQUIVALENCE(JBLK,BLK) EQUIVALENCE (STRING,S) DATA STRING/8HFILEHEAD,8H21XX ,4*8H / C************************************************************ C OPEN UP THE FILE AND CALL ELOCF TO GET DATA. C ISECU=NAMR(5) ICR=NAMR(6) IOPTN=0 CALL OPENF(DCB2,IERR,NAMR,IOPTN,ISECU,ICR,DCB2SZ) IF (IERR .LT. 0) GO TO 9000 CALL ELOCF(DCB2,IERR,IREC,IRB,IOFF,JSEC,JLU,JTY,JREC) IF (IERR .LT. 0) GO TO 9000 BLK=DDI(JSEC,DBLEI(2)) C********************************************************** C SET UP THE STRING TO BE WRITTEN C DO 10 K=1,6 S(K+8)=NAMR(K) 10 CONTINUE S(17)=J S(19)=JREC S(20)=JTY S(21)=JBLK(1) S(22)=JBLK(2) S(24)=2H** C*******************   ************************************** C WRITE IT TO TAPE. C CALL TAPEW(LU1,TAPE,S,24,IERR) CALL ECLOS(DCB2,IERR) RETURN C*********************************************************** C ERROR. C 9000 CALL DBER2(LU1,IERR,NAMR,6HFILEH ,2HXX) CALL ECLOS(DCB2,IERR2) RETURN END   29 92069-18203 2013 S C0122 &DATAH              H0101 kFTN4 SUBROUTINE DATAH(LU1,NAMR,BUFR,BUFSZ,HDSZ,IERR) +,92069-16203 REV.2013 790413 C C C***************************************************************** C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. C NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR C TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR C WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. C****************************************************************** C C C SOURCE: 92069-18203 C RELOC: 92069-16203 C C C****************************************************************: C C C********************************************************* C DATAH SETS UP A DATA HEADER IN THE FIRST 24 WORDS OF BUFR. C IT DOES NOT WRITE BUFR OUT TO TAPE, JUST SETS IT UP. C********************************************************* INTEGER LU1,NAMR(1),BUFR(1),BUFSZ,HDSZ,IERR INTEGER S(24) COMPLEX STRING(6) EQUIVALENCE (S,STRING) DATA STRING/8HDATAHEAD,8H21XX ,4*8H / C******************************************************* C CHECK BUFR IS LARGE ENOUGH C IF (BUFSZ .LT. 25) CALL DBER2(LU1,7777,NAMR,6HDATAH ,2HAB) C********************************************************** C BUILD UP S,THEN TRANSFER IT TO BUFR. C DO 10 J=1,6 S(J+8)=NAMR(J) 10 CONTINUE S(24)=2H** C******************************************************** C TRANSFER S INTO BUFR C DO 20 J=1,24 BUFR(J)=S(J) 20 CONTINUE HDSZ=24 IERR=0 RETURN END  39 92069-18204 2013 S C0122 &RING              H0101 zbFTN4 SUBROUTINE RING(LU1,TAPE,P5,IERR) +,92069-16204 REV.2013 790413 C C C***************************************************************** C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. C NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR C TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR C WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. C****************************************************************** C C C SOURCE: 92069-18204 C RELOC: 92069-16204 C C C****************************************************************: C C C**************************************************** C RING CHECKS THAT THE TAPE LU HAS A WRITE RING IN IT. C IF IT DOES, RING IMMEDIATELY RETURNS. C IF IT DOESNT, RING CHECKS P5 AND ABORTS IF P5 RETURNS C AB, AND PROMPTS THE USER TO INSERT A WRITE RING IF C THE USER SPECIFIED NO ABORT. C***************************************************** INTEGER LU1,TAPE,P5,IERR INTEGER ERR1(17) INTEGER NUM(3) DATA ERR1/2H T,2HAP,2HE ,2HLU,2H X,2HXX,2HXX,2HX ,2HHA,2HS , & 2HNO,2H W,2HRI,2HTE,2H R,2HIN,2HG./ C***************************************************************** C GET DYNAMIC STATUS. C CALL EXEC(13,TAPE,ISTAT) ISTAT=IAND(ISTAT,4B) IF (ISTAT .EQ. 0) IERR=0 IF (IERR .EQ. 0) RETURN C***************************************************************** C TAPE HAS NO WRITE RING. C CALL CNUMD(TAPE,NUM) CALL SMOVE(NUM,1,6,ERR1,10) CALL REIO(2,LU1,ERR1,17) IERR=-230 CALL DBER2(LU1,IERR,6HXXXXXX,6HRING ,2HXX) RETURN END  4: 92069-18205 2013 S C0122 &CKTHD              H0101 ~}FTN4 SUBROUTINE CKTHD(LU1,HDR,BUFR,IERR) +,92069-16205 REV.2013 790418 C C C***************************************************************** C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. C NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR C TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR C WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. C****************************************************************** C C C SOURCE: 92069-18205 C RELOC: 92069-16205 C C C****************************************************************: C C C****************************************************** C CKTHD CHECKS THAT THE HEADER INFO THE USER ENTERED INTO HDR C CORRESPONDS TO THE HDR INFO OFF THE TAPE AS STORED IN BUFR. C******************************************************** INTEGER LU1,HDR(1),BUFR(1),IERR DOUBLE PRECISION REEL1,REEL2 C*************************************************** C SEE IF ITS OK. C CALL COMP(LU1,HDR,BUFR,19,IERR) IF (IERR .GE. 0) GO TO 9500 C********************************************************** C BRANCH ACCORDING TO WHERE THE WORDS DON'T MATCH. C IERR2=-IERR IF (IERR2 .LT. 8) GO TO 9000 IF (IERR2 .LE. 11) GO TO 9010 IF (IERR2 .EQ. 12) CALL DBER2(LU1,7777,6HXXXXXX,6HCKTHD ,2HAB) IF (IERR2 .EQ. 13) GO TO 9017 IF (IERR2 .EQ. 14) GO TO 9019 IF (IERR2 .LE. 19) GO TO 9020 CALL DBER2(LU1,7777,6HXXXXXX,6HCKTHD ,2HAB) C************************************************* C************************************************ C ERROR HANDLING POINTS. C C*********************************************************** C TAPE NOT SAVED BY PROPER PROGRAM. C 9000 CONTINUE CALL REIO(2,LU1,40H TAPE POSITIONED WRONG OR NOT SAVED BY _,20) CALL REIO(2,LU1,HDR,4) IERR=-212 CALL DBER2(LU1,IERR,6HXXXXXX,6HCKTHD ,2HXX) RETURN C*********************************************** C ROOT N  AMRS DON'T AGREE. C 9010 CALL REIO(2,LU1,27H INCORRECT ROOT FILE NAME._,-27) IERR=-243 CALL DBER2(LU1,IERR,6HXXXXXX,6HCKTHD ,2HXX) RETURN C**************************************************** C BAD SECURITY CODE. C 9017 CONTINUE CALL REIO(2,LU1,19H BAD SECURITY CODE.,-19) IERR=-213 CALL DBER2(LU1,IERR,6HXXXXXX,6HCKTHD ,2HXX) RETURN C***************************************************** C BAD CARTRIDGE. C 9019 CONTINUE CALL REIO(2,LU1,15H BAD CARTRIDGE.,-15) IERR=-244 CALL DBER2(LU1,IERR,6HXXXXXX,6HCKTHD ,2HXX) RETURN C********************************************** C LVLWD DOES NOT AGREE. 9020 CALL REIO(2,LU1,16H BAD LEVEL WORD.,8) IERR=-211 CALL DBER2(LU1,IERR,6HXXXXXX,6HCKTHD ,2HXX) RETURN C************************************************************ C CHECK ITS THE RIGHT REEL NUMBER. C 9500 CONTINUE IF (HDR(21) .EQ. BUFR(21)) GO TO 9900 CALL CNUMD(BUFR(21),REEL1) CALL REIO(2,LU1,31H YOU INCORRECTLY MOUNTED REEL _,-31) CALL REIO(2,LU1,REEL1,3) IERR=-242 CALL DBER2(LU1,IERR,6HXXXXXX,6HCKTHD ,2HXX) RETURN C******************************************************* C EVERYTHING IS FINE. BUMP THE HEADER FOR THE NEXT REEL. C 9900 HDR(21)=HDR(21)+1 RETURN END  5< 92069-18206 2013 S C0122 &CKFHD              H0101 oFTN4 SUBROUTINE CKFHD(LU1,TAPE,BUFR,BUFSZ,NAMR,ISIZE,JREC,ITYPE,IERR) +,92069-16206 REV.2013 790511 C C C***************************************************************** C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. C NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR C TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR C WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. C****************************************************************** C C C SOURCE: 92069-18206 C RELOC: 92069-16206 C C C****************************************************************: C C C**************************************************** C CKFHD DOES THE FOLLOWING: C 1) READS ONE RECORD FROM TAPE. C 2) VERIFIES THAT ITS A FILEHEAD. C 3) IF NOT, GIVES NEGATIVE ERROR RETURN. C 4) IF SO,PUTS INFORMATION INTO NAMR,ISIZE,JREC,AND ITYPE AND RETURNS. C**************************************************** INTEGER LU1,TAPE,BUFR(1),BUFSZ,NAMR(1),ISIZE(1),JREC,ITYPE,IERR LOGICAL EOF COMPLEX S(6) DATA S/8HFILEHEAD,8H21XX ,4*8H / C**************************************************************** C CALL TAPER(LU1,TAPE,BUFR,BUFSZ,LEN,EOF,IERR) IF (IERR .LT. 0) RETURN C********************************************************* C MAKE SURE THE BUFR JUST READ CONTAINS A FILEHEAD. C CALL COMP(LU1,BUFR,S,8,IERR) IF (IERR .LT. 0) GO TO 9000 C********************************************************** C HAVE A VALID FILEHEAD, TRANSFER DATA FROM BUFR INTO PARAMETERS C PASSED IN AND RETURN. C DO 10 J=1,6 NAMR(J)=BUFR(J+8) 10 CONTINUE JREC=BUFR(19) ITYPE=BUFR(20) ISIZE(1)=BUFR(21) ISIZE(2)=BUFR(22) IERR=0 RETURN C************************************************************ C ERROR: THIS IS NOT A FILEHEAD. WRITE MESSAGE AND LEAVE C NEGATIVE ERROR AND RETURN. C 9000 CONTINUE CALL REIO(2,LU1,18H BAD HEADER Rb  ECORD,-18) IERR=-7777 CALL DBER2(LU1,IERR,6HXXXXXX,6HCKFHD ,2HXX) RETURN END l&  6= 92069-18207 2013 S C0122 &CKDHD              H0101 mFTN4 SUBROUTINE CKDHD(LU1,NAMR,BLKNO,BUFR,IERR) +,92069-16207 REV.2013 790511 C C C***************************************************************** C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. C NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR C TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR C WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. C****************************************************************** C C C SOURCE: 92069-18207 C RELOC: 92069-16207 C C C****************************************************************: C C C****************************************************** C CKDHD CHECKS THAT THE FIRST 24 WORDS OF BUFR CORRESPOND TO C A VALID DATA HEAD. C****************************************************** INTEGER LU1,NAMR(1),BLKNO,BUFR(1),IERR COMPLEX S(6) DATA S/8HDATAHEAD,8H21XX ,4*8H / C*********************************************************** C WRITE OUT MESSAGE AND CHECK DATA HEAD. C CALL COMP(LU1,BUFR,S,8,IERR) IF (IERR .LT. 0) GO TO 9000 IERR=0 RETURN C************************************************************ C BAD DATA HEAD. LEAVE NEGATIVE IERR AND RETURN. C 9000 CONTINUE CALL REIO(2,LU1,19H BAD HEADER RECORD.,-19) IERR=-7777 CALL DBER2(LU1,IERR,NAMR,6HCKDHD ,2HXX) RETURN END  7= 92069-18208 2013 S C0122 &FLHD2              H0101 ~bFTN4 SUBROUTINE FLHD2(LU1,TAPE,NAME,FILENO,JREC,ENTRY,IERR) +,92069-16208 REV.2013 790413 C C C***************************************************************** C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. C NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR C TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR C WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. C****************************************************************** C C C SOURCE: 92069-18208 C RELOC: 92069-16208 C C C****************************************************************: C C C************************************************************** C FLHD2 WRITES A 24-WORD FILEHEAD TO TAPE. (REFER TO THE IMS FOR C DBULD FOR THE FORMAT OF THE HEADER). C************************************************************** INTEGER LU1,TAPE,NAME(1),FILENO,JREC,ENTRY(1),IERR COMPLEX STRING(6) INTEGER S(24) EQUIVALENCE(S,STRING) DATA STRING/8HFILEHEAD,8H21XX ,4*8H / C***************************************************************** C TRANSFER DATA FROM PARAMETERS INTO S C S(9)=NAME(1) S(10)=NAME(2) S(11)=NAME(3) S(17)=FILENO S(19)=JREC S(21)=ENTRY(1) S(22)=ENTRY(2) S(24)=2H** C****************************************************************** C WRITE THE FILEHEAD TO TAPE. C CALL TAPEW(LU1,TAPE,S,24,IERR) IF (IERR .NE. 0) RETURN RETURN END N# 8> 92069-18209 2013 S C0122 &DTHD2              H0101 `FTN4 SUBROUTINE DTHD2(LU1,NAME,BUFR,BUFSZ,HDEND,IERR) +,92069-16209 REV.2013 790413 C C C***************************************************************** C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. C NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR C TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR C WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. C****************************************************************** C C C SOURCE: 92069-18209 C RELOC: 92069-16209 C C C****************************************************************: C C C*************************************************************** C DTHD2 SETS UP A 24-WORD DATA HEADER IN BUFR.(REFER TO THE IMS C FOR THE FORMAT OF THE DATA HEADER). C C NAME= NAME OF DATA SET YOU'RE WRITING. C BUFR = THE BUFR TO PUT THE HEADER IN. C HDEND= THE LENGTH OF THE HEADER(RETURNED). C**************************************************************** INTEGER LU1,NAME(1),BUFR(1),BUFSZ,HDEND,IERR INTEGER S(24) COMPLEX STRING(6) EQUIVALENCE (STRING,S) DATA STRING/8HDATAHEAD,8H21XX ,4*8H / C******************************************************************* C PRELIMINARY CHECK THAT BUFR IS LARGE ENOUGH C HDEND=24 IF (HDEND .GT. BUFSZ) CALL DBER2(LU1,7777,NAME,6HDTHD2 ,6HDBUL9 ) C****************************************************************** C INIT BUFR TO S C DO 10 J=1,HDEND BUFR(J)=S(J) 10 CONTINUE C****************************************************************** C PUT PARAMETER VALUES INTO BUFR. C BUFR(9)=NAME(1) BUFR(10)=NAME(2) BUFR(11)=NAME(3) BUFR(24)=2H** RETURN END  9? 92069-18210 2013 S C0122 &LEVEL              H0101 pFTN4 SUBROUTINE LEVEL(LU1,DCB1,ROOT,BUF1,LVLWD,IERR) +,92069-16210 REV.2013 790322 C C C***************************************************************** C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. C NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR C TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR C WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. C****************************************************************** C C C SOURCE: 92069-18210 C RELOC: 92069-16210 C C C****************************************************************: C C C************************************************* C LEVEL RETURNS 0 IN IERR IF THE LEVEL WORD IN THE ROOT FILE NAMR C EQUALS THE LEVEL WORD IN LVLWD. OTHERWISE, LEVEL RETURNS -211 C IN IERR. C C START= THE NUMBER OF THE FIRST RECORD IN THE ROOT FILE C PAST THE OVERHEAD RECORDS. C DBLFG= OFFSET FROM START WHERE LEVEL FLAG IS LOCATED. C DBLVL= OFFSET FROM START WHERE FIRST LEVEL WORD SITS. C****************************************************** INTEGER LU1,DCB1(1),ROOT(1),BUF1(1),LVLWD(1),IERR INTEGER DBLFG,THREE,DBLVL INTEGER START INTEGER BLANK(3) DATA DBLFG/14/,THREE/3/,DBLVL/15/ DATA BLANK/2H ,2H ,2H / C******************************************************* C FIND RECORD NUMBER OF START. C CALL EREAD(DCB1,IERR,BUF1,256,LEN,DBLEI(1)) CALL DBER2(LU1,IERR,ROOT,6HLEVEL ,2HXX) IF (IERR .LT. 0) RETURN START=BUF1 C******************************************************** C RETURN IERR = 0 IF NO LEVEL WORDS DEFINED IN SCHEMA. C CALL EREAD(DCB1,IERR,BUF1,256,LEN,DBLEI(START)) CALL DBER2(LU1,IERR,ROOT,6HLEVEL ,2HXX) IF (IERR .LT. 0) RETURN IF (BUF1(DBLFG) .EQ. -1) GO TO 9999 C******************************************************** C GET THE INDEX OF HIGHEST LEVEL WORD INTO J C DO 10 J=14,0,-1 IHIGH = DBLVL+THREE*J CALL COM  P(LU1,BLANK,BUF1(IHIGH),3,IERR) IF (IERR .LT. 0) GO TO 9000 10 CONTINUE C******************************************************** C INDEX OF HIGHEST LEVEL WORD IS IN J. COMPARE WITH LVLWD. C 9000 CONTINUE CALL COMP(LU1,LVLWD,BUF1(IHIGH),3,IERR) IF (IERR .EQ. 0) GO TO 9999 IERR=-211 CALL REIO(2,LU1,16H BAD LEVEL WORD.,-16) CALL DBER2(LU1,IERR,6HXXXXXX,6HLEVEL ,2HXX) RETURN C******************************************************** C LEVEL WORD IS GOOD. C 9999 IERR=0 RETURN END f  :A 92069-18211 2013 S C0122 >PRN              H0101 FTN4 SUBROUTINE GTPRN(LU,LU1,TAPE,ROOT,LVLWD,P5,STRING,LENGTH,IERR) +,92069-16211 REV.2013 790203 C C C***************************************************************** C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. C NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR C TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR C WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. C****************************************************************** C C C SOURCE: 92069-18211 C RELOC: 92069-18211 C C C****************************************************************: C C C****************************************************** C C GTPRN IS USED BY DBSTR AND DBULD TO GET THE RUN TIME C PARAMETERS. THE ONLY DIFFERENCE BETWEEN GTPRN AND GTPRM C IS IN HOW THEY PROMPT FOR THE FIFTH PARAMETER. (2-1-79) C GTPRN PASSES THE STORAGE PARAMETER INFO INTO CKP50 SO THAT C CKP50 CAN ASK THE PROPER QUESTIONS ABOUT WHAT TO DO AT END C OF TAPE OR END OF FILE, AND WHETHER TO OVERWRITE THE STORAGE C FILE IF THE SAVE IS TO A FILE. C C GTPRN RETURNS FIVE PARAMETERS TO THE CALLING PROCEDURE, C ONE EACH IN EACH OF ITS FORMAL PARAMETER POSITIONS. IT ASSUMES C THAT EACH ACTUAL PARAMETER IS A 6-WORD ARRAY AND RETURNS THE C PARAMETER IN THE FOLLOWING FORMAT: C 1. INTEGER VALUE OR FIRST TWO CHARACTERS C 2. 0 OR SECOND TWO CHARACTERS. C 3. 0 OR THIRD TWO CHARACTERS. C 4. TYPE OF PARAMETER (0=NONE,1=INTEGER,3=NAMR) C 5. INTEGER SECURITY CODE, IF NAMR PARAMETER. C 6. INTEGER CARTRIDGE REFERENCE NUMBER, IF NAMR PARAMETER. C********************************************************** INTEGER LU,LU1(1),TAPE(1),ROOT(1),LVLWD(1),P5(1) INTEGER STRING(1),LENGTH,IERR INTEGER DFLT C*********************************************************** C GET THE CONSOLE LU INTO INTO LU1. C SUBROUTINE PRAM RETURNS SUCCESSIVE PARAMETERS ACCORDING TO C THE FORMAT DESCRIBED ABOVE. C USE THE SCHEDULING LU TO LOG ERROR MESSAGES HERE.   ISTRC=1 LNGTH2=2*LENGTH CALL PRAM(LU,STRING,LNGTH2,ISTRC,LU1) DFLT=LU CALL CKLU1(LU,LU1,DFLT,IERR) IF (IERR .LT. 0) RETURN C************************************************************* C GET THE LU OR NAMR OF THE BACKUP DEVICE. C FROM HERE ON, USE LU1 AS THE CONSOLE LU. CALL PRAM(LU1,STRING,LNGTH2,ISTRC,TAPE) DFLT=8 CALL CKLU8(LU1,TAPE,DFLT,IERR) IF (IERR .LT. 0) RETURN C************************************************************* C GET THE ROOT FILE NAMR. CALL PRAM(LU1,STRING,LNGTH2,ISTRC,ROOT) CALL CKROO(LU1,ROOT,IERR) IF (IERR .LT. 0) RETURN C************************************************************ C GET THE LEVEL WORD. CALL PRAM(LU1,STRING,LNGTH2,ISTRC,LVLWD) CALL CKLVL(LU1,LVLWD,IERR) IF (IERR .LT. 0) RETURN C************************************************************ C GET THE FIFTH PARAMETER CALL PRAM(LU1,STRING,LNGTH2,ISTRC,P5) CALL CKP50(LU1,P5,TAPE,IERR) IF (IERR .LT. 0) RETURN C*********************************************************** C RETURN AND END C IERR=0 RETURN END ]|  ;B 92069-18212 2013 S C0122 &CKP50              H0101 hfFTN4 SUBROUTINE CKP50(LU1,P5,TAPE,IERR) +,92069-16212 REV.2013 790316 C C C***************************************************************** C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. C NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR C TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR C WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. C****************************************************************** C C C SOURCE: 92069-18212 C RELOC: 92069-18212 C C C****************************************************************: C C C************************************************************** C CKP50 CHECKS PARAMETER 5, THE ABORT WORD. C 2-5-79 P5(2) IS SET PERMANENTLY TO CO BY THIS ROUTINE NOW, SO C THAT NWFIL WILL ALWAYS OVERWRITE THE STORAGE FILE. C C IF NO PARAMETER WAS PASSED IN, C CKP50 QUERIES THE USER AT CONSOLE LU, READS IN THE ABORT C RESPONSE, AND SETS UP P5 ACCORDINGLY. C*************************************************************** INTEGER LU1,P5(1),TAPE(1),IERR INTEGER TEMP INTEGER IA(2) EQUIVALENCE(REG,IA),(IA(2),IB) C*************************************************************** C IF THE TYPE IS ASCII, NORMAL RETURN. ELSE RETURN ERROR. C 5 CONTINUE IERR = 0 ITYPE = P5(4) IF (ITYPE .EQ. 0) GO TO 10 IF (ITYPE .EQ. 1) GO TO 20 IF (ITYPE .EQ. 3) GO TO 30 C************************************************************ C PROCESS INTERNAL ERROR. C CALL DBER2(LU1,7777,6HXXXXXX,6HCKP50 ,2HAB) C************************************************************* C PROCESS NO PARAMETER BY PROMPTING THE USER AT THE CONSOLE LU. C READ THE PARAMETER, THEN BUILD P5 ACCORDINGLY. C C 10 CONTINUE P5(2)=2HCO P5(3)=2H P5(4)=3 P5(5)=2H P5(6)=2H C CALL REIO(2,LU1,41H ABORT AT END OF STORAGE DEVICE(YES/NO)?_,-41) REG = REIO(1,LU1+400B,TEMP,1) IF ((TEMP .NE. 2HYE) .AN  D. (TEMP .NE. 2HNO)) GO TO 10 P5=2HCO IF (TEMP .EQ. 2HYE) P5=2HAB RETURN C************************************************************* C PROCESS AN INTEGER PARAMETER AS AN ERROR. C 20 CONTINUE CALL REIO(2,LU1,20H ILLEGAL ABORT WORD.,-20) IERR=-248 CALL DBER2(LU1,IERR,6HXXXXXX,6HCKP50 ,2HXX) RETURN C************************************************************* C CHECK AN ASCII PARAMETER FOR LEGALITY. C 30 CONTINUE IF ((P5 .NE. 2HAB) .AND. (P5 .NE. 2HCO)) GO TO 20 P5(2)=2HCO RETURN END +  <C 92069-18213 1912 S C0122 &SIZE SIZE SOURCE             H0101 oLASMB NAM SIZE,7 92069-16210 REV.1912 031579 * * ****************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS RESERVED * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WIOTH OUT THE PRIOR * WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18210 * RELOC: 92069-16210 * * *****************************************************************: * * * * * ENT SIZE EXT .ENTR * * * * * NREC NOP RECLN NOP IERR NOP SIZE NOP JSB .ENTR DEF NREC * LDA NREC,I DO LONG HAND DIVISION CREATING A 3 WORD RESULT MPY RECLN,I MULTIPLY THE HIGH ORDER WORD DST TEMP TEMP+1 = UPPER, TEMP = MIDDLE1 * ISZ NREC ADVANCE TO SECOND HALF OF NREC * LDA NREC,I MULTIPLY LOWER HALF OF NREC MPY RECLN,I B = MIDDLE2, A = LOWER * SSB IF BIT15 OF NREC(2) IS SET THEN TURN THE RESULT ADB RECLN,I BACK INTO A UNSIGNED INTEGER. * CLE ADD THE MIDDLE TWO VALUES PROPAGATING THE OVERFLOW ADB TEMP TO THE THIRD OR UPPER WORD. STB TEMP * SEZ PROPAGATE THE OVERFLOW ISZ TEMP+1 * * * THE OVERFLOW IS DONE, LEAVING THE THREE WORD RESULT * IN THE FOLLOWING MEMORY LOCATIONS: * TEMP+1, B, A * AND ALSO IN: * TEMP+1, TEMP, A * * * LSR 7 DIVID BY 128 STA RES SAVE THE LOWER WORD DLD TEMP PICK UP THE HIGH AND MIDDLE WORD LSR 7 * ASL 16 CHECK FOR OVERFLOW RESULT AFTER DIVID CLA SET THE ERROR INDICATOR SOC CCA STA IERR,I * LDA B LDB RES * JMP SIZE,I RES NOP TEB  MP BSS 2 A EQU 0 B EQU 1 END  =D 92069-18215 2040 S C0122 &DBHD2 &DBHD2 %RDBA HEADER             H0101 tASMB HED HEADER FOR %RDBA NAM RDBA,7 92069-12003 REV.2040 800730 * * ******************************************************************* * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR WRITTEN * CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18215 * RELOC: 92069-16215 * * PRGMR: CEJ * * ******************************************************************* * * END } >D 92069-18216 2040 S C0122 &RBOPN &RBDPN REMOTE DBOPN             H0101 ASMB,L,C,R HED RBOPN SUBROUTINE OF RDBA-IMAGE/1000 NAM RBOPN,7 92069-16216 REV.2040 800630 * * ******************************************************************* * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR WRITTEN * CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18216 * RELOC: 92069-16216 * * PRGMR: CEJ * ALTERED: June 30, 1980 for bug in clean-up after remote data * base opened. - CEJ * * ******************************************************************* * * * * RBOPN is the remote data base DBOPN routine. Its function is to check * the validity of the DBOPN request, send the request, and build the * RDBA data structures necessary for future remote accesses. These data * structures consist of: * 1) Data Base Control Block - * a shortened version of the local DBCB with a modified item * table and data set table sent from the remote machine. * 2) Data Buffer * for sending and receiving data, same structure as used as the * record buffer for local DBMS calls. * * The calling sequence for RBOPN is: * * JSB RBOPN * DEF *+5 return point * DEF BASE data base parameter from DBOPN call. * DEF LEVEL level code word from DBOPN call. * DEF MODE mode parameter from DBOPN call * DEF STAT status array from DBOPN call * SKP ********************************************************************** * * * Run Table for local machine in Remote Data Base Access * * * * The loc׃al copy of the Run Table used by the RDBA master subrou- * * tines consists of the following sections: * * * * 1) Data Base Control Block * * 2) Data Item Table * * 3) Data Set Table * * 4) Sort Table * * * * These sections are in the order stated. Details of each section * * follow. * * * ********************************************************************** *** *** * * * Data Base Control Block - one 17 word entry per data base * * * *** *** RDCBS DEC 17 DBCB size * RDNAM DEC 0 data base name - three words DEC 1 DEC 2 RDRBN DEC 3 remote data base number DEC 4 RDDSN DEC 5 DS node number DEC 6 RDITC DEC 7 data item count RDITP DEC 8 data item table pointer RDDSC DEC 9 data set count RDDSP DEC 10 data set table pointer RDSOP DEC 11 sort table pointer DEC 12 RDLMD DEC 13 lock flag/open mode RDLFG EQU RDLMD 1st byte: lock flag RDMOD EQU RDLMD 2nd byte: open mode DEC 14 RDCBC DEC 15 # of DCBs desired = 0 RDMDL DEC 16 maximum data length * ZERO EQU RDNAM base of zero for future equates. *** *** * - * * Data Item Table - one 5 word entry per item in a 1000 data base * * * *** *** RI1LN EQU ZERO+5 length of a 1000 entry * RI1NM EQU ZERO item name - 3 words RI1NO EQU ZERO+3 item number RI1IL EQU ZERO+4 item length *** *** * * * Data Set Table - one 6 word entry per set in a 1000 data base * * * *** *** RS1LN EQU ZERO+6 length of a 1000 entry * RS1NM EQU ZERO set name - 3 words RS1NO EQU ZERO+3 set number RS1EL EQU ZERO+4 entry length (in words) RS1KL EQU ZERO+5 key item length for a master *** *** * * * Sort Table - one 1 word entry per item and per set. Each entry * * is a pointer to the respective item or set table * * entry relative to the start of the Run Table * * * *** *** SKP A EQU 0 B EQU 1 * ENT RBOPN EXT .ENTR,AIRUN,DBFRT,DBPAR,DBRBL,DBRBP,DBRTP,GETBF EXT PNAME,RBBST,RBMST,RETBF,TRIM * BASE NOP LEVEL NOP MODE NOP STAT NOP * * Get true parameter and return point addresses. * RBOPN NOP JSB .ENTR DEF BASE * * Ask DBPAR to break the BASE parameter into its components. * JSB DBPAR DEF *+3 DEF NAME DEF BASE,I JMP E103 Error return - illegal base param. * * Ask DBFRT to makeׯ sure that the data base is not already open to us * and if not, to give us the index for the next open entry in the Run * Table pointer table. * CLA A = 0 tells DBFRT we are DBOPN JSB DBFRT DEF *+4 DEF BASE,I DEF NAME DEF CRN * SSA,RSS Did DBFRT find the R.T.? JMP E150 Yes - cannot open it again. * LDA AIRUN No - get index from AIRUN STA DBNUM and save for later. CLA STA AIRUN * * Make sure open mode is within [1...8]. * LDA MODE,I SSA JMP E115 Mode < zero. CMA,INA INA,SZA,RSS JMP ROPN1 Mode = 1 ADA D7 SSA JMP E115 Mode > 8. * * Set maximum size of Run Table to 1899 words. * ROPN1 LDB D1899 STB MAXRT * * Ask GETBF to allocate a maximum Run Table for us. If it cannot, then * check the maximum size it has (returned in the error parameter as a * negative number). If this value is greater than 100, set MAXRT to it * and ask GETBF to allocate it for us. * CCB ADB DBRTP Get primary pointer ADB DBNUM for Run Table. STB RTPTR * JSB GETBF DEF *+4 DEF MAXRT GETBF needs: size DEF RTPTR,I primary pointer DEF ERROR returns: 0 or -(memory available) * SSA,RSS Did we get the max? JMP ROPN2 Yes * LDA ERROR No ADA D100 Is there more than 100 words? SSA,RSS JMP E128 No - memory error. * LDA ERROR Yes - allocate all the CMA,INA memory that is left. STA MAXRT * JSB GETBF DEF *+4 DEF MAXRT DEF RTPTR,I DEF ERROR * SSA Did we get it? JMP E160 No - someone's walked on our memory. * * Save the address of the Run Table pointer in case of a later cleanup. * ROPN2 LDB RTPTR,I STB AIRUN * * Build as much of the 17 word DBCB as possible with the information we * now have. This includes: * 1) the data base name in the 1st through 3rd words. * LDA NAME STA B,I INB LDA NAME+1 STA B,I INB LDA NAME+2 STA B,I * * 2) the remote data base number = two blanks in the 4th word. * INB LDA BLNKS STA B,I * * 3) the DS node number in the 6th word. * ADB D2 LDA BASE,I STA B,I * * 4) the lock flag/open mode in the 14th word. * ADB D8 LDA MODE,I STA B,I * * 5) the number of DCB's (= zero) in the 16th word. * ADB D2 CLA STA B,I * * Determine the address for the item and set tables returned by the re- * mote DBOPN processor. This is: address of allocated Run Table + * length of DBCB. * LDB AIRUN ADB RDCBS STB ADDRS * * Determine the length of the maximum item and set tables to return to * us. This is: length of allocated Run Table - length of DBCB. * LDB RDCBS CMB,INB ADB MAXRT STB INDA * * Get this program's name. This is the only data sent with a DBOPN re- * quest. The PNAME subroutine returns our name in the array: NAME. * JSB PNAME DEF *+2 DEF NAME * * Ask RBMST to build the request buffer, send it, and await the reply. * JSB RBMST DEF *+11 DEF D36 RBMST needs: RDBA Index DEF MODE,I open mode DEF LEVEL,I level word (or password) DEF TEMP dummy, returns remote DB # here DEF BASE,I data base parameter DEF STAT,I status array DEF NAME outgoing data buffer DEF D3 outgoing data length DEF ADDRS,I incoming data buffer DEF INDA  incoming data length JMP RCLN2 error return point * * The B register has the length of the returned data, save it in INDA. * STB INDA * * No DS error, but check for an IMAGE error code in the first word of * the status array. * LDA STAT,I SZA JMP RCLN2 * * Set the remote data base number, item count, item table pointer, set * count, and set table pointer in the DBCB. We can get the latter in- * formation from the returned data which looks like: * * word +-------------------------------+ * 1 | item count | * +-------------------------------+ * 2 | | * | item | * | table | * | | * +-------------------------------+ * item count * item table | set count | * entry length + 1 +-------------------------------+ * | | * | set | * | table | * | | * +-------------------------------+ * * The remote data base number is th 4th word of the DBCB and is re- * turned by RBMST in TEMP. * LDB AIRUN ADB RDRBN LDA TEMP STA B,I * * The item count is the 8th word of the DBCB * ADB D4 LDA ADDRS,I STA B,I * * The item table pointer is the 9th word of the DBCB and is equal to * RDCBS + 1 * INB LDA RDCBS INA STA B,I * * The set count is the 10th word of the DBCB and can be found in the * (item count * item table entry length) P+ 1 word of the returned data * and where the entry length is 5. * INB STB TEMP * LDA ADDRS,I CLB MPY RI1LN INA STA CNTR CNTR = index to set count in data * ADA ADDRS STA ADDRS LDA A,I STA TEMP,I * * The set table pointer is the 11th word of the DBCB and is equal to the * index to the set count in data + 1 + length of DBCB. * ISZ TEMP LDA CNTR INA ADA RDCBS STA TEMP,I * * Determine the amount of memory we need to build the sort table. This * is (# of items + # of sets) words. * LDB AIRUN ADB RDITC LDA B,I ADB D2 ADA B,I STA TEMP * * Determine how much memory we've already used. This value is equal to * the length of the returned data + length of the DBCB. * LDA INDA ADA RDCBS * * This value is also the sort table pointer, so put it in the 12th word * of the DBCB. * LDB AIRUN ADB RDSOP STA B,I * * Subtract the already used memory from the Run Table space allocated * and check that the remaining space is large enough for the sort table. * CMA,INA ADA MAXRT CMA ADA TEMP LDB D128 SSA,RSS JMP RCLN1 Not large enough. * * The necessary space is there. Ask RBBST to build the sort table for us * and to return to us the longest entry of any data set in the data base. * ROPN3 JSB RBBST DEF *+2 DEF CNTR * * Add the number of data items or 127, whichever is smaller + 2 (longest * item list) to the longest entry length and this becomes the necessary * data (record) buffer length. Put it in the 17th word of the DBCB. * LDA AIRUN ADA RDITC LDB A,I CMB ADB D127 LDA A,I SSB LDA D127 ADA D2 ADA CNTR STA CNTR LDB AIRUN ADB RDMDL STA B,I * * See if we can tXrim any memory off of our Run Table. The length of the * full Run Table can now be calculated as: * pointer to sort table + length of sort table (= # of items + # of sets). * Get this length and call TRIM to trim off all allocated memory except for * this length. * LDB AIRUN ADB RDITC LDA B,I ADB D2 ADA B,I ADB D2 ADA B,I STA MAXRT * JSB TRIM DEF *+3 DEF RTPTR,I TRIM needs: primary pointer to buffer DEF MAXRT length of buffer to keep * LDB D160 If any error, someone's SSA walked on our memory. JMP RCLN1 * * Now, see if there is a data (record) buffer already allocated. If so, * see if it is large enough for this data base. If so, we are done, re- * turn to the user. If not, deallocate the current buffer (if one) and * try to allocated a new one. If this words, we are once again finished. * If not, we need to undo everything and return unsuccessful to the user. * LDB DBRBL DBRBL = length of allocated data buffer. STB SAVE SZB,RSS If its zero, JMP ROPN4 branch around deallocation. * CMB ADB CNTR If its >= size we need, SSB JMP ROPN6 successful open. * JSB RETBF Else, deallocate it. DEF *+2 DEF DBRBP * LDB D160 If any error, SSA someone's walked on our memory. JMP RCLN1 * CLA STA DBRBL * ROPN4 JSB GETBF Try to allocate new buffer. DEF *+4 DEF CNTR DEF DBRBP DEF ERROR * LDB D128 SSA If any error, JMP RCLNP then return proper error code. * ROPN5 LDB CNTR Else set buffer size to STB DBRBL size of new buffer. * * All went well, put the data base number in the ibase parameter and re- * turn to the user. * ROPN6 LDB DBNUM STB BASE,I * ROPN7 JMP RBOPN,I * * Error return points. * E103 LDB D103 Illegal base parameter. RSS E115 LDB D115 Illegal open mode. RSS E128 LDB D128 Not enough memory. RSS E150 LDB D150 Data base already open error RSS E160 LDB D160 Bad memory error. * ROPN8 STB STAT,I JMP ROPN7 SKP * * The following is the cleanup routine for RBOPN. There are three dif- * ferent entry points. These are: 1) RCLNP - record buffer has possibly * been altered. 2) RCLN1 - the remote DBOPN has succeeded. 3) RCLN3 - * the Run Table has been allocated. Each entry point presupposes the * cleanup for the next. When entered at RCLNP or RCLN1, the B register * has the proper error code. * * RCLNP is the first entry point. Put error code in status array. Then * compare SAVE and DBRBL to see if data (record) buffer has been altered. * RCLNP STB STAT,I * LDB DBRBL Are new and old CPB SAVE lengths the same? JMP CLN11 Yes - no cleanup needed. * SZB,RSS No - is new length = 0? JMP CLNP1 Yes - no deallocation. * JSB RETBF No - deallocate new buffer. DEF *+2 DEF DBRBP Ignore any errors. * CLNP1 LDB SAVE Is old record buffer SZB,RSS size = zero? JMP CLNP2 Yes - no allocation. * JSB GETBF No - allocate the same DEF *+4 size data buffer. DEF SAVE DEF DBRBP DEF ERROR * CLB If any error, SSA,RSS set buffer size to zero LDB SAVE else set to old size CLNP2 STB DBRBL JMP CLN11 * * RCLN1 is the second entry point. Put error code in status array. * * Update AIRUN in case a RETBF, GETBF sequence altered the location * of the Run Table. Then, send a remote DBCLS request. * RCLN1 STB STAT,I * CLN11 LDA RTPTR,I STA AIRUN * JSB RBMST A<:6 DEF *+11 DEF D38 RBMST needs: RDBA Index DEF D1 close mode DEF D0 data set number DEF D0 dummy DEF BASE,I data base parameter DEF NAME status array DEF D0 outgoing data buffer DEF D0 outgoing data length DEF NAME incoming data buffer DEF D0 incoming data length NOP error return point * * RCLN2 is the third entry point. Error code is already in status array. * All there is left to do is deallocate the Run Table space. * RCLN2 JSB RETBF DEF *+2 DEF RTPTR,I * JMP ROPN7 SKP * * Constants and variables. * D0 EQU ZERO D1 EQU ZERO+1 D2 EQU ZERO+2 D3 EQU ZERO+3 D4 EQU ZERO+4 D5 EQU ZERO+5 D7 EQU ZERO+7 D8 EQU ZERO+8 D36 DEC 36 D38 DEC 38 D100 DEC 100 D103 DEC 103 D115 DEC 115 D127 DEC 127 D128 DEC 128 D150 DEC 150 D160 DEC 160 D1899 DEC 1899 * BLNKS ASC 1, * ADDRS NOP NAME BSS 3 } NOTE: Do not change the order CNTR NOP } is the 10 word array for CRN NOP } DBPAR call. DBNUM NOP } ERROR NOP } TEMP NOP } SAVE NOP } MAXRT NOP } * FLAG NOP RTPTR NOP INDA NOP END /< ?N 92069-18217 1912 S C0122 &RBINF RBINF SOURCE             H0101 bASMB,L,C,R HED RBINF SUBROUTINE OF RDBA-IMAGE/1000 NAM RBINF,7 92069-16217 REV.1912 790214 * * ******************************************************************* * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR WRITTEN * CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18217 * RELOC: 92069-16217 * * PRGMR: CEJ * * ******************************************************************* * * * * Remote DBINF processor. The following transforms the DBINF request * into an RDBA request and sends the request through RBMST to the remote * node. * * The calling sequence for RBINF is: * * JSB DBINF * DEF *+6 return point * DEF BASE data base parameter from DBINF call * DEF ID set or item parameter from DBINF call * DEF MODE mode from DBINF call * DEF STAT 10 word status array from DBINF call * DEF BUF buffer parameter from DBINF call * ********************************************************************** * * * Run Table for local machine in Remote Data Base Access * * * * The local copy of the Run Table used by the RDBA master subrou- * * tines consists of the following sections: * * * * 1) Data Base Control Block * * 2) Data Item Table * * 3) Data Set Table * * 4) Sort Table *c * * * These sections are in the order stated. Details of each section * * follow. * * * ********************************************************************** *** *** * * * Data Base Control Block - one 17 word entry per data base * * * *** *** RDCBS DEC 17 DBCB size * RDNAM DEC 0 data base name - three words DEC 1 DEC 2 RDRBN DEC 3 remote data base number DEC 4 RDDSN DEC 5 DS node number DEC 6 RDITC DEC 7 data item count RDITP DEC 8 data item table pointer RDDSC DEC 9 data set count RDDSP DEC 10 data set table pointer RDSOP DEC 11 sort table pointer DEC 12 RDLMD DEC 13 lock flag/open mode RDLFG EQU RDLMD 1st byte: lock flag RDMOD EQU RDLMD 2nd byte: open mode DEC 14 RDCBC DEC 15 # of DCBs desired = 0 RDMDL DEC 16 maximum data length * ZERO EQU RDNAM base of zero for future equates *** *** * * * Data Item Table - one 5 word entry per item in a 1000 data base * * * *** *** RI1LN EQU ZERO+5 length of a 1000 entry * RI1NM EQU ZERO item name - 3 words RI1NO EQU ZERO+3 item number RI1IL EQU ZERO+4 item length *** *** *  * * Data Set Table - one 6 word entry per set in a 1000 data base * * * *** *** RS1LN EQU ZERO+6 length of a 1000 entry * RS1NM EQU ZERO set name - 3 words RS1NO EQU ZERO+3 set number RS1EL EQU ZERO+4 entry length (in words) RS1KL EQU ZERO+5 key item length for a master *** *** * * * Sort Table - one 1 word entry per item and per set. Each entry * * is a pointer to the respective item or set table * * entry relative to the start of the Run Table * * * *** *** SKP A EQU 0 B EQU 1 * ENT RBINF EXT .ENTR,RBCIT,RBCST,RBMST * BASE NOP ID NOP MODE NOP STAT NOP BUF NOP * * Get true parameter and return point addresses. * RBINF NOP JSB .ENTR DEF BASE * * Case on the mode parameter (MODE) to determine what kind of information * the user requests and where to process the request. The case is per- * formed by dividing the mode parameter by 100 and checking the bounds * of the quotient and remainder. The quotient must be within [1..4], * the remainder within [1..4]. Then, use the two values as an index * into the jump table. Four entries in this table are actually error * returns since any combination of quotient within [3,4] and remainder * within [3,4] is invalid. * LDA MODE,I Is mode < 0 SSA JMP E124 Yes - illegal mode * CLB DIV D100 * SZA,RSS Is quotient > 0 JMP E124 CMA,INA ADA D4 and <= 4? SSA JMP E124 No - illegal mode. * SZB,RSS Is remainder > 0 JMP E124 CMB,INB ADB D4 and <= 4? SSB JMP E124 No - illegal mode. * * Put quotient into bits 2 & 3 of A register and remainder in bits 0 & 1. * This becomes, then a four bit index within [0..15] into the jump table. * The index number 0,1,4, and 5 are illegal. * ALS,ALS IOR B STA TEMP * ADA RJMTB JMP A,I * RJMTB DEF *+1 JMP E124 Mode = 404 JMP E124 Mode = 403 JMP RM2 Mode = 402 JMP RM2 Mode = 401 * JMP E124 Mode = 304 JMP E124 Mode = 303 JMP RM2 Mode = 302 JMP RM2 Mode = 301 * JMP RM1 Mode = 204 JMP RM4 Mode = 203 JMP RM2 Mode = 202 JMP RM2 Mode = 201 * JMP RM2 Mode = 104 JMP RM4 Mode = 103 JMP RM1 Mode = 102 JMP RM1 Mode = 101 SKP * * For all modes that branch here, the ID parameter is either a data item * name or a data item number. Ask RBCIT to check this item reference and * give us the item's number. * RM1 JSB RBCIT DEF *+4 DEF ID,I RBCIT needs: item reference DEF NUMBR returns: item number DEF ADDRS item's Item Table entry address JMP E125 Illegal item return point. * JMP RM4 Item okay. * * For all modes that branch here, the ID parameter is either a data set * name or number. Ask RBCST to check the set reference and give us the * set's number, if valid. * RM2 JSB RBCST DEF *+4 DEF ID,I RBCST needs: set reference DEF NUMBR returns: set's number DEF ADDRS set's Set Table entry address JMP E125 Illegal set return point * * All modes rejoin here. We do another case on the mode parameteor to * determine the maximum length of data we want returned to us. * RM4 LDA TEMP Saved calculated index in TEMP. ADA LNTAB LDB A,I * CLA STA OUTDA JMP RM5 * LNTAB DEF *+1 DEC 0 Mode = 404 DEC 0 Mode = 403 DEC 7 Mode = 402 DEC 7 Mode = 401 * DEC 0 Mode = 304 DEC 0 Mode = 303 DEC 2 Mode = 302 DEC 49 Mode = 301 * DEC 51 Mode = 204 DEC 51 Mode = 203 DEC 17 Mode = 202 DEC 1 Mode = 201 * DEC 128 Mode = 104 DEC 256 Mode = 103 DEC 13 Mode = 102 DEC 1 Mode = 101 * * There is one special case, however. If the mode is 402 (index = 2) * there is no returned data only outgoing data, so the integer we picked * up is the OUTDA size and INDA is zero. * RM5 LDA TEMP CPA D2 RSS JMP RM7 * STB OUTDA CLB * * Put the value in INDA and call RBMST to build the request, sent it, * and await the reply. * RM7 STB INDA * JSB RBMST DEF *+11 DEF D37 RBMST needs: RDBA Index DEF MODE,I Info mode DEF NUMBR set or item number DEF D0 dummy DEF BASE,I data base parameter DEF STAT,I status array DEF BUF,I outgoing data buffer DEF OUTDA outgoing data length DEF BUF,I incoming data buffer DEF INDA incoming data length NOP error return RM8 JMP RBINF,I normal return * * Error return points. * E124 LDB D124 Illegal DBINF mode. RSS * E125 LDB D125 Illegal item or set reference. * STB STAT,I Put error code in STAT JMP RM8 and return to user. * * Con$"stants and variables * D0 EQU ZERO D2 EQU ZERO+2 D4 EQU ZERO+4 D37 DEC 37 D100 DEC 100 D124 DEC 124 D125 DEC 125 * NUMBR NOP ADDRS NOP TEMP NOP * INDA NOP OUTDA NOP END v$ @ K 92069-18218 1912 S C0122 &RBFND RBFND SOURCE             H0101 ]ASMB,L,C,R HED RBFND SUBROUTINE OF RDBA-IMAGE/1000 NAM RBFND,7 92069-16218 REV.1912 790130 * * ******************************************************************* * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR WRITTEN * CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18218 * RELOC: 92069-16218 * * PRGMR: CEJ * * ******************************************************************* * * * * This is the remote DBFND call handler. Its function is to transform * the DBFND call into the remote request parameters, then send the re- * quest to the remote machine through RBMST. * * The calling sequence for RBFND is: * * JSB RBFND * DEF *+7 return point * DEF BASE data base parameter from DBFND call * DEF SET data set parameter from DBFND call * DEF MODE mode from DBFND call * DEF STAT status array from DBFND call * DEF ITEM data item parameter from DBFND call * DEF ARG key item value from DBFND call * ********************************************************************** * * * Run Table for local machine in Remote Data Base Access * * * * The local copy of the Run Table used by the RDBA master subrou- * * tines consists of the following sections: * * * * 1) Data Base Control Block * * 2) Data Item Table * * 3) Data Set Table 0 * * 4) Sort Table * * * * These sections are in the order stated. Details of each section * * follow. * * * ********************************************************************** *** *** * * * Data Base Control Block - one 17 word entry per data base * * * *** *** RDCBS DEC 17 DBCB size * RDNAM DEC 0 data base name - three words DEC 1 DEC 2 RDRBN DEC 3 remote data base number DEC 4 RDDSN DEC 5 DS node number DEC 6 RDITC DEC 7 data item count RDITP DEC 8 data item table pointer RDDSC DEC 9 data set count RDDSP DEC 10 data set table pointer RDSOP DEC 11 sort table pointer DEC 12 RDLMD DEC 13 lock flag/open mode RDLFG EQU RDLMD 1st byte: lock flag RDMOD EQU RDLMD 2nd byte: open mode DEC 14 RDCBC DEC 15 # of DCBs desired = 0 RDMDL DEC 16 maximum data length * ZERO EQU RDNAM base of zero for future equates *** *** * * * Data Item Table - one 5 word entry per item in a 1000 data base * * * *** *** RI1LN EQU ZERO+5 length of a 1000 entry * RI1NM EQU ZERO item name - 3 words RI1NO EQU ZERO+3 item number RI1IL EQU ZEJRO+4 item length *** *** * * * Data Set Table - one 6 word entry per set in a 1000 data base * * * *** *** RS1LN EQU ZERO+6 length of a 1000 entry * RS1NM EQU ZERO set name - 3 words RS1NO EQU ZERO+3 set number RS1EL EQU ZERO+4 entry length (in words) RS1KL EQU ZERO+5 key item length for a master *** *** * * * Sort Table - one 1 word entry per item and per set. Each entry * * is a pointer to the respective item or set table * * entry relative to the start of the Run Table * * * *** *** A EQU 0 B EQU 1 * ENT RBFND EXT .ENTR,AIRUN,RBCIT,RBCST,RBMST * BASE NOP SET NOP MODE NOP STAT NOP ITEM NOP ARG NOP * * Get true parameter and return point addresses. * RBFND NOP JSB .ENTR DEF BASE * * Ask RBCST to check the validity of the set reference and to return us * the set's number, if valid. * JSB RBCST DEF *+4 DEF SET,I RBCST needs: set reference DEF STNUM returns: set number DEF STADR set's Set Table entry address JMP E100 Invalid set return. * * Ask RBCIT to check the item reference and to return us the item's number * and Item Table entry address (relative to beginning of Run Table) if * valid. * JSB RBCIT DEF *+4 DEF ITEM,I RDCIT needs: item reference DEF ITNUM returns: item number DEF ITA-#DR item's Item Table entry address JMP E101 Invalid item return. * * Get the item's length from the 5th word of the item's Item Table entry * and store as the outgoing data length. * LDA ITADR ADA AIRUN ADA RI1IL LDA A,I STA OUTDA * * Check that the mode is valid (i.e. equal to 1). * LDA MODE,I CMA,INA INA,SZA JMP E115 * * Ask RBMST to prepare the request, send it, and receive the reply for us. * STA INDA Incoming data length is zero. * JSB RBMST DEF *+11 DEF D39 RBMST needs: RDBA Index DEF MODE,I DBFND mode DEF STNUM data set number DEF ITNUM data item number DEF BASE,I data base parameter DEF STAT,I status array DEF ARG,I outgoing data buffer DEF OUTDA outgoing data length DEF ARG,I incoming data buffer DEF INDA incoming data length NOP RFND1 JMP RBFND,I * * Error return points * E100 LDB D100 Invalid data set. RSS E101 LDB D101 Invalid item. RSS E115 LDB D115 Invalid mode * STB STAT,I JMP RFND1 * * Constants and variables. * D39 DEC 39 D100 DEC 100 D101 DEC 101 D115 DEC 115 * STNUM NOP STADR NOP ITNUM NOP ITADR NOP * OUTDA NOP INDA NOP END s AJ 92069-18219 1912 S C0122 &RBGET RBGET SOURCE             H0101 eASMB,L,C,R HED RBGET SUBROUTINE OF RDBA-IMAGE/1000 NAM RBGET,7 92069-16219 REV.1912 790130 * * ******************************************************************* * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR WRITTEN * CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18219 * RELOC: 92069-16219 * * PRGMR: CEJ * * ******************************************************************* * * * * This is the remote DBGET handler. Its function is to transform the * DBGET parameters into the RDBA request parameters and to send the re- * quest to the remote machine through RBMST. * * The calling sequence for RBGET is: * * JSB RBGET * DEF *+8 return point * DEF BASE data base parameter from DBGET call * DEF SET data set parameter from DBGET call * DEF MODE mode parameter from DBGET call * DEF STAT status array from DBGET call * DEF LIST item list from DBGET call * DEF BUF item value buffer from DBGET call * DEF ARG ARG parameter from DBGET call * ********************************************************************** * * * Run Table for local machine in Remote Data Base Access * * * * The local copy of the Run Table used by the RDBA master subrou- * * tines consists of the following sections: * * * * 1) Data Base Control Block * * 2) Data Item Table   * * 3) Data Set Table * * 4) Sort Table * * * * These sections are in the order stated. Details of each section * * follow. * * * ********************************************************************** *** *** * * * Data Base Control Block - one 17 word entry per data base * * * *** *** RDCBS DEC 17 DBCB size * RDNAM DEC 0 data base name - three words DEC 1 DEC 2 RDRBN DEC 3 remote data base number DEC 4 RDDSN DEC 5 DS node number DEC 6 RDITC DEC 7 data item count RDITP DEC 8 data item table pointer RDDSC DEC 9 data set count RDDSP DEC 10 data set table pointer RDSOP DEC 11 sort table pointer DEC 12 RDLMD DEC 13 lock flag/open mode RDLFG EQU RDLMD 1st byte: lock flag RDMOD EQU RDLMD 2nd byte: open mode DEC 14 RDCBC DEC 15 # of DCBs desired = 0 RDMDL DEC 16 maximum data length * ZERO EQU RDNAM base of zero for future equates *** *** * * * Data Item Table - one 5 word entry per item in a 1000 data base * * * *** *** RI1LN EQU ZERO+5 length of a 1000 entry * RI1NM EQU ZERO item name - 3 words RI1NO EQU ZERO+3 item number RI1IL EQU ZERO+4 item length *** *** * * * Data Set Table - one 6 word entry per set in a 1000 data base * * * *** *** RS1LN EQU ZERO+6 length of a 1000 entry * RS1NM EQU ZERO set name - 3 words RS1NO EQU ZERO+3 set number RS1EL EQU ZERO+4 entry length (in words) RS1KL EQU ZERO+5 key item length for a master *** *** * * * Sort Table - one 1 word entry per item and per set. Each entry * * is a pointer to the respective item or set table * * entry relative to the start of the Run Table * * * *** *** A EQU 0 B EQU 1 * ENT RBGET EXT .ENTR,.MVW,AIRUN,DBRBP,RBCST,RBMST,RBPIL * BASE NOP SET NOP MODE NOP STAT NOP LIST NOP BUF NOP ARG NOP * * Get true parameter and return point addresses. * RBGET NOP JSB .ENTR DEF BASE * * Make sure the Get mode is within [1..7]. * LDA MODE,I SZA,RSS Is mode > 0? JMP E115 SSA JMP E115 No - illegal mode * CMA,INA Is mode <= 7? ADA D7 SSA JMP E115 No - illegal mode. * * Ask RBCST to check the validity of the data set and to return us the * set's number and set table entry address (relative to beginning of the * Run Table) if valid. * JSB RBCST DEF *+4 DEF SET,I RBCST needs: set reference DEF DSNUM returns: set number DEF DSADR set's Set Table entry address JMP E100 Invalid set return. * * Ask RBPIL to process the item list the user gave us and to build an * item number list in the data (record) buffer. It also returns the com- * bined length of the data items. * JSB RBPIL DEF *+4 DEF LIST,I DBPIL needs: item list DEF DSADR set's Set Table entry address] DEF INDA returns: combined length of items JMP E101 Illegal item list return * * Set the outgoing data length to the length of the item list + 1 (for * the length word). * LDA DBRBP,I INA STA OUTDA * * If this is a mode 4 Get, the IARG parameter contains a doubleword in- * teger which we have to move into the data buffer. For a mode 7 or 8 * Get, IARG is a key item value which also must be moved. Check for these * cases. * LDB MODE,I CPB D4 JMP RGET1 Mode = 4 * CPB D7 RSS Mode = 7 JMP RGET3 * * Get the length of the key item value from the set's Set Table entry * 6th word (for a 1000) or 11th word (for a 3000) and put it into the * MVLEN. * LDB AIRUN ADB DSADR ADB RS1KL * LDA B,I STA MVLEN JMP RGET2 * * For mode 4, set the move length to 2. * RGET1 LDB D2 STB MVLEN * * Get the address in the data buffer into which ARG is to be moved. This * is the address of the data buffer + the length of the item list (in * OUTDA). * RGET2 LDB DBRBP ADB OUTDA * * Get the address of ARG and move its value into the data buffer. * LDA ARG JSB .MVW DEF MVLEN DEC 0 * * Add the length of ARG to the outgoing data length. * LDA MVLEN ADA OUTDA STA OUTDA * * Ask RBMST to build the request, sent it, and await the reply. * RGET3 JSB RBMST DEF *+11 DEF D40  RBMST needs: RDBA Index DEF MODE,I DBGET mode DEF DSNUM data set number DEF INDA length of data expected. DEF BASE,I data base parameter DEF STAT,I status array DEF DBRBP,I outgoing data buffer DEF OUTDA outgoing data length DEF BUF,I incoming data buffer DEF INDA incoming data length NOP RGET4 JMP RBGET,I * * Error return points. * E100 LDB D100 Invalid data set RSS E101 LDB D101 Invalid item list. RSS E115 LDB D115 Illegal DBGET mode. * STB STAT,I JMP RGET4 * * Constants and variables. * D2 EQU ZERO+2 D4 EQU ZERO+4 D7 EQU ZERO+7 D8 EQU ZERO+8 D40 DEC 40 D100 DEC 100 D101 DEC 101 D115 DEC 115 * DSNUM NOP DSADR NOP MVLEN NOP * INDA NOP OUTDA NOP END ) B L 92069-18220 1912 S C0122 &RBUPD RBUPD SOURCE             H0101 oASMB,L,C,R HED RBUPD SUBROUTINE OF RDBA-IMAGE/1000 NAM RBUPD,7 92229-16220 REV.1912 790222 * * ******************************************************************* * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR WRITTEN * CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18220 * RELOC: 92069-16220 * * PRGMR: CEJ * * ******************************************************************* * * * * This is the remote DBUPD handler. It transforms the DBUPD parameters * into those needed for RDBA, then calls RBMST to build the request, and * send it to the remote machine * * The calling sequence for RBUPD is: * * JSB RBUPD * DEF *+7 return point * DEF BASE data base parameter from DBUPD call * DEF SET data set parameter from DBUPD call * DEF MODE mode from DBUPD call * DEF STAT status array from DBUPD call * DEF LIST item list from DBUPD call * DEF BUF item values from DBUPD call * ********************************************************************** * * * Run Table for local machine in Remote Data Base Access * * * * The local copy of the Run Table used by the RDBA master subrou- * * tines consists of the following sections: * * * * 1) Data Base Control Block * * 2) Data Item Table * * 3) Data Set Table *| * 4) Sort Table * * * * These sections are in the order stated. Details of each section * * follow. * * * ********************************************************************** *** *** * * * Data Base Control Block - one 17 word entry per data base * * * *** *** RDCBS DEC 17 DBCB size * RDNAM DEC 0 data base name - three words DEC 1 DEC 2 RDRBN DEC 3 remote data base number DEC 4 RDDSN DEC 5 DS node number DEC 6 RDITC DEC 7 data item count RDITP DEC 8 data item table pointer RDDSC DEC 9 data set count RDDSP DEC 10 data set table pointer RDSOP DEC 11 sort table pointer DEC 12 RDLMD DEC 13 lock flag/open mode RDLFG EQU RDLMD 1st byte: lock flag RDMOD EQU RDLMD 2nd byte: open mode DEC 14 RDCBC DEC 15 # of DCBs desired = 0 RDMDL DEC 16 maximum data length * ZERO EQU RDNAM base of zero for future equates *** *** * * * Data Item Table - one 5 word entry per item in a 1000 data base * * * *** *** RI1LN EQU ZERO+5 length of a 1000 entry * RI1NM EQU ZERO item name - 3 words RI1NO EQU ZERO+3 item number RI1IL EQU ZERO+4 item length *** ; *** * * * Data Set Table - one 6 word entry per set in a 1000 data base * * * *** *** RS1LN EQU ZERO+6 length of a 1000 entry * RS1NM EQU ZERO set name - 3 words RS1NO EQU ZERO+3 set number RS1EL EQU ZERO+4 entry length (in words) RS1KL EQU ZERO+5 key item length for a master *** *** * * * Sort Table - one 1 word entry per item and per set. Each entry * * is a pointer to the respective item or set table * * entry relative to the start of the Run Table * * * *** *** A EQU 0 B EQU 1 * ENT RBUPD EXT .ENTR,.MVW,AIRUN,DBRBP,RBCST,RBMST,RBPIL * BASE NOP SET NOP MODE NOP STAT NOP LIST NOP BUF NOP * * Get true address of parameters and return point. * RBUPD NOP JSB .ENTR DEF BASE * * Make sure the data base was opened with a mode within [1,3]. Open * mode is in low order byte of 14th word of DBCB. Also, check that if * the data base is open in mode 1 the data base is locked to the user. * Lock flag is in high order byte of 14th word of DBCB. * LDB AIRUN ADB RDMOD LDA B,I AND LOBYT CPA D1 Mode = 1? JMP RUPD1 Yes CPA D3 No - mode = 3? JMP RUPD2 Yes JMP E104 No -Invalid mode for Update. * RUPD1 LDA B,I Open mode = 1, SSA,RSS is data base locked? JMP E159 No - cannot do Update. * * Make sure the mode for DBUPD is 1. * RUPD2 LDA MODE,I CMA,INA INA,SZA JMP E115 No - illegal DBUPD mode. * * Ask RBCST to check the set reference for validity, and if valid, to * return us the set's number and set table entry address (relative to * beginning of Run Table. * JSB RBCST DEF *+4 DEF SET,I RBCST needs: set reference DEF STNUM returns: set number DEF STADR set's Set Table entry address JMP E100 Invalid set return. * * Ask RBPIL to process the item list given to us by the user in order to * build an item number list in the data (record) buffer and return us the * combined length of the data items in the list. * JSB RBPIL DEF *+4 DEF LIST,I RBPIL needs: item list DEF STADR set's entry address DEF CM/MV returns: combined data lengths JMP E101 Invalid item list return. * * Move the item values given to us by the user into the record buffer * immediately following the item number list. * LDB DBRBP B = address of record buffer ADB DBRBP,I + length of item list INB + 1 (for length word) LDA BUF * JSB .MVW DEF CM/MV DEC 0 * * Calculate the length of outgoing data in the record buffer = * length of item list + 1 (for length word) + length of item values. * LDA DBRBP,I INA ADA CM/MV STA OUTDA * * Ask RBMST to build the request, send it and wait for the reply. * JSB RBMST DEF *+11 DEF D41 RBMST needs: RDBA Index DEF MODE,I DBUPD mode DEF STNUM data set number DEF D0 dummy DEF BASE,I data base parameter DEF STAT,I status array DEF DBRBP,I outgoing data buffer DEF OUTDA outgo)ing data length DEF D0 incoming data buffer DEF D0 incoming data length NOP RUPD3 JMP RBUPD,I * * Error return points. * E100 LDB D100 Invalid set reference RSS E101 LDB D101 Invalid item list. RSS E104 LDB D104 Invalid open mode for an Update. RSS E115 LDB D115 Invalid DBUPD mode. RSS E159 LDB D159 Data base not locked with open mode 1. * STB STAT,I JMP RUPD3 * * Constants and variables. * D0 EQU ZERO D1 EQU ZERO+1 D3 EQU ZERO+3 D7 EQU ZERO+7 D41 DEC 41 D100 DEC 100 D101 DEC 101 D104 DEC 104 D115 DEC 115 D159 DEC 159 * LOBYT OCT 377 * STNUM NOP STADR NOP CM/MV NOP OUTDA NOP END k\ C M 92069-18221 1912 S C0122 &RBPUT RBPUT SOURCE             H0101 ASMB,L,C,R HED RBPUT SUBROUTINE OF RDBA-IMAGE/1000 NAM RBPUT,7 92069-16221 REV.1912 790130 * * ******************************************************************* * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR WRITTEN * CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18221 * RELOC: 92069-16221 * * PRGMR: CEJ * * ******************************************************************* * * * * This is the remote DBPUT handler. Its function is to transform the * DBPUT parameters into those needed for RDBA then to send the request * to the remote machine through DBMST. * * The calling sequence for RBPUT is: * * JSB RBPUT * DEF *+7 return point * DEF BASE data base parameter from DBPUT call * DEF SET data set parameter from DBPUT call * DEF MODE mode from DBPUT call * DEF STAT status array from DBPUT call * DEF LIST item list from DBPUT call * DEF BUF item values from DBPUT call * ********************************************************************** * * * Run Table for local machine in Remote Data Base Access * * * * The local copy of the Run Table used by the RDBA master subrou- * * tines consists of the following sections: * * * * 1) Data Base Control Block * * 2) Data Item Table * * 3) Data Set Table  * * 4) Sort Table * * * * These sections are in the order stated. Details of each section * * follow. * * * ********************************************************************** *** *** * * * Data Base Control Block - one 17 word entry per data base * * * *** *** RDCBS DEC 17 DBCB size * RDNAM DEC 0 data base name - three words DEC 1 DEC 2 RDRBN DEC 3 remote data base number DEC 4 RDDSN DEC 5 DS node number DEC 6 RDITC DEC 7 data item count RDITP DEC 8 data item table pointer RDDSC DEC 9 data set count RDDSP DEC 10 data set table pointer RDSOP DEC 11 sort table pointer DEC 12 RDLMD DEC 13 lock flag/open mode RDLFG EQU RDLMD 1st byte: lock flag RDMOD EQU RDLMD 2nd byte: open mode DEC 14 RDCBC DEC 15 # of DCBs desired = 0 RDMDL DEC 16 maximum data length * ZERO EQU RDNAM base of zero for future equates *** *** * * * Data Item Table - one 5 word entry per item in a 1000 data base * * * *** *** RI1LN EQU ZERO+5 length of a 1000 entry * RI1NM EQU ZERO item name - 3 words RI1NO EQU ZERO+3 item number RI1IL EQU ZERO+4 item length *** *** * * * Data Set Table - one 6 word entry per set in a 1000 data base * * * *** *** RS1LN EQU ZERO+6 length of a 1000 entry * RS1NM EQU ZERO set name - 3 words RS1NO EQU ZERO+3 set number RS1EL EQU ZERO+4 entry length (in words) RS1KL EQU ZERO+5 key item length for a master *** *** * * * Sort Table - one 1 word entry per item and per set. Each entry * * is a pointer to the respective item or set table * * entry relative to the start of the Run Table * * * *** *** * A EQU 0 B EQU 1 * ENT RBPUT EXT .ENTR,.MVW,AIRUN,DBRBP,RBCST,RBMST,RBPIL * BASE NOP SET NOP MODE NOP STAT NOP LIST NOP BUF NOP * * Get true parameter and return point addresses. * RBPUT NOP JSB .ENTR DEF BASE * * Make sure the open mode is within [1,3] and if mode 1, that the data * base is locked to the user. Open mode is in the low order byte of * the 14th word of the DBCB, lock flag is high order byte of same word. * LDB AIRUN ADB RDMOD LDA B,I AND LOBYT * CPA D1 JMP RPUT1 Open mode = 1. CPA D3 JMP RPUT2 Open mode = 3 JMP E104 Improper open mode for a Put. * RPUT1 LDA B,I Is data base locked? SSA,RSS (i.e. lock flag negative?) JMP E159 No - Data base not enabled. * * Make sure the DBPUT mode is 1. * RPUT2 LDA MO}DE,I CMA,INA INA,SZA JMP E115 Invalid DBPUT mode. * * Ask RBCST to check the validity of the set reference and, if valid, to * return the set's number and Set Table entry address (relative to begin- * ning of Run Table). * JSB RBCST DEF *+4 DEF SET,I RBCST needs: set reference DEF STNUM returns: set number DEF STADR set's Set Table entry address JMP E100 Invalid set return * * Ask RBPIL to process the item list the user gave us, building an item * number list in the data (record) buffer and to return to us the com- * bined length of all the items in the list. * JSB RBPIL DEF *+4 DEF LIST,I RBPIL needs: item list DEF STADR set' entry address DEF MVLEN returns: combined item length JMP E101 Invalid item list return * * Move the values for the items from BUF into the data buffer starting * in the word which immediately follows the item number list in the data * buffer. * LDB DBRBP B = record buffer address ADB DBRBP,I + length of item list INB + 1 (for length word) * LDA BUF JSB .MVW DEF MVLEN DEC 0 * * Calculate the length of the outgoing data = length of item number list * + 1 (for length word) + length of item values. * LDA DBRBP,I INA ADA MVLEN STA OUTDA * * Ask RBMST to build the request buffer, send the request, and await the * reply. * JSB RBMST DEF *+11 DEF D42 RBMST needs: RDBA Index DEF MODE,I DBPUT mode DEF STNUM data set number DEF D0 dummy DEF BASE,I data base parameter DEF STAT,I status array DEF DBRBP,I outgoing data buffer DEF OUTDA outgoing data length  DEF DBRBP,I incoming data buffer DEF D0 incoming data length NOP RPUT3 JMP RBPUT,I * * Error return points. * E100 LDB D100 Invalid set reference. RSS E101 LDB D101 Invalid item list. RSS E104 LDB D104 Open mode not valid for a Put. RSS E115 LDB D115 Invalid DBPUT mode. RSS E159 LDB D159 Data base not locked in mode 1. * STB STAT,I JMP RPUT3 * * Constants and variables. * D0 EQU ZERO D1 EQU ZERO+1 D3 EQU ZERO+3 D7 EQU ZERO+7 D42 DEC 42 D100 DEC 100 D101 DEC 101 D104 DEC 104 D115 DEC 115 D159 DEC 159 * LOBYT OCT 377 * STADR NOP STNUM NOP OUTDA NOP MVLEN NOP END  D N 92069-18222 1912 S C0122 &RBDEL RBDEL SOURCE             H0101 |[ASMB,L,C,R HED RBDEL SUBROUTINE OF RDBA-IMAGE/1000 NAM RBDEL,7 92069-16222 REV.1912 790130 * * ******************************************************************* * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR WRITTEN * CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18222 * RELOC: 92069-16222 * * PRGMR: CEJ * * ******************************************************************* * * * * This is the remote DBDEL handler. Its function is to transform the * DBDEL parameters into those needed for RDBA, then to send the request * to the remote machine through RBMST. * * The calling sequence for RBDEL is: * * JSB RBDEL * DEF *+5 return point * DEF BASE data base parameter from DBDEL call * DEF SET data set parameter from DBDEL call * DEF MODE mode from DBDEL call * DEF STAT status array from DBDEL call * ********************************************************************** * * * Run Table for local machine in Remote Data Base Access * * * * The local copy of the Run Table used by the RDBA master subrou- * * tines consists of the following sections: * * * * 1) Data Base Control Block * * 2) Data Item Table * * 3) Data Set Table * * 4) Sort Table * * / * * These sections are in the order stated. Details of each section * * follow. * * * ********************************************************************** *** *** * * * Data Base Control Block - one 17 word entry per data base * * * *** *** RDCBS DEC 17 DBCB size * RDNAM DEC 0 data base name - three words DEC 1 DEC 2 RDRBN DEC 3 remote data base number DEC 4 RDDSN DEC 5 DS node number DEC 6 RDITC DEC 7 data item count RDITP DEC 8 data item table pointer RDDSC DEC 9 data set count RDDSP DEC 10 data set table pointer RDSOP DEC 11 sort table pointer DEC 12 RDLMD DEC 13 lock flag/open mode RDLFG EQU RDLMD 1st byte: lock flag RDMOD EQU RDLMD 2nd byte: open mode DEC 14 RDCBC DEC 15 # of DCBs desired = 0 RDMDL DEC 16 maximum data length * ZERO EQU RDNAM base of zero for future equates *** *** * * * Data Item Table - one 5 word entry per item in a 1000 data base * * * *** *** RI1LN EQU ZERO+5 length of a 1000 entry * RI1NM EQU ZERO item name - 3 words RI1NO EQU ZERO+3 item number RI1IL EQU ZERO+4 item length *** *** *  * * Data Set Table - one 6 word entry per set in a 1000 data base * * * *** *** RS1LN EQU ZERO+6 length of a 1000 entry * RS1NM EQU ZERO set name - 3 words RS1NO EQU ZERO+3 set number RS1EL EQU ZERO+4 entry length (in words) RS1KL EQU ZERO+5 key item length for a master *** *** * * * Sort Table - one 1 word entry per item and per set. Each entry * * is a pointer to the respective item or set table * * entry relative to the start of the Run Table * * * *** *** A EQU 0 B EQU 1 * ENT RBDEL EXT .ENTR,AIRUN,RBCST,RBMST * BASE NOP SET NOP MODE NOP STAT NOP * * Get true parameter and return point addresses. * RBDEL NOP JSB .ENTR DEF BASE * * Check to see if the data base was opened in a mode within [1,3], and * if mode 1, that the data base is locked to the user. Open mode is in * the low order byte of the 14th word of the DBCB, lock flag is in the * high order byte of the same word. * LDB AIRUN ADB RDMOD LDA B,I AND LOBYT * CPA D1 JMP RDEL1 Open mode = 1. CPA D3 JMP RDEL2 Open mode = 3. JMP E104 Invalid open mode for a Delete. * RDEL1 LDA B,I Is data base locked? SSA,RSS (i.e. lock flag negative?) JMP E159 No - data base not enabled. * * Make sure the DBDEL mode is 1. * RDEL2 LDA MODE,I CMA,INA INA,SZA JMP E115 Illegal DBDEL mode. * * Ask RBCST to check the validity of the set reference and to return us * the set's number, if valid. * JSB RBCST DEF *+4 DEF SET,I RBCST needs: set reference DEF STNUM returns: set number DEF STADR set's Set Table entry address JMP E100 Invalid set return. * * Ask RBMST to build the request, send it, and await the reply. * JSB RBMST DEF *+11 DEF D43 RBMST needs: RDBA Index DEF MODE,I DBDEL mode DEF STNUM data set number DEF D0 dummy DEF BASE,I data base parameter DEF STAT,I status array DEF D0 outgoing data buffer DEF D0 outgoing data length DEF D0 incoming data buffer DEF D0 incoming data length NOP RDEL3 JMP RBDEL,I * * Error return points. * E100 LDB D100 Invalid data set. RSS E104 LDB D104 Improper open mode for a Delete. RSS E115 LDB D115 Illegal DBDEL mode. RSS E159 LDB D159 Data base not locked. * RDEL4 STB STAT,I JMP RDEL3 * * Constants and variables. * D0 EQU ZERO D1 EQU ZERO+1 D3 EQU ZERO+3 D7 EQU ZERO+7 D43 DEC 43 D100 DEC 100 D104 DEC 104 D115 DEC 115 D159 DEC 159 * LOBYT OCT 377 * STNUM NOP STADR NOP END END$ . EN 92069-18223 1912 S C0122 &RBLCK RBLCK SOURCE             H0101 `ASMB,L,C,R HED RBLCK AND RBUNL SUBROUTINES OF RDBA-IMAGE/1000 NAM RBLCK,7 92069-16223 REV.1912 790130 * * ******************************************************************* * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR WRITTEN * CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18223 * RELOC: 92069-16223 * * PRGMR: CEJ * * ******************************************************************* * * * * This is the remote DBLCK routine. Its function is to transform the * DBLCK parameters into those needed for RDBA, then to send the request * to the remote machine through RBMST. * * The calling sequence for RBLCK is: * * JSB RBLCK * DEF *+5 return point * DEF BASE data base parameter from DBLCK call * DEF SET data set parameter from DBLCK call * DEF MODE mode from DBLCK call * DEF STAT status array from DBLCK call * ********************************************************************** * * * Run Table for local machine in Remote Data Base Access * * * * The local copy of the Run Table used by the RDBA master subrou- * * tines consists of the following sections: * * * * 1) Data Base Control Block * * 2) Data Item Table * * 3) Data Set Table * * 4) Sort Table * *  * * These sections are in the order stated. Details of each section * * follow. * * * ********************************************************************** *** *** * * * Data Base Control Block - one 17 word entry per data base * * * *** *** RDCBS DEC 17 DBCB size * RDNAM DEC 0 data base name - three words DEC 1 DEC 2 RDRBN DEC 3 remote data base number DEC 4 RDDSN DEC 5 DS node number DEC 6 RDITC DEC 7 data item count RDITP DEC 8 data item table pointer RDDSC DEC 9 data set count RDDSP DEC 10 data set table pointer RDSOP DEC 11 sort table pointer DEC 12 RDLMD DEC 13 lock flag/open mode RDLFG EQU RDLMD 1st byte: lock flag RDMOD EQU RDLMD 2nd byte: open mode DEC 14 RDCBC DEC 15 # of DCBs desired = 0 RDMDL DEC 16 maximum data length * ZERO EQU RDNAM base of zero for future equates *** *** * * * Data Item Table - one 5 word entry per item in a 1000 data base * * * *** *** RI1LN EQU ZERO+5 length of a 1000 entry * RI1NM EQU ZERO item name - 3 words RI1NO EQU ZERO+3 item number RI1IL EQU ZERO+4 item length *** *** *  * * Data Set Table - one 6 word entry per set in a 1000 data base * * * *** *** RS1LN EQU ZERO+6 length of a 1000 entry * RS1NM EQU ZERO set name - 3 words RS1NO EQU ZERO+3 set number RS1EL EQU ZERO+4 entry length (in words) RS1KL EQU ZERO+5 key item length for a master *** *** * * * Sort Table - one 1 word entry per item and per set. Each entry * * is a pointer to the respective item or set table * * entry relative to the start of the Run Table * * * *** *** A EQU 0 B EQU 1 * ENT RBLCK,RBUNL EXT .ENTR,AIRUN,RBMST * LBASE NOP LSET NOP LMODE NOP LSTAT NOP * * Get true parameter and return point addresses. * RBLCK NOP JSB .ENTR DEF LBASE * * Set error code word in status array to zero for ease in return. * CLA STA LSTAT,I * * Make sure that the open mode is 1 and that the data base is not * locked. Else, if the open mode is 3, or the data base is already * locked, then just ignore the call and return successful. Open mode * is in the low order byte of the 14th word of the DBCB, lock flag is * in the high order byte of the same word. * LDB AIRUN ADB RDMOD LDA B,I AND LOBYT * CPA D1 JMP RLCK1 Open mode = 1 CPA D3 JMP RLCK4 Open mode = 3 JMP L134 Bad open mode for a lock. * RLCK1 LDA B,I SSA,RSS JMP RLCK2 Data base not locked to user. JMP RLCK4 Data base already locked. * * Check. that the lock mode is either 1 or 2. * RLCK2 LDA LMODE,I CMA,INA INA,SZA,RSS JMP RLCK3 Lock mode = 1 INA,SZA JMP L115 Lock mode NE 1 or 2, error. * * Ask RBMST to build the request, send it and await the reply. * RLCK3 JSB RBMST DEF *+11 DEF D44 RBMST needs: RDBA Index DEF LMODE,I DBLCK mode DEF LSET,I dummy set parameter DEF D0 dummy DEF LBASE,I data base parameter DEF LSTAT,I status array DEF D0 outgoing data buffer DEF D0 outgoing data length DEF D0 incoming data buffer DEF D0 incoming data length RLCK4 JMP RBLCK,I * * If lock successful, set lock flag negative. Lock flag is high order * byte of 14th word of DBCB. * LDA LSTAT,I First word of status array is SZA zero if lock succeeded. JMP RLCK4 * LDB AIRUN ADB RDLFG LDA B,I IOR NWAIT STA B,I JMP RLCK4 * * Error return points. * L115 LDB D115 Invalid lock mode RSS L134 LDB D134 Invalid open mode for Lock. STB LSTAT,I JMP RLCK4 * * Constants and variables. * D44 DEC 44 D134 DEC 134 * NWAIT OCT 100000 * SKP * * This is the remote DBUNL routine. Its function is to transform the * DBUNL parameters into those needed for RDBA and to send the request * to the remote machine through RBMST. * * The calling sequence for RBUNL is: * * JSB RBUNL * DEF *+5 return point * DEF BASE data base parameter from DBUNL call * DEF SET data set parameter from DBUNL call * DEF MODE mode from DBUNL call * DEF STAT status array from DBUNL call * UBASE NOP USET NOP UMODE NOP USTAT NOP * * Get true parameter and return point addresses. * RBUNL NOP JSB .ENTR DEF UBASE * * Set error code word in status array to zero for ease in return. * CLA STA USTAT,I * * Make sure that the data base was opened in mode 1 and that the data * base is locked. Else, just ignore call and return successful. Open * mode is in low order byte of the 14th word of the DBCB, lock flag is * in the high order byte of same word. * LDB AIRUN ADB RDMOD LDA B,I AND LOBYT * CPA D1 RSS Open mode = 1. JMP RUNL3 No need to unlock, just return. * LDA B,I SSA,RSS Lock flag is negative, if d.b. locked JMP RUNL3 Not locked, just return. * * Make sure the DBUNL mode is 1. * LDA UMODE,I CPA D1 RSS JMP U115 Illegal DBUNL mode. * * Ask RBMST to build the request, send it, and await the reply. * JSB RBMST DEF *+11 DEF D45 RBMST needs: RDBA Index DEF UMODE,I DBUNL mode DEF USET,I dummy data set parameter DEF D0 dummy DEF UBASE,I data base parameter DEF USTAT,I status array DEF D0 outgoing data buffer DEF D0 outgoing data length DEF D0 incoming data buffer DEF D0 incoming data length RUNL3 JMP RBUNL,I * * If unlock successful, clear the lock flag (in high order byte of 14th * word of DBCB). * LDA USTAT,I First word of status array SZA is zero if unlock succeeded. JMP RUNL3 * LDB AIRUN ADB RDLFG LDA B,I AND LOBYT STA B,I JMP RUNL3 * * Error return points. * U115 LDB D115 Illegal DBUNL mode. STB USTAT,I $" JMP RUNL3 * * Constants and variables. * D0 EQU ZERO D1 EQU ZERO+1 D3 EQU ZERO+3 D7 EQU ZERO+7 D45 DEC 45 D115 DEC 115 * LOBYT OCT 377 * END $ F Q 92069-18224 1912 S C0122 &RBCLS RBCLS SOURCE             H0101 hASMB,L,C,R HED RBCLS SUBROUTINE OF RDBA-IMAGE/1000 NAM RBCLS,7 92069-16224 REV.1912 790130 * * ******************************************************************* * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR WRITTEN * CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18224 * RELOC: 92069-16224 * * PRGMR: CEJ * * ******************************************************************* * * * * This is the remote DBCLS routine. Its function is to transform the * DBCLS parameters into those needed for RDBA, then to send the request * to the remote machine through RBMST. * * The calling sequence for RBCLS is: * * JSB RBCLS * DEF *+5 return point * DEF BASE data base parameter from DBCLS call * DEF SET data set parameter from DBCLS call * DEF MODE mode from DBCLS call * DEF STAT status array from DBCLS call * ********************************************************************** * * * Run Table for local machine in Remote Data Base Access * * * * The local copy of the Run Table used by the RDBA master subrou- * * tines consists of the following sections: * * * * 1) Data Base Control Block * * 2) Data Item Table * * 3) Data Set Table * * 4) Sort Table * *  * * These sections are in the order stated. Details of each section * * follow. * * * ********************************************************************** *** *** * * * Data Base Control Block - one 17 word entry per data base * * * *** *** RDCBS DEC 17 DBCB size * RDNAM DEC 0 data base name - three words DEC 1 DEC 2 RDRBN DEC 3 remote data base number DEC 4 RDDSN DEC 5 DS node number DEC 6 RDITC DEC 7 data item count RDITP DEC 8 data item table pointer RDDSC DEC 9 data set count RDDSP DEC 10 data set table pointer RDSOP DEC 11 sort table pointer DEC 12 RDLMD DEC 13 lock flag/open mode RDLFG EQU RDLMD 1st byte: lock flag RDMOD EQU RDLMD 2nd byte: open mode DEC 14 RDCBC DEC 15 # of DCBs desired = 0 RDMDL DEC 16 maximum data length * ZERO EQU RDNAM base of zero for future equates *** *** * * * Data Item Table - one 5 word entry per item in a 1000 data base * * * *** *** RI1LN EQU ZERO+5 length of a 1000 entry * RI1NM EQU ZERO item name - 3 words RI1NO EQU ZERO+3 item number RI1IL EQU ZERO+4 item length *** *** *  * * Data Set Table - one 6 word entry per set in a 1000 data base * * * *** *** RS1LN EQU ZERO+6 length of a 1000 entry * RS1NM EQU ZERO set name - 3 words RS1NO EQU ZERO+3 set number RS1EL EQU ZERO+4 entry length (in words) RS1KL EQU ZERO+5 key item length for a master *** *** * * * Sort Table - one 1 word entry per item and per set. Each entry * * is a pointer to the respective item or set table * * entry relative to the start of the Run Table * * * *** *** A EQU 0 B EQU 1 * ENT RBCLS EXT .ENTR,AIRUN,DBDEX,DBRTP,RETBF,RBCST,RBMST * BASE NOP SET NOP MODE NOP STAT NOP * * Get true parameter and return point addresses. * RBCLS NOP JSB .ENTR DEF BASE * * Make sure that the DBCLS mode is within [1,2]. * LDA MODE,I CMA,INA INA,SZA,RSS JMP RCLS2 Mode = 1 INA,SZA JMP E115 Bad mode. * * For DBCLS mode 2, ask RBCST to check the set reference for validi- * ty and to return us the data set's number, if valid. * JSB RBCST DEF *+4 DEF SET,I RBCST needs: set reference DEF STNUM returns: set number DEF STADR set's Set Table entry address JMP E100 Invalid set return * * Ask RBMST to build the request, send it and wait for the reply. * RCLS2 JSB RBMST DEF *+11 DEF D38 RBMST needs: RDBA Index DEF MODE,I DBCLS mode DEF STNUM @ data set number DEF D0 dummy DEF BASE,I data base parameter DEF STAT,I status array DEF D0 outgoing data buffer DEF D0 outgoing data length DEF D0 incoming data buffer DEF D0 incoming data length RCLS3 JMP RBCLS,I * * There was no DS error, but check the first word of the status array * for an IMAGE error. * LDA STAT,I SZA JMP RCLS3 IMAGE error. * * There was no IMAGE error either. If the close mode was 1, we want to * release any memory used solely by this data base. * LDA MODE,I CPA D1 RSS JMP RCLS3 Mode is not 1. * * First deallocate any extra words in the data (record) buffer used only * by this data base. DBDEX performs this service for us. * JSB DBDEX DEF *+1 JMP E160 Error return, memory corrupt. * * Now, release the Run Table memory space. * CCA ADA BASE,I Get primary pointer to Run Table ADA DBRTP by adding the data base number STA PTRAD to the address of pointer table + 1. * JSB RETBF DEF *+2 DEF PTRAD,I * SSA Did RETBF succeed? JMP E160 NO - someone's walked on our memory. * * A successful DBCLS, replace the first word of the base parameter with * its old value (stored in 6th word of DBCB to which AIRUN still points) * then return to user. * LDB AIRUN ADB RDDSN LDA B,I STA BASE,I * JMP RCLS3 * * Error return points. * E100 LDB D100 Invalid set reference. RSS E115 LDB D115 Illegal DBCLS mode. RSS E160 LDB D160 * STB STAT,I JMP RCLS3 SKP * * Constants and variables. * D0 EQU ZERO D1 EQU ZERO+1 D38 DEC 38 D100 DEC 100 D115 DEC 115 D160 DEC 160 * PTRAD NOP STADR NOP STNUM NOP END  G Q 92069-18225 2040 S C0122 &RBMST &RBMST             H0101 'ASMB,L,C,R HED RBMST UTILITY SUBROUTINE OF RDBA-IMAGE/1000 NAM RBMST,7 92069-1X225 REV.2040 800730 * * ******************************************************************* * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR WRITTEN * CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18225 * RELOC: 92069-1X225 * * PRGMR: CEJ * * ******************************************************************* * * * * Remote data Base MaSTer is a utility subroutine for the RDBA subrou- * tines whose function it is to take the RDBA parameters and build the * DS/1000 or request buffer, send the request to the remote node and * await the reply. When the reply is received, RBMST breaks the reply * buffer into the RDBA reply parameters. If a DS error occurs, it puts the * error code in the status array and takes the error exit, else it takes * the normal return. * * The calling sequence for RBMST is: * * JSB RBMST * DEF *+11 return address * DEF INDEX RDBA index * DEF MODE IMAGE call mode * DEF INFO1 - for DBOPN this is a 3 word level code word * - for all other calls, this is a data set or * data item number. * DEF INFO2 - for a DBFND this is a data item number * - for a DBGET this is the word length of the * data expected * - for a DBOPN the remote data base number * - for all other calls this parameter is a dummy * DEF BASE IMAGE call base parameter * DEF STAT IMAGE call status array. * DEF OUTDA outgoing data buffer * DExF OUTLN outgoing data length * DEF INDA incoming data buffer * DEF INLN incoming data length * < error return > * < normal return > * SKP ********************************************************************** * * * Run Table for local machine in Remote Data Base Access * * * * The local copy of the Run Table used by the RDBA master subrou- * * tines consists of the following sections: * * * * 1) Data Base Control Block * * 2) Data Item Table * * 3) Data Set Table * * 4) Sort Table * * * * These sections are in the order stated. Details of each section * * follow. * * * ********************************************************************** *** *** * * * Data Base Control Block - one 17 word entry per data base * * * *** *** RDCBS DEC 17 DBCB size * RDNAM DEC 0 data base name - three words DEC 1 DEC 2 RDRBN DEC 3 remote data base number DEC 4 RDDSN DEC 5 DS node number DEC 6 RDITC DEC 7 data item count RDITP DEC 8 data item table pointer RDDSC DEC 9  data set count RDDSP DEC 10 data set table pointer RDSOP DEC 11 sort table pointer DEC 12 RDLMD DEC 13 lock flag/open mode RDLFG EQU RDLMD 1st byte: lock flag RDMOD EQU RDLMD 2nd byte: open mode DEC 14 RDCBC DEC 15 # of DCBs desired = 0 RDMDL DEC 16 maximum data length * ZERO EQU RDNAM base of zero for future equates *** *** * * * Data Item Table - one 5 word entry per item in a 1000 data base * * * *** *** RI1LN EQU ZERO+5 length of a 1000 entry * RI1NM EQU ZERO item name - 3 words RI1NO EQU ZERO+3 item number RI1IL EQU ZERO+4 item length *** *** * * * Data Set Table - one 6 word entry per set in a 1000 data base * * * *** *** RS1LN EQU ZERO+6 length of a 1000 entry * RS1NM EQU ZERO set name - 3 words RS1NO EQU ZERO+3 set number RS1EL EQU ZERO+4 entry length (in words) RS1KL EQU ZERO+5 key item length for a master *** *** * * * Sort Table - one 1 word entry per item and per set. Each entry * * is a pointer to the respective item or set table * * entry relative to the start of the Run Table * * * *** *** SKP ****************************** **************************************** *** *** * * * Standard DS/1000 equates. * * * *** *** #STR EQU ZERO #SEQ EQU ZERO+1 #SRC EQU ZERO+2 #DST EQU ZERO+3 #RDB EQU ZERO+4 #EC1 EQU ZERO+4 #EC2 EQU ZERO+5 #ENO EQU ZERO+6 #REP EQU ZERO+7 * * ********************************************************************** * * * DS request buffer for RDBA. * * * * The request buffer is comprised of the following sections: * * * * 1) standard DS/1000 header * * 2) apppendage * * * * These section appear in the order stated. Details of each * * section follow. * * * ********************************************************************** *** *** * * * DS/1000 header - one 4 word entry per request * * * *** *** DS1HL EQU #RDB header length * DS1ST EQU #STR stream word, stream # = 10 DS1SQ EQU #SEQ RTE 2sequence number DS1SN EQU #SRC source node number DS1DN EQU #DST destination node number *** *** * * * Appendage - from 9 to 28 words per request * * * *** *** RBIDX EQU ZERO RDBA index RBMOD EQU ZERO+1 IMAGE call mode RBIN1 EQU ZERO+2 IMAGE call info RBLEV EQU RBIN1 - for DBOPN level code word RBID EQU RBIN1 - for other calls, set or item # RBIN2 EQU ZERO+3 IMAGE call info RBITM EQU RBIN2 - for DBFND item number RBDLN EQU RBIN2 - for DBGET expected data length RBMRT EQU ZERO+5 for DBOPN, the max. returned RT size RBBLN EQU ZERO+6 word size of base parameter RBBAS EQU ZERO+7 base parameter RBRBN EQU RBBAS 1st word: remote base number RBBNR EQU RBBAS+1 remainder of base parameter SKP ********************************************************************** * * * DS reply buffer for RDBA. * * * * The reply buffer is comprised of the following sections: * * * * 1) standard DS/1000 header * * 2) appendage * * * * These section appear in the order stated. Details of each * * section follow. * * * ********************************************************************** ***  *** * * * DS/1000 header - one 7 word entry per reply * * * * The first four words of the reply header are identical to the * * request header. The remaining three words are as follows. * * * *** *** DS1RL EQU #REP header length * DS1E1 EQU #EC1 DS error code word 1 DS1E2 EQU #EC2 DS error code word 2 DS1EN EQU #ENO node # at which error occurred *** *** * * * Appendage - either 10 or 11 words per reply * * * *** *** DSSAR EQU ZERO status array - 10 words DSRBN EQU ZERO+10 remote data base number for DBOPN *** *** * * * Maximum reply length is 18 words. * * * *** *** RPMAX DEC 18 SKP A EQU 0 B EQU 1 * ENT RBMST EXT .ENTR,.MVW,AIRUN,D65MS * INDEX NOP MODE NOP INFO1 NOP INFO2 NOP BASE NOP STAT NOP OUTDA NOP OUTLN NOP INDA NOP INLN NOP * * Get true parameter and return point addresses. * RBMST NOP JSB .ENTR DEF INDEX * * Determine the address in the request buffer for the appendage. This * is the address of the request buffer + length of DS/1000 request header. * h LDB DS1HL ADB RQBUF * * Build the appendage: * * 1) RDBA index * LDA INDEX,I STA B,I INB * * 2) IMAGE call mode * LDA MODE,I STA B,I INB * * 3) INFO1 and INFO2 * A) If INDEX NE 36 (i.e. request not a DBOPN) INFO1 and INFO2 are * both only 1 word long. Move them into the appendage and update * the appendage address to the word to contain the base parameter * size. * LDA INDEX,I CPA D36 JMP MST1 * LDA INFO1,I STA B,I INB LDA INFO2,I STA B,I ADB D3 JMP MST2 * * B) If INDEX = 36, INFO1 is a level code word (3 words long) * and INFO2 is ignored. Immediately following the level code * word in the appendage is the maximum Run Table size expected. * This is found in INLN. * MST1 LDA INFO1 Move level code word JSB .MVW into appendage. DEF D3 DEC 0 * LDA INLN,I Move max. RT length STA B,I into appendage. * INB Update our position in appendage. * * 4) Word size of base parameter. We don't know this yet so save * address in appendage for later. * MST2 STB SAVE INB * * 5) Base parameter * A) Get remote data base number from the DBCB (4th word). This * is the first word of the parameter, for DBOPN this has been * set to two blanks. * LDA AIRUN ADA RDRBN LDA A,I STA B,I INB * * B) Move the 2nd through ?th words of the base parameter into the * appendage word by word. We do this to keep a count of each * word we move and terminate the process with the first blank * or semi-colon encountered. However, in case the parameter is * incorrect, we allow no more than 10 words. * LDA M10 Set up maximum count. STA CNTR_^ * CLA,INA A one to word count STA SAVE,I (for RDB number). * MST3 ISZ BASE Get next word in param. LDA BASE,I STA B,I and put it into appendage. INB * ISZ SAVE,I Bump word count CCA Set processing 1st byte flag. STA FIRST * LDA BASE,I Get first byte. ALF,ALF MST4 AND LOBYT * CPA BLANK Is it a blank? JMP MST6 Yes - end of base param. CPA SEMI No - is it a semi-colon? JMP MST6 Yes - end of base param. * ISZ FIRST Neither - was this the 1st byte? JMP MST5 No LDA BASE,I Yes - get 2nd JMP MST4 and check it. * MST5 ISZ CNTR Done with word, JMP MST3 is param too long? JMP E103 Yes - error * * Note that the length of the base parameter was set in the appendage * by the above loop, so it is complete. Set up the control word for the * DS master subroutine. This includes the no abort bit (bit 15) and * for DBOPN the long timeout bit (bit 14). * MST6 CLA,CCE,INA ERA LDB INDEX,I CPB D36 Index for DBOPN = 36. ERA STA CONWD SKP * * Build the standard four word header on the request. * * 1) stream word = 10 * LDB RQBUF LDA D10 STA B,I * * 2) Destination node number = data base's node number which is found * in 6th word of DBCB. * ADB DS1DN LDA AIRUN ADA RDDSN LDA A,I STA B,I INB B -> appendage * * Determine the length of the request = length of DS/1000 request header * + length of appendage, where length of appendage = 7 (for index through * base length words) + length of base. * LDA DS1HL ADA RBBAS ADB RBBLN ADA B,I STA RQLEN * * Send request through D65MS, it also waits for the reply for us and re- * turns it in the request buffer and any associated data is returned in the * INDA buffer. * JSB D65MS DEF *+9 DEF CONWD D65MS needs: control word DEF RQBUF,I request/reply buffer DEF RQLEN request length DEF OUTDA,I outgoing data buffer DEF OUTLN,I outgoing data length DEF INLN,I incoming data length DEF RPMAX maximum reply length DEF INDA,I incoming data buffer JMP DSERR error return point * STA RQLEN normal return, save reply length STB INLN and data returned length SKP * * Unbuffer the reply parameters. First we need to determine the length * and address of the appendage in the reply buffer. Length of appendage = * length of reply - length of DS standard reply header. Address of ap- * pendage = address of request reply buffer + length of DS standard reply * header. * LDB DS1RL CMB,INB B = -(header length) ADB RQLEN B = length of appendage, STB APPLN save it. * * Move status array from reply into user's status array. Status in first * 10 words of appendage. * LDA RQBUF ADA DS1RL LDB STAT JSB .MVW DEF D10 DEC 0 * * If appendage length > 10, this was a successful DBOPN. Put Remote * Data base number from 11th word of appendage into INFO2 parameter. * LDB APPLN CMB,INB ADB D10 SSB,RSS JMP MST8 * LDA A,I A -> RDB # thanks to MVW, STA INFO2,I LDA RQLEN Get reply and data lengths again. LDB INLN * * Return to user. * MST8 ISZ RBMST Normal return point MST9 JMP RBMST,I * * Error return points. * * DS error. Set up status array as follows: * word +------------------------------------+ * 1 | y<:6 -1 | * +------------------------------------+ * 2 | two word error | * -- -- * 3 | code from A & B regs. | * +------------------------------------+ * DSERR STA SAVE Save 1st word of error code. CCA STA STAT,I ISZ STAT * LDA SAVE Pick up entire error code again DST STAT,I and put it in status array. JMP MST9 Take error return point. * * Illegal base parameter error. * E103 LDA D103 Error code = 103. STA STAT,I JMP MST8 Take normal return point. * * Constants and variables. * M10 DEC -10 D1 EQU ZERO+1 D3 EQU ZERO+3 D10 EQU ZERO+10 D36 DEC 36 D44 DEC 44 D103 DEC 103 * LOBYT OCT 377 BLANK OCT 040 SEMI OCT 073 * SAVE NOP MVLEN NOP FIRST NOP CNTR EQU MVLEN APPLN EQU FIRST CONWD NOP * RQLEN NOP RQBUF DEF *+1 BSS 33 END $END < HW 92069-18226 1912 S C0122 &RBBST RBBST SOURCE             H0101 oASMB,L,C,R HED RBBST UTILITY SUBROUTINE FOR RDBA-IMAGE/1000 NAM RBBST,7 92069-16226 REV.1912 790130 * * ******************************************************************* * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR WRITTEN * CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18226 * RELOC: 92069-16226 * * PRGMR: CEJ * * ******************************************************************* * * * * Build Sort Table is a subroutine for RBOPN which builds the Sort Table * in the local Run Table for Remote Data Base Access. RBBST builds the * Sort Table by doing a straight sort on the entries, adding a new entry * in the Sort Table immediately before the first entry which has a name * higher in alphabetical order than the entry to be added. (The item * and set sort tables are arranged in ascending alphabetical order based * on their names.) Each entry in the Sort Table is one word long and * contains a pointer to the item's or set's entry in the Item or Set * Table. The Sort Table is built in the order: item sort table, set sort * table. * * One additional function of RBBST is to determine and return the length * in words of the longest entry of any data set in the data base. * * The calling sequence for RBBST is: * * JSB RBBST * DEF *+2 return point * DEF LENTH returned longest entry length * * When RBBST is entered, all of the Run Table except the Sort Table is * assumed to have been built. * SKP ********************************************************************** * * * Run Table for local machine in Remote Data Base Access * * A * * The local copy of the Run Table used by the RDBA master subrou- * * tines consists of the following sections: * * * * 1) Data Base Control Block * * 2) Data Item Table * * 3) Data Set Table * * 4) Sort Table * * * * These sections are in the order stated. Details of each section * * follow. * * * ********************************************************************** *** *** * * * Data Base Control Block - one 17 word entry per data base * * * *** *** RDCBS DEC 17 DBCB size * RDNAM DEC 0 data base name - three words DEC 1 DEC 2 RDRBN DEC 3 remote data base number DEC 4 RDDSN DEC 5 DS node number DEC 6 RDITC DEC 7 data item count RDITP DEC 8 data item table pointer RDDSC DEC 9 data set count RDDSP DEC 10 data set table pointer RDSOP DEC 11 sort table pointer DEC 12 RDLMD DEC 13 lock flag/open mode RDLFG EQU RDLMD 1st byte: lock flag RDMOD EQU RDLMD 2nd byte: open mode DEC 14 RDCBC DEC 15 # of DCBs desired = 0 RDMDL DEC 16 maximum data length * ZERO EQU RDNAM base of zero for future equates ***  *** * * * Data Item Table - one 5 word entry per item in a 1000 data base * * * *** *** RI1LN EQU ZERO+5 length of a 1000 entry * RI1NM EQU ZERO item name - 3 words RI1NO EQU ZERO+3 item number RI1IL EQU ZERO+4 item length *** *** * * * Data Set Table - one 6 word entry per set in a 1000 data base * * * *** *** RS1LN EQU ZERO+6 length of a 1000 entry * RS1NM EQU ZERO set name - 3 words RS1NO EQU ZERO+3 set number RS1EL EQU ZERO+4 entry length (in words) RS1KL EQU ZERO+5 key item length for a master *** *** * * * Sort Table - one 1 word entry per item and per set. Each entry * * is a pointer to the respective item or set table * * entry relative to the start of the Run Table * * * *** *** * A EQU 0 B EQU 1 * ENT RBBST EXT .CMW,.ENTR,AIRUN * LENTH NOP * * Get true parameter and return point addresses. * RBBST NOP JSB .ENTR DEF LENTH * * Get the data item count from the DBCB (8th word) and negate it as a * loop counter. * LDB AIRUN ADB RDITC LDA B,I SZA,RSS If no items are accessible, JMP BST5 no sort table to build. CMA,INA STA tOCNTR1 * * Get the item table pointer from the DBCB (9th word). * INB LDA B,I STA CURNT * * Get the Sort Table pointer from the DBCB (12th word) and resolve it * with the address of the Run Table. * ADB D3 LDA B,I ADA AIRUN STA STADR * * Set sorted count to zero. * CLA STA COUNT * * Put pointer to first item table entry into first location in the Sort * Table. * LDB CURNT STB STADR,I * * Increment sorted count. * BST1 ISZ COUNT * * Get next item's Item Table pointer by adding RI1LN to CURNT pointer. * LDB CURNT ADB RI1LN STB CURNT * * If there is another Item Table entry, ask SORT to put it into proper * position in Sort Table. * ISZ CNTR1 RSS JMP BST2 No more items. * JSB SORT JMP BST1 * * Done with item sort so, set up for set sort. * * Set longest entry length to zero. * BST2 CLA STA LENTH,I * * Get the data set count from the DBCB (10th word) and negate it as a * loop counter. * LDB AIRUN ADB RDDSC LDA B,I * SZA,RSS If no sets, JMP BST5 done with sort. * CMA,INA STA CNTR1 * * Get Set Table pointer from the DBCB (11th word) * INB LDA B,I STA CURNT * * Get set sort table pointer = address of sort table + number of sorted * items. * LDA STADR ADA COUNT STA STADR * * Put first set entry pointer into first location in the Sort Table. * LDB CURNT STB STADR,I * * Set sorted count to one, then go put entry length in LENTH. * CLA,INA STA COUNT * JMP BST4 * * Get next set's Set Table pointer by adding RS1LN to CURNT pointer. * BST3 LDB CURNT ADB RS1LN STB CURNT * * If there is another set, ask SORT to put it into proper position in * Sort Table. * IS<Z CNTR1 RSS JMP BST5 No more sets - done with sort. * JSB SORT * * Increment sorted count. * ISZ COUNT * * Get this set's entry length and, if it is longer than the current long- * est entry, put its length into the LENTH parameter. * BST4 LDB CURNT Entry length is in 5th ADB AIRUN word of Set Table entry. ADB RS1EL * LDA B,I CMA,INA ADA LENTH,I SSA,RSS If it is not longer, JMP BST3 just continue with next set. * LDA B,I STA LENTH,I JMP BST3 * * Return to caller when done. * BST5 JMP RBBST,I SKP * * This is the actual sort. * First set up the sort parameters. Use the negative of the number of * entries already in sort table as a counter. * SORT NOP LDA COUNT CMA,INA STA CNTR2 * * Get the actual address of the entry whose pointer (in CURNT) is to be * put in the Sort Table. * LDA CURNT ADA AIRUN STA ENTRY * * Make a copy of the sort table address for easy incrementing. * LDA STADR STA NEXT * * BEGIN SORT * Ask CMW to compare names of the next entry in the sort table and the * entry we want to add. * SORT1 LDB NEXT,I ADB AIRUN B = address of next's name. LDA ENTRY A = address of new entry's name. * JSB .CMW DEF D3 DEC 0 * RSS Names the same JMP SORT2 Next's name > new name. * * Here when names the same or new entry's name > next's name. Get next * entry in Sort Table (if there is one) and continue search for proper * location for new. * ISZ NEXT ISZ CNTR2 JMP SORT1 * * No more entries. The new one belongs at the end of the table (now * pointed to by NEXT). * LDA CURNT STA NEXT,I JMP SORT4 And we are done. * * Here when the new entry's name < next entry's. The new entry belongs z$"* in the entry occupied by next. Put it there and move all the entries * starting with next down one. * SORT2 LDA CURNT * SORT3 LDB NEXT,I Save current entry in next STA NEXT,I and put in new one. * LDA B ISZ NEXT Continue for all ISZ CNTR2 entries in table. JMP SORT3 STA NEXT,I * SORT4 JMP SORT,I Then, return to caller. * * Constants and variables. * D3 EQU ZERO+3 * CNTR1 NOP CURNT NOP STADR NOP COUNT NOP CNTR2 NOP ENTRY NOP NEXT NOP END $END $ I T 92069-18227 1912 S C0122 &RBPIL RBPIL SOURCE             H0101 kASMB,L,C,R HED RBPIL UTILITY SUBROUTINE FOR RDBA-IMAGE/1000 NAM RBPIL,7 92069-16227 REV.1912 790326 * * ******************************************************************* * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR WRITTEN * CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18227 * RELOC: 92069-16227 * * PRGMR: CEJ * * ******************************************************************* * * * * Process Item List is a subroutine which accepts the item list passed * to an RDBA subroutine by the user's program, parses the item list into * its components and builds an item number or special construct list from * them at the beginning of the data buffer. The item list is either: * * 1) A number list in which the first word contains an integer count * of the number of items in the list and each succeeding word, up * to the count number of items, contains an unique item number. * * 2) A name list which is a list of unique item names concatenated * together, separated by commas and terminated by a semi-colon or * a blank. * * 3) A special construct either: * "@ " meaning all items in the data set * or * "0 " meaning no items. * * The information put into the data buffer by RBPIL is the length of the * item list followed by the item number or special construct list. If * the user passed an item name list, it is converted into an item number * list. If the user passed an item number list, each item is still checked * for validity before being put into the item list in the data buffer. * * In addition, RBPIL returns the combined length of all the items in the * item list. * * The calling sequence for RB*PIL is: * * JSB RBPIL * DEF *+4 * DEF IMLST item list passed by user * DEF DSADR pointer to data set's Set Table entry, relative * to start of Run Table * DEF LENTH returned length of items * < error return point > * < normal return point > * SKP ********************************************************************** * * * Run Table for local machine in Remote Data Base Access * * * * The local copy of the Run Table used by the RDBA master subrou- * * tines consists of the following sections: * * * * 1) Data Base Control Block * * 2) Data Item Table * * 3) Data Set Table * * 4) Sort Table * * * * These sections are in the order stated. Details of each section * * follow. * * * ********************************************************************** *** *** * * * Data Base Control Block - one 17 word entry per data base * * * *** *** RDCBS DEC 17 DBCB size * RDNAM DEC 0 data base name - three words DEC 1 DEC 2 RDRBN DEC 3 remote data ba>se number DEC 4 RDDSN DEC 5 DS node number DEC 6 RDITC DEC 7 data item count RDITP DEC 8 data item table pointer RDDSC DEC 9 data set count RDDSP DEC 10 data set table pointer RDSOP DEC 11 sort table pointer DEC 12 RDLMD DEC 13 lock flag/open mode RDLFG EQU RDLMD 1st byte: lock flag RDMOD EQU RDLMD 2nd byte: open mode DEC 14 RDCBC DEC 15 # of DCBs desired = 0 RDMDL DEC 16 maximum data length * ZERO EQU RDNAM base of zero for future equates *** *** * * * Data Item Table - one 5 word entry per item in a 1000 data base * * * *** *** RI1LN EQU ZERO+5 length of a 1000 entry * RI1NM EQU ZERO item name - 3 words RI1NO EQU ZERO+3 item number RI1IL EQU ZERO+4 item length *** *** * * * Data Set Table - one 6 word entry per set in a 1000 data base * * * *** *** RS1LN EQU ZERO+6 length of a 1000 entry * RS1NM EQU ZERO set name - 3 words RS1NO EQU ZERO+3 set number RS1EL EQU ZERO+4 entry length (in words) RS1KL EQU ZERO+5 key item length for a master *** *** * * * Sort Table - one 1 word entry per item and per set. Each entry * * is a pointer to the respective item or set table * * entry relative to the start of the Run Table * * G * *** *** SKP A EQU 0 B EQU 1 * ENT RBPIL EXT .ENTR,AIRUN,DBRBP,NAMR,RBCIT * IMLST NOP DSADR NOP LENTH NOP * * Get true parameter and return point addresses. * RBPIL NOP JSB .ENTR DEF IMLST * * Initialize process's parameters. * CLA Zero to combined length STA LENTH,I STA COUNT and item count. * LDA DBRBP Set up address for item list ADA D2 skipping over item list STA LSTAD length & item count words. * * Determine if a special construct we recognize is given. If so, branch * to the appropriate processing locations. If not, assume the list is * of numbers or names. * LDA IMLST,I SSA If negative first word - JMP EREXT illegal item list. * CPA /@ If an "@ " JMP PIL12 process entire record. * CPA /0 If an "0 " or an integer zero JMP PIL13 SZA,RSS process no items. JMP PIL13 * AND HIBYT Else, if first byte of word is zero - SZA,RSS this is a number list. Set number CCA,RSS flag to TRUE (-1). Else, CLA set number flag to FALSE (0). STA NFLAG * * If this is an item number list, make sure the count specified by the * user is less than 128. * SSA,RSS JMP PIL1 * LDB IMLST,I CMB STB CONTR Counter for later if list okay. * INB ADB D128 SSB JMP EREXT More than 127 items - illegal list. JMP PIL6 * * For a name list, we will use NAMR to parse the string as we need a * name. So we need to set up for NAMR. This means getting the byte * count in the string and setting the starting byte to one. To get the * byte count, we will search each byte in the string until we find a * blank or semi-colon, incrementing the byte count by one for each byte * not matching an ending character. * PIL1 CLA Initialize byte count to zero STA BYCNT INA and starting byte to one. STA BSTRT * LDA M889 Set maximum byte count to -(127*7). STA BMAX 6 bytes per name plus one for separater. * LDB IMLST Get address of item list * PIL2 CCA Set first byte flag to TRUE. STA FIRST LDA B,I Get first byte. ALF,ALF * PIL3 AND LOBYT CPA SEMI If a semi-colon JMP PIL5 CPA ABLNK or a blank JMP PIL5 we are done. * ISZ BYCNT Else, increment byte count. ISZ BMAX If byte count exceeds the max. RSS JMP EREXT a bad item list * ISZ FIRST If we were on first byte JMP PIL4 LDA B,I get second byte in word JMP PIL3 and check it. * PIL4 INB Else get next word and JMP PIL2 process its first byte. * PIL5 LDA BYCNT At end, if byte count SZA,RSS is zero, JMP EREXT a bad item list. JMP PIL7 * * BEGIN MAIN LOOP FOR NUMBER OR NAME LIST. * * This section of code pickes up each item in the list and gets its Item * Table entry, item number and length. If item found in Item Table, puts * the item number in the item list, increments the item count and adds * the item's length to the combined length word. * PIL6 LDB NFLAG If a number list SSB,RSS JMP PIL7 ISZ CONTR then if no more numbers in list, RSS JMP PIL11 we are done. * ISZ IMLST Else, pick up next LDA IMLST,I item number. STA ITEM JMP PIL8 * PIL7 JSB NAMR Else, a name list - DEF *+5 call NAMR to get DEF ITEM next name in list. >  DEF IMLST,I DEF BYCNT DEF BSTRT * SSA If no more names, JMP PIL11 we are done. * PIL8 JSB RBCIT Ask RBCIT to get the item's DEF *+4 Item Table entry relative DEF ITEM to beginning of Run Table DEF NUMBR and item's number. DEF DIADR JMP EREXT Invalid item return. * * Search item list already built for an identical item number. If a * match is found, item list is illegal. * LDB DBRBP ADB D2 PIL9 CPB LSTAD If at end of table, JMP PIL10 everything is fine. * LDA B,I If item number in this entry of table CPA NUMBR same as item number we are processing, JMP EREXT illegal item list. INB Else try next entry until end of JMP PIL9 data in table. * PIL10 LDA NUMBR Item okay - put it STA LSTAD,I into item list * ISZ COUNT increment count and ISZ LSTAD item list address. * * Get item's length from fifth word in Item Table entry. * LDB RI1IL ADB DIADR ADB AIRUN LDA B,I * ADA LENTH,I Add length to current STA LENTH,I combined length total. * * Continue for all items in list. * JMP PIL6 * * END OF LOOP * * We come here when all items in list have successfully been processed. * Put the item count in the first word of the item number list in the * data buffer (actually second word of data buffer), add one to the count * and it becomes the item list length. Branch with this value in the A * register to join all the successful item list processes. * PIL11 LDA COUNT LDB DBRBP INB STA B,I * INA JMP JOIN SKP * * We branch here when the special construct "@ " is passed to us in the * item list. Put this directly into the data buffer's item list, get * the length of the data set's data record fr*8*($om its Set Table entry (5th * word) and set it into the length return parameter. Then, set the length * of the item list in the data buffer to one, and branch with this length * in the A register to join all successful item list processing. * PIL12 LDB DBRBP INB STA B,I A = "@ " from above ! * LDB RS1EL ADB DSADR,I ADB AIRUN LDA B,I STA LENTH,I * CLA,INA JMP JOIN * * We branch here when the special construct "0 " or an item count of zero * is passed to us in the item list. Put this directly into the data buf- * fer's item list, leave the combined length word zero, and set the length * of the item list to 1 in the A register and join all successful item list * processing. * PIL13 LDB DBRBP INB STA B,I A = "0 " or zero from above ! * CLA,INA * * We join all successful processes here to set the itme list length in * the data record, bump the return address to the normal return point * and return to the caller. * JOIN STA DBRBP,I ISZ RBPIL EREXT JMP RBPIL,I (No bump when an error occurs.) * * Constants and variables. * M889 DEC -889 D2 EQU ZERO+2 D128 DEC 128 * /@ ASC 1,@ /0 ASC 1,0 SEMI OCT 73 ABLNK OCT 40 LOBYT OCT 377 HIBYT OCT 177400 * LSTAD NOP NFLAG NOP BYCNT NOP BSTRT NOP FIRST NOP BMAX NOP CONTR NOP COUNT NOP NUMBR NOP DIADR NOP ITEM BSS 10 BSS 0 END $END * J V 92069-18228 1912 S C0122 &RBCST RBCST SOURCE             H0101 pASMB,L,C,R HED RBCST UTILITY SUBROUTINE FOR RDBA-IMAGE/1000 NAM RBCST,7 92069-16228 REV.1912 790130 * * ******************************************************************* * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR WRITTEN * CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18228 * RELOC: 92069-16228 * * PRGMR: CEJ * * ******************************************************************* * * * * Convert SeT is a subroutine which searches the Set Table, in the cur- * rently active local Run Table for RDBA, for a set to determine its * number, entry address and the accessibility of the set. * * The set whose number and entry are to be found is passed to RBCST as * either a set name or set number. If a set name, it must be six char- * acters long padded with trailing blanks if necessary. When the set * is specified by number, a binary search of the Set Table is performed * looking for the set entry containing that number (the sets are in as- * cending numerical order in the Set Table). When the set is specified * by name, a binary search of the Set Table is performed using the set * Sort Table and comparing the set names (the sets are in ascending alpha- * betical order in the Sort Table). * * If an entry matching the specified set is found, total accessibility * to the set is assumed and RBCST returns successful to the caller. If * a matching entry is not found, the set is assumed to be inaccessible * and the error return is taken. * * The calling sequence for RBSCT is: * * JSB RBCST * DEF *+4 return point * DEF SET set name or number * DEF NUMBR returned set number * DEF ADDRS returned _ZSet Table pointer * < error return > * < normal return > * SKP ********************************************************************** * * * Run Table for local machine in Remote Data Base Access * * * * The local copy of the Run Table used by the RDBA master subrou- * * tines consists of the following sections: * * * * 1) Data Base Control Block * * 2) Data Item Table * * 3) Data Set Table * * 4) Sort Table * * * * These sections are in the order stated. Details of each section * * follow. * * * ********************************************************************** *** *** * * * Data Base Control Block - one 17 word entry per data base * * * *** *** RDCBS DEC 17 DBCB size * RDNAM DEC 0 data base name - three words DEC 1 DEC 2 RDRBN DEC 3 remote data base number DEC 4 RDDSN DEC 5 DS node number DEC 6 RDITC DEC 7 data item count RDITP DEC 8 data item table pointer RDDSC DEC 9 data set count RDDSP DEC 10 data set table pointer RDSOP DEC 11 sort table pointer jDEC 12 RDLMD DEC 13 lock flag/open mode RDLFG EQU RDLMD 1st byte: lock flag RDMOD EQU RDLMD 2nd byte: open mode DEC 14 RDCBC DEC 15 # of DCBs desired = 0 RDMDL DEC 16 maximum data length * ZERO EQU RDNAM base of zero for future equates *** *** * * * Data Item Table - one 5 word entry per item in a 1000 data base * * * *** *** RI1LN EQU ZERO+5 length of a 1000 entry * RI1NM EQU ZERO item name - 3 words RI1NO EQU ZERO+3 item number RI1IL EQU ZERO+4 item length *** *** * * * Data Set Table - one 6 word entry per set in a 1000 data base * * * *** *** RS1LN EQU ZERO+6 length of a 1000 entry * RS1NM EQU ZERO set name - 3 words RS1NO EQU ZERO+3 set number RS1EL EQU ZERO+4 entry length (in words) RS1KL EQU ZERO+5 key item length for a master *** *** * * * Sort Table - one 1 word entry per item and per set. Each entry * * is a pointer to the respective item or set table * * entry relative to the start of the Run Table * * * *** *** A EQU 0 B EQU 1 * ENT RBCST,RBCIT EXT .CMW,.ENTR,AIRUN * SET NOP NUMBR NOP ADDRS NOP * * Get true parameter an>0d return point addresses. * RBCST NOP JSB .ENTR DEF SET * * Initialize Set Table search parameters: * 1) Get length of Set Table entry. This is the value in RS1LN. * LDB RS1LN STB ENTLN * * 2) Get number of sets in data base (10th word of DBCB), add one * and this is the highest index for the search. * LDA AIRUN ADA RDDSC LDB A,I INB STB HIGH * * 3) Get pointer to Set Table (11th word of DBCB). This is relative * to start of Run Table. * INA LDB A,I STB TABAD * * 4) Determine address of the set Sort Table = pointer to Sort Table * (12th word of DBCB) + number of items (8th word of DBCB) + * address of Run Table. * INA LDB A,I ADA M4 ADB A,I ADB AIRUN STB STADR * * 5) Set lowest index for search to zero. * << RBCIT joins RBCST at this point. >> * JOIN CLA STA LOW * * 6) Get the first index for the search, this is HIGH/2. * LDA HIGH ARS STA INDEX * * Done with initialization. Determine if a name or number was given. * If a number, the high order byte will be zero, if a name, non-zero. * In either case, if the sign bit is set, the parameter is erroneous. * LDA SET,I SSA JMP CST8 Negative parameter - error. * AND HIBYT SZA JMP CST3 A name reference given. SKP * * Here when a number is given. Perform binary search on Set (or Item) * Table without Sort Table. When an entry is chosen by the algorithm * the address of the entry is calculated by: * (INDEX - 1) * ENTLN + TABAD + AIRUN. * The number in the entry (fourth word in the table entry) is then com- * pared with the number given. * CST1 CCA Get entry's address. ADA INDEX CLB MPY ENTLN ADA TABAD STA ADDRS,I (this is returned if e]ntry a match) ADA AIRUN * ADA RS1NO Get entry's number LDA A,I STA NUMBR,I (this is returned if entry a match) * CMA,INA Compare numbers ADA SET,I SSA JMP CST2 Entry's number > given number SZA,RSS JMP CST7 Entry's number = given number * JSB CHIGH Entry's number < given number. JMP CST1 Get next (higher) index & try it. * CST2 JSB CLOW (Entry>given). Get next JMP CST1 (lower) index & try it. SKP * * Here when a name is given. Perform binary search on Set (or Item) * Table using the Sort Table as a sorted binary tree and using the name * given and the name of the Table entry as the objects of comparison. * When an entry of the Sort Table is chosen by the algorithm, the cor- * responding Set (or Item) Table entry address is calculated by: * Contents of Sort Table entry + AIRUN. * The comparison of names is then performed. * CST3 CCA ADA INDEX ADA STADR LDA A,I A = pointer to entry STA ADDRS,I (this is returned if entry a match) * ADA AIRUN A -> entry LDB SET B -> given name JSB .CMW Compare names. DEF D3 DEC 0 JMP CST6 A match JMP CST5 Entry's name < given name. * JSB CLOW Entry's name > given name. JMP CST3 Get next (lower) index & try it. * CST5 JSB CHIGH (Entry number STA NUMBR,I thanks to CMW * CST7 ISZ RBCST Take normal return when CST8 JMP RBCST,I a match is found. SKP * * Following are the subroutines which do the new index calculations. * First is CLOW. CLOW is called when the entry in the Table chosen by * the algorithm has a comparitor value > that given by the user. The * current index becomes the new HIGH index and CLOW calculates the next * index to use by: * INDEX = INDEX - (HIGH - LOW) / 2. * CLOW NOP CCA Make sure that we are not ADA INDEX already on the lowest CMA,INA posible index. ADA LOW SSA,RSS JMP CST8 Lowest - no matching entry. * LDA INDEX Okay - calculate next STA HIGH (lower) index. LDB LOW CMB,INB ADA B ARS CMA,INA ADA INDEX STA INDEX JMP CLOW,I * * Next is CHIGH. CHIGH is called when the entry in the Table chosen by * the algorithm has a comparitor value < that given by the usr. The * current INDEX becomes the new LOW index and CHIGH calculates the next * index to use by: * INDEX = INDEX + (HIGH - LOW) / 2. * CHIGH NOP LDA INDEX Make sure that we are not INA already on highest CMA possible index. ADA HIGH SSA JMP CST8 Highest - no matching entry. * LDA INDEX Okay - calcualte next STA LOW (higher) index. CMA,INA ADA HIGH ARS ADA INDEX STA INDEX JMP CHIGH,I SKP * * Entry point for RBCIT. The function of RBCIT is the same as RBCST, * except RBCIT works on the Item Table, Item Sort Table, and is called * with an item name or number. The calling sequence for RBCIT is: * * JSB RBCIT * DEF *+4 * DEF ITEM item name or number * DEF NUMB2 returned item number * DEF ADDR2 returned Item Table pointer * < error return > * < normal return > * ITEM NOP NUMB2 NOP ADDR2 NOP * * Get true parameter and return point addresses. * RBCIT NOP JSB .ENTR DEF ITEM * * Initialize Item Table search parameters: * 1) Get length of Item Table entry. This is the value in RI1LN. * LDB RI1LN STB ENTL *($N * * 2) Get number of items in data base (8th word of DBCB), add one * and this is the highest index for the search. * LDA AIRUN ADA RDITC LDB A,I INB STB HIGH * * 3) Get pointer to Item Table (9th word of DBCB). This is relative * to start of Run Table. * INA LDB A,I STB TABAD * * 4) Get address of item Sort Table = pointer to Sort Table (12th * word of DBCB) + address of Run Table. * ADA D3 LDB A,I ADB AIRUN STB STADR * * From this point on, set and item processing is identical. So, make * RBCST look like the point at which we were entered and jump to JOIN * for the joint processing. * LDA ITEM Move parameter addresses. STA SET LDA NUMB2 STA NUMBR LDA ADDR2 STA ADDRS * LDA RBCIT Move return address STA RBCST JMP JOIN and join set processing. * * * Constants and variables. * M4 DEC -4 D3 EQU ZERO+3 * HIBYT OCT 177400 * ENTLN NOP STADR NOP TABAD NOP HIGH NOP LOW NOP INDEX NOP END $END o* K W 92069-18229 1912 S C0122 &DBIDR DBIDR SOURCE             H0101 WASMB,L,C,R HED DBIDS UTILITY SUBROUTINE FOR RDBA-IMAGE/1000 NAM DBIDS,7 92069-16229 REV.1912 790130 * * ******************************************************************* * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR WRITTEN * CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18229 * RELOC: 92069-16229 * * PRGMR: CEJ * * ******************************************************************* * * * * If DS is a utility subroutine for the RDBA-DBMS subroutines which ac- * cepts the BASE parameter from the DBMS call and determines if the data * base is on a remote machine. If the data base is local, it returns * at P+2. If remote at P+3. * * The calling sequence for DBIDS is: * * CLA (for DBOPN meaning data base is not already open) * or * CCA (for all other subroutines, data base is already open) * JSB DBIDS * DEF *+2 return point * DEF BASE base parameter from call * * * * A EQU 0 B EQU 1 * ENT DBIDS EXT #NODE,.ENTP,AIRUN,DBFRT * * Get true parameter and return point addresses. * BASE NOP * DBIDS NOP STA SAVE Save A reg. for later. NOP Note: this NOP is necessary for .ENTP JSB .ENTP DEF BASE * * If A register was zero at entry, the node number is in the first word * of the BASE parameter. * LDA SAVE SZA JMP NOPEN * * Call from DBOPN, get node number from BASE and join with non-opens for * the comparison. * LDB BASE,I JMP JOIN * * Call is not from DBOPN, ask DBFRT to find the Run Table for this daY  ta * base and to set it up as the current Run Table. * NOPEN JSB DBFRT DEF *+2 DEF BASE,I * SSA Did DBFRT succeed? JMP EXIT No - invalid BASE parameter. * * Get node number from 6th word of DBCB. * LDA AIRUN ADA DBDSN LDB A,I * * If node number is two blanks, a -1, or this node's number, data base is * local, else data base is remote. * JOIN CPB BLNKS JMP LOCAL CPB #NODE JMP LOCAL INB,SZB * ISZ DBIDS Remote return LOCAL ISZ DBIDS Local return EXIT JMP DBIDS,I * * Constants and variables. * DBDSN DEC 5 BLNKS ASC 1, * SAVE NOP END END$ G  LS 92069-18235 1912 S C0122 &DBHD3 DBHD3 SOURCE             H0101 [8ASMB HED HEADER FOR %REMOT NAM REMOT,7 92069-12004 REV.1912 790430 * * ******************************************************************* * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR WRITTEN * CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18235 * RELOC: 92069-16235 * * PRGMR: CEJ * * ******************************************************************* * * END  MS 92069-18236 1912 S C0122 &RMOPN RMOPN SOURCE             H0101 ASMB,L,C,R HED DBOPN SUBROUTINE FOR REMOTE ONLY ACCESS NAM DBOPN,7 92069-16236 REV.1912 790130 * * ******************************************************************* * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR WRITTEN * CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18236 * RELOC: 92069-16236 * * PRGMR: CEJ * * ******************************************************************* * * * * This version of DBOPN is for remote only data base access. It assumes * that the data base is remote and merely provides an interface between * the user and RBOPN which handles the remote open. * * * The calling sequence for DBOPN is: * * JSB DBOPN * DEF *+5 return point * DEF BASE an array containing: * a DS/1000 node # in the first word followed * by an FMP namr string specifying at least * the data base name and security code. * On a successful return, DBOPN stores a data * base number in the first word of the array. * DEF LEVEL an array containing the user's level code word * three words long, padded by trailing blanks * if necessary. * DEF MODE DBOPN mode, a one word integer. * DEF STAT a ten word array in which status information * is returned to the user. This subroutine * uses only the first three words which are * as follows: * word contents *    ---- -------- * 1 status code (0 if successful) * if successful: * 2 user's assigned access level * 3 word length of Run Table * A EQU 0 B EQU 1 * SKP ENT DBOPN EXT .ENTR,RBOPN * BASE NOP LEVEL NOP MODE NOP STAT NOP * * Get true parameter and return point addresses. * DBOPN NOP JSB .ENTR DEF BASE * * Make sure all the parameters are there. * LDA STAT SZA,RSS JMP EXIT Missing parameter. * * Ask RBOPN to handle this request. * JSB RBOPN DEF *+5 DEF BASE,I DEF LEVEL,I DEF MODE,I DEF STAT,I * * Reset STAT to zero for parameter check on next entry. * EXIT CLA STA STAT * * Return to caller. * JMP DBOPN,I END END$  NU 92069-18237 1912 S C0122 &RMINF RMNIF SOURCE             H0101 jASMB,L,C,R HED DBINF SUBROUTINE FOR REMOTE ONLY ACCESS NAM DBINF,7 92069-16237 REV.1912 790130 * * ******************************************************************* * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR WRITTEN * CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18237 * RELOC: 92069-16237 * * PRGMR: CEJ * * ******************************************************************* * * * * This version of DBINF is for remote only data base access. It assumes * that the data base is remote and merely provides an interface between * the user and RBINF which handles the remote Info call. * * The calling sequence for DBINF is: * * JSB DBINF * DEF *+6 return point * DEF IBASE data base about which information is to be returned. * This must be the same parameter as used in a * successful remote DBOPN call for the data base. * DEF ID a data set name or number or * a data item name or number * (When the mode calls for a specific set or item.) * DEF MODE DBINF mode, a one word integer. * DEF STAT status return array of the form: * 1st word always the status word, zero on a suc- * cessful return * 2nd word contains the word length of the informa- * tion in the BUF parameter when 1st word is * zero. * DEF BUF buffer to contain returned information (supplied * information on a 402 call). * SKP ENT DBINF EXT .ENTR,DBIDS,RBINF * A EQU 0 I   B EQU 1 * BASE NOP ID NOP MODE NOP STAT NOP BUF NOP * * Get true parameter and return point addresses. * DBINF NOP JSB .ENTR DEF BASE * * Make sure all the parameters are there. * LDA BUF SZA,RSS JMP E162 Missing parameter. * * Ask DBIDS to check the data base specified in BASE to see if it is * valid, and if so to set up its Run Table as the current Run Table. * CCA A = -1 signifies not DBOPN calling. JSB DBIDS DEF *+2 DEF BASE,I * JMP E103 Error return - illegal BASE param. NOP (Local data base return - ignore.) * * Ask RBINF to handle this request. * JSB RBINF DEF *+6 DEF BASE,I DEF ID,I DEF MODE,I DEF STAT,I DEF BUF,I * * Reset BUF to zero for parameter check on next entry. * EXIT CLA STA BUF * * Return to caller. * JMP DBINF,I * * Error return points. * E103 LDA D103 Illegal BASE parameter. RSS E162 LDA D162 Missing parameter. STA STAT,I JMP EXIT * * D103 DEC 103 D162 DEC 162 END END$  OV 92069-18238 1912 S C0122 &RMFND RMFND SOURCE             H0101 jASMB,L,C,R HED DBFND SUBROUTINE FOR REMOTE ONLY ACCESS NAM DBFND,7 92069-16238 REV.1912 790130 * * ******************************************************************* * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR WRITTEN * CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18238 * RELOC: 92069-16238 * * PRGMR: CEJ * * ******************************************************************* * * * * This version of DBFND is for remote only data base access. It assumes * that the data base is remote and merely provides an interface between * the user and RBFND which handles the remote Find. * * The calling sequence for DBFND is: * * JSB DBFND * DEF *+7 return point * DEF IBASE data base parameter used in succesful remote * DBOPN call for the data base in which the set * to be initialized resides. * DEF SET the name or number of the detail data set to * be prepared for chain reads. * DEF MODE DBFND mode = 1 * DEF STAT returned 10 word status array which is of the * form: * 1st word - status code (0 if successful) * 2nd word - zero * 3rd & 4th words - doubleword current record * number set to zero * 5th & 6th words - doubleword count of detail * entries in the chain * 7th & 8th words - doubleword record number of * chain foot * S   9th & 10th words - doubleword record number * of chain head * DEF ITEM detail's key item number for desired chain * DEF ARG key item's value for desired chain * SKP ENT DBFND EXT .ENTR,DBIDS,RBFND * A EQU 0 B EQU 1 * BASE NOP SET NOP MODE NOP STAT NOP ITEM NOP ARG NOP * * Get true parameter and return point addresses. * DBFND NOP JSB .ENTR DEF BASE * * Make sure all the parameters are there. * LDA ARG SZA,RSS JMP E162 Missing parameter. * * Ask DBIDS to check the data base specified in BASE to see if it is * valid, and if so to set up its Run Table as the current Run Table. * CCA A = -1 signifies not DBOPN calling. JSB DBIDS DEF *+2 DEF BASE,I * JMP E103 Error return - illegal BASE param. NOP (Local data base return - ignore.) * * Ask RBFND to handle this request. * JSB RBFND DEF *+7 DEF BASE,I DEF SET,I DEF MODE,I DEF STAT,I DEF ITEM,I DEF ARG,I * * Reset ARG to zero for parameter check on next entry. * EXIT CLA STA ARG * * Return to user. * JMP DBFND,I * * Error return points. * E103 LDA D103 Illegal base parameter. RSS E162 LDA D162 Missing parameter. STA STAT,I JMP EXIT * * D103 DEC 103 D162 DEC 162 END END$  PW 92069-18239 1912 S C0122 &RMGET RMGET SOURCE             H0101 rASMB,L,C,R HED DBGET SUBROUTINE FOR REMOTE ONLY ACCESS NAM DBGET,7 92069-16239 REV.1912 790130 * * ******************************************************************* * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR WRITTEN * CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18239 * RELOC: 92069-16239 * * PRGMR: CEJ * * ******************************************************************* * * * * This version of DBGET is for remote only data base access. It assumes * that the data base is remote and merely provides an interface between * the user and RBGET which handles the remote Get. * * The calling sequence for DBGET is: * * JSB DBGET * DEF *+8 return point * DEF IBASE the data base parameter used on a successful * remote DBOPN call for the data base from * which data is to be retrieved. * DEF ISET the name or number of the detail or manual * master data set from which data is to be * retrieved. * DEF IMODE DBGET mode, a one word integer. * DEF ISTAT a ten word array in which the following is * returned to the user: * word contents * ---- -------- * 1 error code (zero if successful) * If successful: * 2 word length of data returned. * 3-4 record # of entry read * 5-6 zero *  7-8 record # of predecessor of entry * read along current chain * 9-10 record # of successor of entry * read along current chain * DEF LIST a list of item names or numbers whose values * are to be returned to the user from the * entry read * DEF IBUF the buffer into which the item values of the * items specified in LIST are to be put con- * catenated together in the order of the * items in LIST * DEF IARG a doubleword record number for mode 4 * or * the key item value for mode 7 * SKP A EQU 0 B EQU 1 * ENT DBGET EXT .ENTR,DBIDS,RBGET * BASE NOP SET NOP MODE NOP STAT NOP LIST NOP BUF NOP ARG NOP * * Get true parameter and return point addresses * DBGET NOP JSB .ENTR DEF BASE * * Make sure all the parameters are there. * LDA ARG SZA,RSS JMP E162 Missing parameter. * * Ask DBIDS to check the data base specified in BASE to see if it is * valid, and if so to set up its Run Table as the current Run Table. * CCA A = -1 signifies not DBOPN calling. JSB DBIDS DEF *+2 DEF BASE,I * JMP E103 Error return - illegal BASE param. NOP (Local data base return - ignore.) * * Ask RBGET to handle this request. * JSB RBGET DEF *+8 DEF BASE,I DEF SET,I DEF MODE,I DEF STAT,I DEF LIST,I DEF BUF,I DEF ARG,I * * Reset ARG to zero for parameter check on next entry. * EXIT CLA STA ARG * * Return to cal ler. * JMP DBGET,I * * Error return points. * E103 LDA D103 Illegal base parameter. RSS E162 LDA D162 Missing parameter. STA STAT,I JMP EXIT * * D103 DEC 103 D162 DEC 162 END END$  QY 92069-18240 1912 S C0122 &RMUPD RMUPD SOURCE             H0101 |ASMB,L,C,R HED DBUPD SUBROUTINE FOR REMOTE ONLY ACCESS NAM DBUPD,7 92069-16240 REV.1912 790130 * * ******************************************************************* * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR WRITTEN * CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18240 * RELOC: 92069-16240 * * PRGMR: CEJ * * ******************************************************************* * * * * This version of DBUPD is for remote only data base access. It assumes * that the data base is remote and merely provides an interface between * the user and RBUPD which handles the remote Update. * * The calling sequence for DBUPD is: * * JSB DBUPD * DEF *+7 return point * DEF BASE the data base parameter used in a successful re- * mote DBOPN on the data base in which an entry * is to be updated. The data base must have been * opened in either mode 1 or mode 3. * DEF SET data set name or number of the data set in which * the current entry is to be updated. * DEF MODE DBUPD mode = 1. * DEF STAT a ten word array in which the status of the call * is returned. This subroutine only uses the first * two words in which it returns: * word contents * ---- -------- * 1 error code (zero if successful) * If successful: * 2 word length of data in BUF * DEF LIST a list of items whose values in the data record7 * of the current entry in SET are to be replaced * by the values in BUF. Non-writeable and key * items may appear in this list but their values * in BUF must be identical to their values in the * data record. * DEF BUF the values of the items to replaced concatenated * together and in the same order as the items in * LIST. * SKP A EQU 0 B EQU 1 * ENT DBUPD EXT .ENTR,DBIDS,RBUPD * BASE NOP SET NOP MODE NOP STAT NOP LIST NOP BUF NOP * * Get true parameter and return addresses. * DBUPD NOP JSB .ENTR DEF BASE * * Make sure all the parameters are there. * LDA BUF SZA,RSS JMP E162 Missing parameter. * * Ask DBIDS to check the data base specified in BASE to see if it is * valid, and if so to set up its Run Table as the current Run Table. * CCA A = -1 signifies not DBOPN calling. JSB DBIDS DEF *+2 DEF BASE,I * JMP E103 Error return - illegal BASE param NOP (Local data base return - ignore.) * * Ask RBUPD to handles this request. * JSB RBUPD DEF *+7 DEF BASE,I DEF SET,I DEF MODE,I DEF STAT,I DEF LIST,I DEF BUF,I * * Reset BUF to zero for parameter check on next entry. * EXIT CLA STA BUF * * Return to caller. * JMP DBUPD,I * * Error return points. * E103 LDA D103 Illegal BASE parameter. RSS E162 LDA D162 Missing parameter. STA STAT,I JMP EXIT * * D103 DEC 103 D162 DEC 162 END END$ R  RZ 92069-18241 1912 S C0122 &RMPUT RMPUT SOURCE             H0101 ASMB,L,C,R HED DBPUT SUBROUTINE FOR REMOTE ONLY ACCESS NAM DBPUT,7 92069-16241 REV.1912 790130 * * ******************************************************************* * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR WRITTEN * CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18241 * RELOC: 92069-16241 * * PRGMR: CEJ * * ******************************************************************* * * * * This version of DBPUT is for remote only data base access. It assumes * that the data base is remote and merely provides an interface between * the user and RBPUT which handles the remote Put. * * The calling sequence for DBPUT is: * * JSB DBPUT * DEF *+7 return point * DEF BASE the data base parameter used in a successful * remote DBOPN call for the data base in which * an entry is to be added. The data base must * have been opened in either mode 1 or 3, and * if mode 1 must have been previously locked * to the user. * DEF SET the name or number of the manual master or * detail data set in which the entry is to * be added. * DEF MODE DBPUT mode = 1. * DEF STAT a ten word status array in which the follow- * ing is returned: * word contents * ---- -------- * 1 status code (0 if successful) * If successful: *  2 word length of contents of BUF * 3-4 new entry's record number * 5-6 count of entries in * - last chain if detail * - synonym chain if master * 7-8 record number of predecessor in * - last chain if detial * - synonym chain if master * 9-10 zero * DEF LIST a list of item names or numbers of the items * in the data set which are to receive values * in the new entry. Must contain all key * items in the data set. * DEF BUF the values for the items in LIST concatenated * together and in the same order as the items * in LIST. * SKP A EQU 0 B EQU 1 * ENT DBPUT EXT .ENTR,DBIDS,RBPUT * BASE NOP SET NOP MODE NOP STAT NOP LIST NOP BUF NOP * * Get true parameter and return point addresses * DBPUT NOP JSB .ENTR DEF BASE * * Make sure all the parameters are there. * LDA BUF SZA,RSS JMP E162 Missing parameter. * * Ask DBIDS to check the data base specified by the BASE parameter to * see if it is valid, and if so to set up its Run Table as the current * Run Table. * CCA A = -1 signifies not DBOPN calling. JSB DBIDS DEF *+2 DEF BASE,I * JMP E103 Error return - illegal BASE param. NOP (Local data base return - ignore.) * * Ask RBPUT to handle this request. * JSB RBPUT DEF *+7 DEF BASE,I DEF SET,I DEF MODE,I DEF STAT,I DEF LIST,I DEF BUF,I * n * Reset BUF to zero for parameter chech on next entry. * EXIT CLA STA BUF * * Return to caller. * JMP DBPUT,I * * Error return points. * E103 LDA D103 Illegal BASE parameter. RSS E162 LDA D162 Missing parameter. STA STAT,I JMP EXIT * * D103 DEC 103 D162 DEC 162 END END$ R S[ 92069-18242 1912 S C0122 &RMDEL RMPUT SOURCE             H0101 xASMB,L,C,R HED DBDEL SUBROUTINE FOR REMOTE ONLY ACCESS NAM DBDEL,7 92069-16242 REV.1912 790130 * * ******************************************************************* * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR WRITTEN * CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18242 * RELOC: 92069-16242 * * PRGMR: CEJ * * ******************************************************************* * * * * This version of DBDEL is for remote only data base access. It assumes * that the data base is remote and merely provides an interface between * the user and RBDEL which handles the remote Delete. * * The calling sequence for DBDEL is: * * JSB DBDEL * DEF *+5 return point * DEF BASE the data base parameter used in a successful * remote DBOPN for the data base from which the * entry is to be removed. The data base must have * been opened in mode 1 or 3, and if mode 1 must * have been previously locked to the user. * DEF SET the name or number of the manual master or detail * data set from which the current entry is to be * deleted. * DEF MODE DBDEL mode = 1 * DEF STAT a 10 word status array of which only the first * word is used by this subroutine to return to * the user a status code, zero if successful. * SKP A EQU 0 B EQU 1 * ENT DBDEL EXT .ENTR,DBIDS,RBDEL * BASE NOP SET NOP MODE NOP STAT NOP * * Get true parameter and return point addresses. * DBDEL NOP t   JSB .ENTR DEF BASE * * Make sure all the parameters are there. * LDA STAT SZA,RSS JMP EXIT Missing parameter. * * Ask DBIDS to check the data base specified in BASE to see if it is * valid, and if so to set up its Run Table as the current Run Table. * CCA A = -1 signifies not DBOPN calling. JSB DBIDS DEF *+2 DEF BASE,I * JMP E103 Error return - illegal BASE param. NOP (Local data base return - ignore.) * * Ask RBDEL to handle this request. * JSB RBDEL DEF *+5 DEF BASE,I DEF SET,I DEF MODE,I DEF STAT,I * * Reset STAT to zero for parameter check on next entry. * EXIT CLA STA STAT * * Return to user. * JMP DBDEL,I * * Error return points. * E103 LDA D103 Illegal BASE parameter. STA STAT,I JMP EXIT * * D103 DEC 103 END END$ b  T[ 92069-18243 1912 S C0122 &RMLCK RMLCK SOURCE             H0101 mASMB,L,C,R HED DBLCK AND DBUNL SUBROUTINES FOR REMOTE ONLY ACCESS NAM DBLCK,7 92069-16243 REV.1912 790130 * * ******************************************************************* * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR WRITTEN * CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18243 * RELOC: 92069-16243 * * PRGMR: CEJ * * ******************************************************************* * * * * This version of DBLCK is for remote only data base access. It assumes * that the data base is remote and merely provides an interface between * the user and RBLCK which handles the remote Lock. * * The calling sequence for DBLCK is: * * JSB DBLCK * DEF *+5 return point * DEF IBASE data base to be locked - must be the same para- * meter as used in a successful remote DBOPN * call. * DEF ISET (currently unused - place holder) * DEF MODE =1 for a lock with wait * =2 for a lock without wait * DEF ISTAT ten word status array (only first word is used * by this subroutine * ENT DBLCK,DBUNL EXT .ENTR,DBIDS,RBLCK,RBUNL * A EQU 0 B EQU 1 * LBASE NOP LSET NOP LMODE NOP LSTAT NOP * * Get true addresses of parameters and return point. * DBLCK NOP JSB .ENTR DEF LBASE * * Make sure all the parameters are there. * LDA LSTAT SZA,RSS JMP LEXIT Missing parameter. * * Ask DBIDS to check the data base specified in BASE to see if it is * valid, and if so set up its Run Table as the current Run Table. * CCA A = -1 signifies not DBOPN calling. JSB DBIDS DEF *+2 DEF LBASE,I * JMP L103 Error return - illegal BASE parameter. NOP (Local data base return - ignore.) * * Ask RBLCK to handle this request. * JSB RBLCK DEF *+5 DEF LBASE,I DEF LSET,I DEF LMODE,I DEF LSTAT,I * * Reset LSTAT to zero for parameter check on next entry. * LEXIT CLA STA LSTAT * * Return to user. * JMP DBLCK,I * * Error return points. * L103 LDA D103 Illegal BASE parameter. STA LSTAT,I JMP LEXIT SKP * * This version of DBUNL is for remote only data base access. It assumes * that the data base is remote and merely provides an interface between * the user and RBUNL which handles the remote Unlock. * * The calling sequence for DBUNL is: * * JSB DBUNL * DEF *+5 return point * DEF IBASE data base to be unlocked - must be the same para- * meter as used in a successful remote DBOPN call. * DEF ISET (currently unused - place holder) * DEF MODE = 1 * DEF ISTAT ten word status array (only the first word is * used by this subroutine * UBASE NOP USET NOP UMODE NOP USTAT NOP * * Get true parameter and return point addresses. * DBUNL NOP JSB .ENTR DEF UBASE * * Make sure all the parameters are there. * LDA USTAT SZA,RSS JMP UEXIT Missing parameter. * * Ask DBIDS to check the data base specified in UBASE to see if it is * valid, and if so to set up its Run Table as the current Run Table. * CCA A = -1 signifies not DBOPN calling. JSB DBIDS DEF *+2 DEF UBASE,I * JMP U103 Error return - illegal UBASE param. NOP (Local data base return - ignore.) * * Ask RBUNL to handle this request. * ` JSB RBUNL DEF *+5 DEF UBASE,I DEF USET,I DEF UMODE,I DEF USTAT,I * * Reset USTAT to zero for parameter check on next entry. * UEXIT CLA STA USTAT * * Return to user. * JMP DBUNL,I * * Error return points. * U103 LDA D103 Illegal BASE parameter. STA USTAT,I JMP UEXIT * * D103 DEC 103 END END$ h U] 92069-18244 1912 S C0122 &RMCLS RMCLS SOURCE             H0101 uASMB,L,C,R HED DBCLS SUBROUTINE FOR REMOTE ONLY ACCESS NAM DBCLS,7 92069-16244 REV.1912 790130 * * ******************************************************************* * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR WRITTEN * CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18244 * RELOC: 92069-16244 * * PRGMR: CEJ * * ******************************************************************* * * * * This version of DBCLS is for remote only data base access. It assumes * that the data base is remote and merely provides an interface between * the user and RBCLS which handles the remote Close. * * The calling sequence for DBCLS is: * * JSB DBCLS * DEF *+5 * DEF BASE data base parameter used in a successful * remote DBOPN call for the data base which is * to be closed or which contains the data set * to be closed. * DEF SET the name or number of the data set to be * closed if a mode 2 close. * DEF MODE DBCLS mode, a one word integer. * DEF STAT a ten word array in which status information * is returned to the user. This subroutine * uses only the first word of this array in * which is stores an error code, zero if * successful. * SKP A EQU 0 B EQU 1 * ENT DBCLS EXT .ENTR,DBIDS,RBCLS * BASE NOP SET NOP MODE NOP STAT NOP * * Get true parameter and return point addresses. * DBCLS NOP JSB .ENTR DEF BASE * G   * Make sure all the parameters are there. * LDA STAT SZA,RSS JMP EXIT Missing parameter. * * Ask DBIDS to check the data base specified in BASE to see if it is * valid, and if so to set up its Run Table as the current Run Table. * CCA A = -1 signifies not DBOPN calling. JSB DBIDS DEF *+2 DEF BASE,I * JMP E103 Error return - illegal BASE param. NOP (Local data base return - ignore.) * * Ask RBCLS to handle this request. * JSB RBCLS DEF *+5 DEF BASE,I DEF SET,I DEF MODE,I DEF STAT,I * * Reset STAT to zero for parameter check on next entry. * EXIT CLA STA STAT * * Return to caller. * JMP DBCLS,I * * Error return points. * E103 LDA D103 Illegal BASE parameter. STA STAT,I JMP EXIT * * D103 DEC 103 END END$ L  V] 92069-18250 2040 S C0122 &DBHD4 &DBHD4 %NO/DS HEADER             H0101 ASMB HED HEADER FOR %NO/DS NAM NO/DS,7 92069-12005 REV.2040 800730 * * ******************************************************************* * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR WRITTEN * CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18250 * RELOC: 92069-16250 * * PRGMR: CEJ * * ******************************************************************* * * END ` W] 92069-18251 2040 S C0122 &STUB &STUB STUB OUT DS             H0101 ASMB NAM STUB,7 92069-16251 REV.2040 800730 * * ****************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH OUT THE PRIOR * WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18251 * RELOC: 92069-16251 * * *****************************************************************: * * * * * EXT .ENTR ENT #CNOD,#NODE,DEXEC,RMCLN * * * * #CNOD DEC -1 #NODE DEC -1 DEXEC NOP JSB .ENTR DEF DEXEC JMP DEXEC,I * * * RMCLN NOP JSB .ENTR DEF RMCLN CCA JMP RMCLN,I * * DSERR ASC 2,DS01 END a X^ 92069-18252 1912 S C0122 &RDFAK RDFAK SOURCE             H0101 {]ASMB,L,C HED RD.TB STUB FOR LOCAL ONLY DBMS NAM RD.TB,7 91079-16252 REV.1912 790131 * * ******************************************************************* * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR WRITTEN * CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18252 * RELOC: 92069-16252 * * PRGMR: CEJ * * ******************************************************************* * * ENT RD.TB RD.TB DEC 0 END * Y_ 92069-18255 2026 S C0122 &BAIMX              H0101 zASMB,R,L,B HED <> NAM BAIMG,7 92069-16255 REV.2026 800201 * * ******************************************************************* * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR WRITTEN * CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18255 * RELOC: 92069-16255 * * PRGMR: CEJ * ALTERED: FEBUARY 1, 1980 FOR SORTED CHAINS FEATURE - CEJ * * ******************************************************************* * * * * ENT DMOPN,DMINF,DMFND,DMGET,DMUPD,DMPUT,DMDEL,DMCLS ENT DMLCK,DMUNL * EXT $CVT3,.ENTR,.FIXD,.FLTD,.MVW,DBOPN,DBINF,DBFND EXT DBGET,DBUPD,DBPUT,DBDEL,DBCLS,DBLCK,DBUNL EXT DCITA,FLOAT,IFIX,NAMR,RSFLG * * * * CALLING SEQUENCE: * CALL DBOPN(BASEO,LEVLO,MODEO,STATO) * * * ENTRY IN BASIC SUBROUTINE TABLE: * DBOPN(RVA,RA,I,IVA), OV=NN, ENT=DMOPN, FIL=%BAIMG * * WHERE NN IS THE OVERLAY NUMBER * * BASEO NOP LEVLO NOP MODEO NOP STATO NOP * DMOPN NOP ENTRY JSB .ENTR FETCH PARAMETERS DEF BASEO * JSB ASCI CONVERT STRING TO ASCII DEF BASEO PASS ADDRESS OF STRING * LDA BASEO,I MAKE SURE BASE STARTS WITH CPA BLNKS TWO BLANKS RSS JMP E310 * JSB ASCI CONVERT STRING TO ASCII DEF LEVLO PASS ADDRESS OF STRING * JSB PAD PAD LEVEL NAME TO 6 CHARACTERS DEF *+3 DEF LEVLO DEF NAME1 * JSB DBOPN CALL IMAGE OPEN ROUTINE DEF *+5 DEF BASEO,I DEF NAME1 DEF MODEO,I DEF STATO,I * EXTO1 JSB RSFLG  SET SAVE RESOURCES FLAG DEF *+1 JMP DMOPN,I TERMINATE OPEN CALL * E310 LDA .310 ILLEGAL BASE PARAMETER ERROR. STA STATO,I JMP EXTO1 SKP * * * * CALLING SEQUENCE: * CALL DBINF(BASEI,IDI,MODEI,STATI,BUFI) * * * ENTRY IN BASIC SUBROUTINE TABLE: * DBINF(RA,RA,I,IVA,RVA), OV=NN, ENT=DMINF, FIL=%BAIMG * * WHERE NN IS THE OVERLAY NUMBER * * BASEI NOP IDI NOP MODEI NOP STATI NOP BUFI NOP * DMINF NOP ENTRY JSB .ENTR FETCH PARAMETERS DEF BASEI ISZ BASEI * JSB ASCI CONVERT STRING TO ASCII DEF IDI * JSB PAD PAD ID TO 6 CHARACTERS DEF *+3 DEF IDI DEF NAME1 * LDA MODEI,I SSA IS MODE < 0? JMP E324 YES - ILLEGAL DBINF REQUEST * CLB NO - DETERMINE AN INDEX INTO DIV .100 JUMP TABLE BASED ON MODE. * SZA,RSS A = QUOTIENT MODE/100 JMP E324 IS QUOTIENT > 0 CMA,INA ADA .4 AND <=4? SSA JMP E324 NO - ILLEGAL MODE. * SZB,RSS B = REMAINDER MODE/100 JMP E324 IS REMAINDER > 0 CMB,INB ADB .4 AND <=4? SSB JMP E324 NO - ILLEGAL MODE. * ALS,ALS A = (4-QUOTIENT)*2+(4-REMAINDER) IOR B ADA JMPTB JMP A,I * JMPTB DEF *+1 JMP E324 MODE = 404 JMP E324 MODE = 403 JMP INF8 MODE = 402 JMP INF8 MODE = 401 * JMP E324 MODE = 304 JMP E324 MODE = 303 JMP INF7 MODE = 302 JMP INF6 MODE = 301 * JMP INF4 MODE = 204 JMP INF4 MODE = 203 JMP INF5 MODE = 202 QJMP INF1 MODE = 201 * JMP INF3 MODE = 104 JMP INF3 MODE = 103 JMP INF2 MODE = 102 JMP INF1 MODE = 101 * INF1 JSB INFO CALL IMAGE ROUTINE MODES 101 & 201. * LDA BUFFR IF A NEGATIVE NUMBER RETURNED, LDB MINUS THEN PUT A "- " IN BUFI SSA,RSS ELSE PUT A "+ " IN BUFI. LDB PLUS LDA .2 CHARACTER COUNT = 2. DST BUFI,I JMP EXITI * INF2 JSB INFO CALL IMAGE ROUTINE MODE 102. * LDB BUFI SET UP PBUF FOR PAK SUBROUTINE. INB STB PBUF * LDA BUFFR+8 GET ITEM TYPE AND ALF,ALF JSB PAK PACK IT INTO BUFI * LDA COMMA FOLLOW IT BY A COMMA. JSB PAK * LDA BUFFR+9 GET ELEMENT LENGTH AND CCE CONVERT IT INTO A DECIMAL JSB $CVT3 ASCII STRING. CCE,INA A -> 3 SIGNIFICANT CHARACTERS. RAL,ERA SET UP UPBUF FOR PACKN SUBROUTINE. STA UPBUF (SET SIGN BIT OF A.) JSB PACKN MOVE ELEMENT LENGTH INTO BUFI DEF .3 * LDA COMMA FOLLOW IT WITH A COMMA. JSB PAK * LDA BUFFR+10 GET ELEMENT COUNT, CCE AND CONVERT IT. JSB $CVT3 CCE,INA PUT THE RESULTANT 3 RAL,ERA SIGNIFICANT CHARACTERS STA UPBUF INTO BUFI. JSB PACKN DEF .3 * LDA .9 CHARACTER COUNT = 9. STA BUFI,I JMP EXITI * INF3 LDA .102 SET UP MODE FOR STA MODE ITEM CONVERSION. JMP INF34 * INF4 LDA .202 SET UP MODE FOR STA MODE SET CONVERSION. * INF34 JSB INFO CALL IMAGE ROUTINE MODES 103, 104 * 203 & 204. LDA BUFI SET UP FOR PAK SJUBROUTINE. INA STA PBUF * LDA BUFFR GET ITEM (OR SET) COUNT LDB A IF COUNT > 36 CMB,INB ADB .36 THEN TOO GREAT FOR SSB LENGTH OF BUFI LDA .36 RETURN ONLY 36 ITEM (OR SET) NAMES. CMA STA ITEMS SET COUNT FOR PAKIT. * CMA,CCE CONVERT POSITIVE COUNT JSB $CVT3 INTO A DECIMAL ASCII STRING CCE,INA A -> 3 SIGNIFICANT DIGITS RAL,ERA (SET SIGN BIT OF A.) STA UPBUF SET UP FOR PACKN JSB PACKN THEN ASK IT TO MOVE DEF .3 COUNT INTO BUFI. * LDA .3 SET UP FOR PAKIT STA COUNT COUNT = 3 CHARACTERS LDA OFSET INDEX INTO BUFFR = 1. STA INDX JSB PAKIT GO PACK NAMES INTO BUFI. * LDA COUNT SET CHARACTER COUNT IN BUFI STA BUFI,I JMP EXITI * INF5 JSB INFO CALL IMAGE ROUTINE MODE 202. * LDB BUFI SET UP PBUF FOR PAK. INB STB PBUF * LDA BUFFR+8 GET DATA SET TYPE AND ALF,ALF JSB PAK BUF IT INTO BUFI * LDA COMMA FOLLOW IT WITH A COMMA. JSB PAK * LDA BUFFR+9 CONVERT LENGTH OF ENTRY TO CCE A DECIMAL ASCII STRING. JSB $CVT3 INA A -> 4 SIGNIFICANT CHARACTERS. STA UPBUF JSB PACKN MOVE THOSE 4 INTO BUFI DEF .4 * LDA COMMA FOLLOW THEM WITH A COMMA JSB PAK * JSB DCITA CONVERT THE DOUBLEWORD ENTRY DEF *+3 COUNT TO A DECIMAL ASCII STRING. DEF BUFFR+13 DEF BUFF2 LDA OFST2 MOVE THIS STRING INTO BUFI STA UPBUF JSB PACKN DEF .10 * LDA COMMA FOLLOW WITH A COMMA AGAIN. JSB PAK * .JSB DCITA CONVERT DOUBLEWORD CAPACITY DEF *+3 INTO A DECIMAL ASCII STRING. DEF BUFFR+15 DEF BUFF2 LDA OFST2 MOVE STRING INTO BUFI STA UPBUF JSB PACKN DEF .10 * LDA .28 CHARACTER COUNT = 28 STA BUFI,I JMP EXITI * INF6 JSB INFO CALL IMAGE ROUTINE MODE 301. * LDB BUFI SET UP PBUF FOR PAK. INB STB PBUF * LDA BUFFR GET PATH COUNT LDB A CMB NEGATE IT AND SET ITEMS STB ITEMS FOR PKIT2. * CCE CONVERT PATH COUNT TO A JSB $CVT3 DECIMAL ASCII STRING. ADA .2 A -> 2 SIGNIFICANT CHARACTERS. STA UPBUF JSB PACKN PUT THOSE 2 CHARACTERS IN BUFI. DEF .2 * LDA .2 SET UP FOR PKIT2 STA COUNT CHARACTER COUNT = 2. LDA OFSET INDEX INTO BUFFR = 1. STA INDX JSB PKIT2 * LDA COUNT PUT CHARACTER COUNT INTO BUFI. STA BUFI,I JMP EXITI * INF7 JSB INFO CALL IMAGE ROUTINE MODE 302. * LDB BUFI SET UP PBUF FOR PAK. INB STB PBUF * LDA BUFFR IF ITEM # IS ZERO SZA,RSS JMP INF73 MOVE 6 BLANKS INTO BUFI LDA .102 STA MODE JSB DSNAM ELSE CONVERT NUMBER DEF BUFFR INTO A NAME. LDB OFST2 JMP INF75 * INF73 LDB BLNKS INF75 STB UPBUF JSB PACKN MOVE THE NAME OR BLANKS DEF .6 INTO BUFI * LDA .6 CHARACTER COUNT = 6. STA BUFI,I JMP EXITI * INF8 JSB INFO CALL IMAGE ROUTINE MODES 401 & 402. * LDB BUFI MOVE THE RETURNED LDA OFSTB INFO INTO BUFI STB PBUF NOTE THAT BUFI IS STA UPBUF THEN I wNACCESSIBLE BY JSB PACKN ANY BASIC PROGRAM. DEF .14 * LDA .7 SET RETURNED LENGTH TO 7 WORDS. JMP EXTI2 * EXITI INA SET RETURNED LENGTH TO CHARACTER ARS COUNT + 1 DIVIDED BY 2. * EXTI2 LDB STATI GET ADDRESS OF LENGTH WORD INB STA B,I AND PUT LENGTH INTO IT. JMP EXTI3 * ERRI LDA ISTAT GET CONDITION CODE ERRI2 STA STATI,I AND PUT IT INTO STATI. * EXTI3 JSB RSFLG SET SAVE RESOURCES FLAG DEF *+1 JMP DMINF,I AND TERMINATE INFO CALL. * * * E324 LDA .324 ILLEGAL DBINF REQUEST JMP ERRI2 SKP * * DBINF CALL INTERFACE ROUTINE * INFO NOP CALL IMAGE INFORMATION ROUTINE JSB DBINF DEF *+6 DEF BASEI,I DEF NAME1 DEF MODEI,I DEF STATI,I DEF BUFFR * LDA STATI,I TEST FOR ERROR IN INFO CALL. SZA JMP ERRI2 YES - EXIT INTERFACE. * JMP INFO,I NO - RETURN TO CALLER * * *************************************************************** * CONVERT DATA SET OR ITEM NUMBER TO A NAME * * * * CALLING SEQUENCE: MODE = 202 * * JSB DSNAM * * DEF SET * * OR * * MODE = 102 * * JSB DSNAM * * DEF ITEM * * * * NAME RETURNED IN WORDS 1,2,3 * * OF BUFF2 * ************************`*************************************** * DSNAM NOP LDA DSNAM,I STA TMP * JSB DBINF CALL IMAGE INFO SUBROUTINE DEF *+6 IN MODE 202 TO GET NAME. DEF BASEI,I DEF TMP,I DEF MODE DEF ISTAT DEF BUFF2 * LDA ISTAT CHECK FOR ERROR. SZA JMP ERRI2 YES - JUST CONVERT STATUS WORD ISZ DSNAM NO - INCREMENT RETURN ADDRESS JMP DSNAM,I AND RETURN. * * *************************************************************** * ROUTINES TO PACK A LIST OF ITEM OR SET NAMES * * * * CALLING SEQUENCE: MODE = 102 * * ITEMS = NUMBER OF ITEMS * * BUFFR = BUFFER OF NAMES * * INDX = OFFSET INTO BUFFR * * JSB PAKIT * * OR * * MODE = 202 * * SETS <-> ITEMS = NUMBER OF SETS * * BUFFR = BUFFER OF NAMES * * INDX = OFFSET INTO BUFFR * * JSB PAKIT * * * * NAMES ARE PACKED INTO BUFI, * * SEPARATED BY COMMAS * *************************************************************** * PAKIT NOP PAKI1 ISZ ITEMS TEST ITEM COUNT RSS JMP PAKIT,I ALL NAMES PACKED LDA COMMA PACK A COMMA JSB PAK * ISZ COUNT INCREMENT STRING CHARACTER COUNT LDB INDX,I SSB TEST FOR NEGATIVE ITEM NUMBER CMB,INCB YES, MAKE POSITIVE STB INDX,I * JSB DSNAM CONVERT DATA ITEM NUMBER TO NAME DEF INDX,I ITEM NUMBER * LDB OFST2 STB UPBUF SAVE ADDR OF BUFFER TO UNPACK FROM JSB PACKN TRANSFER ITEM NAME TO USER BUFFER DEF .6 * LDA COUNT ADA .6 ADD 6 TO STRING CHARACTER COUNT STA COUNT ISZ INDX INCREMENT POINTER TO NEXT ITEM JMP PAKI1 * * *************************************************************** * ROUTINE TO PACK A LIST OF DATA SET-DATA ITEM NAMES * * * * CALLING SEQUENCE: ITEMS = NUMBER OF DATA SETS + * * DATA ITEMS * * BUFFR = BUFFER OF SETS, ITEMS * * INDX = POINTER TO NEXT SET & * * ITEM PAIR IN BUFFR * * JSB PKIT2 * * NAMES ARE PACKED IN IBUF, * * SEPARATED BY COMMAS * *************************************************************** * PKIT2 NOP LOOP2 ISZ ITEMS TEST SET-ITEM COUNT RSS JMP PKIT2,I LDA COMMA PACK A COMMA JSB PAK ISZ COUNT INCREMENT STRING CHARACTER COUNT * LDA .202 STA MODE JSB DSNAM CONVERT DATA SET NUMBER TO NAME DEF INDX,I DATA SET NUMBER LDB OFST2 STB UPBUF SAVE ADDR OF BUFFER TO UNPACK FROM JSB PACKN PACK DATA SET NAME INTO IBUF DEF .6 LDA COUNT ADA .6 ADD 6 TO STRING CHARACTER COUNT STA COUNT * ISZ INDX INCREMENT POINTER TO NEXT ITEM LDA COMMA PACK A COMMA JSB PAK ISZ COUNT INCREMEN T STRING CHARACTER COUNT * LDA .102 STA MODE JSB DSNAM CONVERT ITEM NUMBER TO ITEM NAME DEF INDX,I DATA ITEM NUMBER LDB OFST2 STB UPBUF SAVE ADDR OF BUFFER TO UNPACK FROM JSB PACKN DEF .6 LDA COUNT ADA .6 ADD 6 TO STRING CHARACTER COUNT STA COUNT * ISZ INDX INCREMENT POINTER TO SORT ITEM LDA COMMA JSB PAK PACK A COMMA ISZ COUNT INCREMENT STRING CHAR. COUNT * LDA INDX,I IF SORT ITEM IS ZERO, SZA JMP PKT2 FILL BUFFER WITH BLANKS LDA BLNKS LDB OFST2 STA B,I INB STA B,I INB STA B,I JMP PKT3 THEN MOVE INTO PACKING BUFFER * PKT2 JSB DSNAM CONVERT ITEM NUMBER TO ITEM NAME DEF INDX,I SORT ITEM NUMBER PKT3 LDB OFST2 STB UPBUF SAVE ADDR OF BUFFER TO UNPACK FROM JSB PACKN DEF .6 LDA COUNT ADA .6 ADD 6 TO STRING CHARACTER COUNT STA COUNT * ISZ INDX INCREMENT POINTER TO NEXT SET JMP LOOP2 & ITEM PAIR * * *************************************************************** * STRING PACK ROUTINE * * * * THE FOLLOWING ROUTINE PACKS A CHARACTER INTO A BUFFER * * ACCORDING TO THE POINTER PBUF WITHOUT OTHERWISE ALTERING * * THE BUFFER. THE ROUTINE UPDATES PBUF SO THAT A PACKED * * ASCII BUFFER MAY BE WRITTEN BY SUCCESSIVE CALLS TO PAK. * * PBUF CONTAINS THE ADDRESS OF THE WORD TO PACK INTO; THE * * SIGN BIT, IF SET, INDICATES A PACK INTO THE LOW ORDER * * BITS OF THE WORD. * * * * CALLING SEQUENCE: LDA VALUE FOR PBUBF * * STA PBUF * * LDA CHARACTER * * JSB PAK * * * *************************************************************** * PAK NOP ENTRY LDB PBUF LOAD CURRENT ADDRESS POINTER CLE ELB,RBR GET SIGN BIT SEZ,RSS TEST IF SIGN BIT SET ALF,ALF STA CHAR LDA B,I GET CONTENTS OF ASCII BUFFER SEZ ALF,ALF AND B177 MASK HIGH BITS SEZ ALF,ALF XOR CHAR GET ACTUAL CHARACTER STA B,I PACK IN CURRENT PACK ADDRESS SEZ,CME TEST IF SIGN BIT SET INB,RSS YES, INCREMENT PACK ADDR ELB,RBR STB PBUF SAVE NEW ADDRESS POINTER JMP PAK,I RETURN * * *************************************************************** * STRING UNPACK ROUTINE * * * * THE FOLLOWING ROUTINE UNPACKS A CHARACTER FROM A PACKED * * ASCII BUFFER ACCORDING TO THE POINTER UPBUF. THE ROUTINE * * UPDATES UPBUF SO THAT A PACKED BUFFER MAY BE SEARCHED BY * * SUCCESSIVE CALLS TO UNPAK. UPBUF CONTAINS THE ADDRESS OF * * THE WORD TO UNPACK FROM; THE SIGN BIT, IF SET, INDICATES * * AN UNPACK FROM THE LOW ORDER BITS OF THE WORD. * * * * CALLING SEQUENCE: LDA VALUE FOR UPBUF * * STA UPBUF * * JSB UNPAK * * CHARACTER RETURNED IN A-REGISTER * * * ************q*************************************************** * UNPAK NOP ENTRY LDB UPBUF LOAD CURRENT ADDRESS POINTER CLE ELB,RBR GET SIGN BIT LDA B,I GET CONTENTS OF PACKED BUFFER SEZ,RSS TEST IF SIGN BIT SET ALF,ALF AND B177 MASK HIGH BITS SEZ,CME TEST IF SIGN BIT SET INB,RSS YES, INCREMENT UNPACK ADDR ELB,RBR STB UPBUF SAVE NEW ADDRESS POINTER JMP UNPAK,I RETURN * * *************************************************************** * CHARACTER UNPAK-PAK ROUTINE * * * * THE FOLLOWING ROUTINE PERFORMS A SERIES OF UNPACK AND * * PACK OPERATIONS BASED ON THE INPUT PARAMETER N. EACH * * UNPAK-PAK OPERATION TRANSFERS THE NEXT CHARACTER IN THE * * BUFFER POINTED TO BY UPBUF INTO THE NEXT CHARACTER * * POSITION POINTED TO BY PBUF. * * * * CALLING SEQUENCE: (UPBUF) = ADDRESS OF FROM-BUFFER, * * USED BY UNPAK * * (PBUF) = ADDRESS OF TO-BUFFER, * * USED BY PAK * * JSB PACKN * * DEF N, WHERE N IS THE NUMBER OF * * CHARACTERS TO BE TRANSFERRED * *************************************************************** * PACKN NOP LDA PACKN,I LDA A,I CMA SAVE CHARACTER COUNT - 1 STA N TESTN ISZ N ALL CHARACTERS TRANSFERRED? RSS JMP EXIT2 YES JSB UNPAK NO, UNPACK NEXT CHARACTER JSB PAK PACK THE CHARACTER INTO TO-BUFFER JMP TESTN EXIT?2 ISZ PACKN INCREMENT RETURN ADDRESS JMP PACKN,I RETURN SKP * * * * CALLING SEQUENCE: * CALL DBFND(BASEF,IDF,MODEF,STATF,ITEMF,ARGF) * * * ENTRY IN BASIC SUBROUTINE TABLE: * DBFND(RA,RA,I,RVA,RA,RA), OV=NN, ENT=DMFND, FIL=%BAIMG * * WHERE NN IS THE OVERLAY NUMBER * * BASEF NOP IDF NOP MODEF NOP STATF NOP ITEMF NOP ARGF NOP * DMFND NOP ENTRY JSB .ENTR FETCH PARAMETERS DEF BASEF ISZ BASEF * JSB ASCI CONVERT STRINGS TO ASCII DEF IDF * JSB PAD PAD SET NAME TO 6 CHARACTERS DEF *+3 DEF IDF DEF NAME1 * JSB ASCI DEF ITEMF * JSB PAD PAD ITEM NAME TO 6 CHARACTERS DEF *+3 DEF ITEMF DEF NAME2 * JSB DBINF CALL IMAGE INFORMATION ROUTINE DEF *+6 DEF BASEF,I DEF NAME2 DEF .102 DEF ISTAT DEF BUFF2 * LDB ISTAT SZB,RSS TEST FOR ERROR IN INFORMATION CALL JMP FIND1 NO JMP ERRF YES - RETURN ERROR TO USER * FIND1 LDA BUFF2+8 DATA ITEM TYPE (I, R, OR X) ALF,ALF AND B377 CPA B111 TEST FOR INTEGER ITEM (I) JMP INTG YES CPA B130 TEST FOR ASCII ITEM (U) RSS YES JMP FIND NO, REAL ITEM * JSB ASCI CONVERT STRING TO ASCII DEF ARGF JMP FIND * INTG DLD ARGF,I JSB IFIX CONVERT REAL TO INTEGER STA ARGF,I SAVE CONVERTED KEY ITEM VALUE * FIND JSB DBFND CALL IMAGE FIND ROUTINE DEF *+7 DEF BASEF,I DEF NAME1 DEF MODEF,I DEF ISTAT DEF NAME2 DEF ARGF,I * LDA ISTAT CHECK FOR ANY ERRORS. SZA  JMP ERRF YES - SKIP ALL BUT ERROR CODE CONVERSION. * LDB STATF NO - SET UP TO CONVERT ALL ADB .2 ENTRIES IN STATUS ARRAY. STB TMP LDB ISTAD ADB .4 STB TMP2 * CLA ZERO (REAL) TO 2ND CLB ELEMENT IN STATF DST TMP,I ISZ TMP ISZ TMP * DST TMP,I DOUBLEWORD CURRENT RECORD ISZ TMP NUMBER SET TO ZERO (REAL) ISZ TMP * LDA M3 STA COUNT * FIND2 DLD TMP2,I DOUBLEWORD COUNT OF # JSB .FLTD OF ENTRIES IN CHAIN DST TMP,I DOUBLEWORD RECORD # ISZ TMP2 OF CHAIN FOOT ISZ TMP2 DOUBLEWORD RECORD # ISZ TMP OF CHAIN HEAD ISZ TMP FLOAT ALL ABOVE ENTRIES. ISZ COUNT JMP FIND2 * ERRF LDA ISTAT FINALLY, CONDITION CODE. JSB FLOAT DST STATF,I * JSB RSFLG SET SAVE RESOURCES FLAG DEF *+1 JMP DMFND,I TERMINATE FIND CALL SKP * * * * CALLING SEQUENCE: * CALL DBGET(BASEG,IDG,MODEG,STATG,ARGG,NAMEG,READ-LIST) * * * ENTRY IN BASIC SUBROUTINE TABLE: * DBGET(RA,RA,I,RVA,RA,RA,RVA,RVA,RVA,RVA,RVA,RVA,RVA,RVA,RVA), * OV=NN, ENT=DMGET, FIL=%BAIMG * * WHERE NN IS THE OVERLAY NUMBER * * BASEG NOP IDG NOP MODEG NOP STATG NOP ARGG NOP NAMEG NOP LISTG BSS 10 * DMGET NOP ENTRY JSB .ENTR FETCH PARAMETERS DEF BASEG ISZ BASEG * JSB ASCI CONVERT STRING TO ASCII DEF IDG * JSB PAD PAD SET NAME TO 6 CHARACTERS DEF *+3 DEF IDG DEF NAME1 * JSB ASCI CONVERT NAME LIST TO ASCII DEF NAMEG * CCB ADB CHARS SAVE CHARACTER LENpGTH OF STB BCNT LIST - 1 FOR NAMR. * LDA MODEG,I GET MODE FOR DATA BASE READ CPA .4 TEST FOR MODE=4 JMP CONVT YES, CONVERT RELATIVE RECORD TO DOUBLE INTG. CPA .7 TEST FOR MODE = 7 JMP GET2 YES, CONVERT IARG TO CORRECT TYPE JMP GET ELSE,JUST DO GET * CONVT CCA TEST IF RELATIVE RECORD NUMBER IS NUMERIC ADA ARGG PARM. TYPE IN WORD -1 OF VARIABLE LDB A,I IS >= 0 IF SO. SSB JMP E306 NO, ERROR DLD ARGG,I RELATIVE RECORD NUMBER (REAL) JSB .FIXD CONVERT REAL TO DOUBLE INTEGER DST ARGG,I JMP GET CALL IMAGE READ ROUTINE * E306 LDA .306 INVALID RECD# IN DIRECTED READ JMP ERRG2 SET USER STATUS CODE TO 306. * GET2 JSB DBINF GET KEY ITEM OF DATA SET IN IDSET DEF *+6 DEF BASEG,I DEF NAME1 DEF .302 DEF ISTAT DEF BUFFR * LDA ISTAT SZA TEST FOR ERROR IN INFORMATION CALL JMP ERRG2 SET USER STATUS CODE TO ERROR NUMBER * LDB BUFFR SZB,RSS CHECK FOR KEY ITEM INACCESSIBLE JMP E118 YES - ERROR * JSB DBINF GET ITEM TYPE OF KEY ITEM DEF *+6 DEF BASEG,I DEF BUFFR DEF .102 DEF ISTAT DEF BUFF2 * LDA ISTAT SZA TEST FOR ERROR IN INFORMATION CALL JMP ERRG2 SET USER STATUS CODE TO ERROR NUMBER * LDA BUFF2+8 ALF,ALF AND B377 DATA ITEM TYPE (I, R, OR X) CPA B130 TEST FOR ASCII ITEM (X) JMP ASC2 YES CPA B111 TEST FOR INTEGER ITEM (I) RSS YES, CONVERT ARGG TO INTEGER JMP GET NO, REAL ITEM (R) * DLD ARGG,I CONVERT ARGG TO INTEGER L JSB IFIX REAL TO INTEGER CONVERSION STA ARGG,I JMP GET ASC2 JSB ASCI CONVERT STRING TO ASCII DEF ARGG * GET JSB DBGET CALL IMAGE GET ROUTINE DEF *+8 DEF BASEG,I DEF NAME1 DEF MODEG,I DEF ISTAT DEF NAMEG,I DEF IBUF DEF ARGG,I * LDA ISTAT TEST FOR SUCCESSFUL DATA BASE READ SZA JMP ERRG2 NO, RETURN * LDB M10 SET UP FOR ITEM VALUE MOVE. STB COUNT NO MORE THAN 9 ITEMS. LDA INDXG SET VARIABLE INDEX TO STA INDX3 VARIABLE NUMBER 1. LDB OFSTB SET UP INDEX INTO IBUF. STB INDXB CLA SET RETURNED LENGTH TO ZERO. STA TOTAL INA SET CHARACTER IN NAME LIST TO 1. STA BSTRT * GET3 JSB NAMR GET NEXT ITEM'S NAME DEF *+5 FROM NAME LIST. DEF BUFF2 DEF NAMEG,I DEF BCNT DEF BSTRT * SSA IS THERE ANOTHER NAME? JMP EXITG NO - DONE WITH MOVE. ISZ COUNT YES - CHECK TO MAKE SURE RSS NO MORE THAN NINE NAMES. JMP E302 * JSB DBINF GET INFORMATION ON THE ITEM. DEF *+6 DEF BASEG,I DEF BUFF2 DEF .102 DEF ISTAT DEF BUFF2 * LDA ISTAT CHECK FOR ERROR. SZA JMP ERRG2 * LDA BUFF2+10 NO ERROR, GET ELEMENT COUNT. CMA,INA STA NCNT NEGATE AS A LOOP COUNT. LDA INDX3,I GET NEXT VARIABLES ADDRESS. STA VARS ISZ INDX3 * SZA,RSS IS THERE A NEXT VARIABLE? JMP E303 NO - MISSING VARIABLE. CCA YES - GET WORD -1 OF CURRENT VAR. ADA VARS TO TEST TYPE OF PARAMETER. LDA A,I  CLE E USED AS INDICATOR OF VAR. TYPE. SSA TEST IF NUMERIC OR STRING. CME STRING - SET E. * LDA BUFF2+8 GET DATA ITEM TYPE. ALF,ALF AND B377 CPA B130 TEST FOR ASCII ITEM (X) JMP GCHAR YES CPA B111 TEST FOR INTEGER ITEM (I) JMP GITR YES * SEZ REAL - TEST IF VARIABLE NUMERIC. JMP E304 NO, ERROR GREL LDA INDX3,I ADDRESS OF NEXT VAR. IN LIST. SZA,RSS TEST IF LAST PARAM JMP GREL1 YES, CONTINUE. LDA VARS NO, TEST IF WRITING ADA .5 IN NEXT VAR. CMA,INA ADA INDX3,I SSA JMP E304 YES, ERROR. * GREL1 DLD INDXB,I NO - GET VALUE AND DST VARS,I PUT INTO VARIABLE. ISZ INDXB UPDATE POSITION IN ISZ INDXB ITEM VALUES ISZ VARS AND VARIABLE LIST. ISZ VARS LDA TOTAL UPDATE RETURNED LENGTH. ADA .2 STA TOTAL * ISZ NCNT ANY MORE ELEMENTS JMP GREL IN THIS VARIABLE? JMP GET3 NO - SEE IF ANOTHER VAR. * GITR SEZ INTEGER - TEST IF RETURN VAR. NUMERIC. JMP E304 NO, ERROR GITR1 LDA INDX3,I ADDRESS OF NEXT VAR. IN LIST SZA,RSS TEST IF LAST VAR. JMP GITR2 YES, CONTINUE LDA VARS NO, TEST IF WRITING IN ADA .5 NEXT VARIABLE. CMA,INA ADA INDX3,I SSA JMP E304 YES,ERROR * GITR2 LDA INDXB,I NO, GET VALUE. JSB FLOAT FLOAT IT DST VARS,I AND STORE IT IN VARIABLE. ISZ INDXB UPDATE POSITION IN IBUF ISZ VARS AND VARIABLE. ISZ VARS LDA TOTAL UPDATE RETURNED LENGTH. ADA .2 STA TOTAL * ISZ NCNT ARE THERE ANYMORE ELEMENTS? JMP GITR1 YES JMP GET3 NO * GCHAR SEZ,RSS CHARACTER - TEST IF VARIABLE TYPE STRING. JMP E304 NO, ERROR LDA BUFF2+9 DETERMINE ITEM LENGTH CLB IN WORDS = MPY BUFF2+10 ELEMENT LENGTH IN BYTES ARS * ELEMENT COUNT / 2. STA LENTH * LDB INDX3,I TEST IF LAST PARAMETER SZB,RSS JMP GCHR1 YES, CONTINUE ADA VARS NO, TEST IF WRITING ADA .3 IN NEXT VARIABLE. CMA,INA ADA INDX3,I SSA JMP E304 YES, ERROR * GCHR1 LDA LENTH NO, IS LENGTH > 127? CMA,INA ADA .127 SSA JMP E304 YES, LENGTH ERROR. * LDB VARS NO, MOVE VALUE IN INB LDA INDXB JSB .MVW DEF LENTH DEC 0 STA INDXB UPDATE POSITION IN BUFFER LDA LENTH AND SET CHARACTER COUNT ALS IN 1ST WORD OF VARIABLE. STA VARS,I ARS UPDATE RETURNED LENGTH. ADA TOTAL STA TOTAL JMP GET3 THEN, SEE IF ANY MORE VARIABLES. * * EXITG LDB STATG SET UP TO CONVERT STATUS ARRAY. ADB .2 STB TMP LDB ISTAD ADB .2 STB TMP2 * LDA TOTAL WORD LENGTH OF DATA TRASFERED. JSB FLOAT DST TMP,I ISZ TMP ISZ TMP * LDA M4 DOUBLEWRD RECORDS AND STA COUNT COUNTS IN CHAIN. GET4 DLD TMP2,I 4 VALUES IN ALL. JSB .FLTD FLOAT ALL 4. DST TMP,I ISZ TMP2 ISZ TMP2 ISZ TMP ISZ TMP ISZ COUNT JMP GET4 * ERRG LDA ISTAT FINALLY, CONDITION COD]E. ERRG2 JSB FLOAT DST STATG,I * JSB RSFLG SET SAVE RESOURCES FLAG DEF *+1 JMP DMGET,I TERMINATE GET CALL * E118 LDA .118 RSS E303 LDA .303 BAD ITEM NAME RSS E302 LDA .302 ILLEGAL ITEM LIST - TOO MANY ITEMS. RSS E304 LDA .304 BAD VARIABLE TYPE OR LENGTH. JMP ERRG2 INDXG DEF LISTG SKP * * * * CALLING SEQUENCE: * CALL DBUPD(BASEU,IDU,MODEU,STATU,NAMEU,LISTU) * * * ENTRY IN BASIC SUBROUTINE TABLE: * DBUPD(RA,RA,I,IVA,RA,RA,RA,RA,RA,RA,RA,RA,RA,RA,RA), * OV=NN, ENT=DMUPD, FIL=%BAIMG * * WHERE NN IS THE OVERLAY NUMBER * * BASEU NOP IDU NOP MODEU NOP STATU NOP NAMEU NOP LISTU BSS 11 * DMUPD NOP ENTRY JSB .ENTR FETCH PARAMETERS DEF BASEU ISZ BASEU * JSB ASCI CONVERT STRING TO ASCII DEF IDU * JSB PAD PAD SET NAME TO 6 CHARACTERS DEF *+3 DEF IDU DEF NAME1 * JSB ASCI CONVERT NAME LIST TO ASCII. DEF NAMEU * CCB ADB CHARS SAVE CHARACTER LENGTH OF STB BCNT LIST -1 FOR NAMR. * JSB IVAL CONSTRUCT IVALU PACKED ARRAY DEF *+4 DEF NAMEU DEF LISTU DEF BASEU SZB,RSS TEST FOR ERROR IN CONSTRUCTION JMP UPDT3 NO STB STATU,I YES, SET USER STATUS CODE TO ERROR JMP ERRU RETURN. * UPDT3 JSB DBUPD CALL IMAGE UPDATE ROUTINE DEF *+7 DEF BASEU,I DEF NAME1 DEF MODEU,I DEF STATU,I DEF NAMEU,I DEF IBUF * ERRU JSB RSFLG SET SAVE RESOURCES FLAG DEF *+1 JMP DMUPD,I TERMINATE UPDATE CALL SKP * * * * CALLING SEQUENCE: * 6z CALL DBPUT(BASEP,IDP,MODEP,STATP,NAMEP,LISTP) * * * ENTRY IN BASIC SUBROUTINE TABLE: * DBPUT(RA,RA,I,RVA,RA,RA,RA,RA,RA,RA,RA,RA,RA,RA,RA), * OV=NN, ENT=DMPUT, FIL=%BIAMG * * WHERE NN IS THE OVERLAY NUMBER * * BASEP NOP IDP NOP MODEP NOP STATP NOP NAMEP NOP LISTP BSS 11 * DMPUT NOP ENTRY JSB .ENTR FETCH PARAMETERS DEF BASEP ISZ BASEP * JSB ASCI CONVERT STRING TO ASCII DEF IDP * JSB PAD PAD SET NAME TO 6 CHARACTERS DEF *+3 DEF IDP DEF NAME1 * JSB ASCI CONVERT NAME LIST TO ASCII DEF NAMEP * CCB ADB CHARS SAVE CHARACTER LENGTH OF STB BCNT LIST -1 FOR NAMR. * JSB IVAL BUILD IVALU PACKED ARRAY DEF *+4 DEF NAMEP DEF LISTP DEF BASEP SZB,RSS TEST FOR ERROR IN PARSE JMP PUT NO ERROR, COMPLETE PUT REQUEST STB ISTAT SET USER STATUS CODE TO ERROR NUMBER JMP ERRP RETURN * PUT JSB DBPUT CALL IMAGE PUT ROUTINE DEF *+7 DEF BASEP,I DEF NAME1 DEF MODEP,I DEF ISTAT DEF NAMEP,I DEF IBUF * LDA ISTAT CHECK FOR ERROR SZA JMP ERRP YES, JUST CONVERT STATUS CODE. * LDB ISTAD NO, CONVERT ENTIRE ARRAY. INB SET UP FOR CONVERSIONS. STB TMP LDB STATP ADB .2 STB TMP2 * LDA TMP,I INTEGER WORD LENGTH OF IBUF JSB FLOAT TO REAL. DST TMP2,I ISZ TMP ISZ TMP2 ISZ TMP2 * LDA M4 FOUR DOUBLEWORDS CONTAINING STA COUNT CONTS AND RECORD NUMBER. EXITP DLD TMP,I FLOAT THEM ALL. JSB .FLTD DST TMP2,I ISZ TMP ISZ TMP ISZ TMP2 ISZ TMP2 ISZ COUNT JMP EXITP * ERRP LDA ISTAT INTEGER ERROR CODE, JSB FLOAT CONVERT TO REAL DST STATP,I * JSB RSFLG SET SAVE RESOURCES FLAG DEF *+1 JMP DMPUT,I TERMINATE PUT CALL SKP * * * SUBROUTINE TO BUILD THE PACKED VALUE ARRAY FOR DBUPD & DBPUT. * * CALLING SEQUENCE: * JSB IVAL * DEF *+4 * DEF NAMES <> * DEF LIST <> * DEF BASE <> * * THE VALUES ARE PACKED INTO IBUF. * IVAL NOP CONSTRUCT IVALU PACKED ARRAY LDB IVAL LDA B,I SAVE RETURN ADDRESS STA IVAL LDA OFSTB INITIALIZE POINTER TO IBUF. STA INDXB INB LDA B,I FETCH PARAMETERS LDA A,I STA TMP SAVE POINTER TO NAME LIST INB LDA B,I VARIABLE LIST STA INDX3 INB LDB B,I AND DATA BASE LDB B,I STB BASE * LDA M11 SET NAME COUNT TO -11. STA COUNT CLA,INA SET STARTING CHARACTER FOR NAMR STA BSTRT TO ONE. * NITEM LDB INDX3,I GET NEXT PARAMETER FROM PRINT-LIST STB VARS SAVE VARIABLE-LIST ADDRESS * JSB NAMR GET NEXT ITEM'S NAME. DEF *+5 DEF BUFF2 DEF TMP,I DEF BCNT DEF BSTRT * SSA END OF NAME LIST? JMP EXIT7 YES ISZ COUNT NO, TOO MANY NAMES? RSS JMP E302A YES * JSB DBINF NO, GET ITEM INFORMATION. DEF *+6 DEF BASE,I DEF BUFF2 DEF .10X2 DEF ISTAT DEF BUFF2 * LDB ISTAT TEST FOR ERROR IN INFO CALL SZB JMP IVAL,I YES, RETURN ERROR * LDA VARS ADDRESS OF PRINT-LIST PARAMETER SZA TEST FOR NO PARAMETER JMP NITM3 NO ERROR, CONTINUE LDB .305 VARIABLE MISSING IN VARIABLE LIST JMP IVAL,I RETURN * NITM3 ISZ INDX3 INCREMENT INDEX TO PLIST LDA BUFF2+10 GET ELEMENT COUNT CMA,INA AND NEGATE FOR LOOP COUNTER. STA NCNT LDA BUFF2+8 DATA ITEM TYPE (I,R, OR X) ALF,ALF AND B377 CPA B130 TEST FOR ASCII ITEM (X) JMP STRNG YES CPA B111 TEST FOR INTEGER ITEM (I) JMP INTGR YES * REAL LDA INDX3,I ADDRESS OF NEXT PARM IN VAR-LIST SZA,RSS TEST IF LAST PARAMETER JMP NITM4 YES, CONTINUE LDA VARS NO, TEST IF READING FROM NEXT PARM ADA .5 CMA,INA ADA INDX3,I SSA,RSS JMP NITM4 NO, CONTINUE E304A LDB .304 ERROR RSS E303A LDB .303 RSS E302A LDB .302 JMP IVAL,I RETURN * NITM4 DLD VARS,I NO, REAL ITEM (R) DST INDXB,I PACK REAL ITEM INTO IVALU ISZ INDXB INCREMENT INDEX TO IVALU ARRAY ISZ INDXB ISZ VARS AND INTO VARIABLE ISZ VARS ISZ NCNT ANY MORE ELEMENTS? JMP REAL YES JMP NITEM NO * STRNG LDB VARS,I STRING CHARACTER COUNT SLB TEST IF ODD COUNT INB YES BRS LENGTH IN WORDS STB TMP2 LDA BUFF2+9 COMPARE WITH LENGTH AS DEFINED CLB MPY BUFF2+10 ARS CPA TMP2 RSS YES, CORRECT ITEM LENGTH JMP E304A NO, INCORRECT ITEM LENGTH Լ JSB ASCI CONVERT STRING TO ASCII DEF VARS LDA VARS MOVE CHARACTER STRING INTO IBUF. LDB INDXB JSB .MVW DEF LENTH DEC 0 STB INDXB SAVE PLACE IN IBUF. JMP NITEM GO SEE IF MORE NAMES. * INTGR LDA INDX3,I ADDRESS OF NEXT PARM IN VAR-LIST SZA,RSS TEST IF LAST PARAMETER JMP INTG2 YES, CONTINUE LDA VARS NO, TEST IF READING FROM NEXT PARM ADA .5 CMA,INA ADA INDX3,I SSA JMP E304A YES, SET ERROR CODE * INTG2 DLD VARS,I GET NEXT VARIABLE IN PRINT-LIST JSB IFIX CONVERT TO INTEGER STA INDXB,I PACK INTEGER INTO IVALU ISZ INDXB INCREMENT INDEX TO IVALU ISZ VARS AND TO VARIABLE ISZ VARS ISZ NCNT ANY MORE ELEMENTS? JMP INTGR YES JMP NITEM NO, GET NEXT ITEM FROM INBR ARRAY * EXIT7 CLB SET INTERNAL ERROR CODE TO ZERO JMP IVAL,I RETURN SKP * * * CALLING SEQUENCE: * CALL DBDEL(BASED,IDD,MODED,STATD) * * * ENTRY IN BASIC SUBROUTINE TABLE: * DBDEL(RA,RA,I,IVA), OV=NN, ENT=DMDEL, FIL=%BAIMG * * WHERE NN IS THE OVERLAY NUMBER * * BASED NOP IDD NOP MODED NOP STATD NOP * DMDEL NOP ENTRY JSB .ENTR FETCH PARAMETERS DEF BASED ISZ BASED * JSB ASCI CONVERT STRING TO ASCII DEF IDD * JSB PAD PAD SET NAME TO 6 CHARACTERS DEF *+3 DEF IDD DEF NAME1 * JSB DBDEL CALL IMAGE DELETE ROUTINE DEF *+5 DEF BASED,I DEF NAME1 DEF MODED,I DEF STATD,I * JSB RSFLG SET SAVE RESOURCES FLAG DEF *+1 JMP DMDEL,I TERMINATE DELETE CALL SKP * * * * CALLING SEQUENCE: * CALL DBCLS(BASEC,IDC,MODEC,STATC) * * * ENTRY IN BASIC SUBROUTINE TABLE: * DBCLS(RVA,RA,I,IVA), OV=NN, ENT=DMCLS, FIL=%BAIMG * * WHERE NN IS THE OVERLAY NUMBER * * BASEC NOP IDC NOP MODEC NOP STATC NOP * DMCLS NOP ENTRY JSB .ENTR FETCH PARAMETERS DEF BASEC ISZ BASEC * JSB ASCI CONVERT STRING TO ASCII DEF IDC * JSB PAD PAD SET NAME TO 6 CHARACTERS. DEF *+3 DEF IDC DEF NAME1 * JSB DBCLS CALL IMAGE CLOSE ROUTINE DEF *+5 DEF BASEC,I DEF NAME1 DEF MODEC,I DEF STATC,I * JSB RSFLG SET SAVE RESOURCES FLAG DEF *+1 JMP DMCLS,I TERMINATE CLOSE CALL SKP * * * * * CALLING SEQUENCE: * CALL DBLCK(BASEL,IDL,MODEL,STATL) * * * ENTRY IN BASIC SUBROUTINE TABLE: * DBLCK(RA,RA,I,IVA), OV=NN, ENT=DMLCK, FIL=%BAIMG * * WHERE NN IS THE OVERLAY NUMBER * * BASEL NOP IDL NOP MODEL NOP STATL NOP * DMLCK NOP ENTRY JSB .ENTR FETCH PARAMETERS DEF BASEL ISZ BASEL * JSB DBLCK CALL IMAGE LOCK ROUTINE DEF *+5 DEF BASEL,I DEF IDL,I DEF MODEL,I DEF STATL,I * JSB RSFLG SET SAVE RESOURCES FLAG DEF *+1 JMP DMLCK,I TERMINATE LOCK CALL SKP * * * * * CALLING SEQUENCE: * CALL DBUNL(BASEN,IDN,MODEN,STATN) * * * ENTRY IN BASIC SUBROUTINE TABLE: * DBUNL(RA,RA,I,IVA), OV=NN, ENT=DMUNL, FIL=%BAIMG * * WHERE NN IS THE OVERLAY NUMBER * * BASEN NOP IDN NOP MODEN NOP STATN NOP * DMUNL NOP ENTRY JSB .ENTR FETCH PARAMETER DEF BASEN ISZ BASEN * JSB DBUNL CALL IMAGE UNLOCK ROUTINE DEF *+5 DEF BASEN,I DEF IDN,I DEF MODEN,I DEF STATN,I * JSB RSFLG SET SAVE RESOURCES FLAG DEF *+1 JMP DMUNL,I TERMINATE UNLOCK CALL SKP * * * BASIC STRING TO ASCII STRING CONVERTER. * * CALLING SEQUENCE: * JSB ASCI * DEF STRING * * RETURNS CHARACTER LENGTH OF STRING IN CHARS. * * ASCI NOP CONVERT STRING TO ASCII LDB ASCI,I FETCH PARAMETER (ADDR OF STRING) LDA B,I LDA A,I AND B377 EXTRACT LENGTH IN CHARACTERS STA CHARS SAVE LENGTH IN CHARACTERS SLA SKIP IF EVEN NUMBER OF CHARS JMP ODDLN ODD NUMBER OF CHARACTERS ARS OBTAIN NUMBER OF WORDS REQUIRED STA LENTH RMOV ISZ B,I CHARACTERS BEGIN AT WORD 2 ISZ ASCI INCREMENT RETURN ADDRESS JMP ASCI,I RETURN * ODDLN INA ADDITIONAL WORD SINCE LENGTH ODD ARS OBTAIN NUMBER OF WORDS REQUIRED STA LENTH STB TEMP SAVE POINTER TO STRING LDB B,I ADB LENTH ADDR OF LAST WORD OF STRING LDA B,I AND MSKLO MASK LOWER BYTE (NO CHAR) IOR B40 PAD WITH A BLANK STA B,I LDB TEMP RESTORE POINTER TO STRING JMP RMOV * TEMP NOP * * *************************************************************** * PAD AN ASCII STRING WITH BLANKS * * * * THE FOLLOWING ROUTINE PADS A SIX-CHARACTER ASCII STRING * * WITH BLANKS, CHECKING THE VARIABLE "LENTH" TO DETERMINE * * THE AMOUNT OF PADDING NECESSARY. * * 3- * * CALLING SEQUENCE: JSB PAD * * DEF *+3 * * DEF SOURCE BUFFER ADDRESS * * DEF RETURN BUFFER ADDRESS * * * *************************************************************** * PAD NOP LDB PAD LDA B,I SAVE RETURN ADDRESS STA PAD INB LDA B,I ORIGINAL ASCII STRING LDA A,I STA TMP INB LDB B,I RETURNED STRING ADDRESS STB TMP2 * LDA LENTH STRING LENGTH IN WORDS CMA,INA ADA .2 SSA TEST IF LENGTH GREATER THAN 2 JMP PAD2 YES INB SZA,RSS TEST FOR NUMBER OF WORDS TO PAD JMP PAD1 LDA BLNKS PAD LAST TWO WORDS STA B,I PAD1 LDA BLNKS PAD LAST WORD INB STA B,I PAD2 LDA TMP A-REG = SOURCE BUFFER ADDRESS LDB TMP2 B-REG = DESTINATION BUFFER ADDRESS JSB .MVW MOVE WORDS DEF LENTH NUMBER OF WORDS TO BE MOVED NOP JMP PAD,I RETURN * * .2 DEC 2 .3 DEC 3 .4 DEC 4 .5 DEC 5 .6 DEC 6 .7 DEC 7 .9 DEC 9 .10 DEC 10 .14 DEC 14 .28 DEC 28 .36 DEC 36 COMMA DEC 44 COMMA .100 DEC 100 .102 DEC 102 .118 DEC 118 .127 DEC 127 .202 DEC 202 .302 DEC 302 INVALID NAME-LIST .303 DEC 303 INVALID NAME IN NAME-LIST .304 DEC 304 INVALID PARAMETER IN VAR-LIST .305 DEC 305 VARIABLE MISSING IN VARIABLE-LIST .306 DEC 306 INVALID RECD# IN DIRECTED READ .310 DEC 310 .324 DEC 324 ILLEGAL DBINF REQUEST M3 DEC -3 M4 DEC -4 M10 DEC -10 M11 DEC -11 B40 OCT 40 B111 OCT 111 "I" B130 OCT 130 "X" B177 EQU .127 B377 OCT 377 MASK UPPER BYTE MSKLO OCT 177400 MASK LOWER BYTE BLNKS ASC 3, MINUS ASC 1,- PLUS ASC 1,+ A EQU 0 B EQU 1 BSTRT NOP BCNT NOP BUFF2 BSS 17 COUNT BSS 1 BASE NOP TOTAL NOP INDX3 NOP INDXB BSS 1 LENTH BSS 1 N EQU BASE NAME1 BSS 3 NCNT BSS 1 OFST2 DEF BUFF2 TMP BSS 1 TMP2 BSS 1 VARS BSS 1 ISTAT BSS 10 ISTAD DEF ISTAT IBUF BSS 2045 BUFFR EQU IBUF (256 WORDS) NAME2 EQU IBUF+257 (3 WORDS) MODE EQU IBUF+261 (1 WORD) ITEMS EQU IBUF+263 (1 WORD) INDX EQU IBUF+265 (1 WORD) CHAR EQU IBUF+267 (1 WORD) PBUF EQU IBUF+269 (1 WORD) UPBUF EQU IBUF+271 (1 WORD) CHARS EQU IBUF+273 (1 WORD) OFSET DEF BUFFR+1 OFSTB DEF BUFFR END  Zy 92069-18256 1912 S C0122 &DBCOP DBCOP SOURCE             H0101 ]ASMB,L,C,R HED DATA BASE CO-ORDINATING PROGRAM OF IMAGE/1000 NAM DBCOP,4,50 92069-16256 REV.1912 790316 * * ******************************************************************* * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR WRITTEN * CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18256 * RELOC: 92069-16256 * * PRGMR: CEJ * * ******************************************************************* * * * * DBCOP is the Data Base Co-Ordinating Program used by all IMAGE soft- * ware modules to co-ordinate access to all data bases on the system. * In order to control access, DBCOP sets up and maintains a co-ordinating * table consisting of 20 27-word entries where each entry is formatted as * follows: * * +-----------------------------------------------+ * | data base | * | root file | * | name (3 words) | * ------------------------------------------------- * | cartridge number | * ------------------------------------------------- * | open mode | # of users | * ------------------------------------------------- * | resource number | * +-----------------------------------------------+ * | name of first program with | -> -1 if empty * | data base open | * | (3 words) | * ------------------------------------------------- * . . . * . . . * V . . . * ------------------------------------------------- * | name of seventh program with | -> -1 if empty * | data base open | * | (3 words) | * +-----------------------------------------------+ * * (An empty entry is signified by a -1 in the first two characters of * the data base name.) * * DBCOP currently provides four services to the calling program. The * specific function provided by DBCOP for each schedule is defined by a * passed function code, where the function codes are defined as follows: * * 1 - check open mode on data base for obtainability * 2 - add user to co-ordinating table * 3 - remove user from co-ordinating table * * -1 - return a copy of co-ordinating table to scheduler (used solely * by RECOV) * * The scheduling sequence for DBCOP is: * * JSB EXEC Call EXEC to schedule program * DEF *+10 * DEF D23 (schedule queue with wait) * DEF NAME name = "DBCOP" * DEF FC/MD DBCOP function code in first byte, * open mode in second byte. * For RECOV, entire word is -1. * DEF DBNAM data * DEF DBNAM+1 base * DEF DBNAM+2 name * DEF CRN Data Base cartridge number. * DEF PNAME buffer containing program's name * DEF D3 length of buffer * * DBCOP returns up to two parameters to its father. The first is always * returned and is the status word, zero if successful, non-zero if un- * successful. The second is a resource number for a function code 2 * schedule, the remaining user count for a function code 3 schedule, or * a class number for a function code -1 schedule. The RN is the data * base RN for mode 1 DBOPNs, thSe class number is the class on which DBCOP * wrote a copy of the co-ordinating table for RECOV to retrieve. * EXT .CMW,.MVW,DTACH,EXEC,PRTN,RMPAR,RNRQ * SUP A EQU 0 B EQU 1 * FC/MD NOP DBNAM BSS 3 CRN NOP * * Retrieve scheduling parameters * BEGIN JSB RMPAR DEF *+2 DEF FC/MD * JSB EXEC DEF *+5 DEF NA14 No abort string passage DEF D1 retrieve string code = 1 DEF PNAME,I DEF D3 NOP * JSB DTACH Tell Session Monitor that DEF *+2 we are not a session program. DEF DUMMY * * If the function code > 0, then search the co-ordinating table for an * entry containing the passed name and cartridge number. Also, find the * first empty entry in the table. * LDA FC/MD If function code = -1 SSA jump to -1 process JMP FCM1 * AND LOBYT Else split open mode and STA MODE LDA FC/MD function code ALF,ALF AND LOBYT STA FCODE * LDA DBCNT and perform table search STA COUNT Set loop counter = - # entries in table * CLA STA EMPTY Set empty entry pointer to zero * CMA STA FOUND Set found flag to FALSE (-1) * LDA COTAB Get address of next entry in table LOOP1 STA SAVE and save. LDB A,I If the first word of the entry is negative, SSB the entry is empty JMP LOOP2 * LDB NAMAD If non-empty, compare data base JSB .CMW names. DEF D3 DEC 0 * JMP SAME1 entry name same as passed name * NOP entry name LT passed name JMP LOOP3 entry name GT passed name * SAME1 LDB A,I Names the same, see if the CRNs CPB CRN are. JMP SAME2 Yes - get out of loop JMP LOOP3 No - just continue. * LOOP2 LDB EMPTY Rcame here from empty jump SZB,RSS if first empty entry, STA EMPTY save its address for future use * LOOP3 LDA SAVE Get next entry address ADA ENTSZ ISZ COUNT (if there is one) JMP LOOP1 and try it * JMP LOOPE else we've completed search. * SAME2 ADA M3 Come here from successful comparison-- CLB point back to top of entry & STB FOUND set found flag to TRUE (0) * LOOPE LDB FCODE Get function code again and CMB,INB compliment it for CASE statement. INB,SZB,RSS JMP FC1 FCODE = 1 INB,SZB,RSS JMP FC2 FCODE = 2 INB,SZB,RSS JMP FC3 FCODE = 3 * JMP E161 Illegal FCODE!!! - "shouldn't" happen. * * Function code = 1 * Check desired data base and open mode for obtainability. * FC1 LDB FOUND If data base already open to someone SZB (i.e. an entry matched) JMP NOTOP * ADA OP/CT then check to make sure that the LDA A,I data base is not open in mode 3 ALF,ALF and if open in the same mode AND LOBYT as the one desired by this father. CPA D3 JMP E129 open in mode 3 - only one user * CPA MODE JMP OKAY same open mode - user okay JMP E152 different modes - unobtainable open * NOTOP LDB EMPTY Data base is not already open SZB is there an empty entry in which JMP OKAY to add it? JMP E131 No--unobtainable open * * Function code = 2 * Add the user to the co-ordinating table * FC2 LDB FOUND If entry already exists for SZB this data base, JMP NEW * LDB A then make sure open modes match ADB OP/CT and open mode is not 3. LDA B,I ALF,ALF AND LOBYT CPA D3 JMP E129 Open mode 3, only one user. * CPA MODE If modes match RSS JMP E152 * LDA B,I increment the user count. INA STA B,I * INB Put RN in return parameter for father. LDA B,I STA RN/CL * LDA M7 Find next empty slot for name. STA COUNT INB FC2A LDA B,I SSA JMP FC2B ADB D3 ISZ COUNT JMP FC2A LDB SAVE No empty slot, reduce user count again. ADB OP/CT CCA ADA B,I STA B,I JMP E131 * FC2B LDA PNAME Put name in slot JSB .MVW DEF D3 DEC 0 JMP OKAY and return successful. * NEW LDB EMPTY Entry doesn't exist, must create one SZB,RSS if there is room. JMP E131 * LDA MODE If open mode =1 CPA D1 RSS JMP BUILD * JSB RNRQ then we have to allocate an RN DEF *+4 DEF ALLOC DEF RN/CL DEF ERROR JMP E132 Call was in error (?) * LDA RN/CL Was an RN available? SZA,RSS JMP E132 No--cannot create entry * LDB EMPTY Yes--put it in entry. ADB RNIDX STA B,I LDB EMPTY * BUILD LDA NAMAD Put data base name in entry. JSB .MVW DEF D3 DEC 0 LDA CRN Put cartridge # in entry. STA B,I INB LDA MODE Put open mode and user count = 1 ALF,ALF in entry. INA STA B,I ADB D2 Put the program's name LDA PNAME in first name slot. JSB .MVW DEF D3 DEC 0 JMP OKAY Then, the entry is built. * * Function code = 3 * Remove a user from the co-ordinating table * FC3 LDB FOUND The entry must be there SZB else this is an erroneous schedule JMP E103 * ADA OP/CT Decrement user count for data base CC8xB ADB A,I STB A,I * LDA B Get remaining user count AND LOBYT and store it in the STA USCNT 2nd return parameter. * LDA M7 Find the slot containing STA COUNT this program's name. LDB SAVE ADB NAMES FC3A STB EMPTY LDA PNAME JSB .CMW DEF D3 DEC 0 JMP FC3B Names match. NOP LDB EMPTY Not a match, ADB D3 continue for all entries. ISZ COUNT JMP FC3A JMP FC3C No name match. * FC3B CCA Set found slot to empty STA EMPTY,I LDA USCNT Now get count again. SZA If count NE 0 JMP OKAY then this process is done * LDB SAVE ADB OP/CT LDA B,I else we must remove the ALF,ALF entry entirely. AND LOBYT CPA D1 For an open mode = 1 RSS this means releasing JMP ERASE the allocated RN. * LDB SAVE Get it from the entry & ADB RNIDX put it in the RNRQ call. STB RNADR * JSB RNRQ Deallocate the RN. DEF *+4 DEF DEALL (global, no wait, no abort) RNADR ABS *-* DEF ERROR JMP E137 erroneous call (?) * LDA ERROR Was deallocate successful? SZA JMP E137 No - illegal RN usage somewhere * ERASE CCA Erase entry by setting its first STA SAVE,I word to a -1 JMP OKAY (signifies empty entry). * FC3C LDB SAVE Program's name did not appear ADB OP/CT LDA B,I in name slots of entry. INA STA B,I Restore user count JMP E103 and return error # 103. * * Function code = -1 * Put a copy of co-ordinating table in SAM and pass it to RECOV. * FCM1 CLA,CCE Set the class # to zero, bit 15 set ERA to tell EXEC to allocate one. STA RN/CL * JSB EXEC DEF *+8 DEF CLWRT Class write/read--no wait, no abort DEF D0 DEF COTAB,I Co-ordinating table address DEF TASIZ and its size DEF D0 dummy DEF D0 parameters DEF RN/CL JMP E162 * SZA Was write successful? JMP E162 No--let RECOV know. * OKAY CLA Here on successful operation. EXIT STA ERROR * JSB PRTN Return parameters to father. DEF *+2 DEF ERROR * JSB EXEC Terminate, save resources. DEF *+4 DEF D6 DEF D0 DEF D1 * JMP BEGIN Next schedule begins here. * * Error return points. * E103 LDA D103 Data base not opened properly JMP EXIT no entry in table on close. E129 LDA D129 Data base already opened exclusively. JMP EXIT E131 LDA D131 No room in co-ordinating table JMP EXIT to add entry. E132 LDA D132 No RN available JMP EXIT E137 LDB SAVE If an RN error on a remove, ADB OP/CT increment the user count CLA,INA back to one. ADA B,I STA B,I LDA PNAME,I And restore first word STA EMPTY,I of program's name. LDA D137 Illegal RN usage. JMP EXIT E152 LDA D152 Data base already opened JMP EXIT in a different mode E161 LDA D161 Illegal function code JMP EXIT E162 LDA D162 Class write unsuccessful. JMP EXIT * * Work areas, table, and constants. * M7 DEC -7 M3 DEC -3 D0 DEC 0 D1 DEC 1 D2 DEC 2 D3 DEC 3 D6 DEC 6 D103 DEC 103 D129 DEC 129 D131 DEC 131 D132 DEC 132 D137 DEC 137 D152 DEC 152 D161 DEC 161 D162 DEC 162 LOBYT OCT 377 * COTAB DEF *+1 Co-ordinating table address UNL REP 540 DEC -1 LST ENTSZ DEC 27 Size of ,/0.*entries in table TASIZ DEC 540 Table size DBCNT DEC -20 Negative # of entries in table OP/CT DEC 4 Index to open mode/ user count RNIDX DEC 5 Index to RN NAMES DEC 6 Index to start of program names in entry. MODE NOP FCODE NOP * ERROR NOP RN/CL NOP USCNT EQU RN/CL * NAMAD DEF DBNAM COUNT NOP FOUND DEC -1 SAVE NOP EMPTY NOP DUMMY EQU EMPTY PNAME DEF *+1 BSS 3 * ALLOC OCT 140020 DEALL OCT 140040 CLWRT OCT 100024 NA14 OCT 100016 END BEGIN * Ep0 [ h 92069-18257 2040 S C0122 &RD.TB &RD.TB             H0101 ASMB HED RDBAP COPY SCHEDULING TABLE NAM RD.TB,30 92069-16257 REV.2040 800730 * * ******************************************************************* * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR WRITTEN * CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18257 * RELOC: 92069-16257 * * PRGMR: CEJ * * ******************************************************************* * * * * This subroutine contains the RDBAP copy scheduling table. This table * must reside in SSGA to quarantee the information it contains is correct. * * The table contains enough room for 20 entries where each entry is as- * signed to a specific copy of RDBAP. Each entry is eight words long * and is of the following format: * * word contents * +-----------------------------------------+ * 1-3 | master |-> zero if * | program's | entry is * | name | empty * ------------------------------------------- entry is * 4 | node number of master | empty * ------------------------------------------- * 5-7 | name of | * | RDBAP copy | * | (3 words) | * ------------------------------------------- * 8 | class number for RDBAP copy | * +-----------------------------------------+ * * This table can be expanded by adding 1 to #ENTR for each extra RDBAP * c  opy desired and adding eight to the REP statement immediately following. * ENT RD.TB * RD.TB DEF *+1 #COPY DEC 0 Number of copies scheduled. #ENTR DEC 20 Number of entries in table. UNL REP 160 RDBAP copy scheduling table. NOP LST BSS 0 END END$ >O  \c 92069-18258 1912 S C0122 &RDBAM RDBAM SOURCE             H0101 [ASMB,L,C,R HED RDBAM - REMOTE DATA BASE ACCESS MONITOR NAM RDBAM,20,30 92069-16258 REV.1912 790130 * * ******************************************************************* * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR WRITTEN * CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18258 * RELOC: 92069-16258 * * PRGMR: CEJ * * ******************************************************************* * * * * RDBAM is the Remote Data Base Access Monitor. It performs the following * sequence of operations: * * 1) When first scheduled (by LSTEN or UPLIN) get class number from first * parameter, set its save class, save buffer bits and store in the * program's memory space. The second scheduling parameter is the * error LU (first time through), if it is zero, set it to 1. * * 2) Make sure the Remote Data Base Access Program (RDBAP) resides in * the system. If not, send a message to the log device. * * 3) Check the RDBAP table to see if any RDBAP copies were previously * scheduled. If so, for each copy of RDBAP scheduled, if copy is * not up, release its class, remove its entry from the table, and * remove the copy from the system. * * 4) Do a class GET on the class from 1 to await a Remote Data Base Access * (RDBA) request. * * 5) When a request is received, make sure the request buffer is no larger * than our maximum buffer size (now 21 words). If a zero length re- * quest, flush it from the class and return to 4. If request size okay * bring it into the program memory. If size illegal, bring first seven * words of request into memory, flush the request from the class * (through PLOG if enabled) and send a reply with tdhe proper DS error * then go to 4. * * 6) If RDBA Index of request a -1 (negative one), this is a special * clean-up request from the DS software. The RDBA mode word contains * either the first two characters of the master program's name or a * negative integer. * * A) If the mode word contains a positive value (two characters): * * I ) Look for master's entry in RDBAP copy scheduling table. * If found, then if RDBAP copy still up, reroute the mes- * sage to it and return to 4. * * II ) If entry found but RDBAP copy is in a bad state, remove * the copy from the system, release its class number, and * remove its entry from the scheduling table. * * III) Flush request from our class (through PLOG if enabled) * and send a successful reply to requestor. * * IV ) Return to 4. * * B) Mode word contains a negative number. For each RDBAP copy * scheduled: * * I ) If copy dormant or on its class get, abort it and remove * it from the system. * * II ) Release the copy's class number and remove it from the * scheduling table. * * III) Go to 5-A-III. * * 7) If RDBA Index of request is a -2 (negative two), this is a "remove * me, I'm done" request from an RDBAP copy. The RDBA mode word con- * tains the copy's index into the RDBAP copy scheduling table. Deter- * mine the copy's entry in the scheduling table using this index. * Remove the copy from the system, release its class and remove it * from the scheduling table. Flush the request from our class and * return to 4. * * 8) All other Indices are RDBA requests. Get the RDBA index and bound * bound check it. (Each IMAGE call has its own Index, for instance * DBOPN's Index is 36.) * * 9) If Index is not within bounds, flush request from class (through * PLOG if enabled) and send a reply with the proper DS error code, * then go to 4. * * 10) If the Index is 36 (i.e. DBOPN call) then: * * A) See if there is an RDBAP copy scheduled for this master. If * so, go to 11. * * B) If no copy scheduled, then get next free entry in RDBAP copy * scheduling table. If no free entry, flush request from class * (through PLOG if enabled), send a reply with the proper DS * error code, then return to 4. * * C) Ask C.RP to bring up a new copy of RDBAP suffixing the copy * with the ASCII equivalent of the copy's index into the schedul- * ing table plus one. If C.RP is unsuccessful, flush the request * from our class (through PLOG if enabled), send a reply with * the proper DS error code, then return to 4. * * D) Allocate a class for this copy of RDBAP. If any error, remove * RDBAP copy from system, flush the request from our class (through * PLOG if enabled), send a reply with the proper DS error code, * then return to 4. * * E) Schedule the RDBAP copy sending it its class, its index, and * our class. If unsuccessful, remove the RDBAP copy from the * system, release its class, remove its scheduling table entry, * flush the request from our class (through PLOG if enabled), * send a reply with the proper DS error code, then return to 4. * * F) Go to 12. * * 10) If the RDBA Index is not 36, the index into the scheduling table * for this master's copy of RDBAP is in the request buffer. Pick * it up and determine the address of the copy's entry in the table * with it. * * 11) Make sure the RDBAP copy is still up. If not, remove it from the * system, release its class number, remove it from the scheduling * table, flush the request from our class (through PLOG if enabled) * send a reply with the proper DS error code, then return to 4. * * 12) Transfer the request from our class to the RDBAP copy's class. * * 13) Go to 4. * SKP ********************************************************************** *** *** * Standard DS/1000 equates * *** *** #STR EQU 1 #SEQ EQU 2 #SRC EQU 3 #DST EQU 4 #RDB EQU 5 #EC1 EQU 5 #EC2 EQU 6 #ENO EQU 7 *** *** ********************************************************************** RQBUF DEF *+1 BSS 21 ********************************************************************** * * * DS/1000 RDBA Communications consist of two descriptive buffers: * * 1) Request buffer * * 2) Reply buffer * * These two static buffers are as described below. * * * ********************************************************************** *** *** * * * Request buffer - one buffer of from 12 to 21 words per RDBA call * * * *** *** RBSTR EQU RQBUF+#STR DS/1000 stream word RBSEQ EQU RQBUF+#SEQ DS/1000 sequence number RBSRC EQU RQBUF+#SRC DS/1000 source node number RBDST EQU RQBUF+#DST DS/1000 destination node number RBIDX EQU RQBUF+#RDB RDBA call Index RBMOD EQU RQBUF+#RDB+1 RDBA call mode RBID EQU RQBUF+#RDB+2 RDBA call item or set number * 1 or for a DBOPN, the level code word RBITM EQU RQBUF+#RDB+3 Search item number for DBFND RBMRT EQU RQBUF+#RDB+5 For DBOPN, the max. return RT size RBLEN EQU RQBUF+#RDB+6 Word size of ibase parameter RBBAS EQU RQBUF+#RDB+7 Ibase parameter * MAXRQ DEC 21 Maximum request buffer length *** *** *** *** * * * Reply buffer - one buffer of 7 words per RDBA call (standard re- * * ply header only sent back by RDBAM upon an error). * * * *** * * RBSTR EQU RQBUF+#STR DS 1000 stream word * RBSEQ EQU RQBUF+#SEQ DS/1000 sequence number * RBSRC EQU RQBUF+#SRC DS/1000 source node number * RBDST EQU RQBUF+#DST DS/1000 destination node number RBEC1 EQU RQBUF+#EC1 DS/1000 1st error code word RBEC2 EQU RQBUF+#EC2 DS/1000 2nd error code word RBEC3 EQU RQBUF+#ENO DS/1000 error node number upon an error * RPLEN DEC 7 Standard reply header length *** *** ********************************************************************** SKP ********************************************************************** * * * RDBAP copy scheduling table * * The scheduling table resides in the module RD.TB in SSGA. It * * consists of information necessary for the co-ordination of RDBAP * * copy scheduling and request routing. Further detail follows. * * * ********************************************************************** *** Lt *** * * * RDBAP copy scheduling table - one 8 word entry per RDBAP copy * * * *** *** BPSIZ DEC 8 Entry size * BPID# DEC 0 Master program's name - 3 words BPNOD DEC 3 Master's node number BPNAM DEC 4 Name of RDBAP copy - 3 words BPCLS DEC 7 Class number for RDBAP copy *** *** *** *** * * * The first two words in this subroutine contain: * * 1) the number of copies of RDBAP currently scheduled * * 2) the number of entries in the scheduling table * * * * The scheduling table starts in the third word of the module. * * * *** *** * * ENT RDBAM EXT #PLOG,#REQU,$LIBR,$LIBX,$OPSY,.CMW EXT .ENTR,.MVW,C.RP,EXEC,RD.TB,RDEXT,RMPAR * A EQU 0 B EQU 1 * * Get our class number and set its save buffer, no deallocate bits. * Then get the error lu, if unspecified, set it to 1. * RDBAM NOP JSB RMPAR DEF *+2 DEF CLASS * LDA CLASS IOR BIT13 IOR BIT14 STA CLASS * LDA ERLU SZA,RSS INA STA ERLU * * Ask C.RP to check to make sure that RDBAP is there. * LDB RDBAP CLA,INA JSB C.RP JSB BAPER Not there, warn user. * * If C.RP had to duplicate the ID, ask it to undo the find. The A regi- * ster will be non-zero in this case. B* SZA,RSS JMP CHK0 LDB RDBAP CLA JSB C.RP NOP Ignore errors. * * See if we are being rescheduled after having been aborted. If so, the * count of RDBAP copies in use may be non-zero, and the states of these * copies should be checked. * CHK0 LDA RD.TB Entry point in SSGA is RD.TB LDB A,I SZB,RSS JMP GET No copies scheduled. * * For each copy of RDBAP scheduled, make sure it is still up, i.e. it is * non-dormant. This is done by trying to schedule it without wait. If * the schedule works or aborts, the copy is dormant and should be removed * from the scheduling table. * CMB,INB Two loop counters: STB CNTR1 1) -(# of copies scheduled) INA LDB A,I 2) -(# of entries in table) SZB,RSS # of entries = 0? JMP GET Nothing we can do about it. CMB,INB STB CNTR2 * INA A -> scheduling table. CLB,INB Set index in scheduling STB INDEX table to one. * CHK1 STA ENTAD LDB A,I If the entry is not empty, SZB,RSS JMP CHK4 JSB SCHED SCHED will schedule it DEF *+1 for us. JMP CHK2 Schedule aborted. * AND LOFOR Low four bits of A reg. = SZA status of copy at schedule. JMP CHK3 If zero, copy was dormant * CHK2 JSB TERM terminate it JSB RID and remove it from table. * CHK3 ISZ CNTR1 Done with all scheduled copies? RSS JMP GET Yes - go to class get. * CHK4 ISZ INDEX Update index into table LDA ENTAD Get next entry's address ADA BPSIZ ISZ CNTR2 and continue for all JMP CHK1 entries in table. * * Do a class GET on our passed class to await an RDBA request. The get * allows abort since an abort indicates our class number is incorrect * and a8fter aborting, UPLIN will bring us back with the correct class * number, hopefully. If UPLIN cannot bring us back something is dras- * tically wrong anyway. * GET JSB EXEC DEF *+7 DEF D21 Class GET DEF CLASS DEF MNAME,I We are only interested in DEF D3 data, if the request is DEF RQADR a DBOPN. DEF RQLEN * * Set the clean-up a new copy of RDBAP flag to false. * CLA STA FLAG * * If this is a zero-length request, then just flush it from the system. * Else, check the length of the request to make sure it is within the * upper bound of an RDBA request buffer (i.e. < 22 words). * LDA RQLEN SZA,RSS JMP ZREQ * CMA,INA ADA MAXRQ SSA JMP SIZER * * The request length is okay. Move the request from system memory into * our own buffer. * LDB RQBUF Get addr. of request buffer. JSB $LIBR Go priveledged to determine NOP if we are in a mapped system. LDA $OPSY RAR,SLA JMP DMSMV * LDA RQBUF If not, do a standard MVW. JSB .MVW DEF RQLEN DEC 0 JMP UNPRV * DMSMV LDA RQLEN If so, do a cross-map move. CAX LDA RQADR MWF * UNPRV JSB $LIBX Turn interrupts back on. DEF *+1 DEF *+1 SKP * * Check to see if this is a special clean-up request from the DS software. * The RDBA Index for such a request is -1 (negative one). * LDA RBIDX INA,SZA JMP RDBA7 Not a clean-up request. * * This is a clean-up request, get the master's name and node # from * the request (next four words after Index). If the first word of the name * is > zero, get its associated RDBAP copy's entry in the RDBAP table. If * the copy is up and running, send it a clean-up request, else do the * clean-up for it. * * If the first word of the name is < zero, this is a shut down clean-up, * abort all RDBAP copies. * LDA RBMOD SSA JMP CLNA Shut down clean-up. * * Single copy clean-up. Get the copy's entry in the scheduling table. * JSB SERCH DEF *+3 DEF RBMOD DEF RBMOD+3 JMP CLN3 No entry for it found. RSS Entry found JMP CLN3 No entry for it found. * * Copy for master found, see if it is dormant by scheduling it. If it * is dormant the schedule should either abort or succeed. * JSB SCHED DEF *+1 JMP CLN2 Schedule aborted. * AND LOFOR Check schedule state. CMA,INA If state is 1, 2, or 3 INA,SZA,RSS JMP CLN1 copy is still up. INA,SZA,RSS JMP CLN1 INA,SZA JMP CLN2 * * Copy is still there, ask SWTCH to switch the clean-up message from our * class to its. * CLN1 JSB SWTCH RSS Error return, clean-up the copy ourselves. JMP GET Return to class get. * * Copy was dormant, ask TERM to get rid of it and RID to remove it from * the scheduling table. * CLN2 JSB TERM JSB RID * * Remove the clean-up request from our class and send a successful reply. * CLN3 LDA #PLOG If PLOG enabled, route SZA,RSS this request to it. JMP CLN4 * JSB #REQU DEF *+3 DEF CLASS DEF #PLOG SSA,RSS If any error, try RMOVE. JMP CLN5 * CLN4 JSB RMOVE Else, just remove it from class. * CLN5 CLA Set error code for DS to zero. CLB DST ERROR * JSB RDEXT Ask RDEXT to send the reply. DEF *+6 DEF RQBUF,I DEF RPLEN DEF DUMMY DEF D0 No data DEF ERROR NOP Ignore errors JMP GET Return to class get. * * Constants and variables. * RQADR NOP RQLEN NOP D21 DEC 21 * SKP * * Clean up all lRDBAP copies request. Set up a loop to check each entry in * the RDBAP copy scheduling table for a scheduled copy. If there is one * in it, see if it is executing (i.e. non-dormant or not on its class get). * If so, just release its class and remove its entry in the scheduling * table. If not, remove it from system, and then release its class and * entry. * CLNA LDA RD.TB Two loop counters. LDB A,I 1) -(# of copies scheduled) SZB,RSS If no copies scheduled, JMP CLN3 just send reply. CMB,INB STB CNTR1 INA LDB A,I 2) -(# entries in table) SZB,RSS # of entries = 0? JMP CLN3 Yes - just send reply. CMB,INB STB CNTR2 * CLB,INB Set index into table to 1. STB INDEX INA Get table address. * CLNA1 STA ENTAD LDB A,I Entry empty? SZB,RSS JMP CLNA4 Yes * JSB SCHED No - executing? DEF *+1 JMP CLNA2 No - not there! * AND LOFOR SZA,RSS Dormant, JMP CLNA2 CPA D3 or on its class get? RSS JMP CLNA3 No * CLNA2 JSB TERM Terminate the copy. CLNA3 JSB RID Remove it from the table. * ISZ CNTR1 Done with all scheduled copies? RSS JMP CLN3 Yes - send reply. * CLNA4 ISZ INDEX Bump index LDA ENTAD get next entry ADA BPSIZ ISZ CNTR2 and continue for JMP CLNA1 entries in table. JMP CLN3 Then, go send reply. SKP * * Check to see if this is a special "remove me" request from an RDBAP copy. * The RDBA Index for such a request is -2. The A register at this point * contains the RDBA Index plus 1, therefore, if the A register is -1 now, * this is a "remove me" request. * RDBA7 INA,SZA JMP RDBA8 No - a valid RDBA request. * * Get index into RDBAP copy table from the 6th word of the request. This * gives us the address of the copy's entry in the scheduling table by: * ((Index - 1) * length of entry) + address of scheduling table. * CCA ADA RBMOD CLB MPY BPSIZ LDB RD.TB ADB D2 ADA B STA ENTAD * * Ask TERM to remove the RDBAP copy from the system, and RID to remove its * entry in the scheduling table. Then, remove the request from our class * and return to the class get. * JSB TERM JSB RID JSB RMOVE JMP GET SKP * * This is a valid RDBA request. Our first action is to bound check the * RDBA Index (5th word of the request buffer). The Index must be within * [36..45]. * RDBA8 LDA RBIDX CMA,INA ADA D45 Is the index < 46? SSA JMP IDXER No - index error. * ADA M10 Yes - is it > 35? SSA,RSS JMP IDXER No - index error. * * Now, check the Index for a DBOPN call. The Index for DBOPN is 36, but * by the bounds check done above, 36 has been mapped into a -1. * INA,SZA JMP NOTOP * * This is a DBOPN request, we need to check for an RDBAP copy already * scheduled for this master. While checking, we also need to get the * index for the first free entry in the RDBAP copy table in the event * this is the first request from the master. The master program's name * is the data received with the request buffer. Ask SERCH to do the * check for us. * JSB SERCH DEF *+3 DEF MNAME,I DEF RBSRC JMP BUERR No RDBAP copy up and no room! JMP RDBA9 RDBAP copy up. * * There is no current copy of RDBAP for this master, get one for it. * LDB RDBAP LDA EMPTY INA JSB C.RP JMP BUERR Did not work! * * Build the entry for the master-copy pair. * STB TEMP Save pointer to copy's name for later. LDA EMPTY STA INDEX Save its index for later. * ISZ RD.TB,I Bump copy count. * ADA M1 CLB MPY BPSIZ Get the address of the entry LDB RD.TB for this copy (derived from index). ADB D2 ADA B STA ENTAD * STA B 1st - 3rd words: LDA MNAME master's name. JSB .MVW DEF D3 DEC 0 * LDA RBSRC 4th word: STA B,I master's node number. * INB 5th - 7th words: LDA TEMP copy's name JSB .MVW DEF D3 DEC 0 * LDA CLSWD 8th word: STA B,I class number, STB CLSAD allocated one. JSB EXEC DEF *+5 DEF NA19 Class control, no abort DEF D0 LU = 0 DEF D0 CLSAD ABS *-* JMP CLERR Abortion return! * LDA CLSAD,I Did we get a class? AND MAPHI SZA,RSS JMP CLERR NO! * IOR BIT13 Yes - reset nodeallocate bit STA CLSAD,I and do a class get to JSB EXEC remove class control DEF *+5 buffer from class. DEF NA21 DEF CLSAD,I DEF DUMMY DEF D0 JMP CLERR Abortion return. * * Schedule the RDBAP copy, then join with non-open processing to pass it * the reqeust. * JSB SCHED DEF *+1 JMP NOGO Schedule did not work! CCA Set the clean-up new RDBAP copy flag STA FLAG to true in case of future errors. JMP JOIN * * Something went wrong, get rid of the RDBAP copy and its class and entry, * then give the master a busy error. * NOGO JSB TERM JSB RID JMP BUERR * * Constants and variables. * M10 DEC -10 D45 DEC 45 CLSWD OCT 160000 * MNAME DEF *+1 BSS 3 * RDBAP DEF *+1 ASC 3,RDBAP SKP * * We come here if the request was not a DBOPN. We assume that a monitor * already exists for the request and that the index for its entry in the * RDBAP copy scheduling table is in the high order byte of the 12th word * of the request buffer. We get the index from the buffer and calculate * the entry's address from it by : * ((Index - 1) * length of entry) + address of copy table. * NOTOP LDA RBBAS ALF,ALF AND LOBYT STA INDEX ADA M1 CLB MPY BPSIZ LDB RD.TB ADB D2 ADA B STA ENTAD * * Make sure the copy is still there by trying to schedule it. If the * schedule aborts or succeeds, we need to clean up after the copy and * send the master a schedule error. * RDBA9 JSB SCHED DEF *+1 JMP BAM2 Abortion return. * AND LOFOR If low four bits of A = zero, SZA RDBAP copy was dormant. JMP JOIN * BAM2 JSB TERM Get copy out of system, JSB RID remove its table entry JMP SCERR and send master an error reply. * * All went well. Transfer the request from RDBAM's class to the RDBAP * copy's class. Then, return to the class get. * JOIN JSB SWTCH RSS Error return JMP GET Normal return CPA M10 If too many requests error, JMP BUERR send a busy error JMP CLER2 else send a class error. * * Constants and variables. * LOFOR OCT 17 LOBYT OCT 377 * SKP * * Error handlers. * SIZER LDB M153 Illegal request length JMP EREXT * IDXER LDB M159 Illegal Index parameter. JMP EREXT * CLERR JSB TERM No class available JSB RID CLER2 LDB M158 or class errror from #REQU. JMP EREXT * SCERR LDB M144 RDBAP copy not up. JMP EREXT * BUERR LDB M156 System is too busy error. * EREXT CLA Set the error code for the reply. DST ERROR * LDA #PLOG Flush the request from our class. If AY SZA,RSS PLOG is enabled, give JMP ZREQ the request to it STA CLAS2 * JSB #REQU DEF *+3 DEF CLASS DEF CLAS2 SSA,RSS Error return, try RMOVE. JMP EXT3 * ZREQ JSB RMOVE If PLOG is not enabled, RMOVE flushes request. * LDA RQLEN If this was a zero-length SZA,RSS request, just return to JMP GET class GET. * EXT3 JSB RDEXT Else, send reply with DEF *+6 DS error code to orginator. DEF RQBUF,I DEF RPLEN DEF DUMMY DEF D0 no data DEF ERROR two word error code NOP ignore any errors. * LDA FLAG Any more clean-up to do? SSA,RSS JMP GET No - return to class get. * JSB TERM Yes - get rid of new JMP RID copy of RDBAP. JMP GET Then return to class get. * * Constants and variables. * M159 DEC -159 M158 DEC -158 M156 DEC -156 M153 DEC -153 D0 EQU BPID# * NA21 OCT 100025 * DUMMY NOP ERROR BSS 2 CLAS2 NOP CLASS BSS 5 ERLU EQU CLASS+1 FLAG NOP SKP * * SERCH is a utility subroutine for RDBAM which searches the RDBAP copy * scheduling table for a copy of RDBAP associated with the master whose * name is the same as that passed and for the first empty entry in the * table, leaving its index in EMPTY. * * The calling sequence for SERCH is: * * JSB SERCH * DEF *+3 return address * DEF IDSNM master program's name * DEF SRCND master program's node number * * * * IDSNM NOP SRCND NOP SERCH NOP JSB .ENTR DEF IDSNM * * Set up parameters for table search. * LDA RD.TB Two loop counters: LDB A,I 1) -(# of copies scheduled) CMB,INB STB CNTR1 INA LDB A,I 2) -(# of entries in table) SZB,RSS If # of entries = 0, JMP SRCH7 take error return. CMB,INB STB CNTR2 * INA A -> RDBAP copy scheduling table CLB STB EMPTY EMPTY = ENTAD = 0 STB ENTAD INB First index into table is one. STB INDEX * * BEGIN MAJOR LOOP * * BEGIN MINOR LOOP * SRCH0 STA TABAD LDB A,I If the entry is not empty, SZB,RSS JMP SRCH3 LDB IDSNM compare the master names. JSB .CMW DEF D3 DEC 0 JMP SRCH1 A match NOP JMP SRCH2 Not a match * SRCH1 LDB A,I A match, compare node numbers. CPB SRCND,I RSS A match, entry found. JMP SRCH4 Not a match, try next * LDA TABAD Set up ENTAD for return STA ENTAD and return P+2. JMP SRCH6 * SRCH2 ISZ CNTR1 Not a match, done with all scheduled copies? JMP SRCH4 No LDA EMPTY Yes - did we already find SZA an empty entry? JMP SRCH5 Yes JMP SRCH4 No * * END MINOR LOOP * SRCH3 LDB INDEX Empty entry found, LDA EMPTY first one? SZA,RSS STB EMPTY Yes - save its index. * SRCH4 LDA TABAD Get next entry's address ADA BPSIZ ISZ INDEX bump index ISZ CNTR2 and try next one. JMP SRCH0 * * END MAJOR LOOP * * Here when entire table is searched. * LDA EMPTY Did we find an empty entry? SZA,RSS JMP SRCH7 No SRCH5 ISZ SERCH Yes return P+3. SRCH6 ISZ SERCH Entry =found, return P+2. SRCH7 JMP SERCH,I Return. SKP * * RID is a utility subroutine for RDBAM which remove an RDBAP copy from * the scheduling table by releasing its class number and zeroing the * first word of its entry. * * The calling sequence for RID is: * * ENTAD = address of RDBAP copy's entry in scheduling table to * get rid of. * JSB RID * * RID NOP * * Get the RDBAP copy's class number, clear its save buffer bit and set * its save class and no wait bits. * LDB ENTAD ADB BPCLS LDA B,I CCE,SZA,RSS If class never allocated, JMP RID3 just clear entry. AND MAPHI IOR BIT13 RAL,ERA STA CLAS2 * * Set up a loop to remove all requests on this class number, then to re- * lease the class number. * RID1 CCA Set the release retry STA TEMP switch to -1. * RID2 JSB EXEC Go to RTE to release class buffer. DEF *+5 DEF NA21 Class get, no abort DEF CLAS2 DEF DUMMY DEF D0 RSS Ignore errors. * ISZ TEMP Release processing completed? JMP RID3 Yes - zero entry. INA,SZA No - all pending reqs. cleared? JMP RID1 No - continue to clear requests. * LDA CLAS2 Yes - remove save class XOR BIT13 number bit (bit 13) STA CLAS2 and return for final JMP RID2 deallocation. * * Set the first word of the entry to zero to signify the entry is empty, * decrement the copy count, then return. * RID3 CLA STA ENTAD,I CMA ADA RD.TB,I STA RD.TB,I JMP RID,I SKP * * SCHEDule is a utility subroutine for RDBAM which schedules the RDBAP * copy described in the entry of the RDBAP copy scheduling table speci- * fied in ENTAD. The schedule is immediate, without wait3~ and the RDBAP * copy is passed: * 1) its class number * 2) its index into the scheduling table * 3) RDBAM's class number * * The calling sequence for SCHED is: * * ENTAD = address of RDBAP copy's entry in scheduling table * INDEX = index into scheduling table for RDBAP copy's entry * JSB SCHED * DEF *+1 return address * * * SCHED NOP JSB .ENTR DEF SCHED * * Get addresses of RDBAP copy's name and class number in entry, and put * them into scheduling EXEC call. * LDA ENTAD ADA BPNAM STA NAMAD ADA D3 STA CLADR * * Schedule RDBAP copy. * JSB EXEC DEF *+6 DEF NA10 Immediate schedule, no wait, no abort NAMAD ABS *-* CLADR ABS *-* DEF INDEX DEF CLASS JMP SCHED,I Abortion return point. * ISZ SCHED JMP SCHED,I Normal return point. SKP * * TERMinate is a utility subroutine for RDBAM which terminates the copy * of RDBAP specified by the entry in the scheduling table pointed to by * ENTAD and removes it from the system. * * The calling sequence for TERM is: * * ENTAD = address of RDBAP copy's entry in scheduling table * JSB TERM * * TERM NOP * * Get address of RDBAP copy's name and put it in terminating EXEC call. * LDA ENTAD ADA BPNAM STA OFNAM * * Go to RTE to terminate the copy normally. * JSB EXEC DEF *+4 DEF NA6 Terminate, no abort. OFNAM ABS *-* DEF D0 Normal completion. NOP Ignore errors. * * Ask C.RP to remove the copy's ID segment from the system. * LDB OFNAM CLA JSB C.RP NOP Ignore errors. JMP TERM,I Return to caller. * * NA6 OCT 100006 SKP * * SWTCH is a utility subroutine for RDBAM which calls #REQU to transfer * a request from RDBAM's class to the class of the RDBAP copy specified * by the entry of the scheduling table pointed to by ENTAD. * * The calling sequence for SWTCH is: * * ENTAD = address of entry in scheduling table for RDBAP copy * JSB SWTCH * * * SWTCH NOP * * Get the RDBAP copy's class number from its entry in the scheduling table * and call #REQU. * LDA ENTAD ADA BPCLS LDB A,I STB CLAS2 * JSB #REQU DEF *+3 DEF CLASS DEF CLAS2 * SSA,RSS If no error, ISZ SWTCH bump return point. JMP SWTCH,I Return. SKP * * RMOVE is a utility subroutine which removes the current request from * RDBAM's class number. * * The calling sequence for RMOVE is: * * CLASS = RDBAM's class number * JSB RMOVE * * RMOVE NOP * * Get class number, remove its save buffer bit, set its save class and * no waits bits. * LDA CLASS XOR BIT14 STA CLAS2 * * Go to RTE to release class buffer. * JSB EXEC DEF *+5 DEF NA21 Class get, no abort DEF CLAS2 DEF DUMMY DEF D0 No data NOP Ignore errors. JMP RMOVE,I SKP * * This short subroutine is bid up when RDBAM is first scheduled and is * unable to find the type 6 file named RDBAP. It merely prints a warning * message to the system console and returns. * BAPER NOP * JSB EXEC DEF *+5 DEF NA2 write, no abort DEF ERLU error lu passed by LSTEN DEF BAMES warning message DEF D22 message length NOP ignore abort return * CLA Set A to zero so as to skip JMP BAPER,I call to C.RP on return. * .rplBAMES ASC 22,/RDBAM - WARNING RDBAP MUST BE IN THE SYSTEM * D22 DEC 22 NA2 OCT 100002 M144 DEC -144 M1 DEC -1 D2 DEC 2 D3 DEC 3 * MAPHI OCT 17777 BIT13 OCT 020000 BIT14 OCT 040000 NA19 OCT 100023 NA10 OCT 100012 * CNTR1 NOP CNTR2 NOP TABAD NOP ENTAD NOP EMPTY NOP INDEX NOP TEMP NOP END RDBAM END$ vr ]u 92069-18259 1912 S C0122 &BAPHD BAPHD SOURCE             H0101 yTASMB,L HED HEADER FOR RDBAP NAM BAPHD,7 92069-16259 REV.1912 790130 * * ******************************************************************* * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR WRITTEN * CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18259 * RELOC: 92069-16259 * * PRGMR: CEJ * * ******************************************************************* * * END MU ^d 92069-18260 1912 S C0122 &RDBAP RDBAP SOURCE             H0101 z_ASMB,L,C,R HED RDBAP - REMOTE DATA BASE ACCESS PROGRAM MAIN NAM RDBAP,20,40 92069-16259 REV.1912 790130 * * ******************************************************************* * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR WRITTEN * CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18260 * RELOC: 92069-16259 * * PRGMR: CEJ * * ******************************************************************* * * * * COM DABUF(2174),RQBUF(21) COM RECRQ,RECDA,SEGNM,DBCNT,CLASS(5) * * This is the main of the Remote Data Base Access Program for Remote * IMAGE/1000. It performs the following sequence of operations. * * 1) Retrieve scheduling parameters. These are our class number, our * index in the RDBAP copy scheduling table, and RDBAM's class number, * in that order. * * 2) Ask D65GT to get the request and data off of our class. If there * is any error: * * A) Send a reply with proper DS error code. * * B) If we do not have a data base open (DBCNT is zero) then send * RDBAM a request to remove us from the system (RDBA Index is -2 * and Mode is our index in RDBAP copy scheduling table) and termi- * nate normally. * * C) Return to class GET. * * 3) Get RDBA Index from 5th word of request buffer. If it is a negative * one (-1), this is a clean-up request. Schedule the 4th segment of * this program. If any error, set DBCNT to zero and go to 2-B. * * 4) Get RDBA Index from 5th word of request buffer and bound check for * validity. Index must be within [36,45]. If bound check fails, go * to 2-A. * * 5) Determine the segment of our program which is to service this re- * quest as ;follows: * DBOPN, DBINF, DBLCK, DBUNL, DBCLS serviced by segment 1 * DBFND, DBGET, DBUPD serviced by segment 2 * DBPUT, DBDEL serviced by segment 3 * * 6) Load and execute the appropriate segment. If any error go to 2-A. * ENT RDBAP,BP.GT EXT BAPS1,BAPS2,BAPS3 EXT D65GT,DBBUF,EXEC,RDEXT,RMPAR,SEGLD SKP ********************************************************************** *** *** * Standard DS/1000 equates * *** *** #STR EQU 0 #SEQ EQU 1 #SRC EQU 2 #DST EQU 3 #RDB EQU 4 #EC1 EQU 4 #EC2 EQU 5 #ENO EQU 6 #REP EQU 7 *** *** ********************************************************************** ********************************************************************** * * * DS/1000 RDBA Communications consist of two descriptive buffers: * * 1) Request buffer * * 2) Reply buffer * * These two static buffers are as described below. * * * ********************************************************************** *** *** * * * Request buffer - one buffer of from 12 to 21 words per RDBA call * * * *** *** RBSTR EQU #STR DS/1000 stream word RBSEQ EQU #SEQ DS/1000 sequence number RBSRC EQU #SRC DS/1000 source node number RBDST EQU #DST DS/1000 destinatYion node number RBIDX EQU #RDB RDBA call Index RBMOD EQU #RDB+1 RDBA call mode RBID EQU #RDB+2 RDBA call item or set number * or for a DBOPN, the level code word RBITM EQU #RDB+3 Search item number for DBFND RBMRT EQU #RDB+5 For DBOPN, max. returned RT size RBLEN EQU #RDB+6 Word size of ibase parameter RBBAS EQU #RDB+7 Ibase parameter *** *** *** *** * * * Reply buffer - one buffer of either 17 or 18 words per RDBA call * * * *** * * RBSTR EQU #STR DS 1000 stream word * RBSEQ EQU #SEQ DS/1000 sequence number * RBSRC EQU #SRC DS/1000 source node number * RBDST EQU #DST DS/1000 destination node number RBEC1 EQU #EC1 DS/1000 1st error code word RBEC2 EQU #EC2 DS/1000 2nd error code word RBEC3 EQU #ENO DS/1000 error node number upon an error RBSTA EQU #REP RDBA call status array RBNUM EQU #REP+10 RDBA data base number for DBOPN * RPLEN DEC 17 Standard reply buffer length * 18 for DBOPN *** *** ********************************************************************** * * Maximum request and data buffers. * MAXRQ DEC 21 MAXDA DEC 2174 * A EQU 0 B EQU 1 SKP * * Retrieve scheduling parameters * RDBAP JSB RMPAR DEF *+2 DEF CLASS * * Ask D65GT to get the data and request off of our class number for us. * BP.GT JSB D65GT DEF *+6 DEF CLASS D65GT needs: class number DEF RQBUF request buffer DEF MAXRQ max. request length DEF DABUF P data buffer DEF MAXDA max. data length JMP E153 error return point * STA RECRQ returns: request length in STB RECDA A reg., data length in B. * * Get the RDBA Index from the request buffer (5th word) and check if this * is a special clean-up request from the DS software. If so, the Index * will be -1, bring up the 4th segment to perform the clean-up. * LDA RQBUF+RBIDX INA,SZA JMP BAP No - a normal request. * JSB SEGLD DEF *+3 DEF SEG4,I DEF IERR * * If we returned from the SEGLD call, we got an error. One of our seg- * ments is missing. Set data base count (DBCNT) to zero, and terminate * permanently. * CLB STB DBCNT JMP EREXT SKP * * Get the RDBA index from the request buffer (5th word) and make sure it * falls within the bounds of an IMAGE/1000 call, i.e. Index within [36..45]. * The bound check effectively maps [36..45] onto [0..9] in a one-to-one * fashion. * BAP LDB RQBUF+RBIDX CMB,INB ADB D35 Is index > 35? SSB,RSS JMP E159 No - error ADB D10 Yes - is index < 46? SSB JMP E159 No - error STB RQBUF+RBIDX Yes - save this result * * The base parameter for the IMAGE call starts in the 12th word of the * request buffer. Its first word contains the index for our program in the * high byte and the data base number in the low byte. Remove our index * from this word (unless this happens to be a DBOPN call in which case it * is two blanks and is left the same). * CPB D9 B = 9 if a DBOPN request. JMP BAP0 LDA RQBUF+RBBAS AND LOBYT STA RQBUF+RBBAS * * We will allow each segment to do its own parse of the request (and data) * buffer(s) because it varies from call to call. Now, all we need to do * is determine which segment to load t(based on the index we resulted in * from our subtractions and additions above and jumping into the table * below), then we load it. * BAP0 BLS Multiply index by two ADB TABAD (2 words/entry in table) JMP B,I then index into the table. * TABAD DEF *+1 LDA SEG1 Index = 45, DBUNL JMP BAP1 LDA SEG1 Index = 44, DBLCK JMP BAP1 LDA SEG3 Index = 43, DBDEL JMP BAP1 LDA SEG3 Index = 42, DBPUT JMP BAP1 LDA SEG2 Index = 41, DBUPD JMP BAP1 LDA SEG2 Index = 40, DBGET JMP BAP1 LDA SEG2 Index = 39, DBFND JMP BAP1 LDA SEG1 Index = 38, DBCLS JMP BAP1 LDA SEG1 Index = 37, DBINF JMP BAP1 LDA SEG1 Index = 36, DBOPN * BAP1 STA SEGAD * * Check to see if this segment is already in memory. If so, no need to * call SEGLD to bring it in again. The current segment's name suffix * is in SEGNM in common. * ADA D2 LDA A,I CPA SEGNM RSS JMP BAP2 Not there, load it. * * Segment is already in memory. Determine which entry point to take by * putting the number suffix in the low order byte of the A register and * subtracting 61B to get a number within [0..2]. Then use this number * as an index into the following JMP table. * ALF,ALF AND LOBYT ADA M61B ADA JMPTB JMP A,I * JMPTB DEF *+1 JMP BAPS1 Segment one. JMP BAPS2 Segment two. JMP BAPS3 Segment three. * * Segment not already in memory. Load it and give it control. * BAP2 JSB SEGLD DEF *+3 SEGAD ABS *-* DEF IERR * * If we returned from the SEGLD call, we got an error. One of our seg- * ments is missing. * LDB M156 Segment error RSS E159 LDB M159 Illegal index RSS E153 LDB M153 Illegal request or data size EREXT CLA $" DST ERROR * CLB STB RECDA Set returned data length to zero. JSB RDEXT Send DS reply. DEF *+6 DEF RQBUF RDEXT needs: reply buffer DEF RPLEN reply length DEF DABUF data buffer DEF RECDA data length DEF ERROR error code. NOP * LDA DBCNT If we have no open data base, SZA JMP BP.GT * LDA M2 Send RDBAM a "remove me" request. STA RQBUF+RBIDX RDBA Index is -2 for this request LDA CLASS+1 and the mode is our index STA RQBUF+RBMOD into the RDBAP copy scheduling table. * JSB EXEC DEF *+8 DEF WT/RD write/read w/no abort DEF CONTR double buffer, lu zero DEF DABUF DEF D0 no data DEF RQBUF OFf request buffer DEF D7 request length DEF CLASS+2 RDBAM's class number NOP ignore errors * JSB EXEC End of run. DEF *+4 DEF D6 DEF D0 DEF D0 Normal completion. * * Constants and variables. * M159 DEC -159 M156 DEC -156 M153 DEC -153 M61B OCT -61 M2 DEC -2 D0 DEC 0 D2 DEC 2 D6 DEC 6 D7 DEC 7 D9 DEC 9 D10 DEC 10 D35 DEC 35 * WT/RD OCT 100024 CONTR OCT 010000 LOBYT OCT 377 * ERROR BSS 2 IERR EQU ERROR * SEG1 DEF *+1 ASC 3,BAPS1 SEG2 DEF *+1 ASC 3,BAPS2 SEG3 DEF *+1 ASC 3,BAPS3 SEG4 DEF *+1 ASC 3,BAPS4 END RDBAP $ _ j 92069-18261 1912 S C0122 &BAPS1 BAPS1 SOURCE             H0101 iMASMB,L,C,R HED BAPS1 - REMOTE DATA BASE ACCESS PROGRAM SEGMENT 1 NAM BAPS1,5 92069-16259 REV.1912 790214 * * ******************************************************************* * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR WRITTEN * CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18261 * RELOC: 92069-16259 * * PRGMR: CEJ * * ******************************************************************* * * * COM DABUF(2174),RQBUF(21) COM RECRQ,RECDA,SEGNM,DBCNT,CLASS(5) * * Segment 1 of the Remote Data Base Access Program. This segment has the * following sequence of operations. * * 1) Determine the type of IMAGE call and branch to the appropriate * call handler. * * A) DBOPN * * I ) Perform the DBOPN call. If any error, go to 2. * * II ) Increment data base count. * * III) Build compacted Run Table for the source node in the data * buffer. * * IV ) Go to 2. * * B) DBINF * * I ) Perform DBINF call. * * II) Go to 2. * * C) DBCLS * * I ) Perform DBCLS call. If DBCLS successful and this was a * mode 1 DBCLS, then decrement the data base count (DBCNT). * * II) Go to 2. * * D) DBLCK * * I ) Perform DBLCK call. * * II) Go to 2. * * E) DBUNL * * I ) Perform DBUNL call. * * II) Go to 2. * * 2) Send the RDBA reply and any data associated with it. * * 3) If data base count (DBCNT) is zero, then send a request to RDBAM to * remove us from the system and terminate normally. * * 4) Return to class get in main. SKP ********************************************************************** *** *** * Standard DS/1000 equates * *** *** #STR EQU 0 #SEQ EQU 1 #SRC EQU 2 #DST EQU 3 #RDB EQU 4 #EC1 EQU 4 #EC2 EQU 5 #ENO EQU 6 #REP EQU 7 *** *** ********************************************************************** ********************************************************************** * * * DS/1000 RDBA Communications consist of two descriptive buffers: * * 1) Request buffer * * 2) Reply buffer * * These two static buffers are as described below. * * * ********************************************************************** *** *** * * * Request buffer - one buffer of from 12 to 21 words per RDBA call * * * *** *** RBSTR EQU #STR DS/1000 stream word RBSEQ EQU #SEQ DS/1000 sequence number RBSRC EQU #SRC DS/1000 source node number RBDST EQU #DST DS/1000 destination node number RBIDX EQU #RDB RDBA call Index RBMOD EQU #RDB+1 RDBA call mode RBID EQU #RDB+2 RDBA call item or set number * or for a DBOPN, the level code word RBITM EQU #RDB+3 Search item number for DBFND RBMRT EQU #RDB+5 For DBOPN, max. returned RT size RBLEN EQU #RDB+6 Word size of ibase parameter RBBAS EQU #RDB+7 Ibase parameter * MAXRQ DEC |h21 Maximum request buffer length *** *** *** *** * * * Reply buffer - one buffer of either 17 or 18 words per RDBA call * * * *** * * RBSTR EQU #STR DS 1000 stream word * RBSEQ EQU #SEQ DS/1000 sequence number * RBSRC EQU #SRC DS/1000 source node number * RBDST EQU #DST DS/1000 destination node number RBEC1 EQU #EC1 DS/1000 1st error code word RBEC2 EQU #EC2 DS/1000 2nd error code word RBEC3 EQU #ENO DS/1000 error node number upon an error RBSTA EQU #REP RDBA call status array RBNUM EQU #REP+10 RDBA data base number for DBOPN * RPLEN DEC 17 Standard reply buffer length * 18 for DBOPN *** *** ********************************************************************** * ENT BAPS1 EXT BP.GT,DBCLS,DBINF,DBLCK,DBOPN,DBUNL EXT EXEC,GETKY,RDEXT * A EQU 0 B EQU 1 DAADR DEF DABUF BFLEN DEC 2174 * * Set the reply length to the standard reply length. * BAPS1 LDA RPLEN STA LENTH * * Put our name suffix into SEGNM in common. That way, RDBAP (the main) * will not reload us if another request comes through for us to handle. * LDA SUFIX STA SEGNM * * Determine the type of IMAGE call being made by the index calculated in * the main and jump to the proper handling routine. Remember that this * index is: 45 - (RDBA Index). * LDA RQBUF+RBIDX ADA JMPTB JMP A,I * JMPTB DEF *+1 JMP UNL RDBA Index = 45, DBUNL JMP LCK RDBA Index = 44, DBLCK JMP E159 JMP E159 RDBA Index within _[43,39] JMP E159 should not happen. JMP E159 JMP E159 JMP CLS RDBA Index = 38, DBCLS JMP INF RDBA Index = 37, DBINF JMP OPN RDBA Index = 36, DBOPN SKP * * A remote DBOPN. * The RDBA request buffer contains the following information. * OPMOD EQU RQBUF+RBMOD open mode LEVEL EQU RQBUF+RBID level code word (3 words) OPBAS EQU RQBUF+RBBAS data base namr * * The status array is the 8th through 17th words of the reply buffer. * In the 18th word of the reply buffer, we return our suffix. * OPSTA EQU RQBUF+RBSTA status array OPSUF EQU RQBUF+RBNUM remote data base number. * * Save off maximum acceptable Run Table size for later. * OPN LDA RQBUF+RBMRT STA MAXRT * * Perform the DBOPN call. * JSB DBOPN DEF *+5 DEF OPBAS DEF LEVEL DEF OPMOD DEF OPSTA * * If DBOPN succeeded, we need to build the source node's compacted Run * Table and increment the data base count. Else, we can just return the * error to the source node. * CLB Set length of reply data to zero. LDA OPSTA SZA JMP EXIT * * Since DBOPN succeeded, put our index into first byte of OPSUF, then * set the reply length to 18 words instead of 17. * ISZ DBCNT Increment data base count. LDA CLASS+1 ALF,ALF IOR OPBAS STA OPSUF ISZ LENTH * * Initialize the parameters for the Run Table build. * * * Get the address of the data buffer from common. * LDA DAADR STA ADDRS * * Determine the address for the item number buffer. We will use this for * a call to DBINF in mode 103. This returns the number of accesible items * in the data base and their respective item numbers (negative if write- * able). * ADA BFLEN Use the last 256 words of the ADA M256 data buffer. Maximum of STA ITADR 255 items. * * -o Call DBINF to return us the item count and numbers. * JSB DBINF DEF *+6 DEF OPBAS DEF DUMMY This param ignored. DEF D103 DEF DUMMY We need only 2 words for status. DEF ITADR,I * * Now, our data buffer looks like this: * * word +------------------------------+ * DABUF -> 1 | | * | unused | * | as | * | of | * | yet | * | | * -------------------------------- * DABUF + BFLEN - 256 | item count | * | followed by count | * | number of item numbers | * DABUF + BFLEN +------------------------------+ * * We want to build the item table for the remote machine at the begin- * ning + 1 word of the data buffer as follows: * For each item number returned to us through the DBINF 103 call, call * DBINF in mode 102 to get the item's name, element count and element * length. (DBINF actually returns us 13 words of info but only these * 9 words are of interest to us.) These 13 words of info are put into * the first 13 words of the data buffer which, as of yet, have not been * used. To get an idea of what this does, the data buffer with look * like this after the first mode 102 call: * * word +------------------------------+ * DABUF + 2 | 16 character | * | data item name | * | (8 words) | * -------------------------------- * DABUF + 10 | item type | blank | * + -------------------------------- * DABUF + 11 | element length | * -------------------------------- * DABUF + 12 | element count | * -------------------------------- * DABUF + 13 | doubleword | * | zero | * -------------------------------- * DABUF + 15 | | * | unused | * | as | * | of | * | yet | * | | * -------------------------------- * DABUF + BFLEN - 256 | item count | * | followed by count num- | * | ber of item numbers | * DABUF + BFLEN +------------------------------+ * * We then condense these 13 words into the 5 words needed by a remote * 1000 node. The result takes the form: * * word +------------------------------+ * DABUF + 2 | item name | * | (3 words) | * | | * -------------------------------- * DABUF + 5 | item number | * -------------------------------- * DABUF + 6 | item length = element count *| element length * -------------------------------- * DABUF + 7 | | * | unused | * | as | * | of | * | yet | * | | * -------------------------------- * DABUF + BFLEN - 256 | item count | * | followed by count num- | * | ber of item numbers | * DABUF + BFLEN +------------------------------+ * * The first word of the data buffer contains the item count which is taken * from the first word of the item number buffer at the end. The buffer * for the next DBINF call then starts at the first word following the 5 * words of information for the first item. This process is repeated for * each item in the item number list. * LDA ITADR,I Use negative number of items STA ADDRS,I as a loop counter. ISZ ADDRS SZA,RSS JMP OPN2 No items accessible. CMA,INA STA CNTR * OPN1 ISZ ITADR If item number is negative, LDA ITADR,I make it positive. SSA CMA,INA STA ITADR,I * JSB DBINF Get the item's info. DEF *+6 DEF OPBAS DEF ITADR,I DEF D102 DEF DUMMY DEF ADDRS,I * LDB ADDRS Get item type from ADB D8 returned info STB TEMP and save. INB Get element length LDA B,I INB and element count STB DUMMY CLB and multiply to get item MPY DUMMY,I length in a register. LDB TEMP,I If item type is X CPB /X this length is now in bytes. ARS get it in words. * LDB ADDRS Compact the info. ADB D3 STB ADDRS LDB ITADR,I STB ADDRS,I ISZ ADDRS STA ADDRS,I ISZ ADDRS * ISZ CNTR JMP OPN1 * *  Now that we've built the item table for the remote machine, we need to * build its set table. The set table is built basically the same as the * item table. First we do a mode 203 DBINF call to get the count and * numbers of all available sets. Then, for each set we do a mode 202 call * to get the set name, entry length and set type. Although DBINF returns * 17 words of information only these five words are of interest. We then * compact the 17 words into 5 words for the remote 1000. After this com- * paction, we check the type of the data set. If it is a master, we need * to determine the length of its key item. GETKY performs this service * for us. Then, the key item length is appended to the compacted informa- * tion. If the set is a detail, a zero is appended. Each entry, then, * appears as: * * +------------------------------+ * | set name | * | (3 words) | * | | * -------------------------------- * | set number | * -------------------------------- * | length of entry | * -------------------------------- * | key item length, or zero | * +------------------------------+ * * Preceding the set table, and in the first word after the item table, is * stored the set count. The final remote Run Table then looks like: * * +------------------------------+ * | item count | * -------------------------------- * | item table | } 5 * | entry # 1 | } words * -98------------------------------- * . . * . . * . . * -------------------------------- * | item table | * | entry # count | * -------------------------------- * | set count | * -------------------------------- * | set table | } 6 * | entry # 1 | } words * -------------------------------- * . . * . . * . . * -------------------------------- * | set table | * | entry # count | * +------------------------------+ * * * First, determine the address for the set number buffer. We will use the * last 51 words of the data buffer for this purpose. * OPN2 LDA DAADR ADA BFLEN ADA M51 STA STADR * * Call DBINF to return us the set count and numbers. * JSB DBINF DEF *+6 DEF OPBAS DEF DUMMY This param. ignored DEF D203 DEF DUMMY Two words of status only DEF STADR,I * * Put the set count in the data buffer, and negate it for a loop counter. * LDA STADR,I STA ADDRS,I ISZ ADDRS SZA,RSS JMP OPN5 No sets accessible CMA,INA STA CNTR * * For each set number in the buffer get the necessary information. * OPN3 ISZ STADR LDA STADR,I If the seto number is negative, SSA CMA,INA make it positive. STA STADR,I * JSB DBINF DEF *+6 DEF OPBAS DEF STADR,I DEF D202 DEF DUMMY DEF ADDRS,I * * Compact the information we already have. * LDB ADDRS ADB D8 But first get and save the LDA B,I set type in word 8 STA TEMP INB and the entry length LDA B,I in word 9. STA DUMMY * LDB ADDRS ADB D3 LDA STADR,I Set number STA B,I INB LDA DUMMY Entry length STA B,I INB STB ADDRS Save place in entry. * * If set a master, get its key item length through GETKY. * LDA TEMP CPA /D JMP OPN4 * JSB GETKY Returns length DEF *+2 in A register. DEF STADR,I RSS * OPN4 CLA Length = 0 for a detail STA ADDRS,I ISZ ADDRS ISZ CNTR JMP OPN3 * * Run Table complete. Calculate the length of the returned data as fol- * lows: * length = (# of items) * 5 * + (# of sets) * 6 * + 2 <>. * Make sure that the Run Table built is no longer than the maximum allow- * able, then jump with the data length in the B register to the exit * routine. If the resulting Run Table is longer than maximum, then clean- * up open and return an IMAGE size error. * OPN5 LDA DABUF CLB MPY D5 STA TEMP ADA DAADR INA LDA A,I CLB MPY D6 LDB D2 ADB A ADB TEMP * STB A A = B = length of built Run Table. CMA,INA ADA MAXRT SSA,RSS A > max. allowed? JMP EXIT No * LDA OPSUF Yes - get data base number AND LOBYT from reply buffer. STA TEMP * JSB DBCLS Close newly opened data base. DEF8 *+5 DEF TEMP DEF D0 DEF D1 DEF DUMMY * CCA Decrement data base count. ADA DBCNT STA DBCNT * LDA D128 Set error code to 128 STA OPSTA LDA RPLEN reply length to 17 STA LENTH CLB and data length to zero. JMP EXIT Then return. * * Constants and variables. * M256 DEC -256 M51 DEC -51 D3 DEC 3 D5 DEC 5 D8 DEC 8 D102 DEC 102 D103 DEC 103 D128 DEC 128 D202 DEC 202 D203 DEC 203 * /D ASC 1,D /X ASC 1,X * CNTR NOP ADDRS NOP ITADR NOP STADR EQU ITADR DUMMY BSS 2 TEMP NOP MAXRT NOP SKP * * A remote DBINF. * The RDBA request buffer contains the following information: * IFMOD EQU RQBUF+RBMOD Info mode IFID EQU RQBUF+RBID Data set or item number IFBAS EQU RQBUF+RBBAS Data base parameter * * The status array is the 8th through 17th words of the reply buffer. * IFSTA EQU RQBUF+RBSTA * * The ibuf parameter is the data buffer. * IFBUF EQU DABUF * * Perform the DBINF call. * INF JSB DBINF DEF *+6 DEF IFBAS DEF IFID DEF IFMOD DEF IFSTA DEF IFBUF * * If DBINF returned an error code or this was a mode 402 request, there * is no data to return. Else, get the length of the data to return from * the second word of istat and jump to the EXIT routine. * CLB LDA IFMOD CPA D402 RSS LDA IFSTA SZA,RSS LDB IFSTA+1 JMP EXIT SKP * * A remote DBCLS. * The RDBA request buffer contains the following information: * CLMOD EQU RQBUF+RBMOD Close mode CLID EQU RQBUF+RBID Data set number CLBAS EQU RQBUF+RBBAS Data base parameter * * The status array is the 8th through 17th words of the reply buffer. * CLSTA EQU RQBUF+RBSTA * * There is no data associated with the request or reply. * * Perform the DBCLS call. * CLS JSB DBCLS DEF *+5 DEF CLBAS DEF CLID DEF CLMOD DEF CLSTA * * Set the returned data langth to zero. Then, if the close mode was 1 * and the DBCLS call succeeded, decrement the data base count. * CLB LDA CLMOD CPA D1 RSS JMP EXIT * CCB ADB DBCNT LDA CLSTA 1st word of CLSTA is zero SZA,RSS if DBCLS succeeded. STB DBCNT CLB JMP EXIT SKP * * A remote DBLCK. * The RDBA buffer contains the following information: * LKMOD EQU RQBUF+RBMOD Lock mode LKID EQU RQBUF+RBID Unused data set number LKBAS EQU RQBUF+RBBAS Data base parameter * * The status array is the 8th through 17th words of the reply buffer. * LKSTA EQU RQBUF+RBSTA * * There is no data associated with the request or reply. * * Perform the DBLCK call. * LCK JSB DBLCK DEF *+5 DEF LKBAS DEF LKID DEF LKMOD DEF LKSTA * * Set the returned data length to zero and jump to the exit routine. * CLB JMP EXIT SKP * * A remote DBUNL. * The RDBA request buffer contains the following information: * ULMOD EQU RQBUF+RBMOD Unlock mode ULID EQU RQBUF+RBID Unused data set number ULBAS EQU RQBUF+RBBAS Data base parameter * * The status array is the 8th through 17th words of the reply buffer. * ULSTA EQU RQBUF+RBSTA * * There is no data associated with the request or reply. * * Perform the DBUNL call. * UNL JSB DBUNL DEF *+5 DEF ULBAS DEF ULID DEF ULMOD DEF ULSTA * * Set the returned data length to zero and continue into the exit routine. * CLB JMP EXIT SKP * * This is the only DS error return point. A bad RDBA index found. * E159 LDB M159 Get error code and set CLA returned data length to zero. STA RECDA JMP EXIT2 * * This is tެhe exit routine for segment 1 of RDBAP. Its purpose is to * call the necessary subroutines in order to send the RDBA reply to the * orginating node and to terminate this operation. All replies are sent * through RDEXT. * EXIT STB RECDA Set returned data length in common. CLA Set error code to zero CLB i.e. no error. EXIT2 DST ERROR * JSB RDEXT RDEXT builds the reply buffer DEF *+6 and then sends it to the DEF RQBUF originator through D65SV. DEF LENTH DEF DABUF DEF RECDA DEF ERROR RSS Error on sending reply. JMP EXIT3 Normal return. * * On error from RDEXT, check to see if this was a successful DBOPN re- * quest. (The reply length will be 18 in this case.) If so, close the * newly opened data base and decrement the data base count. * LDA LENTH CPA D18 RSS JMP EXIT3 Not a DBOPN. * LDA OPSUF Get data base number AND LOBYT from reply buffer. STA TEMP This is all we need for DBCLS. * JSB DBCLS DEF *+5 DEF TEMP DEF D0 DEF D1 Close mode 1. DEF DUMMY Dummy status array. * CCA Decrement data base count. ADA DBCNT STA DBCNT * * If the data base count is now zero, we want to terminate ourselves. * EXIT3 LDA DBCNT If data base count is not zero, SZA JMP BP.GT return to class get in main. * LDA M2 Else, tell RDBAM to OFf us. STA RQBUF+RBIDX RDBA Index = -2 for such a request. LDA CLASS+1 Mode is our index into STA RQBUF+RBMOD the RDBAP copy scheduling table. JSB EXEC DEF *+8 DEF WT/RD write/read w/no abort DEF CONTR double buffer, lu 0 DEF DABUF DEF D0 no data DEF RQBUF OFf request buffer DEF D7 and length DEF CTRNLASS+2 RDBAM's class number NOP ignore abortion return * JSB EXEC Then terminate. DEF *+4 DEF D6 DEF D0 DEF D0 Normal completion. * * Constants and variables. * M159 DEC -159 M2 DEC -2 D0 DEC 0 D1 DEC 1 D2 DEC 2 D6 DEC 6 D7 DEC 7 D18 DEC 18 D402 DEC 402 * WT/RD OCT 100024 CONTR OCT 010000 LOBYT OCT 377 SUFIX ASC 1,1 * ERROR BSS 2 LENTH NOP END BAPS1 T `s 92069-18262 1912 S C0122 &BAPS2 BAPS2 SOURCE             H0101 kNASMB,L,C,R HED BAPS2 - REMOTE DATA BASE ACCESS PROGRAM SEGMENT 2 NAM BAPS2,5 92069-16259 REV.1912 790130 * * ******************************************************************* * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR WRITTEN * CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18262 * RELOC: 92069-16259 * * PRGMR: CEJ * * ******************************************************************* * * * COM DABUF(2174),RQBUF(21) COM RECRQ,RECDA,SEGNM * * Segment two of the Remote Data Base Access Program. This segment has * the following sequence of operations. * * 1) Determine the type of IMAGE call and branch to the appropriate call * handler. * * A) DBFND * * I ) Perform the DBFND call. * * II) Go to 2. * * B) DBGET * * I ) Perform the DBGET call. * * II) Go to 2. * * C) DBUPD * * I ) Perform the DBUPD call. * * II) Go to 2. * * 2) Send the RDBA reply and any associated data. Ignore any errors. * * 3) Return to class get in main. * SKP ********************************************************************** *** *** * Standard DS/1000 equates * *** *** #STR EQU 0 #SEQ EQU 1 #SRC EQU 2 #DST EQU 3 #RDB EQU 4 #EC1 EQU 4 #EC2 EQU 5 #ENO EQU 6 #REP EQU 7 *** *** ********************************************************************** ********************************************************************** *  * * DS/1000 RDBA Communications consist of two descriptive buffers: * * 1) Request buffer * * 2) Reply buffer * * These two static buffers are as described below. * * * ********************************************************************** *** *** * * * Request buffer - one buffer of from 12 to 21 words per RDBA call * * * *** *** RBSTR EQU #STR DS/1000 stream word RBSEQ EQU #SEQ DS/1000 sequence number RBSRC EQU #SRC DS/1000 source node number RBDST EQU #DST DS/1000 destination node number RBIDX EQU #RDB RDBA call Index RBMOD EQU #RDB+1 RDBA call mode RBID EQU #RDB+2 RDBA call item or set number * or for a DBOPN, the level code word RBITM EQU #RDB+3 Search item number for DBFND RBMRT EQU #RDB+5 For DBOPN, the max. returned RT size RBLEN EQU #RDB+6 Word size of ibase parameter RBBAS EQU #RDB+7 Ibase parameter * MAXRQ DEC 21 Maximum request buffer length *** *** *** *** * * * Reply buffer - one buffer of either 17 or 18 words per RDBA call * * * *** * * RBSTR EQU #STR DS 1000 stream word * RBSEQ EQU #SEQ DS/1000 sequence number * RBSRC EQU #SRC DS/1000 source node number * RBDST EQU #DST DS/1000 destination node number RBEC1 EQU #EC1 DS/1000 1st error code word RBEC2 EQU #EC2 DS/1000 2nd error code word RBEC3 EQU #ENO DS/1000 error node number upon an error RBSTA EQU #REP RDBA call status array RBNUM EQU #REP+10 RDBA data base number for DBOPN * RPLEN DEC 17 Standard reply buffer length * 18 for DBOPN *** *** ********************************************************************** ENT BAPS2 EXT BP.GT,DBFND,DBGET,DBUPD EXT RDEXT * DAADR DEF DABUF A EQU 0 B EQU 1 * * Put our name suffix into SEGNM in common. That way, if another request * comes through for this segment, RDBAP (the main) will not reload us. * BAPS2 LDA SUFIX STA SEGNM * * Determine the type of IMAGE call being made by the index calculated * in the main and jump to the proper handling routine. Remember that * this index is: 45 - (RDBA Index). * LDB RQBUF+RBIDX ADB JMPTB JMP B,I * JMPTB DEF *+1 JMP E159 JMP E159 RDBA Index within [45,42] JMP E159 should not happen. JMP E159 JMP UPD RDBA Index = 41, DBUPD JMP GET RDBA Index = 42, DBGET JMP FND RDBA Index = 40, DBFND JMP E159 JMP E159 RDBA Index within [39,36] JMP E159 should not happen. SKP * * A remote DBFND. * The request buffer contains the following information: * FNMOD EQU RQBUF+RBMOD Find mode FNSET EQU RQBUF+RBID Data set number FNITM EQU RQBUF+RBITM Data item number FNBAS EQU RQBUF+RBBAS Data base parameter * * The status array is the 8th through 17th words of the reply buffer. * FNSTA EQU RQBUF+RBSTA * * The key item value is in the data buffer. * FNARG EQU DABUF * * Perform the DBFND call. * FND JSB DBFND DEF *`5+7 DEF FNBAS DEF FNSET DEF FNMOD DEF FNSTA DEF FNITM DEF FNARG * * There is no data to return, so set reply data length to zero (in B * register) and jump to the exit routine. * CLB JMP EXIT SKP * * A remote DBGET. * The request buffer contains the following information: * GTMOD EQU RQBUF+RBMOD Get mode GTSET EQU RQBUF+RBID Data set number GTBAS EQU RQBUF+RBBAS Data base parameter * * The status array is the 8th through 17th words of the reply buffer. * GTSTA EQU RQBUF+RBSTA * * The item list is the 2nd through ?th words of the data buffer. * GTLST EQU DABUF+1 * * The key item value for a mode 7 get or the record number for a mode * 4 get is in the necessary number of words immediately following the * item list in the data buffer. The first word of the data buffer con- * tains the length of the item list. Therefore, the address of the IARG * parameter is the address of the data buffer plus the length of the list * plus one. * GET LDA DAADR ADA DABUF INA STA GTARG * * Perform the DBGET call, the data read is returned in the data buffer. * JSB DBGET DEF *+8 DEF GTBAS DEF GTSET DEF GTMOD DEF GTSTA DEF GTLST DEF DABUF DEF GTARG,I * * If DBGET did not succeed (i.e. first word of GTSTA NE 0) then the re- * turned data length is zero. Else, the returned data length is in the * 2nd word of the status array. Get this length in the B register and * jump to the exit routine. * CLB LDA GTSTA SZA,RSS LDB GTSTA+1 JMP EXIT * * Constants and variables. * GTARG NOP SKP * * A remote DBUPD. * The request buffer contains the following information: * UPMOD EQU RQBUF+RBMOD Update mode UPSET EQU RQBUF+RBID Data set number UPBAS EQU RQBUF+RBBAS Data base parameter * * The status array is the 8th through 17th words of the reply buffer. * UPSTA EQU RQBUF+RBSTA * * The item list starts in the 2nd word of the data buffer. * UPLST EQU DABUF+1 * * The values for the items in the item list immediately follow the item * list in the data buffer. The first word of the data buffer contains * the length of the item list. Therefore, the address of the value buf- * fer is the address of the data buffer plus the length of the item list * plus one. * UPD LDA DAADR ADA DABUF INA STA UPBUF * * Perform the DBUPD call. * JSB DBUPD DEF *+7 DEF UPBAS DEF UPSET DEF UPMOD DEF UPSTA DEF UPLST DEF UPBUF,I * * There is no return data, so set the length of returned data to zero, * and jump to the exit routine. * CLB JMP EXIT * * Constants and variables. * UPBUF NOP SKP * * The only DS error routine is when the RDBA Index for this segment is * in error. * E159 LDB M159 CLA STA RECDA Set data length to zero. JMP EXIT2 * * This is the exit routine for segment 2 of RDBAP. Its purpose is to * call the necessary subroutines in order to send the RDBA reply to the * originating node and to terminate the program, saving resources. All * DS replies are sent through RDEXT. * EXIT STB RECDA Set returning data length CLA CLB and zero the error code. EXIT2 DST ERROR * JSB RDEXT Then let RDEXT send the reply. DEF *+6 DEF RQBUF It needs: reply buffer DEF RPLEN reply length DEF DABUF data buffer DEF RECDA data length DEF ERROR error code NOP * JMP BP.GT Return to class get in main. * * Constants and variables. * M159 DEC -159 * SUFIX ASC 1,2 * ERROR BSS 2 END BAPS2 f$"$ a l 92069-18263 1912 S C0122 &BAPS3 BAPS3 SOURCE             H0101 mOASMB,L,C,R HED BAPS3 - REMOTE DATA BASE ACCESS PROGRAM SEGMENT 3 NAM BAPS3,5 92069-16259 REV.1912 790130 * * ******************************************************************* * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR WRITTEN * CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18263 * RELOC: 92069-16259 * * PRGMR: CEJ * * ******************************************************************* * * * COM DABUF(2174),RQBUF(21) COM RECRQ,RECDA,SEGNM * * Segment three of the Remote Data Base Access Program. This segment * has the following sequence of operations. * * 1) Determine the tyep of IMAGE call and branch to the appropriate call * handler. * * A) DBPUT * * I ) Perform the DBPUT call. * * II) Go to 2. * * B) DBDEL * * I ) Perform the DBDEL call. * * II) Go to 2. * * 2) Send the RDBA reply (no data). * * 3) Return to class get in main. * SKP ********************************************************************** *** *** * Standard DS/1000 equates * *** *** #STR EQU 0 #SEQ EQU 1 #SRC EQU 2 #DST EQU 3 #RDB EQU 4 #EC1 EQU 4 #EC2 EQU 5 #ENO EQU 6 #REP EQU 7 *** *** ********************************************************************** ********************************************************************** * * * DS/1000 RDBA Communications consist of two descriptive buffers:! * * 1) Request buffer * * 2) Reply buffer * * These two static buffers are as described below. * * * ********************************************************************** *** *** * * * Request buffer - one buffer of from 12 to 21 words per RDBA call * * * *** *** RBSTR EQU #STR DS/1000 stream word RBSEQ EQU #SEQ DS/1000 sequence number RBSRC EQU #SRC DS/1000 source node number RBDST EQU #DST DS/1000 destination node number RBIDX EQU #RDB RDBA call Index RBMOD EQU #RDB+1 RDBA call mode RBID EQU #RDB+2 RDBA call item or set number * or for a DBOPN, the level code word RBITM EQU #RDB+3 Search item number for DBFND RBMRT EQU #RDB+5 For DBOPN, the max. returned RT size RBLEN EQU #RDB+6 Word size of ibase parameter RBBAS EQU #RDB+7 Ibase parameter * MAXRQ DEC 21 Maximum request buffer length *** *** *** *** * * * Reply buffer - one buffer of either 17 or 18 words per RDBA call * * * *** * * RBSTR EQU #STR DS 1000 stream word * RBSEQ EQU #SEQ DS/1000 sequence number * RBSRC EQU #SRC DS/1000 source node number * RBDST EQU #DST DS/1000 destination node number RBEC1 EQU #EC1 DS/1000 1st error code word RBEC2 dEQU #EC2 DS/1000 2nd error code word RBEC3 EQU #ENO DS/1000 error node number upon an error RBSTA EQU #REP RDBA call status array RBNUM EQU #REP+10 RDBA data base number for DBOPN * RPLEN DEC 17 Standard reply buffer length * 18 for DBOPN *** *** ********************************************************************** ENT BAPS3 EXT BP.GT,DBDEL,DBPUT EXT RDEXT * A EQU 0 B EQU 1 DAADR DEF DABUF * * Put our name suffix into SEGNM in common. That way, if another request * comes though for this segment, RDBAP (the main) will not reload us. * BAPS3 LDA SUFIX STA SEGNM * * Determine the type of IMAGE call being made by the index calculated * in the main and jump to the proper handling routine. Remember that * this index is: 45 - (RDBA Index). * LDB RQBUF+RBIDX ADB JMPTB JMP B,I * JMPTB DEF *+1 JMP E159 RDBA Index within [45,44] JMP E159 should not happen JMP DEL RDBA Index = 43, DBDEL JMP PUT RDBA Index = 42, DBPUT JMP E159 JMP E159 JMP E159 RDBA Index within [41,36] JMP E159 should not happen. JMP E159 JMP E159 SKP * * A remote DBPUT. * The request buffer contains the following information: * PTMOD EQU RQBUF+RBMOD Put mode PTSET EQU RQBUF+RBID Data set number PTBAS EQU RQBUF+RBBAS Data base parameter * * The status array is the 8th through 17th words of the reply buffer. * PTSTA EQU RQBUF+RBSTA * * The item list starts in the 2nd word of the data buffer. * PTLST EQU DABUF+1 * * The values for the items in the item list immediately follow the item * list in the data buffer. The first word of the data buffer contains * the length of the item list. Therefore, the address of the value buf- * fer is the address of the data buffer plus the length of the item list * plus one. * PUT LDA DAADR ADA DABUF INA STA PTBUF * * Perform the DBPUT call. * JSB DBPUT DEF *+7 DEF PTBAS DEF PTSET DEF PTMOD DEF PTSTA DEF PTLST DEF PTBUF,I * * There is no return data, so set the length of returned data to zero, * and jump to the exit routine. * CLB JMP EXIT * * Constants and variables * PTBUF NOP SKP * * A remote DBDEL. * The information in the request buffer is as follows: * DEMOD EQU RQBUF+RBMOD Delete mode DESET EQU RQBUF+RBID Data set number DEBAS EQU RQBUF+RBBAS Data base parameter * * The status array is the 8th through 17th words of the reply buffer. * DESTA EQU RQBUF+RBSTA * * There is no data associated with either the request or reply. * * Perform the DBDEL call. * DEL JSB DBDEL DEF *+5 DEF DEBAS DEF DESET DEF DEMOD DEF DESTA * * Set the returned data length to zero and jump to the exit routine. * CLB JMP EXIT SKP * * The only DS error is when the RDBA index for this segment is in error. * E159 LDB M159 CLA STA RECDA Set the data length to zero. JMP EXIT2 * * This is the exit routine for segment 3 of RDBAP. Its purpose is to * call the necessary subroutines in order to send the RDBA reply to the * orginiating node and to terminate the program, saving resources. All * DS replies are sent through RDEXT. * EXIT STB RECDA Set returned data length. CLA CLB Set the error code to zero. EXIT2 DST ERROR * JSB RDEXT Then, let RDEXT send the reply. DEF *+6 DEF RQBUF It needs: reply buffer DEF RPLEN reply length DEF DABUF data buffer DEF RECDA data length DEF ERROR error code NOP NQ * JMP BP.GT Return to class get in main. * * Constants and variables. * M159 DEC -159 * SUFIX ASC 1,3 * ERROR BSS 2 END BAPS3 % b l 92069-18264 1912 S C0122 &BAPS4 BAPS4 SOURCE             H0101 oPASMB,L,C,R HED BAPS4 - REMOTE DATA BASE ACCESS PROGRAM SEGMENT 4 NAM BAPS4,5 92069-16259 REV.1912 790130 * * ******************************************************************* * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR WRITTEN * CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18264 * RELOC: 92069-16259 * * PRGMR: CEJ * * ******************************************************************* * * * * COM DABUF(2174),RQBUF(21) COM RECRQ,RECDA,SEGNM,DBCNT,CLASS(5) * * Segment 4 of the Remote Data Base Access Program. This segment is the * special clean-up segment and has the following sequence of operations: * * 1) For each entry in data base pointer table: * * A) If entry not empty, call DBCLS to release the data base to * whose Run Table it points. * * 2) Send a request to RDBAM to remove us from the system and terminate * normally. SKP ********************************************************************** *** *** * Standard DS/1000 equates * *** *** #STR EQU 0 #SEQ EQU 1 #SRC EQU 2 #DST EQU 3 #RDB EQU 4 #EC1 EQU 4 #EC2 EQU 5 #ENO EQU 6 #REP EQU 7 *** *** ********************************************************************** ********************************************************************** * * * DS/1000 RDBA communications consist of two descriptive buffers: * * 1) Request buffer  * * 2) Reply buffer * * These two static buffers are as described below. * * * ********************************************************************** *** *** * * * Request buffer - one buffer of from 12 to 21 words per RDBA call * * * *** *** RBSTR EQU #STR DS/1000 stream word RBSEQ EQU #SEQ DS/1000 sequence number RBSRC EQU #SRC DS/1000 source node number RBDST EQU #DST DS/1000 destination node number RBIDX EQU #RDB RDBA call Index RBMOD EQU #RDB+1 RDBA call mode RBID EQU #RDB+2 RDBA call item or set number * or for a DBOPN, the level code word RBITM EQU #RDB+3 search item number for DBFND RBMRT EQU #RDB+5 For DBOPN, the max. returned RT size RBLEN EQU #RDB+6 word size of ibase parameter RBBAS EQU #RDB+7 ibase parameter * MAXRQ DEC 21 maximum request buffer length *** *** *** *** * * * Reply buffer - one buffer of either 17 or 18 words per RDBA call * * * *** *** * RBSTR EQU #STR DS/1000 stream word * RBSEQ EQU #SEQ DS/1000 sequence number * RBSRC EQU #SRC DS/1000 source node number * RBDST EQU #DST DS/1000 destination node number RBEC1 EQU #EC1 DS/1000 1st error code word RBEC2 EQU #EC2 DS/1000 2nd error code word RBEC3 EQU #ENO DSx^/1000 3rd error code word RBSTA EQU #REP RDBA call status array RBNUM EQU #REP+10 RDBA data base number for DBOPN * RPLEN DEC 17 standard reply buffer length * 18 for DBOPN *** *** ********************************************************************** EXT DBCLS,DBRTP,DBRTM,EXEC,RDEXT * A EQU 0 B EQU 1 * * Get the -(maximum number of entries in data base pointer table) as a * loop counter, get a copy of the address of this table, and set the data * base index to 1. * BAPS4 LDA DBRTM CMA,INA STA CNTR * LDA DBRTP STA ADDRS CLB,INB STB INDEX * * For each entry in the table: * 1) If entry not empty, call DBCLS to release data base. * LOOP LDB ADDRS,I SZB,RSS JMP EMPTY Entry is empty. * JSB DBCLS DEF *+5 DEF INDEX Only the d.b. index is needed by DBCLS. DEF D0 DEF D1 Close mode 1. DEF STAT * EMPTY ISZ INDEX Bump d.b. index, ISZ ADDRS and R.T. pointer table address. ISZ CNTR Done with all entries? JMP LOOP No - continue. * * When done, send the requestor a successful reply. * CLA CLB DST ERROR * JSB RDEXT DEF *+6 DEF RQBUF reply buffer DEF D7 reply length DEF DABUF DEF D0 no data DEF ERROR NOP ignore errors. * * Send RDBAM a special "remove me" request to purge this copy from the * system. * LDA M2 RDBA Index for such a STA RQBUF+RBIDX request is -2. LDA CLASS+1 Mode for the request is STA RQBUF+RBMOD our index into scheduling table. * JSB EXEC DEF *+8 DEF WT/RD Class write/read w/no abort DEF CONTR double buffer, lu 0 DEF DABUF DEF D0 no data DEF RQBUF request buffer DEF D7 and its length DEF CLASS+2 RDBAM's class number NOP Ignore any errors. * * Terminate, normal completion. * JSB EXEC DEF *+4 DEF D6 DEF D0 DEF D0 * * Constants and variables. * M2 DEC -2 D0 DEC 0 D1 DEC 1 D6 DEC 6 D7 DEC 7 * WT/RD OCT 100024 CONTR OCT 010000 * CNTR NOP ADDRS NOP INDEX NOP ERROR BSS 2 STAT EQU ERROR END BAPS4 END$ J cl 92069-18265 1912 S C0122 &GETKY GETKY SOURCE             H0101 zASMB,L,C,R HED GETKY UTILITY SUBROUTINE FOR RDBAP NAM GETKY,7 92069-16259 REV.1912 790130 * * ******************************************************************* * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR WRITTEN * CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18265 * RELOC: 92069-16259 * * PRGMR: CEJ * * ******************************************************************* * * * * GET KeY is a utility subroutine for the use of RDBAP servicing a remote * DBOPN. Its function is to determine the length of the key item be- * longing to the master data set whose number is the only parameter. * This key item length is returned in the A register. * ENT GETKY EXT .ENTR,AIRUN,DBFDI,DBFDS * B EQU 1 * SET NOP * GETKY NOP JSB .ENTR Retrieve the data set DEF SET number's address. * JSB DBFDS Ask DBFDS to calculate the set's DEF *+5 DEF SET,I DSCB relative address. DEF DUMMY DEF DUMMY DEF ADDRS * LDB ADDRS Add the relative addr. to the ADB AIRUN Run Table addr. to get true addr. * ADB DSCCT Get the key item's number LDA B,I from the high order byte of ALF,ALF the 11th word of the DSCB. AND LOBYT STA KEY * JSB DBFDI Ask DBFDI to calculate DEF *+5 the item's Data Item DEF KEY Table relative address. DEF DUMMY DEF DUMMY DEF ADDRS * LDB ADDRS Add to Run Table address to ADB AIRUN get true address. ADB ITLNG Get item's length from the 7th LDA B,I word of the entry * JMP GETKY,I and returnn  . * * Constants and variables. * ITLNG DEC 6 DSCCT DEC 10 * LOBYT OCT 377 * ADDRS NOP KEY NOP DUMMY NOP END GETKY U7  dk 92069-18266 1912 S C0122 &DAD DAD SOURCE             H0101 ASMB HED "DAD" - FORTRAN INTERFACE TO .DAD . NAM DAD,7 92069-16266 REV.1912 790320 * * ****************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH OUT THE PRIOR * WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18266 * RELOC: 92069-16266 * * *****************************************************************: * * * * * * ENT DAD EXT .DAD,.ENTR * * DAD PROVIDES A FORTRAN-CALLABLE DOUBLE INTEGER ADD. * * CALLING SEQUENCE: * * Z = DAD(X,Y) * * WHERE X,Y&Z ARE DECLARED REAL BUT CONTAIN DOUBLE * INTEGER VALUES. * * OVERFLOW IS SET ONLY IF THE OPERATION OVERFLOWS, AND * IS TESTABLE BY THE ROUTINE "OFL". SPC 3 DADA DEF *-* DADB DEF *-* DAD NOP JSB .ENTR COPY ADDRESSES. DEF DADA DLD DADA,I DO OPERATION. JSB .DAD DEF DADB,I JMP DAD,I EXIT. RESULT IS IN (A,B) * END \Z ek 92069-18267 1912 S C0122 &DSB DSB SOURCE             H0101 1ASMB HED "DSB" - FORTRAN INTERFACE TO .DSB . NAM DSB,7 92069-16267 REV.1912 790320 * * ****************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR * WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18267 * RELOC: 92069-16267 * * *****************************************************************: * * * * * * ENT DSB EXT .DSB,.ENTR * * DSB PROVIDES A FORTRAN-CALLABLE DOUBLE INTEGER SUBTRACT. * * CALLING SEQUENCE: * * Z = DSB(X,Y) * * WHERE X,Y&Z ARE DECLARED REAL BUT CONTAIN DOUBLE * INTEGER VALUES. * * OVERFLOW IS SET ONLY IF THE OPERATION OVERFLOWS, AND * IS TESTABLE BY THE ROUTINE "OFL". SPC 3 DSBA DEF *-* DSBB DEF *-* DSB NOP JSB .ENTR COPY ADDRESSES. DEF DSBA DLD DSBA,I DO OPERATION. JSB .DSB DEF DSBB,I JMP DSB,I EXIT. RESULT IS IN (A,B) * END K fl 92069-18268 1912 S C0122 &DMP DMP SOURCE             H0101 :ASMB HED "DMP" - FORTRAN INTERFACE TO .DMP . NAM DMP,7 92069-16268 REV.1912 790320 * * * ****************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR * WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18268 * RELOC: 92069-16268 * * *****************************************************************: * * * * * ENT DMP EXT .DMP,.ENTR * * DMP PROVIDES A FORTRAN-CALLABLE DOUBLE INTEGER MULTIPLY. * * CALLING SEQUENCE: * * Z = DMP(X,Y) * * WHERE X,Y&Z ARE DECLARED REAL BUT CONTAIN DOUBLE * INTEGER VALUES. * * OVERFLOW IS SET ONLY IF THE OPERATION OVERFLOWS, AND * IS TESTABLE BY THE ROUTINE "OFL". SPC 3 DMPA DEF *-* DMPB DEF *-* DMP NOP JSB .ENTR COPY ADDRESSES. DEF DMPA DLD DMPA,I DO OPERATION. JSB .DMP DEF DMPB,I JMP DMP,I EXIT. RESULT IS IN (A,B) * END I4 gm 92069-18269 1912 S C0122 &DDI DDI SOURCE             H0101 +ASMB HED "DDI" - FORTRAN INTERFACE TO .DDI . NAM DDI,7 92069-16269 REV.1912 790320 * * ****************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR * WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18269 * RELOC: 92069-16269 * * *****************************************************************: * * * * * * ENT DDI EXT .DDI,.ENTR * * DDI PROVIDES A FORTRAN-CALLABLE DOUBLE INTEGER DIVIDE. * * CALLING SEQUENCE: * * Z = DDI(X,Y) * * WHERE X,Y&Z ARE DECLARED REAL BUT CONTAIN DOUBLE * INTEGER VALUES. * * OVERFLOW IS SET ONLY IF THE OPERATION OVERFLOWS, AND * IS TESTABLE BY THE ROUTINE "OFL". SPC 3 DDIA DEF *-* DDIB DEF *-* DDI NOP JSB .ENTR COPY ADDRESSES. DEF DDIA DLD DDIA,I DO OPERATION. JSB .DDI DEF DDIB,I JMP DDI,I EXIT. RESULT IS IN (A,B) * END ^f hn 92069-18270 1912 S C0122 &DIN DIN SOURCE             H0101 ,ASMB HED "DIN" - FORTRAN INTERFACE TO .DIN . NAM DIN,7 92069-16270 REV.1912 790320 * * * ****************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR * WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18270 * RELOC: 92069-16270 * * *****************************************************************: * * * * * ENT DIN EXT .DIN,.ENTR * * DIN PROVIDES A FORTRAN-CALLABLE DOUBLE INTEGER INCREMENT. * * CALLING SEQUENCE: * * Y = DIN(X) * * WHERE X & Y ARE DECLARED REAL BUT CONTAIN DOUBLE * INTEGER VALUES. * * OVERFLOW IS SET ONLY IF THE OPERATION OVERFLOWS, AND * IS TESTABLE BY THE ROUTINE "OFL". SPC 3 DINA DEF *-* DIN NOP JSB .ENTR COPY ADDRESSES. DEF DINA DLD DINA,I DO OPERATION. JSB .DIN JMP DIN,I EXIT. RESULT IS IN (A,B) * END  io 92069-18271 1912 S C0122 &DDE DDE SOURCE             H0101 ASMB HED "DDE" - FORTRAN INTERFACE TO .DDE . NAM DDE,7 92069-16271 REV.1912 790320 * * ****************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR * WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18271 * RELOC: 92069-16271 * * *****************************************************************: * * * * * * ENT DDE EXT .DDE,.ENTR * * DDE PROVIDES A FORTRAN-CALLABLE DOUBLE INTEGER DECREMENT. * * CALLING SEQUENCE: * * Y = DDE(X) * * WHERE X & Y ARE DECLARED REAL BUT CONTAIN DOUBLE * INTEGER VALUES. * * OVERFLOW IS SET ONLY IF THE OPERATION OVERFLOWS, AND * IS TESTABLE BY THE ROUTINE "OFL". SPC 3 DDEA DEF *-* DDE NOP JSB .ENTR COPY ADDRESSES. DEF DDEA DLD DDEA,I DO OPERATION. JSB .DDE JMP DDE,I EXIT. RESULT IS IN (A,B) * END ,: jp 92069-18272 1912 S C0122 &DNG DNG SOURCE             H0101 ,ASMB HED "DNG" - FORTRAN INTERFACE TO .DNG . NAM DNG,7 92069-16272 REV.1912 790320 * * ****************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR * WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18272 * RELOC: 92069-16272 * * *****************************************************************: * * * * * * ENT DNG EXT .DNG,.ENTR * * DNG PROVIDES A FORTRAN-CALLABLE DOUBLE INTEGER NEGATE. * * CALLING SEQUENCE: * * Y = DNG(X) * * WHERE X & Y ARE DECLARED REAL BUT CONTAIN DOUBLE * INTEGER VALUES. * * OVERFLOW IS SET ONLY IF THE OPERATION OVERFLOWS, AND * IS TESTABLE BY THE ROUTINE "OFL". SPC 3 DNGA DEF *-* DNG NOP JSB .ENTR COPY ADDRESSES. DEF DNGA DLD DNGA,I DO OPERATION. JSB .DNG JMP DNG,I EXIT. RESULT IS IN (A,B) * END 8 kq 92069-18273 1912 S C0122 &DIS DIS SOURCE             H0101 4ASMB HED "DIS" - FORTRAN INTERFACE TO .DIS . NAM DIS,7 92069-16273 REV.1912 790320 * * ****************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR * WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18273 * RELOC: 92069-16273 * * *****************************************************************: * * * * * * ENT DIS EXT .DIS,.ENTR * * DIS PROVIDES A FORTRAN-CALLABLE DOUBLE INTEGER * INCREMENT AND TEST IF ZERO. * * CALLING SEQUENCE: * * LOGICAL DIS * . * . -OR- CALL DIS(X) * . * IF(DIS(X)) * * WHERE X IS DECLARED REAL BUT CONTAINS A DOUBLE INTEGER VALUE. SPC 3 DISA DEF *-* DIS NOP JSB .ENTR COPY ADDRESS. DEF DISA CCA A WILL CONTAIN LOGICAL FALSE (0) OR TRUE (-1). JSB .DIS DEF DISA,I CLA NO SKIP. FALSE. JMP DIS,I EXIT. * END  lr 92069-18274 1912 S C0122 &DDS DDS SOURCE             H0101 0ASMB HED "DDS" - FORTRAN INTERFACE TO .DDS . NAM DDS,7 92069-16274 REV.1912 790320 * * ****************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR * WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18274 * RELOC: 92069-16274 * * *****************************************************************: * * * * * * ENT DDS EXT .DDS,.ENTR * * DDS PROVIDES A FORTRAN-CALLABLE DOUBLE INTEGER * DECREMENT AND TEST IF ZERO. * * CALLING SEQUENCE: * * LOGICAL DDS * . * . -OR- CALL DDS(X) * . * IF(DDS(X)) * * WHERE X IS DECLARED REAL BUT CONTAINS A DOUBLE INTEGER VALUE. SPC 3 DDSA DEF *-* DDS NOP JSB .ENTR COPY ADDRESS. DEF DDSA CCA A WILL CONTAIN LOGICAL FALSE (0) OR TRUE (-1). JSB .DDS DEF DDSA,I CLA NO SKIP. FALSE. JMP DDS,I EXIT. * END  ms 92069-18275 1912 S C0122 &DCO DCO SOURCE             H0101 , ASMB HED "DCO" - FORTRAN INTERFACE TO .DCO . NAM DCO,7 92069-16275 REV.1912 790320 * * ****************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR * WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18275 * RELOC: 92069-16275 * * *****************************************************************: * * * * * * ENT DCO EXT .DCO,.ENTR * * DCO PROVIDES A FORTRAN-CALLABLE DOUBLE INTEGER COMPARE. * * CALLING SEQUENCE: * * IF(DCO(X,Y)) S1,S2,S3 * * WHERE X & Y ARE DECLARED REAL BUT CONTAIN DOUBLE * INTEGER VALUES. CONTROL IS TRANSFERRED TO STATEMENT * S1,S2 OR S3 IF XY RESPECTIVELY. SPC 3 DCOA DEF *-* DCOB DEF *-* DCO NOP JSB .ENTR COPY ADDRESSES. DEF DCOA DLD DCOA,I DO OPERATION. JSB .DCO DEF DCOB,I JMP DCO1 = JMP DCO2 < DLD =F1.0 >, RETURN +1.0 JMP DCO,I DCO1 CLA =, RETURN 0.0 CLB JMP DCO,I DCO2 LDA =B100000 <, RETURN -1.0 CLB JMP DCO,I END V nt 92069-18276 1912 S C0122 &FIXD FIXD SOURCE             H0101 bBASMB HED "FIXD" - FORTRAN INTERFACE TO .FIXD . NAM FIXD,7 92069-16276 REV.1912 790320 * * ****************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR * WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18276 * RELOC: 92069-16276 * * *****************************************************************: * * * * * * ENT FIXD EXT .FIXD,.ENTR * * FIXD PROVIDES A FORTRAN-CALLABLE CONVERSION FROM * SINGLE-PRECISION (32-BIT) FLOATING-POINT TO DOUBLE * INTEGER. * * CALLING SEQUENCE: * * Y = FIXD(A) * * WHERE Y IS DECLARED REAL BUT CONTAINS A DOUBLE * INTEGER VALUE. * * OVERFLOW IS SET ONLY IF THE ARGUMENT IS OUTSIDE THE RANGE * [-2**31,+2**31), AND IS TESTABLE BY THE ROUTINE "OFL". SPC 3 FIXDA DEF *-* FIXD NOP JSB .ENTR COPY ADDRESS. DEF FIXDA DLD FIXDA,I DO OPERATION. JSB .FIXD JMP FIXD,I EXIT. RESULT IS IN (A,B) * END *s ou 92069-18277 2026 S C0122 &XFXD &XFXD              H0101 ASMB HED "ZFXD" - FORTRAN INTERFACE TO .XFXD . NAM ZFXD,7 92069-16277 REV.2026 800122 * * ****************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR * WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18277 * RELOC: 92069-16277 * * ALTERED: JANUARY 22, 1980 TO RENAME ENTRY POINT DUE TO * CONFLICT WITH GRAPHICS/1000 * NAME CHANGED FROM XFXD TO ZFXD * ****************************************************************** * * * * * * ENT ZFXD EXT .XFXD,.ENTR * * ZFXD PROVIDES A FORTRAN-CALLABLE CONVERSION FROM * EXTENDED-PRECISION (48-BIT) FLOATING-POINT TO DOUBLE * INTEGER. * * CALLING SEQUENCE: * * FTN,L * . * . * DOUBLE PRECISION DX * . * . * Y = ZFXD(DX) * * WHERE Y IS DECLARED REAL BUT CONTAINS A DOUBLE * INTEGER VALUE. THE RESULT IS TRUNCATED. * * OVERFLOW IS SET ONLY IF THE ARGUMENT IS OUTSIDE THE RANGE * [-2**31,+2**31), AND IS TESTABLE BY THE ROUTINE "OFL". SPC 3 XFXDA DEF *-* ZFXD NOP JSB .ENTR COPY ADDRESS. DEF XFXDA JSB .XFXD DO OPERATION. DEF XFXDA,I JMP ZFXD,I EXIT. RESULT IS IN (A,B) * END  pv 92069-18278 1912 S C0122 &TFXD TFXD SOURCE             H0101 oMASMB HED "TFXD" - FORTRAN INTERFACE TO .TFXD . NAM TFXD,7 92069-16278 REV.1912 790320 * * ****************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR * WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18278 * RELOC: 92069-16278 * * *****************************************************************: * * * * * * ENT TFXD EXT .TFXD,.ENTR * * TFXD PROVIDES A FORTRAN-CALLABLE CONVERSION FROM * DOUBLE-PRECISION (64-BIT) FLOATING-POINT TO DOUBLE * INTEGER. * * CALLING SEQUENCE: * * FTN,L,Y * . * . * DOUBLE PRECISION DX * . * . * Y = TFXD(DX) * * WHERE Y IS DECLARED REAL BUT CONTAINS A DOUBLE * INTEGER VALUE. THE RESULT IS TRUNCATED. * * OVERFLOW IS SET ONLY IF THE ARGUMENT IS OUTSIDE THE RANGE * [-2**31,+2**31), AND IS TESTABLE BY THE ROUTINE "OFL". SPC 3 TFXDA DEF *-* TFXD NOP JSB .ENTR COPY ADDRESS. DEF TFXDA JSB .TFXD DO OPERATION. DEF TFXDA,I JMP TFXD,I EXIT. RESULT IS IN (A,B) * END ( qw 92069-18279 1912 S C0122 &FLTD FLTD SOURCE             H0101 dAASMB HED "FLTD" - FORTRAN INTERFACE TO .FLTD . NAM FLTD,7 92069-16279 REV.1912 790320 * * ****************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR * WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18279 * RELOC: 92069-16279 * * *****************************************************************: * * * * * * ENT FLTD EXT .FLTD,.ENTR * * FLTD PROVIDES A FORTRAN-CALLABLE CONVERSION FROM * DOUBLE INTEGER TO SINGLE-PRECISION (32-BIT) * FLOATING-POINT. * * CALLING SEQUENCE: * * A = FLTD(X) * * WHERE X IS DECLARED REAL BUT CONTAINS A DOUBLE * INTEGER VALUE. * * OVERFLOW CANNOT OCCUR, BUT PRECISION MAY BE LOST * SINCE SINGLE PRECISION CARRIES ONLY 23 BITS AND * DOUBLE INTEGER HAS 31. EXCESS BITS ARE TRUNCATED, * SO THE VALUE OF THE RESULT IS ALWAYS LESS THAN OR * EQUAL TO THE VALUE OF THE ARGUMENT: IF IT IS NEGATIVE, * THE ABSOLUTE VALUE IS GREATER THAN OR EQUAL TO. SPC 3 FLTDA DEF *-* FLTD NOP JSB .ENTR COPY ADDRESS. DEF FLTDA DLD FLTDA,I DO OPERATION. JSB .FLTD JMP FLTD,I EXIT. RESULT IS IN (A,B) * END 7v rx 92069-18280 1912 S C0122 &FXTD FXTD SOURCE             H0101 gNASMB HED "XFTD" - FORTRAN INTERFACE TO .XFTD . NAM XFTD,7 92069-16280 REV.1912 790320 * * ****************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR * WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18280 * RELOC: 92069-16280 * * *****************************************************************: * * * * * * ENT XFTD EXT .XFTD,.ENTR * * XFTD PROVIDES A FORTRAN-CALLABLE CONVERSION FROM * DOUBLE INTEGER TO EXTENDED-PRECISION (48-BIT) * FLOATING-POINT. * * CALLING SEQUENCE: * * FTN,L * . * . * DOUBLE PRECISION DA,XFTD * . * . * DA = XFTD(X) * * WHERE X IS DECLARED REAL BUT CONTAINS A DOUBLE * INTEGER VALUE. * * OVERFLOW CANNOT OCCUR. SPC 3 XFTDA DEF *-* XFTDB DEF *-* XFTD NOP JSB .ENTR COPY ADDRESSES. DEF XFTDA DLD XFTDB,I DO OPERATION. JSB .XFTD DEF XFTDA,I JMP XFTD,I EXIT. * END  sy 92069-18281 1912 S C0122 &TFTD TFTD SOURCE             H0101 dJASMB HED "TFTD" - FORTRAN INTERFACE TO .TFTD . NAM TFTD,7 92069-16281 REV.1912 790320 * * ****************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR * WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18281 * RELOC: 92069-16281 * * *****************************************************************: * * * * * * ENT TFTD EXT .TFTD,.ENTR * * TFTD PROVIDES A FORTRAN-CALLABLE CONVERSION FROM * DOUBLE INTEGER TO DOUBLE-PRECISION (64-BIT) * FLOATING-POINT. * * CALLING SEQUENCE: * * FTN,L,Y * . * . * DOUBLE PRECISION DA,TFTD * . * . * DA = TFTD(X) * * WHERE X IS DECLARED REAL BUT CONTAINS A DOUBLE * INTEGER VALUE. * * OVERFLOW CANNOT OCCUR. SPC 3 TFTDA DEF *-* TFTDB DEF *-* TFTD NOP JSB .ENTR COPY ADDRESSES. DEF TFTDA DLD TFTDB,I DO OPERATION. JSB .TFTD DEF TFTDA,I JMP TFTD,I EXIT. * END I tz 92069-18282 1912 S C0122 &ISNGL ISNGL SOURCE             H0101 uASMB HED "ISNGL" - FORTRAN CONVERSION FROM DOUBLE TO SINGLE INTEGER. NAM ISNGL,7 92069-16282 REV.1912 790320 * * ****************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR * WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18282 * RELOC: 92069-16282 * * *****************************************************************: * * * * * * ENT ISNGL EXT .ENTR * * ISNGL CONVERTS A DOUBLE INTEGER ARGUMENT TO A SINGLE * INTEGER RESULT. OVERFLOW IS SET IFF THE CONVERSION * OVERFLOWS. * * CALLING SEQUENCE: * * I = ISNGL(X) * * WHERE X IS DECLARED REAL BUT CONTAINS A DOUBLE INTEGER VALUE. SPC 3 ISNGA DEF *-* ISNGL NOP JSB .ENTR COPY ADDRESS. DEF ISNGA DLD ISNGA,I GET DOUBLE INTEGER. SWP CONVERT. ASL 16 LDA 1 JMP ISNGL,I EXIT. A = RESULT. * END > u{ 92069-18283 1912 S C0122 &DBLEI DBLEI SOURCE             H0101 tXASMB HED "DBLEI" - FORTRAN CONVERSION FROM SINGLE TO DOUBLE INTEGER. NAM DBLEI,7 92069-16283 REV.1912 790320 * * ****************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR * WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18283 * RELOC: 92069-16283 * * *****************************************************************: * * * * * * ENT DBLEI EXT .ENTR * * DBLEI CONVERTS A SINGLE INTEGER ARGUMENT TO A DOUBLE * INTEGER RESULT. * * CALLING SEQUENCE: * * X = DBLEI(I) * * WHERE X IS DECLARED REAL BUT CONTAINS A DOUBLE INTEGER VALUE. SPC 3 DBLEA DEF *-* DBLEI NOP JSB .ENTR COPY ADDRESS. DEF DBLEA LDB DBLEA,I GET SINGLE INTEGER. ASR 16 CONVERT. SWP JMP DBLEI,I EXIT. (A,B) = RESULT. * END G v| 92069-18284 2040 S C0122 &DBHD5 &DBHD5             H0101 ASMB HED HEADER FOR $DSDB NAM $DSDB,7 92069-12007 REV.2040 800730 * * ******************************************************************* * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980. ALL RIGHTS RESERVED. * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR WRITTEN * CONSENT OF HEWLETT-PACKARD COMPANY. ******************************************************************* * * * SOURCE: 92069-18284 * RELOC: 92069-1X284 * * * ******************************************************************* * * END % w} 92069-18999 2040 S C0122 A92069 S/W CONFIG GUIDE             H0101 J A92069 SOF NUM CAT REV 2040 (92069-18999) MODULE DESCRIPTION DATE CODE PART NUMBER MEDIUM P/N %BAIMX BASIC/IMAGE INTERFACE 2026 92069-16255 92069-13303 %DBBLX DBBLD - DATA BASE BUILD 1912 92069-16001 92069-13304 %DBCOP DATA BASE COORDINATING PROGRAM 1912 92069-16256 92069-13305 %DBDSX DBDS - SCHEMA PROCESSOR 2026 92069-16015 92069-13304 %DBLOX DBLOD - DATA BASE LOAD 2013 92069-16128 92069-13306 %DBMS IMAGE LOCAL SUBROUTINES 2040 92069-12002 92069-13301 %DBRSX DBRST - DATA BASE RESTORE 2013 92069-16126 92069-13304 %DBSPX DBSPA - DATA BASE SPACE UTILITY 1912 92069-16133 92069-13306 %DBSTX DBSTR - DATA BASE STORE 2013 92069-16125 92069-13304 %DBULX DBULD - DATA BASE UNLOAD 2013 92069-16127 92069-13306 %LOCAL LOCAL ONLY LIBRARY 1912 92069-12006 92069-13305 %NO/DS STUB LIBRARY 2040 92069-12005 92069-13305 %QRYX2 QUERY SUBROUTINES 2026 92069-16061 92069-13303 %QURYX QUERY SEGMENTS 2026 92069-16060 92069-13302 %RDBA IMAGE REMOTE LIBRARY 2040 92069-12003 92069-13305 %RECVX RECOV - RECOVER UTILITY 2013 92069-16134 92069-13306 %REMOT RMT ONLY LIBRARY 1912 92069-12004 92069-13305 *DBUP UPGRADE UTILITY 1912 92069-12001 92069-13306 QSHELP QUERY HELP FILE 1912 92069-16122 92069-13303 D x~ 92070-18001 2001 S C0122 &FM.CM              H0101 kbSPL,L,O,M ! NAME: FM.CM ! SOURCE: 92070-18001 ! RELOC: 92070-16001 ! PGMR: G.A.A. ! ! *************************************************************** ! * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * ! * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * ! * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* ! * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ! *************************************************************** ! NAME FM.CM(8) " 92070-1X001 REV.2001 800103" ! ! EXTERNAL SUBROUTINES LET .DFER BE SUBROUTINE,EXTERNAL,DIRECT LET EXEC BE SUBROUTINE,EXTERNAL LET OPENF BE SUBROUTINE,EXTERNAL ! EXTERNAL FUNCTIONS LET GTOPN BE FUNCTION,EXTERNAL LET IFBRK BE FUNCTION,EXTERNAL LET IFTTY BE FUNCTION,EXTERNAL ! EXTERNAL LABELS LET FM.AB BE LABEL,EXTERNAL ! EXTERNAL VARIBLES LET P.6 BE INTEGER,EXTERNAL LET .E.R BE INTEGER,EXTERNAL LET C.BUX BE INTEGER,EXTERNAL LET CAM.I BE INTEGER,EXTERNAL LET CAM.O BE INTEGER,EXTERNAL LET ECH BE INTEGER,EXTERNAL LET ECHF. BE INTEGER,EXTERNAL LET INT. BE INTEGER,EXTERNAL LET P.TR BE INTEGER,EXTERNAL LET SVCOD BE INTEGER,EXTERNAL ! INTERNAL SUBROUTINES LET CONV. BE SUBROUTINE LET ECHO BE SUBROUTINE LET FM.ER BE SUBROUTINE LET IER. BE SUBROUTINE,DIRECT LET JER. BE SUBROUTINE,DIRECT LET MSS. BE SUBROUTINE LET MVW BE SUBROUTINE LET OPEN. BE SUBROUTINE ! INTERNAL FUNCTIONS LET ILOG BE FUNCTION,DIRECT ! INTERNAL VARIBLES LET FM(2) BE INTEGER LET MS1 BE INTEGER LET MS2 BE INTEGER INITIALIZE FM,MS1,MS2 TO "FMGR 000" LET OPTN BE INTEGER LET SRPMS BE INTEGER LET NO-  BE INTEGER LET S BE INTEGER LET WATMS(8) BE INTEGER LET WATM BE INTEGER INITIALIZE WATMS TO "WAITING FOR LU " ! ! MSS.: SUBROUTINE(ER,NX)GLOBAL LET ER,NX BE INTEGER ! ! MESSAGE FORMAT: ! FMGR XXX ! ! MESSAGE ERROR WORD FORMAT ! THE THOUSANDS DIGIT IS USED AS FOLLOWS: ! IF ONE OR THREE THEN TWO MESSAGES ARE TO BE PRINTED ! ! IF ZERO OR TWO THEN ONLY ONE MESSAGE IS PRINTED ! ! IF ZERO OR ONE THEN SEND THE INPUT DEVICE TO THE LOG UNIT ! IF 2 OR 3 LEAVE THE LOG AND INPUT DEVICES AS IT IS ! NO _ ER S_NO/1000 !ISOLATE ERROR CODE P.6 _ .B. !SET 6P TO ERROR CODE MS1_" " !SET SIGN FOR PLUS IF NO<0 THEN [ \IF NEGATIVE, NO _ -NO; \CONVERT ERROR TO POSITIVE MS1_ 26400K] !AND USE MINUS SIGN S_NO/1000 NO_ .B. MSS00:CONV.(NO,MS2,3) !CONVERT THE NUMBER FM.ER([IF S>1 THEN 1,ELSE 2],FM,4) IF S AND 1 THEN[ \DO SECOND NUMBER S _ S-1; \ NO_ NX ; \ MS1 _ 20040K; \ GOTO MSS00] ! RETURN END ! ! COMMAND OUTPUT (ERROR) SUBROUTINE ! FM.ER:SUBROUTINE(SCCOD,BFMS,LN)GLOBAL LET BFMS BE INTEGER LET LN BE INTEGER LET SCCOD BE INTEGER ! ! FM.ER PRINTS ONLY IF SCCOD IS GREATER THAN OR EQUAL TO ! THE SVCOD ENTERED AT TURN ON TIME ! ! IN ADDITION IF THE SCCOD IS IS GREATER THAN 1 CONTROL IS SWITCHED ! TO THE LOG CHANNEL ! IF SCCOD > 1 THEN GO TO EC !ALWAYS PRINT IF 2 OR MORE IF SCCOD 3 THEN RETURN !IF CODE HI ENOUGH, RETURN ! IF ILOG() THEN RETURN !IF ON LOG ALREADY, RETURN OPEN.(CAM.I,CAM.O,0.0,410K) !OPEN INPUT TO LOG RETURN END ! ! OPEN.:SUBROUTINE(ODCB,OLU,PLIST,OPLST) GLOBAL LET ODCB BE INTEGER(144) !USER'S DCB LET OLU BE INTEGER(3) !THE NAME,LU ARRAY LET PLIST BE INTEGER(2) !SECURITY CODE, CRN LET OPLST BE INTEGER !OPEN OPTION ! ! SKPMS _ 1 !SET UP TO PRINT WAIT MES IF NECESSARY OPTN _ OPLST !SET UP IN CASE OF INPUT (NOTE 1) IF @ODCB = @CAM.I THEN[ \OPEN THE INPUT FILE? $P.TR_ ODCB(15); \YES,SAVE CURRENT RECORD COUNT P.TR _ P.TR+1; \POINT TO START OF NEXT BLOCK CALL .DFER($P.TR,OLU); \PUT IN NAME/LU P.TR _ P.TR+3; \POINT TO SECURITY CODE OPTN _ OPTN OR 1] !DON'T ALLOW INPUT TO BE LOCKED OPIN: OPENF(ODCB,.E.R,OLU,OPTN,PLIST(1),PLIST(2))!OPEN NEW FILE/LU IF .E.R < 0 THEN[ \WAS THERE AN ERROR? IF @ODCB = @CAM.I THEN[ \YES, IS THIS INPUT FILE P.TR _ P.TR-4; \BACK UP TO LAST REC COUNT ODCB(15) _ $P.TR; \RESET IN DCB IF SVCOD > 3 THEN[ \TRANSFER TO LOG NOT ALLOWED MSS.(.E.R); \SO REPORT ERROR RETURN]]] C| !AND RETURN IF .E.R = -36 THEN[ \NO RESOURCE NUMBER OR IF SKPMS THEN[ \ SKPMS _ 0; \ CONV.(ODCB(4) AND 77K,WATM,2); \CONVERT LU EXEC(2,CAM.O,WATMS,9)]; \WRITE WAITING MESSAGE EXEC(12,0,2,0,-5); \TRY IN FIVE SECONDS .E.R _ 0; \CLEAR ERROR CODE JER.; \CHECK BREAK FLAG GOTO OPIN], \GO TRY AGAIN ELSE IER. !REPORT ALL OTHER ERRORS ! IF @ODCB = @CAM.I THEN[ \IS THIS THE INPUT DEVICE? $P.TR _ PLIST(1); \YES, STACK THE SECURITY CODE P.TR _ P.TR+1; \POINT TO CRN/LU $P.TR _ -(ODCB(1) AND 77K); \STORE THE -LU P.TR _ P.TR+1; \NOW POINT TO RECORD COUNT INT._ [IF ODCB(3) THEN 0, ELSE IFTTY(ODCB(4))]]!SET UP INT FLAG RETURN !DONE END ! ! NOTE 1: THE INPUT DEVICE IS NEVER ALLOWED TO BE LOCKED. IF A TR ! OCCURS, THEN A TRANSFER BACK TO THE PREVIOUS DEVICE WOULD HAVE LOST ! THE LOCK IN THE MEAN TIME. ALSO, THE TRANSFER STACK WOULD BE COR- ! RUPTED IF A BREAK OCCURED WHILE WAITING FOR AN ALREADY LOCKED LU. ! TO PREVENT THE LOCK, THE NON-EXCLUSIVE BIT IS ALWAYS OR'ED INTO ! THE USER'S OPTION WORD WHEN THE INPUT IS OPENED. OPEN WILL THERE- ! FORE NEVER REPORT ERROR -36. ! ! ! ! ECHO: SUBROUTINE GLOBAL !TO ECHO COMMANDS IFNOT ECHF. THEN RETURN !IF DONE ALREADY, RETURN IF ILOG() THEN GOTO ECH0 !IF INPUT ON LOG, DON'T ECHO C.BUX_ 20072K !IF XFER FILE, USE " :" IF INT. THEN C.BUX_ 20040K !IF LOG NOT INPUT " "  !CHANGE IT CALL EXEC(2,CAM.O,C.BUX,ECH+1) !ECHO THE COMMAND ECH0: ECHF._ 0 !SET THE ECHOED FLAG RETURN END ! ! ILOG: FUNCTION DIRECT DCB9_[DCB3_[DCB2_@CAM.I+2]+1]+6 !SET UP DCB ADDRESSES IFNOT ($DCB3 XOR CAM.O) AND 77K THEN[ \ IFNOT $DCB2 THEN[ \ IF $DCB9 = GTOPN THEN RETURN 1]] ! RETURN 0 END ! ! IER.: SUBROUTINE GLOBAL,DIRECT IF .E.R =>0 THEN RETURN ABEX: MSS.(.E.R) GOTO FM.AB END ! ! JER.: SUBROUTINE GLOBAL,DIRECT !SUBROUTINE TO CHECK ERRORS IER. !AND BREAK CONDITION .E.R _ 0 !SET ERROR CODE FOR BREAK ERROR IF IFBRK THEN GOTO ABEX !IF BREAK CONDITION, EXIT RETURN !ELSE RETURN END ! ! CONV.:SUBROUTINE (NOO,BUF,NDIG) GLOBAL LET NOO,BUF,NDIG BE INTEGER ! ROUTINE TO CONVERT NOO WITH NDIG DIGITS TO ASCII AT BUF ! BUF WILL CONTAIN THE LOWEST DIGITS BUF-1 THE NEXT ! LOWEST ETC. ! EV,BF_@BUF NUM_NOO FOR I_1 TO NDIG DO THRU COV NUM _ NUM/10 IF [DI_ .B.] < 0 THEN[ DI_ -DI] DI _ DI + 60K $BF _ [IF EV THEN ($BF AND 177400K)+DI, \ ELSE ($BF AND 377K)+(DI-<8)] COV: IF EV THEN EV _ 0, \ ELSE EV,BF _ BF-1 RETURN END ! ! MVW: SUBROUTINE(FROM,TT,LENZ) GLOBAL ! ASSEMBLE["EXT .MVW";\ "LDA FROM,I";\ "LDB TT,I ";\ "JSB .MVW ";\ "DEF LENZ,I";\ "NOP "] RETURN END ! ! ! END END$ $"$ y 92070-18002 1941 S C0122 &FMGR0              H0101 ~gASMB,R,L HED FMGR0 * NAME: FMGR0 * SOURCE: 92070-18002 * RELOC: 92070-16002 * PGMR: G.A.A. * MOD: M.L.K. * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * NAM FMGR0,5 92070-1X002 REV.1941 790712 EXT SEG.R,CAD.,.IDAD SUP SPC 1 FMGR0 STA .IDAD LDA TABL JMP SEG.R SPC 1 TABL DEF *+1 SPC 1 EXT CR.. DEF CR.. EXT PK.. DEF PK.. END FMGR0 + z 92070-18003 1941 S C0122 &FMGR1              H0101 hASMB,R,L,C HED FMGR1 * NAME: FMGR1 * SOURCE: 92070-18003 * RELOC: 92070-16003 * PGMR: G.A.A. MOD. M.L.K. * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * NAM FMGR1,5 92070-1X003 REV.1941 790712 EXT PARS.,.PARS,REA.C EXT NO.RD,.ENTR,PAR.R,SEG.R,TR..,.IDAD EXT INT.,ECHF.,MSS.,IFBRK SUP FMGR1 STA .IDAD LDA PARSE SET THE PARSE ROUTINE ADDRESS STA PARS. IN THE MAINS ADDRESS WORD JMP PAR.R RETURN TO THE MAIN SPC 2 PAR NOP READ AND PARSE ENTRY POINT JSB .ENTR DEF PAR FETCH RETURN ADDRESS JSB IFBRK CHECK FOR BREAK PENDING DEF *+1 SZA,RSS IF NO BREAK JMP PAR1 SKIP MESSAGE * JSB MSS. ELSE SEND THE BREAK MESSAGE DEF *+2 AND TRANSFER TO LOG DEVICE DEF ZERO * PAR1 LDA NO.RD IF NO READ FLAG SET SZA THEN JMP PAR2 BY PASS THE READ CALL * JSB REA.C CALL TO READ A COMMAND DEF *+1 CCA SET THE ECHO NOT DONE FLAG STA ECHF. JSB .PARS PARSE THE COMMAND DEF *+1 JMP PAR,I AND RETURN * PAR2 CLB CLEAR THE NO READ CALL FLAG STB NO.RD STB ECHF. DON'T ECHO INTERNAL CALLS SSA,RSS JMP TRLD * CLB,INB SET TO INTERACTIVE INPUT LDA INT. SAVE THE TTY FLAG STB INT. SET IT FOR NOW STA TMPM PARS JSB .PARS PARS THE COMMAND DEF *+1 LDA TMPM RESTORE THE TTY FLAG STA INT. JMP PAR,I RETURN TO THE MAIN TO CALn  L THE SEGMENT * TRLD LDA TR JMP SEG.R * DEC -2 TMPM NOP TR DEF * DEF TR.. TR+1 ZERO NOP TR+4 PARSE DEF PAR TR+5 A EQU 0 B EQU 1 ORG * END FMGR1  { 92070-18004 1941 S C0122 &FMGR2              H0101 iASMB,R,L HED FMGR2 * NAME: FMGR2 * SOURCE: 92070-18004 * RELOC: 92070-16004 * PGMR: G.A.A. * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * NAM FMGR2,5 92070-1X004 REV.1941 790712 EXT SEG.R,CAD.,.IDAD SPC 1 FMGR2 STA .IDAD LDA TABL JMP SEG.R SPC 2 TABL DEF *+1 SPC 1 EXT IN.IT DEF IN.IT EXT DC.. DEF DC.. EXT IN.. DEF IN.. EXT MC.. DEF MC.. EXT PU.. DEF PU.. END FMGR2  | 92070-18005 1941 S C0122 &FMGR3              H0101 jASMB,R,L HED FMGR3 * NAME: FMGR3 * SOURCE: 92070-18005 * RELOC: 92070-16005 * PGMR: G.A.A. * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * NAM FMGR3,5 92070-1X005 REV.1941 790712 EXT SEG.R,CAD.,.IDAD SUP SPC 1 FMGR3 STA .IDAD LDA TABL JMP SEG.R SPC 2 TABL DEF *+1 SPC 1 EXT DL.. DEF DL.. EXT LI.. DEF LI.. END FMGR3 E } 92070-18006 1941 S C0122 &FMGR4              H0101 kASMB,R,L HED FMGR4 * NAME: FMGR4 * SOURCE: 92070-18006 * RELOC: 92070-16006 * PGMR: G.A.A. * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * NAM FMGR4,5 92070-1X006 REV.1941 790712 EXT SEG.R,.IDAD SPC 1 FMGR4 STA .IDAD LDA TABL JMP SEG.R SPC 1 TABL DEF *+1 SPC 1 EXT CL.. DEF CL.. EXT CO.. DEF CO.. EXT DU.. DEF DU.. EXT ST.. DEF ST.. END FMGR4 . ~ 92070-18007 1941 S C0122 &FMGR5              H0101 lASMB,R,L HED FMGR5 * NAME: FMGR5 * SOURCE: 92070-18007 * RELOC: 92070-16007 * PGMR: G.A.A. * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * NAM FMGR5,5 92070-1X007 REV.1941 790712 EXT SEG.R,.IDAD SPC 1 FMGR5 STA .IDAD LDA TABL JMP SEG.R SPC 1 TABL DEF *+1 SPC 1 EXT CA.. DEF CA.. EXT DP.. DEF DP.. EXT IF.. DEF IF.. EXT LL.. DEF LL.. EXT LO.. DEF LO.. EXT PA.. DEF PA.. EXT RN.. DEF RN.. EXT RP.. DEF RP.. EXT RU.. DEF RU.. EXT SV.. DEF SV.. EXT XQ.. DEF XQ.. END FMGR5   92070-18008 1941 S C0122 &FMGR6              H0101 mASMB,R,L HED FMGR6 * NAME: FMGR6 * SOURCE: 92070-18008 * RELOC: 92070-16008 * PGMR: M.L.K. * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * NAM FMGR6,5 92070-1X008 REV.1941 790712 EXT SEG.R,.IDAD SPC 1 FMGR6 STA .IDAD LDA TABL JMP SEG.R SPC 1 TABL DEF *+1 SPC 1 EXT BL.. DEF BL.. EXT CN.. DEF CN.. EXT IO.. DEF IO.. EXT IT.. DEF IT.. EXT LA.. DEF LA.. EXT ON.. DEF ON.. EXT PL.. DEF PL.. EXT TM.. DEF TM.. EXT TO.. DEF TO.. END FMGR6 Q  92070-18009 2040 S C0122 &$CLBL HEADER FOR RTE-L             H0101 KASMB,R,L,C HED COMPILER LIBRARY HEADER ROUTINE(RTE-L) NAM $CLIB,7 92070-12009 REV. 2040 800725 $CLIB * * THE PART NUMBER FOR THIS IS: 9206X-18XXX END   92070-18010 1941 S C0122 &REA.C              H0101 PSPL,L,O,M ! NAME: REA.C ! SOURCE: 92070-18010 ! RELOC: 92070-16010 ! PGMR: G.A.A. ! ! *************************************************************** ! * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * ! * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * ! * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* ! * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ! *************************************************************** ! NAME REA.C(8) " 92070-1X010 REV.1941 790712" ! READ COMMAND SUBROUTINE ! ! EXTERNAL SUBROUTINES LET MSS. BE SUBROUTINE,EXTERNAL LET PNAME BE SUBROUTINE,EXTERNAL LET READF BE SUBROUTINE,EXTERNAL LET WRITF BE SUBROUTINE,EXTERNAL ! EXTERNAL INTEGERS LET .E.R BE INTEGER,EXTERNAL LET C.BUF BE INTEGER,EXTERNAL LET CAM.I BE INTEGER,EXTERNAL LET ECH BE INTEGER,EXTERNAL LET INT. BE INTEGER,EXTERNAL ! INTERNAL VARIBLES LET RPRMT BE INTEGER LET PRMPT(4) BE INTEGER INITIALIZE RPRMT,PRMPT TO 20015K,0,0,0,20137K ! REA.C:SUBROUTINE GLOBAL ! IF TTY THEN PROMPT READ1:IF INT. THEN[ \WRITE PROMPT PNAME(PRMPT); \GET PROGRAM'S NAME PRMPT(3)_ PRMPT(3) + 32K; \ADD IN COLON WRITF(CAM.I,.E.R,PRMPT,4)] !WRITE OUT ! READ2:READF(CAM.I,.E.R,C.BUF,36,ECH) !READ THE COMMAND ! IF .E.R < 0 THEN[ \IF READ ERROR MSS.(.E.R-2000); \REPORT ERROR BUT DON'T TR ECH_ 0; \SET ZERO TRANSMISSION RETURN] !NOW EXIT IF INT. THEN[ IF ECH= -1 THEN[ \IF CTRL-D OR TO, RE-PROMPT WRITF(CAM.I,.E.R,RPRMT,5);\WITH "CRFMGR : " ms   GOTO READ2]] !NOW READ IF ECH <0 THEN[ \IF EOF, SET C.BUF_ [IF INT. THEN ": ", ELSE "::"]; \IN A TRANSFER CMND ECH_ 1] ! ! ! RETURN END ! END END$ >   92070-18011 2001 S C0122 &.PARS              H0101 }dSPL,L,O,M ! NAME: .PARS ! SOURCE: 92070-18011 ! RELOC: 92070-16011 ! PGMR: G.A.A.,A.M.G ! ! *************************************************************** ! * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * ! * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * ! * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* ! * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ! *************************************************************** ! NAME .PARS (8) " 92070-1X011 REV.2001 800103" ! ! THE PARSE SUBROUTINE AND ITS ROUTINES SCAN AN ASCII ! STRING AND PRODUCES: ! ! A. AN ACTION ROUTINE ADDRESS (CAD.) ! B. A PARAMETER COUNT (NOCM.) ! C. A PARAMETER LIST WITH 4 WORDS FOR EACH PARAMETER: (P.RAM) ! ! 1. TYPE ! (A.) 0 - NULL ! (B.) 1 - NUMBER ! (C.) 1 - SIGNED OR OCTAL NUMBER ! (D.) 3 - ASC STRING ! ! 2. FOR TYPE 1 THE VALUE, ! ELSE FOR TYPE 3 THE FIRST TWO CHARACTERS. ! ! 3. FOR TYPE 3 CHARACTERS 3 AND 4. ! ! 4. FOR TYPE 3 CHARACTERS 5 AND 6. ! ! D. A 10 WORD OPTION LIST AT N.OPL ! OPTIONS MAY APPEAR ON THE FIRST TWO PARAMETERS ! OPTIONS ARE SEPERATED FROM EACH OTHER AND FROM ! THE PARAMETER ITSELF BY COLONS. ! EACH OPTION IS STORED IN N.OPL STARTING AT ! WORD ZERO FOR PARAMETER ONE AND WORD 5 FOR PARAMETER TWO ! THERE MAY BE ONLY FIVE OPTIONS PER PARAMETER. ! THE FIRST TWO PARAMETERS MAY BE ASCII,THE REST ! MUST BE NUMERIC. ! THE INPUT STRING IS TO BE DELIMITED BY COMMAS. ! BLANKS ARE IGNORED UNLESS THEY ARE WITHIN ASCII STRINGS. ! THE FIRST CHARACTER MUST BE ":" IF INPUT IS NOT FROM A TTY. ! ! ! LET INT., \INTERACTIVE INPUT FLAG ] U.CMD, \USER'S COMMAND N.OPL, \NAMER SUBPARAMETER LIST SVCOD, \FMGR INTERNAL SEVERITY CODE P.RAM, \PARAMETER LIST ARRAY P.CNT, \NUMBER OF PARAMETERS FOUND G0.., \GLOBAL ARRAY CAD., \COMMAND ADDRESS OR INDEX IF IN SEGMENT ECH, \INPUT COMMAND LENGTH(WORDS) RESET FOR ECHO C.DLM, \CHARACTER ADDRESS OF FIRST DELIMITER AFTER COMMAND C.TAB, \COMMAND TABLE (SIGN SET ON COMMAND INDICATES SPECIAL) CUSE., \CURRENT SEGMENT SUFFIX CHARACTER C.BUF, \COMMAND BUFFER O.BUF, \OUTPUT DCB, USED AS A WORKING BUFFER SCR. \CHARACTERS 3 AND 4 OF COMMAND (OR 0 IF NONE) BE INTEGER,EXTERNAL LET FM.ER, \PRINT ERROR MESSAGE ROUTINE ECHO, \ECHO THE COMMAND ROUTINE CNUMD, \NUMBER TO ASCII CONVERSION ROUTINE MSS., \ERROR MESSAGE ROUTINE MVW \FMGR MOVE WORDS SUBROUTINE BE SUBROUTINE,EXTERNAL LET IN.ER BE SUBROUTINE LET COLON BE CONSTANT(72K ) ! : LET BLANK BE CONSTANT(40K ) LET COMMA BE CONSTANT (54K ) ! , LET CHAR0 BE CONSTANT(60K ) ! 0 LET PSIGN BE CONSTANT(53K) ! + LET MSIGN BE CONSTANT(55K) ! - LET QUES BE CONSTANT( 77K) ! ? ! ! ! GETCR: FUNCTION DIRECT .B._PTR !CHARACTER ADDRESS TO B. ASSEMBLE["CLE,ERB"; \CORE ADDRESS TO B,E=U/L 0/1 "LDA 1,I"; \GET THE WORD "ELB"; \ADDRESS BACK TO B "SLB,INB,RSS"; \STEP THE ADDRESS SKIP IF LOW CHAR "ALF,ALF" ] !ROTATE TO LOW IF NEEDED PTR_.B. !RESTORE B TO POINTER .A.,CHAR_.A. AND 377K !ISOLATE THE CHARACTER_# AND SAVE RETURN .A. !DONE GET OUT END ! PUTCR: FUNCTION DIRECT IF [.B._BUFPT]=LIMIT THEN GO TO EXITF !EXIT IF NO ROOM .A._CHAR !CHAR TO A FOR ASSMBLY ASSEMBLE["CLE,ERB"; \WORD ADD TO B, U/L FLAG TO E "XOR 1,I"; \KEEP OLD HIGH CHAR "AND LOWM"; \IN CASE THIS IS LOW "XOR 1,I"; \NEW CHAR IN LOW A OLD IN HIGH "SEZ,RSS"; \IF UPPER "ALF,ALF"; \ROTATE "STA 1,I"; \STASH IT AWAY "ISZ BUFPT" ] !PUSH BUFFER POINTER BACK TO SPL IF CHAR=BLANK THEN[ \IF FIRST BLANK AFTER IFNOT BF THEN BUFPT_BUFPT-1; \BF SET TO ZERO RETURN 1], \RETURN TRUE FOR ALL BLANKS ELSE [ \NOT A BLANK BF,BFEND_BUFPT; \KEEP TRACK OF HIGHEST NON BLANK RETURN 0 \AND RETURN ZERO ] END ! GETCR.EQ.DELIM:FUNCTION DIRECT !RETURNS TRUE IF NEXT !CHARACTER IS DELIMETER, !FALSE IF NOT ! IF PTR=EOL THEN[ \IF END OF LINE STOPF,CHAR_1; \SET STOP FLAG AND GO TO DELT \EXIT TRUE ] IF GETCR=COLON THEN GO TO DELT !ELSE GET CHAR AND IF CHAR =COMMA THEN GO TO DELT !IF ":" OR "," EXIT TRUE RETURN 0 !EXIT FALSE NOT A DELIMITER ! DELT: RETURN 1 !EXIT TRUE A DELIMITER END ! DIGT: FUNCTION DIRECT IF [CRAC_CHAR-CHAR0] >= 0 THEN[ \IF GREATER THAN "0" IF CRAC < BASE THEN [ &+\AND LESS THAN BASE ACCUMULATE VAL_VAL*BASE+CRAC; \T NUMBER SET THE FLAG AND T_1; \ RETURN T \RETURN TRUE ] \ ] RETURN 0 !ELSE RETURN FALSE END ! ! PARSE ROUTINE BEGINS HERE. ! .PARS:SUBROUTINE GLOBAL,FEXIT ! ! THE FOLLOWING IS PASS 1 OF A 2-PASS PARSE. THE PROMPT ! CHARACTER, IF PRESENT, IS REMOVED, GLOBALS ARE TRANSLATED AND ! BLANKS BEFORE AND AFTER DELIMITERS ARE REMOVED. ! BASE_10 LOWM_377K !ESTABLISH CONSTANT FOR PUTCH ACM,STOPF _ 0 !ZERO EOL FLAG AND COMMAND FLAG EF,PTR,CBUFC _[CBUFA_@C.BUF]-<1 !SET CHARACTER ADDRESSES EOL_CBUFC+ECH+ECH !END OF LINE FLAG (CHAR ADRS) BUFPT,CRONE_[C.DLM_@O.BUF]-<1 !OUT LINE CHAR ADDRESSES LIMIT_CRONE+80 !AND LIMIT ! IFNOT ECH THEN GO TO START !IF EMPTY LINE GO TO PASS TWO IFNOT INT. THEN[ \IF NOT INTERACTIVE IF GETCR # COLON THEN GO TO EXITF] !MUST HAVE LEAD ":" INGL: SIGN _ 1; OBUFS,BFEND_BUFPT !SET UP FOR VAL,T,BF_0 !SET BLANK STRIP FLAG PRAMS: IF GETCR.EQ.DELIM THEN GO TO ENDP !LOOP TILL DELIMITER ! IF PUTCR THEN GO TO PRAMS !PASS BLANKS IF CHAR = MSIGN THEN GO TO NGLBL !LOOK FOR NUMERICS IF CHAR = PSIGN THEN GOTO GLBL !GLOBAL PARAMETERS. IF DIGT THEN GOTO GLBL !FOUND A DIGIT. ! ! SCAN TO NEXT DELIMITER IT IS NOT A GLOBAL ! TOEND:UNTIL GETCR.EQ.DELIM DO PUTCR !PASS TILL NEXT PRAM ! ENDP: BUFPT_BFEND !STRIP TRAILING BLANKS IF STOPF THEN GO TO START !IF EOL THEN GO TO PASS 2 PUTCR !ELSE PASS THE DELIMITER GO TO INGL nI !ELSE GET NEXT PRAM ! ! SIGN PART OF NUMBER DETECTED MIGHT BE GLOBAL ! NGLBL:SIGN_ -1 !IT WAS A "-" SO SET FLAG GLBL: IF GETCR.EQ.DELIM THEN GO TO ENDP !NOT GLOBAL IF DELIMITER IF PUTCR THEN GO TO GLBL !JUST PASS BLANKS IF DIGT THEN GO TO GLBL !KEEP A TOTAL OF IF CHAR = "G" THEN [ \LOOK FOR GLOBAL GV _ 0; \DESIGNATORS. SZ _ 4; GOTO REPL] IF CHAR = "P" THEN [ \ GV _ 40; SZ _ 1; \ GOTO REPL] GOTO TOEND !NOT DIGIT OR "G","P" ! REPL: IFNOT T THEN GOTO TOEND !CHECK IF WE HAVE UNTIL GETCR.EQ.DELIM DO[ \PASS ANY TRAILING BLANKS IFNOT PUTCR THEN GO TO TOEND] !IF OTHER THEN NOT GLOBAL ! ! HONEST TO GOODIE GLOBAL BUT IS IT IN RANGE?? ! CBUFS_PTR-1 !SAVE IN ADD (REREAD DELIMITER) ADD _ VAL * SIGN * SZ + GV !A REAL GLOBAL. IF ADD < 0 THEN GO TO EXITF !CHECK BOUNDS. IF ADD > 47 THEN GO TO EXITF ADD _ ADD + @G0.. !GET TABLE OFFSET. BUFPT,BFEND_OBUFS !SET OUTBUF BACK ! ! EVALUATE GLOBAL ! IF SZ # 1 THEN [SZ _ $ADD;ADD_ADD+1] !IF NOT "P" SET SIZE IF SZ = 1 THEN[ \IF NUMERIC GLOBAL VAL_$ADD; \CONVERT THE NUMBER IF VAL < 0 THEN[ \IF NEGATIVE MUST SET VAL_ -VAL;CHAR_MSIGN; \POSITIVE AND SEND A "-" PUTCR \ SEND THE "-" ];\ CALL CNUMD(VAL,P.RAM); \CONVERT THE NUMBER ADD_ @P.RAM \SET RESULT ADDRESS ] IF SZ THEN[ \IF THERE IS A PARAMETER PTR_ADD-< 1;BF,EF_0; \SET TO MOVE IT IN REPEAT 6 TIMES DO [ \ GETCR;PUTCR \MOVE A CHARACTER ] \ ] EF,PTR_CBUFS;GETCR !RESET SOURCE POINTER CHAR GO TO ENDP !GO PROCESS THE DELIMITER ! ! THE SECOND PASS. ! ! INITIALIZE SCAN ! START:BF,CHAR_BLANK !PAD LINE IN CASE ODD CHARS EOL_BUFPT-CRONE+CBUFC !SET EOL FLAG FOR PASS 2. PUTCR !SEND FINAL CHAR. ECH _(BUFPT-CRONE) >- 1 !SET LINE LENGTH IN WORDS. MVW(C.DLM,CBUFA,ECH) !MOVE THE BUFFER BACK PTR_CBUFC !SET FOR INPUT IFNOT SVCOD THEN[ \ECHO IF REQUIRED IF C.BUF # "SV" THEN ECHO] !LET SV ECHO ITS OWN CAD._@IN.ER !SET CMND ADRS TO INPUT ERROR STOPF,C.DLM_0 FOR T_ @N.OPL TO @P.CNT DO $T_ 0 !ZERO THE OPTION LIST LIMIT_([PRAM_@P.RAM]+64) -< 1 !SET PUTCR LIMIT GOTO SCANS !GO START THE SCAN ! GETCH:UNTIL GETCR.EQ.DELIM DO[ PUTCR;GV_CHAR]!MOVE CHARACTERS UNTIL DELIM ! ! A DELIMITER 0 OR COMMA OR COLON - ENCOUNTERED ! VAL,T _ 0 !SET UP FOR NUMERIC CONVERSION IF C.DLM THEN GO TO PRMST !IF WE HAVE A COMMAND GO TO PRAM ADD_@C.TAB !MUST BE THE COMMAND SO C.DLM_PTR !SAVE FIRST DELIMITER ADDRESS U.CMD _ $PLOC !SET END OF C.TAB SCR. _ $PLOC1 ! SAVE CHARS 3,4 ALWAYS DO[ \AND LOOK IT UP IN IF ($ADD AND 77777K)=$PLOC THEN[ \ ACM_$ADD;CAD._$(ADD+1);GO TO RPLOC],\ ELSE [ADD_ADD+2]] !FIND THE PROCESSOR IN TABLE ! ! NOT FIRST SO SET UP THE PARAMETER o! PRMST:CBUFS_PTR-1;POS_BUFPT !SAVE DELIMITER ADDRESS, END ADD IF BUFPT=CUPAD THEN GOTO NULLS !NULL SO ZERO IT ! ! ATTEMPT NUMERIC CONVERSION ! IF GV = "B" THEN[ \IF OCTAL SET UP BASE_8;POS_POS-1], \BASE AND END OF STRING ELSE \OTHER WISE USE BASE_10 !BASE 10 ! PTR_CUPAD;SIGN_1 !SET FOR LOOP ! ! CONVERSION LOOP ! UNTIL PTR=POS DO THRU CLOOP IF GETCR= BLANK THEN GOTO CLOOP !IGNOR IMBEDED BLANKS IFNOT DIGT THEN [ \IF NOT DIGIT IF PTR=SZ THEN[ \IF FIRST CHAR TEST IF CHAR=MSIGN THEN[SIGN_-SIGN;GO TO CLOOP];\ IF CHAR=PSIGN THEN GO TO CLOOP \ ]; \ GO TO NOTNO \NOT DIGIT OR LEGAL SIGN ] CLOOP: !END OF CONVERSION LOOP ! ! SET TYPE AND NO. IN THE LIST ! IFNOT [$PLOC0_T] THEN GOTO NOTNO !IF NO DIGITS-NOT A NUMBER NULLS:$PLOC_VAL*SIGN !SET THE VALUE IN THE LIST $[REAL]PLOC1_0.0 !ZERO THE EXTRA WORDS ! ! SET UP FOR THE NEXT PARAMETER ! NXPRM:PTR_CBUFS;GETCR !GET THE DELIMITER IFNOT SBSCN THEN GO TO NOTSU !SKIP IF NOT SUB SCAN IF [SUBCO_SUBCO+1]<3 THEN GOTO STPM !SKIP ASC TEST IF FIRST TWO IF $PLOC0=3 THEN GO TO SKIPP !SUB PRAMETERS ELSE ASC ERROR STPM: IF P.CNT< 3 THEN$(SBSCN+SUBCO)_$PLOC !SET THE SUB PRAM IN THE OP LIST ! IF CHAR=COLON THEN[IF SUBCO=5 THEN GOTO SKIPP ,\ TOO MANY ELSE GO TO RPLOC] !GO GET NEXT SUB PRAM ! SCANS:SUBCO,SBSCN_0 !ZERO THE SUB SCAN FLAGS ! SCANC:PLOC1_[PLOC_[PLOC0_PRAM+4*P.CNT]+1]+1 !SET THE CURRENT ADDRESSES ! RPLOC:SZ_[CUPAD,BUFPT_PLOC -< 1]+1 !SET AƓDDRESSES FOR PUTCR IF CUPAD>LIMIT THEN GO TO EXITF !TOO MANY PRAMS? $PLOC0,$PLOC,$PLOC1_0 !SET LIST LOCATIONS TO ZERO IF STOPF THEN GO TO EXIT !IF FINAL DELIMITER EXIT GO TO GETCH !ELSE GET NEXT PRAM ! ! PARAMETER END NOT SUB PRAM ! NOTSU: IF CHAR = COLON THEN [ \CHECK FOR ILLEGAL IF P.CNT > 1 THEN [ \DELIMITER, BUT LET IF ACM > 0 THEN[ \IT GO THROUGH IN GOTO EXITF], \CASE OF SPECIAL ELSE[ \ P.CNT_ P.CNT + 1; \ GOTO SKIP1]], \COMMANDS ONLY. ELSE SBSCN _ @INT. + P.CNT*5] !SET UP SUB-SCAN. ! P.CNT_P.CNT+1 !STEP COUNT GO TO SCANC !GO SCAN IT ! ! NOT A LEGAL NUMBER - TRY FOR A NAME ! NOTNO:$PLOC0_3 !ASSUME NAME AND SET UP CHAR_BLANK !SET UP TO BLANK FILL UNTIL BUFPT=>CUPAD+6 DO PUTCR !FILL IT GO TO NXPRM !ASSUME A NAME AND CONTINUE ! ! NORMAL EXIT ROUTINE CLEAR END OF LIST AND CHECK FOR SEG ! EXIT: CHAR_0 UNTIL BUFPT >= LIMIT DO PUTCR !ZAP THE LIST IF CAD.<0 THEN GO TO EXIT1 !IF LOCAL GO EXIT IF CAD.>10000K THEN GO TO EXIT1 !IF LOCAL GO TO EXIT. CHAR,CUSE._(CAD. AND 377K)-<8 !SET SEGMENT ADRS INTO CUSE ! CAD._((CAD. AND 17400K)-<8) !SET ROUTINE NUMBER IN CAD. EXIT1:.B._ACM !SET ASCII COMMAND IN B FOR MAIN IFNOT CHAR THEN RETURN,ELSE FRETURN ! EXITF:IF ACM<0 THEN GO TO EXIT !IF WE HAVE A SPECIAL THEN EXIT EXITG:IFNOT EF THEN PTR_CBUFS !IF ERROR WHILE PTR WRONG RESET CAD._@IN.ER;CHAR_0;GO TO EXIT1 !ELSE ERROR EXIT ! ! ! PAx640RSE ERROR ON SUBPARAMETER. IF SPECIAL COMMAND, ! IGNORE EVERYTHING UNTIL NEXT COMMA OR END OF LINE IS ! FOUND. ! SKIPP:IF ACM >= 0 THEN GOTO EXITG !IFNOT SPECIAL, EXIT SKIP1:IF CHAR = COLON THEN[ \FLUSH THE SUB PARMS SKIP2: IFNOT GETCR.EQ.DELIM THEN \ GOTO SKIP2; \SKIP UNTIL NEXT DELIMITER IF STOPF THEN GOTO EXIT, \EXIT IF END OF LINE ELSE GOTO SKIP1] !GO CHECK FOR ANOTHER SUBP GOTO SCANS !WHEN COMMA, CONTINUE END ! IN.ER:SUBROUTINE MSS.(10) !FORCE ECHO AND PRINT ERROR BUFPT_PTR;CHAR_QUES;PUTCR !PLANT A "?" CHAR_BLANK;PUTCR !AND A BLANK PAD FM.ER(1,C.BUF,(BUFPT-CBUFC)>-1) !WRITE IT OUT RETURN END END END$ G6  92070-18012 1941 S C0122 &C.TAB              H0101 NASMB,R,L,C * NAME: C.TAB * SOURCE: 92070-18012 * RELOC: 92070-16012 * PGMR: G.A.A. * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * NAM C.TAB,8 92070-1X012 REV.1941 790712 ENT C.TAB,U.CMD,EX.. EXT TR..,SE..,SY..,??.. EXT CAM.I,CLOSE,EXEC SUP * * SET UP SEGMENT AND ROUTINE NUMBERS. * * R = ROUTINE NUMBER WITHIN SEGMENT * S = ASCII VALUE FOR SEGMENT NUMBER * R0 EQU 0 R1 EQU 400B R2 EQU R1+R1 R3 EQU R2+R1 R4 EQU R3+R1 R5 EQU R4+R1 R6 EQU R5+R1 R7 EQU R6+R1 R8 EQU R7+R1 R9 EQU R8+R1 R10 EQU R9+R1 SPC 2 S0 EQU 60B S1 EQU S0+1 S2 EQU S0+2 S3 EQU S0+3 S4 EQU S0+4 S5 EQU S0+5 S6 EQU S0+6 S7 EQU S0+7 S8 EQU S0+8 S9 EQU S0+9 * * THIS IS THE COMMAND DISPATCH TABLE FOR THE FMGR PROGRAM * EACH COMMAND ID IS FOLLOWED BY ITS ADDRESS. * FOR ROUTINES IN THE HOME SEGMENT THIS IS AN ADDRESS (DEF XX) * FOR ROUTINES IN OTHER SEGMENTS IT IS THE ASCII SEGMENT * SUFFIX IN THE LOW HALF OF THE WORD AND THE ROUTINE * NUMBER IN THAT SEGMENT IN THE HIGH HALF OF THE WORD. * .PARS BREAKS THESE APART BY THE ADDRESS BEING 0< ADD < 10000B * (=4000.) FOR SEGMENT ADDRESS. MAXIMUM NUMBER OF ROUTINES PER SEGMENT * IS 15. * * COMMANDS WITH THE SIGN BIT SET INDICATE THAT THE COMMAND * NEED NOT SATISFY ALL THE SYNTAX RESTRICTIONS IMPOSED ON * OTHER COMMANDS. * SKP C.TAB EQU * FMGR COMMAND TABLE * * SEGMENT 0 * ASC 1,CR ABS S0+R0 ASC 1,PK ABS S0+R1 * * SEGMENT 1 * } ASC 1,EX DEF EX.. ASC 1,SE DEF SE.. ASC 1,TR DEF TR.. NOP FOR ":" DO A TR DEF TR.. OCT 125052 "**" WITH SIGN BIT SET DEF COMM OCT 125000 "*" WITH SIGN BIT SET DEF COMM OCT 125040 "*" WITH SIGN BIT SET DEF COMM ASC 1,?? DEF ??.. * * SEGMENT 2 * * IN.IT IS ROUTINE 0 ASC 1,DC ABS S2+R1 ASC 1,IN ABS S2+R2 ASC 1,MC ABS S2+R3 ASC 1,PU ABS S2+R4 * * SEGMENT 3 * ASC 1,DL ABS S3+R0 ASC 1,LI ABS S3+R1 SKP * * SEGMENT 4 * ASC 1,CL ABS S4+R0 ASC 1,CO ABS S4+R1 ASC 1,DU ABS S4+R2 ASC 1,ST ABS S4+R3 * * SEGMENT 5 * ASC 1,CA ABS S5+R0 OCT 142120 "DP" WITH THE SIGN BIT SET ABS S5+R1 ASC 1,IF ABS S5+R2 ASC 1,LL ABS S5+R3 ASC 1,LO ABS S5+R4 OCT 150101 "PA" WITH THE SIGN BIT SET ABS S5+R5 ASC 1,RN ABS S5+R6 ASC 1,RP ABS S5+R7 OCT 151125 "RU" WITH SIGN BIT SET ABS S5+R8 ASC 1,SV ABS S5+R9 OCT 154121 "XQ" WITH SIGN BIT SET ABS S5+R10 * * SEGMENT 6 * ASC 1,BL ABS S6+R0 ASC 1,CN ABS S6+R1 ASC 1,IO ABS S6+R2 ASC 1,IT ABS S6+R3 ASC 1,LA ABS S6+R4 ASC 1,ON ABS S6+R5 ASC 1,PL ABS S6+R6 ASC 1,TM ABS S6+R7 ASC 1,TO ABS S6+R8 * * SYSTEM ROUTINE (SY..) * U.CMD NOP USER'S COMMAND WITH SIGN BIT SET DEF SY.. SKP * * COMMENT ACTION ROUTINE * COMM NOP LDA COMM,I JMP 0,I * * EXIT ACTION ROUTINE * EX.. NOP JSB CLOSE CLOSE INPUT FILE/DEVICE DEF *+2 DEF CAM.I *  JSB EXEC TERMINATE DEF *+2 DEF .6 * * .6 DEC 6 END   92070-18013 1941 S C0122 &CA..              H0101 O<ASMB,R,L,C HED CA.. ROUTINE * NAME: CA.. * SOURCE: 92070-18013 * RELOC: 92070-16013 * PGMR: G.A.A. * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * NAM CA..,8 92070-1X013 REV.1941 790712 ENT CA.. EXT N.OPL,.ENTR,.DFER,G0.. SUP * * THIS MODULE OF THE RTE FILE MANAGEMENT PACKAGE CACULATES * A VALUE AND STORES IT IN A GLOBAL LOCATION. IT IS CALLED * WHEN A STATEMENT OF THE FORM: * * :CA,#,OPERAND1,OPERATION,OPERAND2,OPERATION,OPERAND3...ETC. * * IS ENCOUNTERED. * * THE RESULT OF THE OPERATION WILL BECOME GLOBAL '#'. * * OPERATION CODES ARE: * * + ADD * - SUBTRACT (1-2) * / DIVIDE (1/2) * * MULTIPLY (1*2) * O OR (1 OR 2) * X EXCLUSIVE OR (1 XOR 2) * A AND (1 AND 2) * * THE ORDER OF THE RESULT WILL BE THE MAXIMUM OF THE ORDERS * OF THE OPERANDS. (THE ORDER IS 0=NULL,1=NUMERIC AND 3=ASCII) * IN ALL CASES EXCEPT / AND * THE CACULATION IS DONE INDEPENDTLY * ON THE THREE WORD VALUES OF THE OPERANDS. IN THE CASE OF * / AND * THE FIRST WORD OF OPERAND TWO IS USED FOR ALL * THREE WORD OF OPERAND ONE. * * EVALUATION PROCEEDS FROM LEFT TO RIGHT UNTIL A NULL OPERATION * CODE IS DETECTED. ANY OTHER PRECEDENCE MUST BE EFFECTED BY * MULTIPLE STATEMENTS. * COUNT NOP PRAM NOP ERR NOP CA.. NOP JSB .ENTR GET THE PRAMS DEF COUNT * * ISZ PRAM STEP TO GLOBAL # LDA PRAM,I GET IT LDB N.OPL GET POQSSIBLE 'P' FLAG CPB "P" SET ?? JMP PTST YES GO TEST 'P' NUMBER * SSA,RSS CMA,INA,SZA,RSS IF 0 OR - JMP EREX TAKE GAS. * ADA .9 IF MORE THAN SSA 9 JMP EREX TAKE GAS. * LDB PRAM,I GET THE NUMBER BLS,BLS TIMES 4 PADD LDA DGLOB GET THE ADDRESS OF THE RAL,CLE,SLA,ERA GLOBAL ARRAY LDA A,I ADA B COMPUTE THE DESTINATION ADDRESS STA DESTT AND SET IT LDB PRAM SET UP THE TEMP ADB .3 STORE STB TDES ADDRESS STB PRAM * LOOP ADB .5 INDEX TO OP LDA B,I PICK UP OP CODE ADB .3 INDEX TO OP2 STB PRAM SET ADDRESS SZA,RSS IF NO CODE JMP EXOK THEN END OF LINE, GO EXIT * AND C377 KEEP FIRST CHARACTER CLB,CLE SET UP THE COMP LOOP STB COMP STB ADDR STB DMCD CPA MINUS SUBTRACT? CCE,RSS YES SET FLAG AND USE PLUS CPA PLUS ADD LDB ADA YES USE ADD INSTR CPA "O" OR? LDB IOR YES CPA "X" XOR? LDB XOR YES CPA "A" AND? LDB AND YES SZB ON OF THE ABOVE? JMP SETOP YES GO SET UP * CPA "/" DIVIDE? LDB DIV YES CPA TIMES *? LDB MPY YES SZB,RSS IF STILL NO GO JMP EREX THEN GO EXIT ERROR * STB DMCD SET *, / CODE LDB LDB SET A LDB BEFORE IT STB COMP AND LDB PRAM SET THE OP 2 ADDRESS CLE,INB AFTER THE DIV STB ADDR LDB ASR GET THE ASR INSTRUCTION * SETOP STB OPCD SET THE OP CODE LDA NEGAT IF - SEZ SET STA COMP A CMA,INA LDA N3 SET THE LOOP COUNT STA COUNT LDA TDES AND THE DESTINATION ADDRESS = STA DES LDA A,I SET THE ORDER CODE NEGAT CMA,INA ADA PRAM,I TO THE LDB PRAM,I MAX SSA,RSS OF THE STB DES,I ORDERS PRESENT * CLOOP ISZ DES STEP DESTINATION ADDRESS ISZ PRAM AND SOURCE ADDRESS LDB DES GET ADDRESS TO B LDA PRAM,I OP2 TO A COMP CMA,INA /NOP /LDB B,I DO IT OPCD ADA B,I /ASR 16 DMCD NOP /DIV/MPY ADDR NOP /ADDR -PRAM STA DES,I SET THE RESULT AWAY ISZ COUNT DONE? JMP CLOOP NO DO NEXT WORD * LDB PRAM SET UP A FOR ADB N3 NEXT OP CODE JMP LOOP AND LOOP * PTST ADA .36 MUST BE IN RANGE -36<= X < 7 SSA,RSS IF NEGATIVE THEN < -36 CPA .36 DON'T ALLOW ZERO EITHER JMP EREX ERROR ZERO OR LESS THAN -36 * ADA N43 TEST FOR > 7 SSA,RSS OK? JMP EREX NO NUMBER TO BIG * LDB PRAM,I GET PRAM AND ADB .40 CACULATE THE ADDRESS OFFSET JMP PADD GO SET IT UP AND DO THE 'CA' * * EXOK LDA TDES,I AH - SWEET SUCCESS STA DESTT,I SET NEW PRAM IN DESTINATION ISZ TDES LDB N.OPL IF A CPB "P" P CACULATE JMP PSET GO RESET TO RIGHT THING * ISZ DESTT AND JSB .DFER THEN DESTT NOP TDES NOP EXP CLA,RSS EREX LDA BADPM ERROR EXIT STA ERR,I SET ERROR CODE JMP CA..,I EXIT * * PSET LDA TDES,I GET THE VALUE WORD STA DESTT,I AND SET FOR P JMP EXP GO EXIT * DES NOP DGLOB DEF G0.. BADPM DEC 56 ASR ASR 16 LDB LDB B,I ADA ADA B,I IOR IOR B,I AND AND B,I XOR XOR B,I DIV OCT 100400 MPY OCT 100200 "A" OCT 40400 "X" OCT 54000 "O" OCT 47400 "P" ASC 1,P P BLANK FOR P TEST MINUS OCT 26400 PLUS OCT 25400 "/" OCT 27400 TIMES OCT 25000 C377 OCT 177400 .3 DEC 3 .9 DEC 9 .5 DEC 5 .36 DEC 36 .40 DEC 40 N3 DEC -3 N43 DEC -43 A EQU 0 B EQU 1 ORG * END   92070-18014 1941 S C0122 &CL..              H0101 [<SPL,L,O,M ! NAME: CL.. ! SOURCE: 92070-18014 ! RELOC: 92070-16014 ! PGMR: G.A.A. MOD. M.L.K. ! ! *************************************************************** ! * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * ! * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * ! * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* ! * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ! *************************************************************** ! ! NAME CL..(7) " 92070-1X014 REV.1941 790712" ! ! DISC DIRECTORY LIST ! ! ENTERED BY ! ! CL COMMAND ! ! ! ! EXTERNAL SUBROUTINES LET CONV. BE SUBROUTINE,EXTERNAL LET D.RIO BE SUBROUTINE,EXTERNAL LET FTIME BE SUBROUTINE,EXTERNAL LET IER. BE SUBROUTINE,EXTERNAL,DIRECT LET OPEN. BE SUBROUTINE,EXTERNAL LET WRITF BE SUBROUTINE,EXTERNAL ! EXTERNAL VARIBLES LET .E.R BE INTEGER,EXTERNAL LET %IDA BE INTEGER,EXTERNAL !SYSTEM ENTRY $IDA LET %IDSZ BE INTEGER,EXTERNAL !SYSTEM ENTRY $IDSZ LET BUF.(129) BE INTEGER,EXTERNAL LET D.SDR BE INTEGER,EXTERNAL LET I.BUF BE INTEGER,EXTERNAL LET TMP. BE INTEGER,EXTERNAL ! INTERNAL VARIBLES LET BLANK(14) BE INTEGER !THESE TWO INITIALIZE BLANK TO " LU LAST TRACK CR LOCK" !BUFFERS LET TIME(19) BE INTEGER !MUST BE INITIALIZE TIME TO 19(20040K) !IN ORDER ! ! CL..: SUBROUTINE GLOBAL !NO PRAMETERS NEEDED T_@TMP.+3 !POINT TO SEC CODE AND CRN OPEN.(I.BUF,TMP.,$T,0) ! OPEN LIST FILE TB_@BUF.+1 BUF.(1) _BLANK(1) FTIME(TIME(3)) !GET DATE AND TIME WRITF(I.BUF,.E.R,BLANK,32) !WRITE THE HEAD Y IER. !CHECK FOR ERROR WRITF(I.BUF,.E.R,BUF.,1) !SPACE A LINE IER. !CHECK FOR ERROR CALL D.RIO !READ THE DIRECTORY OF DISCS PN_ [PCR_ [PTR_ TB+ 4]+ 5]+ 2 !SET UP POINTERS TO OUTPUT BUF TL_@D.SDR !BEGINNING OF DIRECTORY ! NEXT: IFNOT $TL \IF END OF CART LIST, THEN[ \THEN DONE: WRITF(I.BUF,.E.R,T,-1); \WRITE END OF FILE IER.; \CHECK FOR ERROR RETURN] !AND EXIT ! FOR T_ TB TO PN DO[$T_BLANK(1)] !CLEAR THE OUTPUT BUF CONV.($TL,$TB ,2) !CONVERT LU AND STORE AT TB CONV.($[TL_TL+1],$PTR,4) !CONVERT LAST TRACK CONV.($[TL_TL+1],$PCR,5) !CONVERT CRN IFNOT $[TL_TL+1] \IF LOCK WRD IS 0 THEN[ \ N_11; \SET LINE LENGTH TO 11 GOTO WRT] !AND WRITE THE LINE T _ $%IDA +((($TL AND 377K)-1)*$%IDSZ)+11 !POINT TO ID NAME FOR T2 _ PN TO PN+2 DO[ \MOVE ID NAME TO $T2 _ $[T_T+1]] !OUTPUT BUFFER T2 _ T2-1 !BACK UP ONE $T2 _ ($T2 AND 177400K) + 40K !CLEAR LAST BYTE OF NAME N _ 15 !SET LINE LENGTH ! WRT: WRITF(I.BUF,.E.R,BUF.,N) !WRITE OUT OUTPUT BUF IER. !CHECK FOR ERRORS TL_TL+1 !POINT TO NEXT CART ENTRY GOTO NEXT !LIST NEXT ENTRY ! END END END$ N   92070-18015 2014 S C0122 &CO..              H0101 ]6ASMB,R,L,C HED (FMGR) CO..: COPY COMMAND * NAME: CO.. * SOURCE: 92070-18015 * RELOC: 92070-16015 * PGMR: E.D.B. * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * NAM CO..,7 92070-1X015 REV.2014 800409 * ENT CO.. * EXT IF.ER, CK.NM, CLR.C, DR.CT, CR.LU EXT F.SET, FM.ER, MSC. EXT I.BUF, O.BUF, N.OPL, G0.. EXT CREAT, PURGE, COPYF EXT .ENTR, .MVW, IFBRK SUP SKP * * DESCRIPTION * * THIS IS THE COPY COMMAND OF THE RTE-L FMGR * SEE ERS FOR DETAILS. * * PROCESSES: * * CO,SLU,DLU,OPT,FIRST,LAST,MSC * * WHERE: * * SLU IS A NAMR OR CRN OF THE SOURCE CARTRIDGE * * DLU IS THE DESTINATION CARTRIDGE * * OPT IS THE OPTIONS * * FIRST IS THE FIRST FILE TO BE TRANSFERRED (OPTIONAL) * * LAST IS THE LAST FILE TO BE TRANSFERRED (OPTIONAL) * * MSC IS THE MASTER SECURITY CODE (OPTIONAL) * * POSSIBLE ERRORS: * * -14 DIRECTORY FULL * -33 CARTRIDGE OUT OF ROOM * 21 ILLEGAL LU * 22 COPY TERMINATED * 51 BAD MASTER SECURITY CODE * 56 BAD PARAMETER * * COPY OPTIONS: * * C CLEAR DESTINATION CARTRIDGE BEFORE COPY * (REQUIRES MSC) * D DUMP FILE EVEN IF EXISTING * E ELIMINATE EXTENTS * P PURGE SOURCE FILE AFTER COPY * (MAY REQUIRE MSC) * V VERIFY COPY SKP * * ENTRY * N NOP LIST NOP ER NOP * CO.. NOP ENTRY POINT JSB .ENTR DEF N * * PROCESS REQUEST * CLA ZEQRO OUT SOME VARIABLES STA CLRSW STA DMPSW STA ELISW STA PURSW STA VERSW STA MORE * * PARSE FIRST PARAMETER (SOURCE) * LDA LIST,I GET TYPE OF FIRST PARAMETER ISZ LIST CPA .3 IF ASCII, JMP ASCII THEN GO SET MASK * JSB F.SET SET UP DEFAULT MASK DEF *+2 DEF DFALT * LDA LIST,I GET SOURCE CRN JMP CO..1 AND CONTINUE * ASCII JSB F.SET SET UP MASK DEF *+2 DEF LIST,I * LDA N.OPL+1 GET CRN FROM SUBPARAMETER BUFFER * CO..1 STA SLU SAVE SOURCE CARTRIDGE ID JSB CR.LU TEST FOR LEGAL ID DEF *+2 DEF SLU * SZA,RSS IF NOT LEGAL ID, JMP ER21 THEN TAKE ERROR RETURN * CMA,INA NEGATE STA SLU AND SAVE SKP * * PARSE SECOND PARAMETER (DESTINATION) * LDB LIST GET LIST ADDRESS ADB .3 BUMP TO DESTINATION ID LDA B,I GET TYPE CPA .3 IF ASCII JMP ER56 THEN TAKE ERROR EXIT * INB BUMP TO ID LDA B,I GET IT STA DLU SAVE IT * JSB CR.LU TEST FOR LEGAL ID DEF *+2 DEF DLU * SZA,RSS IF NOT LEGAL ID, JMP ER21 THEN TAKE ERROR EXIT * CMA,INA NEGATE STA DLU AND SAVE CPA SLU IF SAME AS SOURCE LU, JMP ER21 THEN TAKE ERROR EXIT SKP * * PARSE THIRD PARAMETER (OPTIONS) * LDB LIST GET LIST ADDRESS ADB .7 BUMP TO OPTIONS LDA B,I GET TYPE SZA,RSS IF NOT SUPPLIED, JMP CONT THEN CONTINUE * INB BUMP TO INFO CLE,ELB CONVERT INTO BYTE COUNTER LDA N6 GET LOOP COUNTER STA COUNT SAVE * PARSE CLE,ERB GET ADDRESS AND SET E TO BYTE LDA B,I GET 2 CHARACTERS ELB,SLB fIF LOW BYTE, ALF,ALF THEN SHIFT TO HIGH BYTE AND NB400 ISOLATE HIGH BYTE ADA .32 PUT SPACE INTO LOW BYTE * CPA .SP IF SPACE, JMP PARS1 THEN IGNORE * CPA .C IF OPTION C, JMP SET.C THEN SET CLEAR SWITCH * CPA .D IF OPTION D, JMP SET.D THEN SET DUMP SWITCH * CPA .E IF OPTION E, JMP SET.E THEN SET ELIMINATE SWITCH * CPA .P IF OPTION P, JMP SET.P THEN SET PURGE SWITCH * CPA .V IF OPTION V, JMP SET.V THEN SET VERIFY SWITCH * JMP ER56 ELSE TAKE ERROR EXIT * SET.C ISZ CLRSW SET CLEAR SWITCH JMP PARS1 AND CONTINUE * SET.D ISZ DMPSW SET DUMP SWITCH JMP PARS1 AND CONTINUE * SET.E ISZ ELISW SET ELIMINATE SWITCH JMP PARS1 AND CONTINUE * SET.P ISZ PURSW SET PURGE SWITCH JMP PARS1 AND CONTINUE * SET.V ISZ VERSW SET VERIFY SWITCH * PARS1 INB INCREMENT BYTE COUNT ISZ COUNT IF NOT DONE, JMP PARSE THEN CONTINUE PARSE SKP * * PARSE FOURTH PARAMETER (FIRST FILE) * CONT LDB LIST GET LIST ADDRESS ADB .11 BUMP TO FOURTH PARAMETER * LDA B,I GET THE TYPE CPA .1 IF NUMERIC, JMP ER56 THEN INDICATE BAD PARAMETER * INB BUMP TO 2 CHARS LDA B,I GET THEM STA FIRST AND SAVE THEM * INB BUMP TO NEXT 4 CHARS DLD B,I GET THEM DST FIRST+1 AND SAVE THEM * * PARSE FIFTH PARAMETER (LAST FILE) * LDB LIST GET LIST ADDRESS ADB .15 BUMP TO FIFTH PARAMETER * LDA B,I GET THE TYPE CPA .1 IF NUMERIC, JMP ER56 THEN INDICATE BAD PARAMETER * INB BUMP TO 2 CHARS LDA B,I GET THEM STA LAST AND SAVE THEM * INB G BUMP TO NEXT 2 CHARS DLD B,I GET THEM DST LAST+1 AND SAVE THEM SKP * * PARSE SIXTH PARAMETER (MSC) * LDB LIST GET LIST ADDRESS ADB .19 BUMP TO SIXTH PARAMETER * LDA B,I GET THE TYPE SZA,RSS IF NOT PRESENT, JMP BDMSC THEN BAD MASTER SECURITY CODE * STB MSECU SAVE P.RAM ADDRESS FOR MSC * JSB MSC. TEST PASSED MASTER SECURITY CODE DEF *+2 DEF MSECU,I * SZA,RSS IF BAD SECURITY CODE, JMP ER51 THEN TAKE ERROR EXIT * BDMSC STA MSECU SAVE STATUS SKP * * CLEAR DESTINATION IF REQUESTED * LDA CLRSW GET CLEAR SWITCH SZA,RSS IF NOT REQUESTED, JMP COPY6 THEN CONTINUE * LDA MSECU GET MSC STATUS SZA,RSS IF NOT CORRECT MSC, JMP ER51 THEN TAKE ERROR EXIT * JSB CLR.C CLEAR DESTINATION DEF *+2 DEF DLU * CPA .60 IF CLEAR NOT PERMITTED, JMP EXIT THEN TAKE GOOD EXIT * SZA IF ANY OTHER ERROR, JMP EREX THEN TAKE ERROR EXIT SKP * * START TRANSFER LOOP * COPY6 JSB DR.CT READ IN PSEUDO DIRECTORY DEF *+8 DEF SLU DEF NAME DEF DIRMX DEF DIRLN DEF MORE DEF FIRST DEF LAST * LDA DIRLN GET DIRECTORY LENGTH SZA,RSS IF EMPTY, JMP GTMOR THEN GET MORE * CLA SET COUNTER TO ZERO STA CUR AND SAVE * COPY1 LDA CUR CALCULATE DIRECTORY OFFSET ALF,ARS MULTIPLY BY 8 ADA ANAME ADD TO BASE ADDRESS * LDB AFNAM GET ADDRESS OF LOCAL COPY JSB .MVW MOVE 8 WORDS DEF .8 NOP (FOR COMPATIBILITY) * JSB CK.NM CHECK IF FILE IS BOOTEX DEF *+3 DEF FNAME DEF "BOOT * SEZ,RSS IF FILE WAS "BOOTE[X", JMP IGNOR THEN IGNORE IT * LDA FTYPE GET FILE TYPE SZA,RSS IF NON-DISC FILE, JMP IGNOR THEN IGNORE IT * JSB FM.ER PRINT OUT FILE NAME DEF *+4 DEF .1 DEF FNAME DEF .3 * JSB IFBRK TEST FOR BREAK DEF *+1 SSA,RSS IF NO BREAK, JMP COPY2 THEN CONTINUE * LDA .22 INDICATE COPY TERMINATED JMP ABEND * COPY2 LDA ELISW GET ELIMINATE-SWITCH SZA IF SET, JMP ELIM THEN CALCULATE NEW SIZE * LDA FSIZE GET FILE SIZE (IN BLOCKS) JMP CO..3 * ELIM LDA FEXTS GET NUMBER OF EXTENTS INA ADD ONE MPY FSIZE MULTIPLY BY FILE SIZE (IN BLOCKS) * CO..3 STA SZ SAVE FILE SIZE FOR CREAT LDA FRECL GET FILE RECORD LENGTH STA SZ+1 SAVE FOR CREAT SKP * * CREATE DESTINATION FILE * CRIT JSB CREAT TRY CREATING DESTINATION FILE DEF *+8 DEF O.BUF DEF IERR DEF FNAME DEF SZ DEF FTYPE DEF FSEC USE WILDCARD SECURITY CODE DEF DLU * CPA N2 IF DUPLICATE FILE ERROR, JMP DMPIT THEN TEST FOR DUMP-MODE * CPA N33 IF NOT ENOUGH ROOM, JMP ABEND THEN ABEND * CPA N14 IF DIRECTORY FULL, JMP ABEND THEN ABEND * COPY7 JSB IF.ER IF ANY OTHER ERROR, DEF *+3 THEN PRINT MESSAGE DEF IERR DEF IGNOR AND IGNORE JMP CPYIT OTHERWISE GO COPY FILE * * PURGE DESTINATION FILE (IF DUMP MODE) * DMPIT LDB DMPSW GET DUMP SWITCH SZB,RSS IF NOT DUMP-MODE, JMP COPY7 THEN PRINT MESSAGE * JSB PURGE TRY TO PURGE OLD DESTINATION FILE DEF *+6 DEF O.BUF DEF IERR DEF FNAME DEF FSEC PURGE ONLY IF WILDCARD MATCHES DEF DLU * JSB IF.ER IF ERROR, DEF *+3 THEN PRINT MESSAGE DEF IERR DEF IGNOR AND IGNORE JMP CRIT ELSE GO CREATE IT SKP * * COPY A FILE * CPYIT JSB COPYF USE COPYF ROUTINE DEF *+11 DEF I.BUF DEF IERR DEF FNAME DEF FSEC USE WILDCARD SECURITY CODE DEF SLU DEF O.BUF DEF FNAME DEF FSEC USE WILDCARD SECURITY CODE DEF DLU DEF VERSW * SZA,RSS IF NO ERROR, JMP PRGIT THEN CONTINUE * * PURGE DESTINATION FILE (IF NOT FULLY COPIED) * JSB PURGE TRY TO PURGE DESTINATION FILE DEF *+6 DEF O.BUF DEF SZ USE FOR DUMMY ERROR CODE DEF FNAME DEF FSEC USE WILDCARD SECURITY CODE DEF DLU * LDA IERR GET ERROR CODE AGAIN CPA N33 IF NOT ENOUGH ROOM, JMP ABEND THEN TERMINATE ABNORMALLY * CPA N14 IF DIRECTORY FULL, JMP ABEND THEN TERMINATE ABNORMALLY * CPA N49 IF VERIFY FAILED, JMP ABEND THEN TERMINATE ABNORMALLY * JSB IF.ER IF ANY OTHER ERROR, DEF *+3 THEN PRINT MESSAGE DEF IERR DEF IGNOR AND IGNORE IT SKP * * PURGE SOURCE FILE (IF REQUESTED) * PRGIT LDA PURSW GET PURGE SWITCH SZA,RSS IF NOT REQUESTED, JMP IGNOR THEN IGNORE PURGE REQUEST * LDA MSECU GET MSC STATUS FLAG LDB N.OPL GET PASSED SECURITY CODE SZA,RSS IF NOT CORRECT MSC, STB FSEC THEN OVERRIDE SAVED SECURITY CODE * JSB PURGE TRY TO PURGE SOURCE FILE DEF *+6 DEF I.BUF DEF IERR DEF FNAME DEF FSEC USE WILDCARD OR PASSED SECURITY CODE DEF SLU * JSB IF.ER IF ERROR, DEF *+3 THEN PRINT MESSAGE DEF IERR DEF IGNOR AND IGNORE PURGE REQUEST SKP * * DO ANOTHER FILE * IGNOR LDA CUR GET CURRENuT NUMBER INA INCREMENT STA CUR AND SAVE CPA DIRLN IF FINISHED, JMP GTMOR THEN LOOK FOR MORE JMP COPY1 ELSE DO ANOTHER * * TEST FOR MORE FILES * GTMOR LDA MORE GET MORE FLAG SZA IF MORE, JMP COPY6 THEN GO READ IN ANOTHER HANDFUL * * FINISHED WITH FILES WITHOUT ANY ERRORS, * SET 1P TO 0 AND RETURN * CLA SET 1P PARAMETER TO ZERO STA G0..+41 JMP EXIT AND RETURN SKP * * ABNORMAL TERMINATION OF COPY (BY BR, INTERNAL ERROR, VERIFY * OR DESTINATION FULL), ERROR CODE IS IN A-REG, * SET 10G TO CURRENT FILE AND EXIT * ABEND LDB FNAME SET 10G PARAMETER TO CURRENT NAME STB G0..+41 * LDB FNAME+1 STB G0..+42 * LDB FNAME+2 STB G0..+43 JMP EREX SKP * * EXIT * EXIT CLA NO ERROR JMP EREX * ER21 LDA .21 ILLEGAL LU JMP EREX * ER51 LDA .51 BAD MASTER SECURITY CODE JMP EREX * ER56 LDA .56 BAD PARAMETER * EREX STA ER,I SAVE ERROR JMP CO..,I AND RETURN SKP * * STORAGE AREA * .1 DEC 1 .3 DEC 3 .7 DEC 7 .8 DEC 8 .11 DEC 11 .15 DEC 15 .19 DEC 19 .21 DEC 21 .22 DEC 22 .32 DEC 32 .51 DEC 51 .56 DEC 56 .60 DEC 60 * N2 DEC -2 N49 DEC -49 N6 DEC -6 N14 DEC -14 N33 DEC -33 * NB400 OCT -400 * .C ASC 1,C .D ASC 1,D .E ASC 1,E .P ASC 1,P .V ASC 1,V .SP ASC 1, * "BOOT ASC 3,BOOTEX DFALT ASC 3,------ * DIRMX DEC 42 MAX NUMBER OF ENTRIES (LESS 8) IN NAME ARRAY * ANAME DEF NAME AFNAM DEF FNAME * FNAME NOP - NOP ! LOCAL COPY NOP ! OF CURRENT FTYPE NOP ! FILE FEXTS NOP ! ENTRY FSIZE NOP ! FRECL NOP ! FSEC NOP - * COUNT NOP COUNTER CUR NOv0.*P COUNTER MORE NOP FLAG FOR MORE FILES IN DIRECTORY * CLRSW NOP CLEAR-SWITCH DMPSW NOP DUMP-SWITCH ELISW NOP ELIMINATE-SWITCH PURSW NOP PURGE-SWITCH VERSW NOP VERIFY-SWITCH MSECU NOP MSC STATUS FLAG * SLU NOP SOURCE LU DLU NOP DESTINATION LU * DIRLN NOP CURRENT LENGTH OF DIRECTORY IERR NOP ERROR RETURN CODE SZ NOP SIZE ARRAY FOR CREATE (AND DUMMY ERROR) NOP * FIRST BSS 3 FIRST FILE TO BE TRANSFERRED LAST BSS 3 LAST FILE TO BE TRANSFERRED * NAME BSS 400 DIRECTORY OF SELECTED FILES * A EQU 0 B EQU 1 * END EQU * * END 0  92070-18016 1941 S C0122 &CR..              H0101 c<SPL,L,O,M ! NAME: CR.. ! SOURCE: 92070-18016 ! RELOC: 92070-16016 ! PGMR: G.A.A. MOD. M.L.K. ! ! *************************************************************** ! * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * ! * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * ! * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* ! * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ! *************************************************************** ! ! NAME CR..(7) " 92070-1X016 REV.1941 790712" ! ! THIS MODULE OF THE RTE FMP ! ROUTINE F M G R CREATES EMPTY ! FILES, IT ALSO CREATS TYPE ! ZERO FILES. ! COMMANDS THIS ROUTINE HANDLES ! ARE: ! CR,NAMR ! WHERE ! NAMR IS A NAME REFERENCE ! WHICH INCLUDES ! SC SECURITY CODE ! CR CARTRIDGE ID ! TY TYPE ! SZ 1 SIZE (NO. OF BLOCKS) ! SZ 2 RECORD SIZE (ONLY IF TY=2) ! OR ! CR,NAMR,LU,RWOP,SPOP,EOFOP, SUBFUN OP ! WHERE : ! NAMR IS AS ABOVE EXCEPT ! TY=0 ! (IN THIS CASE CR IS FORCED TO-2) ! LU IS THE DEVICE LOGICAL UNIT ! RWOP IS THE READ WRITE OPTION ! I.E. "READ", "WRITE", "BOTH" ! SPOP IS THE SPACING OPTION ! I.E. " BSPACF", "FSPACE", "BOTH" ! EOF IS THE END OF FILE OPTION ! I.E. "EOF","LEADER","PAGE", ! NUMERIC SUB FUNCTION. ! SUBFUNOP IS THE READ/WRITE ! SUB FUNCTION ! (I.E. "BINARY","ASCII",NUMERIC ! SUBFUNCTION. ! ! EXTERNAL SUBROUTINES LET CLD.R BE SUBROUTINE,EXTERNAL,DIRECT LET CLOSE BE SUBROUTINE,EXTERNAL LET CREA. BE SUBROUTINE,EXTERNAL LET D.RIO BE SUBROUTINE,EXTERNAL LET EXEC BE SUBROUTINE,EXTERNAL LET LOCK. BE SUBROUTINE,EXTERNAL LET MSS. BE SUBROUTINE,EXTERNAL LET MVW BE SUBROUTINE,EXTERNAL LET NAM.. BE SUBROUTINE,EXTERNAL LET OPEN. BE SUBROUTINE,EXTERNAL LET RWNDF BE SUBROUTINE,EXTERNAL LET WRITF BE SUBROUTINE,EXTERNAL ! EXTERNAL VARIBLES LET .P1 BE INTEGER,EXTERNAL !D.RTR CALL PARAMETERS LET .P2 BE INTEGER,EXTERNAL LET .P3 BE INTEGER,EXTERNAL LET .P4 BE INTEGER,EXTERNAL LET .P5 BE INTEGER,EXTERNAL LET .P6 BE INTEGER,EXTERNAL LET .P7 BE INTEGER,EXTERNAL LET .R1 BE INTEGER,EXTERNAL !D.RTR RETURN PARAMETER LET .R2 BE INTEGER,EXTERNAL LET .R3 BE INTEGER,EXTERNAL LET D.SDR BE INTEGER,EXTERNAL LET O.BUF BE INTEGER,EXTERNAL LET N.OPL BE INTEGER,EXTERNAL ! INTERNAL SUBROUTINES LET CR.. BE SUBROUTINE ! INTERNAL VARIBLES LET NAM BE INTEGER !DEFINE TYPE 0 NAME BLOCK LET NAM1 BE INTEGER LET NAM2 BE INTEGER LET LUC BE INTEGER LET EF BE INTEGER LET SP BE INTEGER LET RW BE INTEGER LET SC(8) BE INTEGER ! INTERNAL CONSTANTS LET EOF BE CONSTANT (42517K) LET LE BE CONSTANT (46105K) LET PA BE CONSTANT (50101K) LET AS BE CONSTANT (40523K) LET BI BE CONSTANT (41111K) LET RE BE CONSTANT (51105K) LET WR BE CONSTANT (53522K) LET BO BE CONSTANT (41117K) LET BS BE CONSTANT (41123K) LET FS BE CONSTANT (43123K) ! LET READI BE CONSTANT (1) LET WRITI BE CONSTANT (2) LET A BE CONSTANT (0) LET B BE CONSTANT (1) ! CR..: SUBROUTINE(NO,LIS, ER) GLOBAL TY_@N.OPL+2 LIS21_[LIS20_[LIS17_[LIS16_[LIS13_[LIS9_[ \ x LIS5_[LIS1_@LIS+1]+4]+4]+4]+3]+1]+ \ 3]+1 ! ! CREATE FILE FOR TYPES 1 TO 32767 ! IF $TY \ THEN[ \ CREA.(O.BUF,$LIS1,N.OPL)?[ER_ -15];\CHECK FOR ERROR RETURN RETURN] ! AND RETURN ! ! CREATE TYPE 0 FILES ! DCB9_ [DCB4_ [DCB_ @O.BUF]+ 4]+ 5 ADD_128 BLK,RW,SP,EF_ 0 !INITIALIZE FLAGS ! FOR T_@NAM TO @NAM+14 DO $T_0 !CLEAR TYPE 0 NAME BLOCK ! IF $LIS5 >20000K THEN GO TO ILLU !IF LU IS ASCII, ILLEGAL IF $LIS5<1 THEN GO TO ILLU !IF LU NEGATIVE, ILLEGAL OPEN.(O.BUF,$LIS5,N.OPL,1) !GET DEFAULT EOF CLOSE(O.BUF) !NOW CLOSE LU ! ! ! SET R/W CODE ! IFNOT $LIS9 THEN GOTO MISPM !MISSING PARAMETER IF $LIS9 = RE THEN RW_100000K !SET READ CODE IF $LIS9 = WR THEN RW_1 !SET WRITE CODE IF $LIS9 = BO THEN RW_100001K !SET BOTH READ,WRITE CODES IFNOT RW THEN GOTO ILLPM !IF NO RW CODE, ILLEGAL ! ! SET SPACING CODE ! IFNOT $LIS13 THEN GOTO EOFCD !IF NO SP CODE, WORK ON EOF IF $LIS13= BS THEN SP_100000K !SET BACKSPACE CODE IF $LIS13= FS THEN SP_1 !SET FORWARD SPACE CODE IF $LIS13= BO THEN SP_100001K !SET BOTH CODES IFNOT SP THEN GOTO ILLPM !BAD SP CODE ! ! SET EOF CODE (DEFAULT -FMGR DEFAULT) ! EOFCD:IF $LIS17=EOF THEN EF_100K !EOF (MAG TAPE) IF $LIS17=PA THEN EF_1100K !PAGE EJECT IF $LIS17=LE THEN EF_1000K !PUNCH LEADER IF $LIS16<3 THEN EF_($LIS17 AND 37K)-<6 IFNOT $LIS16 THEN EF_$DCB4 !GET DEFAULT EOF B IFNOT EF THEN GO TO ILLPM !ILLEGAL PARAMETER ! ! SET SUB FUNCTION (DEFAULT 00=ASCII) ! IFNOT $LIS20 THEN GOTO SETUP IF $LIS20<3 THEN LUC_($LIS21 AND 37K)-<6 IF $LIS21 = BI THEN LUC_100K IF $LIS21=AS THEN GO TO SETUP IFNOT LUC THEN GO TO ILLPM !IF GIVEN AND NOT SET ERROR ! SETUP:LUC_ LUC+[T_($ LIS5 AND 77K)] EF_EF OR T SC(1)_N.OPL !SET SECURITY CODE NAM.. ($LIS1) AREG_$0 IF AREG THEN GO TO ILNAM ! IFNOT [LULK_ $(@N.OPL+1)] THEN[ \USE DISC INDICATED D.RIO(READI); \GET COPY OF MASTER DIR. IFNOT [LULK_-D.SDR] THEN[ \IF NOTHING MOUNTED ER_ -32; \ SET ERROR -32 RETURN]] ! AND EXIT ! LOCK.(LULK,3) ? [RETURN] !LOCK THE DISC ! .P1_1 !SET FUNCTION CODE .P2_LULK !SET THE NEG DISK LU .P3_$LIS1 !SET 1ST 2 CHAR OF NAME .P4_$(LIS1+1) !NEXT TWO .P5_$(LIS1+2) !LAST TWO .P6,.P7_ 0 !SET TYPE AND SIZE TO 0 CLD.R !CALL D.RTR FOR A DIR ENT IF [ER_.R1] THEN GOTO EXIT !EXIT IF ERROR TR_((.R2 AND 177700K) -> 6) !ISOLATE TRACK SECT_ .R3 AND 377K ! SECTOR AND OFFSET_ ((.R3 AND 177400K)->8) !OFFSET OF DIR ENTRY ! DSLU_ (.R2 AND 77K) + 7700K !CREATE DISC LU W/PROTECT EXEC(READI,DSLU,O.BUF,128,TR,SECT) !READ THE BLOCK IF $B # 128 THEN[ \ IF [T_LULK] < 0 THEN T_ -T; \ MSS.(2001,T+2000);  \ GOTO EXIT] ! ! OFFSET_@O.BUF+OFFSET+4 !SET ADDRESS OF LU WORD MVW(@LUC, OFFSET,12) EXEC(WRITI,DSLU,O.BUF,128,TR,SECT) !WRITE NEW BLOCK ! EXIT: LOCK.(LULK,5) !UNLOCK THE DISC O.BUF_0 !CLEAR FIRST WORD FOR CLOSE RETURN ! ILLU: DO[ ER_ 20 ; RETURN] !ILLEGAL LU MISPM:DO[ ER_ 55 ; RETURN] !MISSING PARAMETER ILLPM:DO[ ER_ 56 ; RETURN] !ILLEGAL PARAMETER ILNAM:DO[ ER_-15 ; RETURN] !ILLEGAL NAME ! END END END$ M  92070-18017 1941 S C0122 &DL..              H0101 ^=SPL,L,O,M ! NAME: DL.. ! SOURCE: 92070-18017 ! RELOC: 92070-16017 ! PGMR: G.A.A. MOD. M.L.K. ! ! *************************************************************** ! * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * ! * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * ! * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* ! * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ! *************************************************************** ! ! NAME DL..(7) " 92070-1X017 REV.1941 790712" ! ! ! RTE FMGR DIRECTORY LIST MODULE ! ! ENTERED ON COMMAND: ! ! DL,CR,MSC ! ! WHERE: ! CR IF GIVEN RESTRICTS THE LIST TO ! THE GIVEN CARTRIDE ! ! MSC IF GIVEN MUST BE THE MASTER ! SECURITY CODE AND CAUSES THE ! EXPANDED LIST FORMAT. (SEE BELOW) ! ! FORMATS: ! ! HEAD: ! !L1 CR=XXXXX !L2 ILAB=YYYYYY NXTR=XXXX NXSEC=XXX #SEC/TR=XXX ! LAST TR= XXXX #DR TR=XX ! ! ! ! WHERE: CR IS FOLLOWED BY THE CARTRIDGE ID NUMBER ! YYYYYY IS THE CARTRIDGE LABEL ! NXTR INDICATES THE NEXT TRACK ! NXSEC THE NEXT SECTOR ! #SEC/TR THE NO. OF SECTORS/TRACK ! LAST TR THE LAST TRACK AND ! #DR TR THE NUMBER OF DIRECTORY TRACKS ! ! STANDARD (MSC NOT SUPPLIED): !L3 NAME TYPE #BLKS/LU OPEN TO ! ! FOLLOWED BY THE DIRECTORY ENTRIES ! ! EXTENDED FORMAT (MSC SUPPLIED) ! NAME TYPE #BLKS/LU SCODE TRACK SEC OPEN TO ! ! ! IF THE LIST DEVICE IS A TTY (TYPE 00 OR 05) ! THE EXTENDED FORMAT MAY FORCE TWO LINES ! (IF 7 PROGRMS HAVE THE FILE OPEN) ! IF A PROGRAM HAS A FILE OPEN EXCLUSIVELY ! A - (MINUS SIGN) WILL FOLLOW THE PROGRAMS NAME ! IF AN ENTRY IS FOR AN EXTENT A + (PLUS SIGN) ! WILL BE PRINTED IN THE OPEN TO FIELD ! FOLLOWED BY THE EXTENT NURMBER ! ! ! EXTERNAL SUBROUTINES LET CONV. BE SUBROUTINE,EXTERNAL LET D.RIO BE SUBROUTINE,EXTERNAL LET DR.RD BE SUBROUTINE,EXTERNAL LET F.SET BE SUBROUTINE,EXTERNAL LET FTIME BE SUBROUTINE,EXTERNAL LET JER. BE SUBROUTINE,EXTERNAL,DIRECT LET LOCF BE SUBROUTINE,EXTERNAL LET OPEN. BE SUBROUTINE,EXTERNAL LET WRITF BE SUBROUTINE,EXTERNAL ! EXTERNAL FUNCTIONS LET F.TST BE FUNCTION,EXTERNAL LET FID. BE FUNCTION,EXTERNAL LET IFTTY BE FUNCTION,EXTERNAL LET MSC. BE FUNCTION,EXTERNAL ! EXTERNAL VARIBLES LET .E.R BE INTEGER,EXTERNAL LET %IDNM BE INTEGER,EXTERNAL LET %IDA BE INTEGER,EXTERNAL LET %IDSZ BE INTEGER,EXTERNAL LET BUF. BE INTEGER,EXTERNAL LET D.SDR BE INTEGER,EXTERNAL LET I.BUF BE INTEGER,EXTERNAL LET N.OPL BE INTEGER,EXTERNAL LET O.BUF BE INTEGER,EXTERNAL LET PK.DR BE INTEGER,EXTERNAL LET TMP. BE INTEGER,EXTERNAL ! INTERNAL SUBROUTINES LET SETAD BE SUBROUTINE LET SPACE BE SUBROUTINE LET WRIT BE SUBROUTINE ! INTERNAL VARIBLES LET HEAD.(4),H1(2),H1.5,H2(4),H3,H4(4),H5,H6(5),H7,H8(6),H9,\ H10(4),H11 BE INTEGER LET HEA.1(15),HEA.2(24) BE INTEGER INITIALIZE HEAD.,H1,H1.5,H2,H3,H4,H5,H6,H7,H8,H9,H10,H11 TO \ " ILAB=YYYYYY NXTR=XXXX NXSEC=XXX #SEC/TR=XXX LAST TR= XX"\ ,"XX #DR TR=XX" INITIALIZE HEA.1 TO " NAME TYPE #BLKS/LU OPEN TO" INITIALIZE HEA.2 TO " NAME TYPE #BLKS/LU SCODE TRACK SEC ",\ "OPEN TO " ! INTERNAL CONSTANTS LET BLANK BE CONSTANT (20040K) LET C.R BE CONSTANT (41522K)!CR LET EQ.BL BE CONSTANT (36440K)!= LET MIN.B BE CONSTANT (26440K)!- LET PLS.B BE CONSTANT (25440K)!+ LET MIN BE CONSTANT (  55K)! - ! ! DL..: SUBROUTINE(N,LIS,ER) GLOBAL FFLAG,EXEND_ 0 !ASSUME NO FILTER, SHORT LIST DL_ @LIS+1 !SET DISC SPEC IF LIS = 3 THEN[ \IF MASK OPTION FFLAG_ 1; \SET UP THE MASKS F.SET($DL); \AND THE NEW DL_ $(@N.OPL+1)], \CR REFERENCE ELSE \OTHERWISE DL_ $DL !USE AS A CR LUPT_@D.SDR !SET LU POINTER T_ @LIS+4 !CHECK IF $T \SECURITY THEN[ \CODE IFNOT [EXEND_MSC.($T)] \ THEN[ \ ER_ 51; \ERROR 51 RETURN]] !AND RETURN D.RIO(1) T_ @TMP.+3 !POINT TO SECURITY CODE OPEN.(O.BUF,TMP.,$T,0) !OPEN LIST LU LOCF(O.BUF,.E.R,T,T,T,T,T2) !GET LIST LU TTY_ [IF IFTTY(T2) THEN 1, ELSE 0] !SET TTY FLAG AGAIN:DIS_[IF DL THEN DL,ELSE -$LUPT] !GET DISC ID IFNOT DIS THEN RETURN !END OF DIRECTORY, DONE BLK,INDEX_0 TB_ [BF_ @BUF.]+1 ! $BF_ BLANK ! NXBLK:DR.RD(1,DIS,BLK)?[IFNOT BLK THEN[ \READ DIRECTORY BLK ER_-32; \IF BLK=0 THEN ASSUME RETURN], \NOT MOUNTED, RETURN ELSE[ \OTHERWISE ASSUME AT END GOTO CLEAN]] !OF DISC DIRECTORY NXFIL:SETAD?[INDEX_0;BLK_BLK+1;GO TO NXBLK] !SET ADDRESSES TO DIRECT. fP_TB ! IF INDEX+BLK-16 THEN GOTO FILEP !DISC HEADER? ! WRITE DISC HEADER $P_C.R !YES, SET $(P+1)_ EQ.BL !CR=XXXX CONV.($PK3,$(P+3),5) !IN BUFFER FOR I_ 4 TO 14 DO[ $(P+I)_ BLANK] !CLEAR BUFFER FTIME($(P+5)) !GET DATE AND TIME WRIT($BF,20) !WRITE ON LIST UNIT CONV.($PK9,H3,4) !INSERT NEXT TRACK CONV.($PK5,H5,3) !NEXT SECTOR $PK6_$PK6 AND 377K !ISOLATE #SECTORS/TRACK CONV.($PK6,H7,3) !#SECTORS/TRACK CONV.($PK7-$PK8-1,H9,4) !LAST TRACK CONV.(-$PK8,H11,2) !#DIRECTORY TRACKS FOR T6_@H1 TO @H1.5 DO[ $T6_$PK AND 77777K;\ PK_PK+1] WRIT(HEAD.,34) IF FID.(DIS) THEN GOTO CLEAN !CHECK FOR VALID SYS SPACE IF EXEND THEN WRIT(HEA.2,23) ,ELSE WRIT(HEA.1,14)!WRITE NORMAL OR !EXTENDED HEADER SPACE !SPACE T6_[T5_[T4_[T3_TB+2]+3]+3]+2 !SET POINTERS GO TO NXFIL !START LIST ! ! PROCESS FILES ! FILEP:IF $PK<0 THEN GO TO NXFIL !PURGED ENTRY IFNOT $PK THEN GOTO CLEAN !END OF DIRECTORY IF FFLAG THEN[ \IF MASK OPTION IFNOT F.TST(PK) THEN GOTO NXFIL] !REJECT IF NOT SET FOR T_TB TO TB+80 DO[$T_BLANK] !BLANK BUFFER FOR T_TB TO T3 DO [$T_$PK;PK_PK+1] !SET NAME CONV.($PK3,$T4,5) !SET TYPE IF $PK3 THEN GOTO NOT0 !IF TYPE ZERO CONV.($PK4 AND 77K,$T5,2)  !CONVERT LU GOTO EXCK !ELSE NOT0: CONV.($PK6/2,$T5,5) !CONVERT BLOCK SIZE ! EXCK: IFNOT EXEND THEN GO TO NAMST !NOT EXTENDED JUMP ! !SET NAME LIST ORIGIN ! T6_[PK_[PK6_[T2_[P_TB+10]+2]+3]+2]+2 IF $PK8 <0 THEN [$P_MIN.B ;$PK8_-$PK8] !IF SEC CODE NEG SET POS CONV.($PK8,$T2,5) !SET SECURITY CODE IFNOT $PK3 THEN GOTO NAMST !IF TYPE ZERO CONV.($PK4,$PK6,4) !SKIP TRACK CONV.($PK5 AND 377K,$PK,3) !AND SECTOR NAMST:T2_T6 !SET WORKING ADDRESS IF $PK3 THEN [IF [T_($PK5 -<8)AND 377K] THEN[\ $T6_PLS.B ;CONV.(T,$(T6+1),3);GO TO PRT] ] ! REPEAT 7 TIMES DO[ \CHECK ALL OPEN FLAGS IF $[PK8_ PK8+1] THEN[ \OPEN FLAG PRESENT? P_ ($PK8 AND 377K)-1; \YES, SO ISOLATE ID# IF P< $%IDNM THEN[ \LEGAL ID# SO PROCESS IT P_ $%IDA + (P*$%IDSZ) +12; \CALCULATE ID NAME ADRS FOR T_ P TO P+2 DO[ \MOVE ID NAME INTO $T2_ $T; \OUTPUT BUFFER T2_ T2+1]; \INCREMENT OUTPUT BUF PT T_ T2-1; \POINT TO LAST CHARACTER $T_($T AND 177400K)+[IF $PK8<0 THEN MIN, ELSE 40K]]]]!SET LAST !CHARACTER TO "-" IF !EXCLUSIVE OPEN, ELSE BLANK PRT: P_TB+81 !SET LINE LENGTH LNCK: IF $[P_P-1]=BLANK THEN GOTO LNCK !BACK UP OVER BLANKS L_P-TB+1 T_BF !SET BUFFER ADDRESS IF L>34 THEN[WRIT($BF,34);L_L-15;T_TB+14; \IF LINE > 68 CHAR. w$" FOR T6_T TO TB+33 DO $T6_BLANK] !WRITE IT ON 2 LINES WRIT($T,L) !WRITE THE LINE GOTO NXFIL ! CLEAN:IF $(@O.BUF+2) THEN[ \IF OUTPUT TYPE > 0 SPACE; \THEN WRITE 2 SPACES SPACE], \TO OUTPUT FILE ELSE[ \IF TYPE 0, THEN WRITF(O.BUF,.E.R,T,-1); \WRITE END OF FILE JER.] !AND CHECK FOR ERROR ! IFNOT DL THEN[LUPT_LUPT+4;GOTO AGAIN] ! RETURN END ! SETAD:SUBROUTINE FEXIT !SET PACK DIRECTORY ENTRY !ADDRESSES IF INDEX=128 THEN FRETURN !END BLOCK EXIT PK9_[PK8_[PK7_[PK6_[PK5_[PK4_[PK3_[PK_INDEX+@PK.DR]+\ 3]+1]+1]+1]+1]+1]+1 !SET THE ADDRESSES INDEX_INDEX+16 !STEP INDEX RETURN END ! ! WRIT: SUBROUTINE(BAD,NWORD) !WRITE N WORDS ON O.BUF !IF NOT A TTY TWO BLOCKS ARE WRITF(O.BUF,.E.R ,$(@BAD+TTY),NWORD+1-TTY) !ADDED JER. !AT THE RETURN !FRONT END ! SPACE:SUBROUTINE $TB_BLANK !SET A ONE WORD BLANK WRIT($BF,1) !WRITE IT RETURN !RETURN END ! END END$ $  92070-18018 1941 S C0122 &F.SET              H0101 XASMB,R,L,C * NAME: F.SET * SOURCE: 92070-18018 * RELOC: 92070-16018 * PGMR: G.A.A. * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * NAM F.SET,8 92070-1X018 REV.1941 790712 EXT .ENTR EXT N.OPL ENT F.SET FILTER SET UP ENTRY ENT F.TST FILTER TEST ENTRY * * FILTER FOR DL COMMAND * * THIS ROUTINE SET UP THE FILTER MASKS AND TESTS NAMES AGAINST THEM * NAME NOP F.SET NOP ONE PARAMETER THE FILE NAME JSB .ENTR GET PRAM DEF NAME JSB NAMF GET MASK AND TEST FOR FIRST WORD STA CPA1 SET THE VALUES STB MSK1 FOR LATER JSB NAMF GET SAME FOR WORD 2 STA CPA2 AND SAVE STB MSK2 JSB NAMF SAME FOR NAME 3 STA CPA3 STB MSK3 LDA DN.OP GET ADDRESS OF SUB PRAMS RAL,CLE,SLA,ERA CLEAR INDIRECT LDA A,I GET ADDRESS STA NAME SET ADDRESS JSB SUTY GET MASK FOR SC STA CPASC SAVE SC VALUE ONE CMA,SSA,INA SET MASK 2 CMA,INA USE SAME IF POSITIVE CODE PROVIDED STA CPASM STB MSKSC ISZ NAME STEP TO JSB SUTY GET MASK FOR TYPE STB MSKTY STA CPATY JSB SUTY STB MSKSZ ADA A DOUBLE SIZE TO GET SECTORS STA CPASZ JSB SUTY NOW GET RECORD LENGTH STB MSKRL STA CPARL SET VALUES JMP F.SET,I RETURN ALL MASKS SET UP * NAMF NOP NAME DON'T CARE SET UP LDA NAME,I GET VALUE AND C377 ISOLATE THE HIGH CHAR CPA "HM"  IS "-"? CLB,RSS YES SET MASK LDB C377 NO, SET KEEP MASK XOR NAME,I GET OTHER CHAR. CPA "LM" IS "-"? RSS YES LEAVE ZERO MASK ADB B377 NO SET THE LOW BITS LDA NAME,I GET THE VALUE AND B MASK IT ISZ NAME STEP FOR NEXT TIME JMP NAMF,I RETURN A=VALUE, B= MASK * SUTY NOP TYPE MASK SET ROUTINE LDA NAME,I GET CURRENT PRAM SZA,RSS SET MASK BASED ON IF SUPPLIED CLB,RSS CCB B IS MASK ,A IS VALUE ISZ NAME STEP TO NEXT ENTRY JMP SUTY,I RETURN * B377 OCT 377 C377 OCT 177400 CPA1 NOP CPA2 NOP CPA3 NOP CPASC NOP CPASM NOP CPATY NOP CPASZ NOP CPARL NOP * MSK1 NOP MSK2 NOP MSK3 NOP MSKSC NOP MSKTY NOP MSKSZ NOP MSKRL NOP "HM" OCT 26400 "LM" OCT 55 DN.OP DEF N.OPL * * DADD NOP F.TST NOP MASK TEST ROUTINE PRAM IS ADDRESS OF DIRECTORY ENTRY JSB .ENTR DEF DADD LDB DADD,I GET THE ADDRESS LDA B,I GET NAME1 AND MSK1 KEEP UN MASKED CHAR CPA CPA1 IF OK CONTINUE INB,RSS ELSE JMP NO TAKE NO EXIT * LDA B,I NAME 2 AND MSK2 CPA CPA2 INB,RSS JMP NO * LDA B,I AND MSK3 CPA CPA3 INB,RSS JMP NO * LDA B,I AND MSKTY TYPE TEST CPA CPATY INB,RSS JMP NO * INB INB STEP OVER DISC ADDRESS LDA B,I GET SIZE AND MSKSZ CPA CPASZ INB,RSS JMP NO * LDA B,I AND MSKRL CPA CPARL INB,RSS RECORD LENGTH OK? JMP NO * LDA B,I SECURITY CODE AND MSKSC CPA CPASC TWO CHANCES HERE RSS CPA CPASM OK? CCA,RSS YES NO CLA NO MATCH EXIT JMP F.TST,I RETURN * A EQ6 U 0 B EQU 1 END )  92070-18019 1941 S C0122 &DP..              H0101 d=SPL,L,O,M ! NAME: DP.. ! SOURCE: 92070-18019 ! RELOC: 92070-16019 ! PGMR: G.A.A. ! ! *************************************************************** ! * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * ! * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * ! * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* ! * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ! *************************************************************** ! NAME DP..(8) " 92070-1X019 REV.1941 790712" ! ! ! EXTERNAL SUBROUTINES LET EXEC BE SUBROUTINE,EXTERNAL ! EXTERNAL INTEGERS LET C.BUF BE INTEGER,EXTERNAL !INPUT BUFFER LET C.DLM BE INTEGER,EXTERNAL !FIRST DELIMITER LET CAM.O BE INTEGER,EXTERNAL !LOG LU LET ECH BE INTEGER,EXTERNAL !INPUT CHAR COUNT ! ! DP..: SUBROUTINE GLOBAL B377_377K;UBLK_20000K !SET BLANK AND MASK ASSEMBLE["CCB"; \REPLACE THE FIRST DELIM "ADB C.DLM";\ "CLE,ERB";\ "LDA 1,I";\ "AND B377";\ "IOR UBLK";\ "STA 1,I";\ "SEZ";\ "INB"] ADD_.B. CALL EXEC(2,CAM.O,$ADD,@C.BUF-ADD+ECH) RETURN END END END$   92070-18020 1941 S C0122 &IF..              H0101 QCSPL,L,O,M ! NAME: IF.. ! SOURCE: 92070-18020 ! RELOC: 92070-16020 ! PGMR: A.M.G. ! ! *************************************************************** ! * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * ! * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * ! * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* ! * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ! *************************************************************** ! NAME IF..(8) " 92070-1X020 REV.1941 790803" ! ! EXTERNAL SUBROUTINES LET IER. BE SUBROUTINE,EXTERNAL,DIRECT LET POSNT BE SUBROUTINE,EXTERNAL LET READF BE SUBROUTINE,EXTERNAL ! EXTERNAL INTEGERS LET .E.R BE INTEGER,EXTERNAL LET C.BUF BE REAL,EXTERNAL LET CAD. BE INTEGER,EXTERNAL LET CAM.I BE INTEGER,EXTERNAL LET INT. BE INTEGER,EXTERNAL LET NO.RD BE INTEGER,EXTERNAL ! INTERNAL VARIBLES LET ETAB BE CONSTANT (43K) LET LTAB BE CONSTANT (31K) LET GTAB BE CONSTANT (26K) LET FTR BE INTEGER (2) LET DIF,NCOM,P1,P2,MASK,RTABP,REL BE INTEGER LET RTAB BE INTEGER (7) INITIALIZE FTR TO "TR",0 INITIALIZE RTAB TO "LEGEGTLTNEEQ",0 ! ! IF..: SUBROUTINE(N,PLIST,ERR) GLOBAL LET N,PLIST,ERR BE INTEGER IF INT. THEN [ERR _ 10; RETURN] !IF TTY, REJECT REQ. NCOM _ [P2 _ [REL _ [P1 _ \SET UP POINTERS. @PLIST - 1] + 6] + 2] + 6 FOR I _ 1 TO 4 DO [ \COMPARE P1 AND P2. IF [DIF _ $[P1 _ P1 + 1] \ - $[P2 _ P2 + 1]] THEN \ GOTO COMP] COMP: DIF _ [IF DIF < 0 THEN \GET APPROPRIATE LTAB, ELSE [IF DIF THEN GTAB, \MASK WORD. ELSE ETAB]] RTABP _ @REL; MASK _ 1 CLOOP: IFNOT $[RTABP _ RTABP + 1] \MATCH RELATION THEN [ER@  R _ 56; RETURN] !USED IN COMMAND. IFNOT $RTABP = $REL THEN [ \ MASK _ MASK <- 1; GOTO CLOOP] IFNOT (MASK AND DIF) THEN RETURN IF $(NCOM-1) = 3 THEN[ERR_ 56; RETURN] !IF ASCII, ERROR IFNOT $NCOM THEN $NCOM _ 1 !DEFAULT SKIP CALL POSNT(CAM.I,.E.R,$NCOM) !SKIP INDICATED IF .E.R= -12 THEN [ \EOF OR SOF ERROR IF $NCOM<0 THEN RETURN; \ N,$(@PLIST+1)_0; \ CAD.,NO.RD _ 1 ; \FORCE XFER STACK BACK RETURN ] IER. RETURN END END END$ ѡ   92070-18021 2004 S C0122 &IN..              H0101 W=SPL,L,O,M ! NAME: IN.. ! SOURCE: 92070-18021 ! RELOC: 92070-16021 ! PGMR: G.A.A. ! MOD: M.L.K. ! ! *************************************************************** ! * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980. ALL RIGHTS * ! * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * ! * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* ! * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ! *************************************************************** ! ! NAME IN..(7) " 92070-1X021 REV.2004 800123" ! ! ! IN.. IS THE RTE FILE MANAGER ACTION ROUTINE ! FOR THE IN DIRECTIVE. ! ! THE IN DIRECTIVE HAS THE FORM: ! ! IN,MSC,CR,LABEL,ILAB,#FT,#DTR,#SEC/TR,BTL !PARAMETER 1 5 9 13 17 21 25 29 ! ! OR ! ! IN,MSC--NMSC ! ! W H E R E: ! ! MSC IS THE TWO CHARACTER MASTER SECURITY CODE ! ! CR IS EITHER THE CARTRIDGE LABEL(+) OR ITS ! LOGICAL UNIT(-) (MUST BE NUMERIC) ! ! LABEL IS THE NEW CARTRIDGE LABEL (MUST BE NUMERIC > 0). ! ! ILAB IS THE CARTRIDGE INFORMATION LABEL (MUST BE ASCII). ! ! #FT IS THE FIRST FMP TRACK. ! ! #DTR IS THE NUMBER OF DIRECTORY TRACK ! (NULL (SET TO 1) OR NUMERIC) ! ! #SEC/TR IS THE NUMBER OF 64 WORD SECTORS ! PER TRACK (NUMERIC ). ! ! BTL IS A BAD TRACK LIST - UP TO 6 BAD TRACK NUMBERS. ! ! NMSC IS A NEW MASTER SECURITY CODE. ! ! THE MASTER SECURITY CODE IS SET AT GENERATION ! AND MUST MATCH THEREAFTER. ! ! ! ! EXTERNAL SUBROUTINES LET CLD.R BE SUBROUTINE,EXTERNAL,DIRECT LET D.RIO BE SUBROUTINE,EXTERNAL LET DR.RD BE SUBROUTINE,EXTERNAL LET EXEC BE SUBROUTINE,EXTERNAL LET IMESS BE SUBROUTINE,EXTERNAL LET LOCK. BE SUBROUTINE,EXTERNAL LET MVW  BE SUBROUTINE,EXTERNAL LET MSS. BE SUBROUTINE,EXTERNAL LET NAM.. BE SUBROUTINE,EXTERNAL LET PR.IT BE SUBROUTINE,EXTERNAL LET READF BE SUBROUTINE,EXTERNAL LET REIO BE SUBROUTINE,EXTERNAL LET WRITF BE SUBROUTINE,EXTERNAL ! EXTERNAL FUNCTIONS LET FID. BE FUNCTION,EXTERNAL LET MSC. BE FUNCTION,EXTERNAL LET SY.TR BE FUNCTION,EXTERNAL LET TR.SC BE FUNCTION,EXTERNAL ! EXTERNAL LABELS LET FM.AB BE LABEL,EXTERNAL ! EXTERNAL INTEGERS LET .P1 BE INTEGER,EXTERNAL LET .P2 BE INTEGER,EXTERNAL LET .P3 BE INTEGER,EXTERNAL LET .P4 BE INTEGER,EXTERNAL LET .P5 BE INTEGER,EXTERNAL LET .P6 BE INTEGER,EXTERNAL LET .P7 BE INTEGER,EXTERNAL LET .R1 BE INTEGER,EXTERNAL LET BOOTX(512) BE INTEGER,EXTERNAL LET C.BUF BE INTEGER,EXTERNAL LET CAM.O BE INTEGER,EXTERNAL LET D.LB BE INTEGER,EXTERNAL LET D.LT BE INTEGER,EXTERNAL LET D.SDR BE INTEGER,EXTERNAL LET DS.DF BE INTEGER,EXTERNAL LET DS.F1 BE INTEGER,EXTERNAL LET DS.LU BE INTEGER,EXTERNAL LET O.BUF BE INTEGER,EXTERNAL LET P.6 BE INTEGER,EXTERNAL LET PK.DR BE INTEGER,EXTERNAL ! INTERNAL SUBROUTINES LET PTST BE SUBROUTINE ! LET LK0(3),LK3,LK4,LK5,LK6,LK7,LK8,TMP(2) \ BE INTEGER LET PRMPT(31) BE INTEGER INITIALIZE PRMPT TO "FMGR 060 DO YOU REALLY WANT TO PURGE THIS ",\ "DISC? (YES OR NO).",20137K ! INITIALIZE LK0 TO "BOOTEX" !FILE NAME INITIALIZE LK3 TO 1 !TYPE INITIALIZE LK4 TO 0 !STARTING TRACK INITIALIZE LK5 TO 0 !STARTING SECTOR INITIALIZE LK6 TO 8 !SIZE IN 64 WORD SECTORS INITIALIZE LK7 TO 0 !RECORD LENGTH INITIALIZE LK8 TO -32767 !SECURITY CODE ! CONSTANTS LET YE BE CONSTANT(54505K) LET NO BE CONSTANT(47117K) LET A BE CONSTANT(0 ) LET B BE CONSTANT(1 ) LET WRIT BE CONSTANT(2 ) LET READI BE CONSTANT(1 ) LET DMSIN BE CONSTANT(26455K) ! "--" ! ! ! IN..: SUBROUTINE(NCAM,PLIST,MSNO)GLOBAL LET NCAM,PLIST,MSNO BE INTEGER ! DDIR_@D.SDR PDIR2_[PDIR1_[PDIR_@PK.DR]+1]+1 PDIR9_[PDIR8_[PDIR7_[PDIR6_[PDIR5_[PDIR4_[PDIR3_\ PDIR2+1]+1]+1]+1]+1]+1]+1 LIS29_[LIS21_[LIS17_[LIS13_[LIST9_[LIST5_@PLIST+5]+4]+4]+4]+4]+8 MSNO_0 !INIT FOR NO ERRORS ! ! TEST FOR LEGAL PARAMETERS ! IF NCAM>3 THEN GO TO IN2 !IF MORE THAN 3 PARMS !CONTINUE AT IN2 IF NCAM#1 THEN GOTO NOPRM !IF < 3, MUST BE 1 ! ! MASTER SECURITY CODE (MSC) CHANGE ! IFNOT MSC.(PLIST) THEN GOTO SCER !SECURITY CODE LEGAL? IF $(@PLIST+2)#DMSIN THEN GOTO NOPRM !SECOND 2 CHARS ARE DASHES T2_[IF([T_$(@PLIST+3)]AND 77400K)=20000K THEN 0,ELSE T] ! ! GO PRIV AND SET NEW MASTER SECURITY CODE ! ASSEMBLE[" JSB .DRCT"; \ " EXT $XECM"; \ " DEF $XECM"; \ " STA 1 "; \SAVE ADDRESS IN B " LDA DEFT2"; \GET ADRS OF NEW CODE " EXT PMOVE"; \ " JSB PMOVE"; \ " OCT 1 "] ! RETURN !RETURN ! DEFT2: ASSEMBLE " DEF T2" ! ! ! LABER:DO[MSNO_53;RETURN] !LABEL ERROR  NOPRM:DO[MSNO_50;RETURN] !NOT ENOUGH PARMS, EXIT ! ! INITIALIZE DISC ! IN2: IFNOT MSC.(PLIST)THEN GOTO SCER !CHECK SECURITY ! ! CHECK LABEL PARAMETERS ! IN6: IFNOT -$LIST9<0 THEN GOTO LABER !LABEL MUST BE > 0 IF $(@PLIST+12)#3 THEN GOTO LABER !MUST BE ASCII NAM..($(LIS13 )) !MUST BE VALID NAMR AREG_$A IF AREG THEN GOTO LABER ! ! SET UP TO TEST THE REST OF THE PRAMS. ! FOR T_4 TO 13 DO[PTST($(@PLIST+T*4))] IFNOT$[T_(LIS21)]THEN $T_1 !MUST HAVE DRTRK ! ! READ BLOCK ZERO ! IN7: DR.RD(READI,$LIST5,0)?[MSNO_-32;RETURN] IF TR.SC($DS.LU,T,SECT) THEN[MSNO_ -18; RETURN] !GET SECTRTRACK T_@PLIST+25 !SET # OF SECTORS ADRS IFNOT $T THEN $T_ SECT !IF # SECTORS NOT GIVEN !USE SECTORS/TRACK LTR_$$@D.LT !SET CURRENT LAST TRACK NEW,TN_LTR-[FTR_$LIS17]+1 !SET 1ST TRK,TOTAL TRACKS IF TN<[ND_$LIS21] THEN GOTO BADPM IF ND>((TN-ND)>-3)+1 THEN GOTO BADPM !DISALLOW UNREASONABLE !NUMBER OF DIR TRACKS ! ! CHECK THE BAD TRACKS AND ARRANGE IN ASCENDING ORDER ! LIS49_[T1_LIS29]+20 FOR T_LIS29 TO LIS49 BY 4 DO[\ IF $T THEN[$T1_$T;T1_T1+1]] FOR T_T1 TO LIS29+6 DO[$T_0] !ZERO END OF LIST IN10: SWP,LAST_0 !INITIALIZE THE SORT FOR T_LIS29 TO T1-1 DO[ \SWAP LOOP IF $T LTR-ND THEN GOTO BTER IN13: T3_$$@DS.LU x !SET LU DLB_D.LB !SET THE LABEL ADDRESS IF $LIST9=$DLB THEN GO TO IN12 !IF SAME LABEL, SKIP ! ! CHECK FOR DUPLICATE LABEL ! DR.RD(READI,$LIST9,0)?[DR.RD(READI,$LIST5,0);GO TO IN12] MSNO_12 !DUPLICATE LABEL RETURN !ERROR RETURN ! ! WE MUST PROTECT TRACK AND SECTOR 0 ! IN12: .P1_ 3 !LOCK DISC, RET IF ERROR .P2_ $LIST5 CLD.R !CALL D.RTR FOR LOCK DS.DF_ 0 !SET FOR RE- READ DS.F1_ 0 ! OF DIRECTORY IF .R1 < 0 THEN[ \IF ERROR, BUT NOT IF .R1# -103 THEN [MSNO_.R1; RETURN]] !CORRUPT, RETURN IF [TX,NEW_FID. ($(LIST5))] THEN GOTO IN20!TEST FOR FILE SYSTEM ! ! A DIRECTORY EXISTS - IS THE NEW PRAM SET COMPATIBLE? ! ! CALCULATE # BLOCKS IN DIRECTORY ! IF $(PDIR+16) = 0 THEN[ NEW_ 1] !IF NO FILES, TREAT AS NEW ENDBL_ -$PDIR8*($PDIR6 AND 377K)/2 IF FTR>$(PDIR4 ) THEN GOTO IN15 IF $(PDIR9 )>(LTR-ND+1) THEN GOTO IN15 IF ND+$PDIR8 <0 THEN GO TO IN15 !IF FEWER DIREC TRACKS ASK IFNOT FTR THEN[ \IF INIT DOWN IF $PDIR4 THEN GOTO IN15] !TO TRK 0 THEN ASK ! ! FULL SPEED AHEAD! ! IN20: FLCR_16 !OFFSET VALUE FOR DIR CLEAR $PDIR_$(LIS13)+100000K !SET ID+SIGN BIT $(PDIR1)_ $(@PLIST+14) !SET LAST 2 WORDS OF ID $(PDIR2)_ $(@PLIST+15) $(PDIR3)_ $LIST9 !SET LABEL $(PDIR4)_ FTR !SET 1ST AVAILABLE TRACK IFNOT NEW THEN GOTO IN21 !DON'T SET NXTRK & SECT IF OLD L !SKIP SECT/TRK INFO AS DIRECTORY !AND FILES ARE ALREADY WRITTEN ! ! IF FIRST TRACK=0 THEN SET FIRST SECTOR (PDIR5) ! TO 8 AND MOVE BOOTX CODE INTO FIRST FILE ! $(PDIR9)_FTR !SET NEXT TRACK TO 1ST $(PDIR5)_0 !SET NEXT SECTOR IFNOT FTR THEN[ \IF TRACK = 0 MVW(@LK0,PDIR+16,9); \THEN MOVE DUMMY ENTRY IN FLCR_25; \AND SET TO CLEAR FOLLOWING ENTRY $(PDIR5)_ 8; \SET NEXT SECT PAST DUMMY EXEC(13,$DS.LU+10000K,T,T,BOOTX(7),8);\GET DISC PARAMETERS EXEC(2,$DS.LU+7700K,BOOTX,BOOTX(3),0,0);\WRITE INTO FILE IF .B. # BOOTX(3) THEN[ \CHECK XMISSION LOG MSS.(1,$DS.LU); \WRITE OUT DISC ERROR GOTO FM.AB]] !ABORT REQUEST $(PDIR6 )_$(@PLIST+25) !SET SECTORS/TRACK ! IN21: $(PDIR7 )_LTR-ND+1 !SET LOWEST DIR TRACK $(PDIR8 )_-ND !SET #DIR TRACKS ! ! SET BAD TRACKS ! FOR T_10 TO 15 DO $(PDIR+T)_$(@PLIST+T+19) ! ! IF NEW CLEAR REST OF DIRECTORY ! IF NEW THEN[FOR T_FLCR TO 127 DO $(PDIR+T)_0] BL_0 !SET THE BLOCK TO ZERO ! ! NOW WRITE IT OUT ! IN22: DR.RD(WRIT,$LIST5,BL)?[GO TO IN30] ! ! CLEAR BUFFER ! FOR T_0 TO 127 DO $(PDIR+T)_0 IFNOT NEW THEN [BL,NEW_ENDBL;GOTO IN22] !SET TO 0 ADDED DIR BL_BL+1 GOTO IN22 !ZERO THE NEXT BLOCK ! ! SET UP FOR CALL TO D.RTR TO UPDATE THE CRN ! IN30: IF $LIST9=$DLB THEN GO TO EXNOW !SKIP UPDATE OF CRN IF SAME .P1_7 !SET FUNCTION CODE .P2_$LIST9 O*($ !SET THE LABEL .P3_ $$@DS.LU !SET THE LU .P7_ -1 !UPDATE CRN ONLY CALL CLD.R !CALL D.RTR ! ! IF DUP CRN THEN ERROR 12 WILL RETURN ! IN THIS CASE--THE DISK WILL HAVE BEEN INITIALIZED ! BUT THE MASTER DIRECTORY WILL NOT HAVE IT'S CRN ! THAT WORD WILL BE ZERO MSNO_ .R1 !SET THE ERROR CODE EXNOW: LOCK.(-($DS.LU),5) !RELEASE THE LOCK RETURN !EXIT ! IN15: IF SY.TR($LIST5,O.BUF,128,T,T) THEN[ \IS SYSTEM USING DISC? MSS.(38); \YES, ERROR 38 PR.IT(O.BUF,128); \PRINT OFFENDING PROGRAMS GOTO EXNOW] !UNLOCK AND EXIT IN40: REIO(2,CAM.O,PRMPT,31) !SEND FMGR 060 PROMPT REIO(1,CAM.O OR 400K,C.BUF,36) !READ RESPONSE LN_ $1 !SET LENGTH RECIEVED IF LN<1 THEN GOTO IN40 IF C.BUF=YE THEN[NEW_1; GO TO IN20], ELSE [ \ IF C.BUF=NO THEN GOTO EXNOW ,\ ELSE GOTO IN40] ! BADPM:DO[MSNO_56;RETURN] MSPRM:DO[MSNO_55;RETURN] BTER: DO[MSNO_57;RETURN] SCER: MSNO_51 RETURN END PTST: SUBROUTINE(PTR) !PARAMETER TEST. 0 OR 1 OK IF PTR=3 THEN GOTO BADPM !MUST NOT BE ASCII IF $(@PTR+1)<0 THEN GOTO BADPM !ILLEGAL IF < 0 RETURN !OK, RETURN ! END END ! END$ l*  92070-18022 1941 S C0122 &IN.IT              H0101 vwSPL,L,O,M ! NAME: IN.IT ! SOURCE: 92070-18022 ! RELOC: 92070-16022 ! PGMR: M.L.K. ! ! *************************************************************** ! * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * ! * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * ! * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* ! * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ! *************************************************************** ! ! NAME IN.IT(7) " 92070-1X022 REV.1941 790906" ! ! THIS ROUTINE HANDLES THE INITIALIZATION OF THE ! INPUT, LOG AND LIST DEVICES FOR THE RTE-LC FMGR. ! THE SCHEDULING PARAMETERS ARE PASSED TO IN.IT THROUGH ! THE FIRST PARAMETERS OF PRAM. ! ! EXTERNAL SUBROUTINES LET .DFER BE SUBROUTINE,EXTERNAL,DIRECT!MOVE NAME LET EXEC BE SUBROUTINE,EXTERNAL LET OPEN. BE SUBROUTINE,EXTERNAL !FMGR OPEN ROUTINE ! EXTERNAL FUNCTIONS LET IFTTY BE FUNCTION,EXTERNAL !RETURNS INTERACTIVE FLAG LET LOGLU BE FUNCTION,EXTERNAL !RETURNS CONSOLE LU ! EXTERNAL VARIBLES LET C.BUF BE INTEGER,EXTERNAL !INPUT BUFFER LET CAM.I BE INTEGER,EXTERNAL !COMND INPUT DCB LET CAM.O BE INTEGER,EXTERNAL !LOG LU LET CAMS. BE INTEGER(61),EXTERNAL !XFER STACK LET ECH BE INTEGER,EXTERNAL !ECHO WORD COUNT LET G0.. BE INTEGER(48),EXTERNAL !GLOBAL ARRAY LET INT. BE INTEGER,EXTERNAL !INPUT INTERACTIVE FLAG LET NO.RD BE INTEGER,EXTERNAL !NO READ FLAG LET P.7 BE INTEGER,EXTERNAL !7P GLOBAL LET P.TR BE INTEGER,EXTERNAL !XFER STACK POINTER LET SVCOD BE INTEGER,EXTERNAL !FMGR SEVERITY CODE LET TMP. BE INTEGER,EXTERNAL !LIST NAMR ARRAY LET XPAND BE INTEGER,EXTERNAL  !ERROR EXPANSION FLG ! INTERNAL CONSTANTS LET BLANK BE CONSTANT (20040K) !ASCII LET CONLU BE INTEGER !CONSOLE LU ! ! IN.IT:SUBROUTINE(PCNT,PRAM,ER) GLOBAL LET ER BE INTEGER LET PCNT BE INTEGER LET PRAM(64) BE INTEGER ! CONLU _ LOGLU(D) !GET CONSOLE LU ! ! SET UP INPUT DEVICE AND LOG DEVICE ! IF PRAM(1) >= 20000K \IF INPUT IS ASCII THEN[ \ IFNOT PRAM(2) THEN PRAM(2)_BLANK; \IF 3 & 4 CHARS=0, BLANK IFNOT PRAM(3) THEN PRAM(3)_BLANK; \IF 4 & 5 CHARS=0, BLANK INT._ 0; \SET INPUT INTERACTIVE TO FALSE G0..(1)_ 3; \SET 0G TYPE TO ASCII CALL .DFER(G0..(2),PRAM(1)); \COPY INPUT TO 0G CAMS.(2)_ CONLU; \INIT XFER STACK P.TR_ @CAMS. + 6; \POINT TO NEXT ENTRY CAM.O_ CONLU; \SET LOG TO CONSOLE TMP._ PRAM(5) ], \SAVE LIST LU ELSE[ \IF INPUT IS LU IFNOT PRAM(1) THEN PRAM(1)_ CONLU; \DEFAULT INPUT TO CONSOLE INT._ IFTTY(PRAM(1)); \SET INTERACTIVE FLAG G0..(1)_ 1; \SET 0G TYPE TO INTEGER G0..(2)_ PRAM(1); \SET INPUT LU TO OG CAM.O_ PRAM(2); \SET LOG DEVICE TMP._ PRAM(3); \SAVE THE LIST LU PRAM(2),PRAM(3)_ 0] !CLEAR FOR OPEN. CALL OPEN.(CAM.I,PRAM(1),0.0,411K) !OPEN INPUT DEVICE ! ! CHECK LOG DEVICE ! IFNOT CAM.O THEN[ \IF LOG=0 CAM.O_ CONLU], \ THEN USE THE CONSOLE ELSE[ { \IF LOG#0 IFNOT IFTTY(CAM.O) THEN[ \IS IT INTERACTIVE? IF INT. \NO, IS THE INPUT INTERACTIVE? THEN CAM.O_ PRAM(1), \YES, USE IT ELSE CAM.O_ CONLU]] !NO, USE CONSOLE ! ! CHECK LIST DEVICE ! IFNOT TMP. THEN TMP._ CONLU !DEFAULT TO CONSOLE ! ! SET SEVERITY CODES ! SVCOD_ PRAM(4) !GET PASSED SEVERITY CODE IF SVCOD =< 0 THEN SVCOD_ 1000 !SET WITHIN RANGE XPAND_ SVCOD/1000 !SET ERR XPANSION FLAG SVCOD_ .B. !SET SV CODE IF SVCOD > 4 THEN SVCOD_ 4 !SET WITHIN RANGE P.7_ SVCOD + 1000*XPAND !SET GLOBAL 7P TO SEVERITY CODE ! ! CHECK FOR RUN STRING ! CALL EXEC(14,1,C.BUF,40) !CHECK FOR PASSED STRING ECH_ .B. !SAVE COUNT FOR ECHO IF ECH \IF STRING PASSED THEN[ \ IF (C.BUF AND 177400K) = 35000K \AND IF IT BEGINS WITH ":" THEN[ \ C.BUF_ C.BUF - 15000K; \CLEAR THE COLON NO.RD_ -1]] !SET NO READ FLAG RETURN END END END$ ho  92070-18023 1941 S C0122 &LI..              H0101 WFSPL,L,O,M ! NAME: LI.. ! SOURCE: 92070-18023 ! RELOC: 92070-16023 ! PGMR: G.A.A. ! MOD: M.L.K. ! ! *************************************************************** ! * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * ! * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * ! * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* ! * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ! *************************************************************** ! ! NAME LI..(7) " 92070-1X023 REV.1941 790712" ! ! ! LI.. IS THE RTE FMGR FILE LIST MODULE ! IT IS ENTERED ON COMMAND ! ! LI,NAMR,TY,FREC,LREC ! -- ---- ---- ! ! WHERE: ! ! ! NAMR IS THE NAME REFERENCE INCLUDING ! SECURITY CODE AND DISC ID ! ! TY IS THE LISTING TYPE AND IS ASCII: ! ! S OR A OR NULL SOURCE WITH LINE NUMBERS ! B BINARY DUMP ! D DIRECTORY HEAD ONLY ! ! FREC FIRST RECORD TO PRINT ! ! LREC LAST RECORD TO PRINT ! ! ! EACH LISTING WILL BE PROCEEDED BY THE HEAD: ! ! NAMEL T=XXXXX IS ON PK XXXXX USING XXXX BLKS R=XXXX ! XX:XX AM MON., XX DEC., 1978 ! ! ! ! ! ! S FORMAT IS A BLANK FOLLOWED BY 4 DIGIT ! LINE NUMBER FOLLOWED BY TWO BLANKS FOLLOWED ! BY THE RECORD. ! ! B FORMAT IS : ! A)THE RECORD HEAD: REC# XXXXX ! B)N LINES FORMATED AS FOLLOWS ! 8 5-DIGIT OCTAL NUMBERS SEPERATED BY BLANKS ! AND FOLLOWED BY A "*" FOLLOWED BY THE ! 16 ASCII CHARACTERS THE DIGITS REP. ! NON-PRINTING CHARACTERS WILL BE FILLED ! WITH BLANKS ! ! D FORMAT IS THE HEAD ONLY ! ! ! EXTERNAL SUBROUTINES LET CONV. BE SUBROUTINE,EXTERNAL LET DR.RD BE SUBROUTINE,EXTERNAL LET EXEC BE SUBROUTINE,EXTERNALN LET FTIME BE SUBROUTINE,EXTERNAL LET JER. BE SUBROUTINE,EXTERNAL,DIRECT LET LOCF BE SUBROUTINE,EXTERNAL LET OPEN. BE SUBROUTINE,EXTERNAL LET READF BE SUBROUTINE,EXTERNAL LET WRITF BE SUBROUTINE,EXTERNAL ! EXTERNAL FUNCTIONS LET IFTTY BE FUNCTION,EXTERNAL ! EXTERNAL VARIBLES LET .E.R BE INTEGER,EXTERNAL LET BUF. BE INTEGER,EXTERNAL LET D.LB BE INTEGER,EXTERNAL LET I.BUF BE INTEGER,EXTERNAL LET N.OPL BE INTEGER,EXTERNAL LET O.BUF BE INTEGER,EXTERNAL LET TMP. BE INTEGER,EXTERNAL ! INTERNAL SUBROUTINES LET SETA BE SUBROUTINE,DIRECT LET SPACE BE SUBROUTINE,DIRECT LET WRIT BE SUBROUTINE,DIRECT ! INTERNAL CONSTANTS ! HL LET BL.T BE CONSTANT (20124K)! T LET EQ.BL BE CONSTANT (36440K)!= LET BL.I BE CONSTANT (20111K)! I LET S.BL BE CONSTANT (51440K)!S LET O.N BE CONSTANT (47516K)!ON LET BL.C BE CONSTANT (20103K)! C LET R.BL BE CONSTANT (51040K)!R LET BL.L BE CONSTANT (20114K)! L LET U.BL BE CONSTANT (52440K)!U LET BL.U BE CONSTANT (20125K)! U LET S.I BE CONSTANT (51511K)!SI LET N.G BE CONSTANT (47107K)!NG LET BL.B BE CONSTANT (20102K)! B LET L.K BE CONSTANT (46113K)!LK LET R.EQ BE CONSTANT (51075K)!R= LET A.BL BE CONSTANT (40440K)!A LET B.BL BE CONSTANT (41040K)!B LET D.BL BE CONSTANT (42040K)!D LET R.E BE CONSTANT (51105K)!RE LET C.NO BE CONSTANT (41443K)!C# LET DST BE CONSTANT (25052K)!** ! INTERNAL BUFFERS LET LSTBF(2) BE INTEGER LET LNNO BE INTEGER LET BLWD BE INTEGER LET LBF(128) BE INTEGER ! ! LI..: SUBROUTINE(NOC,LIS ,ER) GLOBAL ! IFNOT zNOC THEN[ ER_ 50 ;RETURN] !NO PARMS, EXIT OPFL_411K !SET DFLT OPEN OPTION NUL_0 !PRESET NULL PRAM FLAG LR_ $([FR_[TYPF_[LIS1_ @LIS+1]+4]+4]+4) ! TYPF_($TYPF AND 177400K)+40K IF [FR_$FR] THEN[ \SET FIRST AND LAST REC IFNOT LR THEN LR_ FR] !DEFAULTS IF TYPF=A.BL THEN GOTO STYP !CHECK FOR IF TYPF=40K THEN[NUL_1;GO TO STYP] !LEGAL IF TYPF=D.BL THEN GOTO TYPOK !OPTIONS IF TYPF=B.BL THEN[OPFL_311K;GO TO TYPOK] !NULL A,S,B,D IF TYPF#S.BL THEN [ER_56;RETURN] !NO, RETURN 56 ! STYP: TYPF_S.BL !FORCE NULL,ATOS TYPOK:OPLS_ @TMP.+3 !GET LIST UNIT OP LIST OPEN.(I.BUF,TMP.,$OPLS, 0) !OPEN LIST FILE OPEN.(O.BUF,$LIS1,N.OPL,OPFL) !OPEN FILE TO BE LISTED ! LOCF(O.BUF,.E.R ,LP,LP,LP,NSEC,FLU,FTYP,RECS) IFNOT NUL THEN GOTO OK !IF NULL, CHOSE RITE OPTION IFNOT FTYP THEN GOTO OK !TYPE ZERO DFLT IS ASC IF FTYP=3 THEN GOTO OK !SAME FOR TYPE 3 IF FTYP=4 THEN GOTO OK !SAME FOR TYPE 4 CTYP: TYPF_B.BL !ELSE USE BINARY FORMAT ! OK: LOCF(I.BUF,.E.R ,LP,LP,LP,LP,LLU) !GET LIST LU EXEC(13,LLU,DVT6) !GET LIST LU TYPE CODE P36_[P3_@LIS +4]+33 !SET UP LIST ADDRESSES LP_1 !SET LINE PRINTER FLAG IF (DVT6 AND 37400K)<5000K THEN LP_0 TTY_IFTTY(LLU) !INTERACTIVE DEVICE? FOR T_ P3 TO P36 DO[$T_20040K] !BLANK THE BUFFER P_P3-1 SETA(BL.T) !SET BLANK T SETA(EQ.BL) !SET = BLANK P_P+2 CONV.(FTYP,$P,5) !SET TYPE SETA(BL.I) !SET BLANK I SETA(S.BL) !SET S BLANK SETA (O.N) !SET ON IF FTYP THEN[SETA(BL.C);SETA(R.BL);DR.RD(1,-FLU,\ 0);T_$$@D.LB;N_5],\ ELSE[SETA(BL.L);SETA(U.BL);T_FLU;N_2] P_P + N/2 CONV.(T,$P,N) IFNOT FTYP THEN[N_13;GO TO WRHD] SETA(BL.U) !SET USING SETA(S.I ) SETA(N.G ) P_P+3 ! CONV.(NSEC/2,$P,5) ! SETA(BL.B) !SET BLKS R= SETA(L.K) SETA(S.BL) SETA(R.EQ) ! P_P+2 ! CONV.(RECS,$P,4) ! N_27 ! WRHD: TB_[BF_[IF TYPF=S.BL THEN @LSTBF,ELSE @BUF.]]+1 $BF_20040K !BLANK FIRST WORD P_LIS1 FOR T_TB TO TB+N DO [$T_$P;P_P+1] !MOVE LINE IF LIS #3 THEN[$([P_TB+1]+1)_DST; \IF FAKE FILE, REPLACE NAME $P_DST;$TB_DST] !WITH "******" WRIT !WRITE THE HEAD ! ! WRITE OUT DATE AND TIME ! P_ BF !RESET BUFFER POINTER FOR I_ 1 TO 4 DO[ SETA(20040K)] !SPACE OVER FTIME($[P_ P+1]) !GET DATE AND TIME N_ 19 !SET LINE LENGTH WRIT !WRITE OUT LINE ! IF TYPF=D.BL THEN GOTO EOF !DONE IF HEAD ONLY SPACE !SPACE A LINE IF FTYP=6 THEN $(@O.BUF+2)_1 !FORCE TYPE 6 TO 1 RC_1 NEXT: P_BF !INITIALIZE BUFFER POINTER SETA(R.E) !SET UP SETA(C.NO) !REC# XXXXX B SETA(20040K) P_P+2 CONV.(RC,$P,5) !SET NUMBER READF(O.BUF,.E.R ,LBF,128,L) !READ RECORD IF .E.R = -12 THEN GO TO EOF !IF EOF, GO EXIT JER. !CHECK FOR ERRORS IF L <0 THEN GOTO EOF !SOFT EOF? IF RC < FR THEN GOTO NEXTR !SKIP TO FIRST REC N_L+3 IF TYPF=S.BL THEN[CONV.(RC,LNNO,4);BLWD_20040K;\ L_0;GO TO WRTIT] !JUST LISTING, GO WRIT ! SPACE !SPACE A LINE N_5 !WRITE THE RECORD NUMBER WRIT ! SPACE !SPACE A LINE ! F_@LBF !SET BUFFER POINTER NEXTL:IFNOT L THEN[ \IF NO DATA GET NEXT NEXTR: RC_ RC+1; \INCREMENT REC COUNT IF LR THEN[ IF RC > LR THEN GOTO EOF]; \END OF RANGE? GOTO NEXT] !DO NEXT P_[ST_[WP,T_TB]+27]+1 !INITIALIZE POINTERS REPEAT 36 TIMES DO[ $T_20040K; T_T+1] UP_ -1 !SET UPPER FLAG TRUE REPEAT 8 TIMES DO THRU PTSTP IF[T2_ [T_$F]AND 77400K]>57400K THEN GOTO BLANK IF T2>17777K THEN GOTO OKUP ! BLANK:T_ (T AND 177K)+20000K ! OKUP: IF [T2_($F AND 177K)]<140K THEN[IF T2> 37K THEN\ GO TO OKLOW] ! T_ (T AND 77400K) +40K ! OKLOW:DO[ $P_T AND 77577K;P_P+1] ! T2_ [T_$F-<1] AND 1 ! $WP_[IF UP THEN (T2-<8)+([T_T-<3] AND 7)+30060K,\ ELSE T2 + 20060K] ! REPEAT 2 TIMES DO[ \ $[WP_WP+1]_(([T_T-<3] AND 7)-<8)+\ ([T_T-<3] AND 7)+ 30060K] ! IF UP THEN GOTO PTSTP ! $[WP_WP+1]_(((T-<3) AND 7)-<8)+30040K ! PTSTP:DO[W]$"P_WP+1;UP_NOT UP;F_F+1;IFNOT [L_L-1] THEN\ GO TO PREPR] ! ! PREPR:IF $[P_P-1]=20040K THEN GO TO PREPR !FIND LAST !NON BLANK N_ P-TB+1 !PRINT LENGTH ! $ST_ $ST +12K !SET THE STAR SEPARATOR ! WRTIT:WRIT !TRANSMIT THE LINE ! GOTO NEXTL !GO DO NEXT LINE ! EOF: WRITF(I.BUF,.E.R ,$BF,-1) !WRITE EOF JER. ! RETURN END ! ! SETA: SUBROUTINE(PRA)DIRECT !STEP P AND SET PRA IN P INDIRECT $[P_P+1]_PRA RETURN END ! ! WRIT: SUBROUTINE DIRECT!WRITE ON I.BUF BUFFER AT BF IF LP !OR TB IF NOT LP WITH LENGTH N+LP !IF TTY -LIMIT LENGTH TO 72. IF TTY THEN[IF N>36 THEN N_36] WRITF(I.BUF,.E.R ,$(TB-LP),N+LP) JER. RETURN END ! ! SPACE:SUBROUTINE DIRECT !SPACE THE LIST DEVICE N_1 !SET LENGTH TO ONE WORD DO[T_$TB;$TB_ 20040K]!SET BLANK IN BUFFER WRIT !WRIT BLANK LINE $TB_T !RESTORE OLD CONTENTS RETURN !RETURN END END END$ ]$  92070-18024 1941 S C0122 &F.UTM              H0101 cSPL,L,O,M ! NAME: F.UTM ! SOURCE: 92070-18024 ! RELOC: 92070-16024 ! PGMR: G.A.A. ! ! *************************************************************** ! * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * ! * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * ! * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* ! * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ! *************************************************************** ! NAME F.UTM(8) " 92070-1X024 REV.1941 790712" ! ! EXTERNAL SUBROUTINES LET CONV. BE SUBROUTINE,EXTERNAL LET ECHO BE SUBROUTINE,EXTERNAL LET EXEC BE SUBROUTINE,EXTERNAL LET OPEN. BE SUBROUTINE,EXTERNAL ! EXTERNAL FUNCTIONS LET IFTTY BE FUNCTION,EXTERNAL ! EXTERNAL VARIBLES LET .E.R BE INTEGER,EXTERNAL LET CAM.O BE INTEGER,EXTERNAL LET G0.. BE INTEGER,EXTERNAL LET I.BUF BE INTEGER,EXTERNAL LET N.OPL BE INTEGER,EXTERNAL LET P.6 BE INTEGER,EXTERNAL LET P.7 BE INTEGER,EXTERNAL LET SVCOD BE INTEGER,EXTERNAL LET TMP. BE INTEGER,EXTERNAL LET XPAND BE INTEGER,EXTERNAL ! LET LLMSG(6) BE INTEGER LET LOMSG(4) BE INTEGER LET SVMSG(5) BE INTEGER ! INITIALIZE LLMSG TO " LL= " INITIALIZE LOMSG TO " LO= " INITIALIZE SVMSG TO " SV= " ! ! LL..: SUBROUTINE(N14,LIS14,ER14)GLOBAL !LIST CHANGE SUBROUTINE RC_@LIS14+1 !SET LIST ADDRESSES IFNOT N14 THEN[ \NO PARAMETERS IF TMP. < 20000K THEN[ \IF LIST A LU CONV.(TMP.,LLMSG(4),2); \CONVERT LU AND OCNT_ 4], \SET MESSAGE SIZE ELSE[ \ LLMSG(4)_ TMP.; \IFK LIST ASCII, LLMSG(5)_ $([T_ @TMP.+1]); \PUT LIST FILE NAME LLMSG(6)_ $(T+1); \INTO LIST MESSAGE OCNT_ 6]; \SET OUTPUT LENGTH EXEC(2,CAM.O,LLMSG,OCNT); \PRINT MESSAGE TO LOG RETURN] !RETURN OPEN.(I.BUF,$RC,N.OPL,410K) !ATTEMPT OPEN T2_@TMP. !SET LIST DEF ADDRESS FOR T_RC TO RC+2 DO[ \ $T2_$T; \ T2 _ T2+1] ! $T2_N.OPL ! $(T2+1)_ -(I.BUF AND 77K) ! RETURN ! END ! ! LO..:SUBROUTINE(N13,LI13,ER13) GLOBAL !NEW LOG UNIT SUBROUTINE IFNOT N13 THEN[ \NO PARAMETERS CONV.(CAM.O,LOMSG(4),2); \CONVERT LOG LU EXEC (2,CAM.O,LOMSG,4); \OUTPUT TO LOG LU RETURN] !RETURN IF IFTTY([T_$(@LI13+1)]) THEN \ CAM.O_T, \ ELSE ER13_56 ! RETURN END ! SV..: SUBROUTINE(N15,LI15,ER15) GLOBAL RC_[T2_[T_@LI15+1]+4]+4 IFNOT N15 THEN[ \NO PARAMETERS T_ SVCOD + 1000*XPAND; \CREATE USER'S CODE IF T < 1000 THEN[ \IF RANGE 0 - 4 CONV.(T,SVMSG(4),1); \PUT INTO MESSAGE OCNT_ 4], \SET OUTPUT COUNT ELSE[ \IF RANGE 1000 - 1004 CONV.(T,SVMSG(5),4); \THEN CONVERT OCNT_ 5]; \SET OUTPUT COUNT EXEC(2,CAM.O,SVMSG,OCNT); 9 \OUTPUT TO LOG LU RETURN] !RETURN IF $RC # "IH" THEN [IFNOT P.7 THEN \ECHO IF CONDITIONS ARE RIGHT ECHO] IF $T2 THEN[ \IF A GLOBAL PROVIDED SAVE THE IF $T2 > 0 THEN[ \MAKE SURE IT IS LEGAL IF $T2 < 10 THEN[ \1-9 ONLY T2_@G0..+($T2 -< 2); \SET BASE ADDRESS $T2_1;T2_T2+1; \SET THE TYPE $T2_P.7;T2_T2+1; \THE VALUE $[REAL]T2_0.0; \CLEAN THE OTHER WORDS GO TO SETSV \AND SKIP ERROR ] \ ]; \ ER15_56;RETURN \ILL NUMBER EXIT ] SETSV:IF [XPAND_ $T/1000] THEN P.6_ 0 !SET ERROR EXPANSION FLAG T_ .B. !SAVE SEVERITY CODE IF T< 0 THEN T_ 0 !IF SV NEG, SET TO 0 IF T> 4 THEN T_ 4 !IF > 4, SET TO 4 P.7_ T + 1000*XPAND !SET GLOBAL P7 TO SEVERITY SVCOD_ T !SET INTERNAL SEVERITY RETURN END ! END END$   92070-18025 1941 S C0122 &MCDC.              H0101 hkASMB,R,L,C * NAME: MCDC. * SOURCE: 92070-18025 * RELOC: 92070-16025 * PGMR: G.L.M. * MOD: M.L.K. * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * * NAM MCDC.,7 92070-1X025 REV.1941 790906 * * ENT MC..,DC.. EXT EXEC,.ENTR,CLD.R,.P1,.P2,.P3,.P4,.P5 EXT DS.F1,DS.DF,.P6,.P7,.R1,SY.TR,PR.IT EXT GTOPN,O.BUF,MSS.,.R2,TR.SC * * MOUNT/DISMOUNT SUBROUTINE * * N NOP LIS NOP ER NOP MC.. NOP JSB .ENTR DEF N ISZ LIS LDA LIS,I FETCH FIRST PARAMETER SZA,RSS MUST NOT BE ZERO JMP EX50 ELSE, RETURN ERROR=50 * SSA CMA,INA ALLOW NEG NUMBERS STA LU IOR B7700 ADD IN DISC PROTECT BITS STA PLU SAVE FOR DISC EXEC CALLS * LDA LU GET LU AGAIN SSA IS IT POSITIVE? JMP BADLU NO, BAD LU ADA N64 IS IT LESS THAN 64? SSA,RSS YES, GOOD LU, PROCESS IT JMP BADLU NO, ILLEGAL LU * LDA LIS ADA .4 ADVANCE TO LAST TRACK PARAMETER STA LSTRK SAVE IT * MOUNT CARTRIDGE SUBROUTINE * THIS ROUTINE PERFORMS THE FOLLOWING: * -CHECK DRIVER TYPE (MUST BE DISC) * -DETERMINE MAX LAST TRACK * -DOES VALIDITY CHECK ON DISK * PASSES CONTROL TO DIRECTORY MANAGER (D.RTR) WHO THEN: * -FINDS DIRECTORY SPACE * -CHECKS FOR DUPLICATE DRN OR LU * -WRITES DIRECTORY ENTRY IN MEMORY RESIDENT LIBRARY (%TBLFP) * JSB EXEC GET STATUS ON LU DEF STRTN TO DETERMINE DRIVER TYPE DEF STCOD (10001E5B) DEF LU DEF DVT6 CONTAINS DEVICE TYPE DEF IFT6 STRTN JMP BADLU IF LU IS UNDEFINED, EXIT LDA DVT6 GET DEVICE TYPE ALF,ALF POSITION TO LOW BITS AND B77 ISOLATE DEVICE TYPE ADA BN30 IS IT LESS SSA THAN 30 (DEVICE TYPES OCTAL)? JMP BADLU NOT DISC! ADA N8 IS IT GREATER SSA,RSS THAN 37? JMP BADLU NOT DISC EITHER * JSB TR.SC CALL FOR NUMBER OF TRACKS DEF *+4 DEF LU DISC LU DEF TRACK NUMBER OF TRACKS DEF IFT6 DUMMY SZA LEGAL LU? JMP BADLU NO, EXIT LDB TRACK GET NUMBER OF TRACKS ADB N1 SUBTRACT 1 FOR LAST TRACK ADRS * * IF LAST TRACK NOT GIVEN, USE MAX LAST TRACK * LDA LSTRK,I PASSED LAST TRACK SZA,RSS IF ZERO JMP LAST USE MAX LAST TRACK * * LAST TRACK CANNOT BE > MAX LAST TRACK * CMA,INA SET PASSED LAST TRACK NEGATIVE ADB A SUBTRACT FROM MAX LDA .56 PRESET WITH "BAD PARAMETER" ERROR CODE SSB IS PASSED VALUE GREATER? JMP EXMC YES, LAST TRACK IS > MAX, ERROR LDB LSTRK,I GET PASSED VALUE AGAIN LAST LDA .55 PRESET WITH "MISSING PARAMETER" ERROR CODE SZB,RSS PASSED VALUE ZERO? JMP EXMC YES, ERROR LDA N1024 CHECK NUMBER OF TRACKS > 1024 ADA B SSA,RSS TOO LARGE? JMP EX33 YES, ERROR 33 STB TRACK VALUE OK, USE IT * * SET UP DIRECTORY MANAGER CALL TO MOUNT AND LOCK * STUP LDA .7 P1=7 STA .P1 LDA LU P2=-LU STA .P3 CMA,INA P3=LU STA .P2 LDA TRACK P4=LAST TRACK STA .P4 JSB RD16 GO READ CART HEAD FOR CRN LDA DBF3 P5=DISC REFERENCE STA .P5 JSB GTOPN GO GET OPEN FLAG DEF *+1 STA .P6 pSET PARAMETER 6 LDB N2 SUBFUNCTION CODE = MOUNT STB .P7 SET PARAMETER 7 JSB CLD.R GOTO DIRECTORY MANAGER LDA .R1 GET ERROR RETURN SZA ANY ERRORS? JMP EXMC YES, EXIT * * CALL D.RTR TO UNLOCK AND VALIDATE DISC * LDA .5 REQUEST UNLOCK (NOTE, DISC LU SET STA .P1 IN PREVIOUS CALL) JSB CLD.R CALL FOR UNLOCK LDA .R1 GET ERROR FOR RETURN * EXMC STA ER,I CLA STA DS.DF STA DS.F1 FORCE NEW READ OF MASTER DIRECTORY JMP MC..,I SKP * EX50 LDA .50 JMP EXMC EX33 LDA .33 JMP EXMC * BADLU LDA N18 JMP EXMC * RD16 NOP READ THE CARTRIDGE HEADER JSB EXEC DEF R16X DEF X.1 DEF PLU DEF DBUF DEF .16 DEF TRACK DEF ZERO R16X JMP BADLU ERROR, ASSUME ITS A BAD LU LDA N1 PRESET FOR DISC ERROR CPB .16 CHECK XMISSION LOG, GET 16 WORDS? JMP RD16,I YES, RETURN JMP EXMC NO, DISC ERROR * STCOD OCT 100015 DVT6 NOP IFT6 NOP TRACK NOP NUMBER OF TRACKS LU NOP ZERO NOP PLU NOP DISC LU WITH PROTECT BITS CNT NOP COUNT OF ACTIVE FILES FOR DISMOUNT * X.1 OCT 100001 .4 DEC 4 .16 DEC 16 N64 DEC -64 N8 DEC -8 N2 DEC -2 N1 DEC -1 .3 DEC 3 .5 DEC 5 .7 DEC 7 .33 DEC 33 .2038 DEC 2038 N18 DEC -18 BN30 OCT -30 B77 OCT 77 N103 DEC -103 N1024 DEC -1024 .50 DEC 50 .55 DEC 55 .56 DEC 56 .128 DEC 128 B7700 OCT 7700 DBUF BSS 16 DBF3 EQU DBUF+3 DBF4 EQU DBUF+4 DBF7 EQU DBUF+7 DBF8 EQU DBUF+8 DBF9 EQU DBUF+9 * A EQU 0 B EQU 1 SKP * DISM - DISMOUNT SUBROUTINE PERFORMS THE FOLLOWING* * CALLS THE DIRECTORY MANAGER TO PLACE A LOCK ON THE * REQUESTED DISC - THIS ASSURES THAT NO ACTIVE OPEN * FILES EXIST ON THE DISC. * * CALLS THE DIRECTORY MANGER TO CLEAR THE DIRECTORY * ENTRY FOR THE DISC & CLOSE UP ANY GAPS IN THE * DIRECTORY CAUSED BY THE DISMOUNT. * * NN NOP NLIS NOP NER NOP DC.. NOP JSB .ENTR DEF NN * ISZ NLIS ADVANCE TO DRN PARAMETER LDA NLIS,I FETCH IT SZA,RSS MUST BE GIVEN JMP EXD55 ELSE ERROR EXIT * * STA .P2 SAVE DRN FOR D.RTR LDA .3 SET FUNCTION CODE STA .P1 FOR DISC LOCK JSB CLD.R GOTO CLD.R LDA .R1 FETCH ERROR CODE CPA N103 CORRUPT DIRECTORY? JMP TYPE6 YES, ALLOW HIM TO DISMOUNT IT SZA JMP EXDC ERROR EXIT * * TEST FOR SYSTEM USAGE OF THIS DISC * TYPE6 JSB SY.TR CALL SY.TR FOR PROGRAM AND SWAP AREA DEF *+6 DEF .P2 DISC ID DEF O.BUF BUFFER FOR PROGRAM NAMES DEF .128 SIZE OF BUFFER DEF IFT6 \ TWO DUMMY PARAMETERS DEF TRACK / STA CNT SAVE THE ACTIVE FILE COUNT SZA,RSS IF NO ERROR JMP DCIT GO DISMOUNT THE CARTRIDGE * JSB MSS. GO PRINT ERROR DEF *+2 DEF .2038 SYSTEM USING DISC * JSB PR.IT PRINT LIST OF CONFLICTING PROGRAMS DEF *+3 DEF O.BUF DEF .128 * * DISC IS LOCKED SO NO OPEN FILES EXIST * SET UP DISMOUNT CALL TO DIRECTORY MANAGER * DCIT LDA .7 SET FUNCTION CODE STA .P1 FOR DIRECTORY MODIFICATION LDA NLIS,I GET THE LU/CRN AGAIN STA .P2 STORE INTO D.RTR CALL PARAMETERS CLB SET P3=0 & SUBFUNCTION P7 STB .P3 =0 FOR DISMOUNT STB .P7 SUBFUNCTION = 0 FOR DISMOUNT JSB CLD.R LDA .R1 FETCH ERROR CODE SZA ANY ERRORS? JMP EXDC ERROR, DIDN'T DISMOUNT LDA CNT GET NUMBER OF ACTIVE FILES SZA,RSS ANY? JMP EXNOW NONE, EXIT * LDA .R2 ?W GET TRACK/LU WORD FROM D.RTR AND B77 ISOLATE LU CMA,INA SET IT NEGATIVE STA NLIS,I AND SAVE IT LDA NLIS GET ADDRESS OF PARAMETERS ADA N1 SUBTRACT ONE TO POINT AT TYPE STA NLIS AND SAVE FOR CALL TO MC.. CLA,INA SET 1 INTO PARAMETER STA NLIS,I TYPE FOR CALL TO MC.. JSB MC.. RE-MOUNT CARTRIDGE IF ACTIVE FILES ON IT DEF *+4 DEF NN,I DEF NLIS,I DEF NER,I JMP EXNOW SKIP ERROR SET EXDC STA NER,I STORE ERROR CODE INTO USER'S ERROR LDA .5 SET UP FOR UNLOCK STA .P1 JUST IN CASE STILL LOCKED LDA NLIS,I GET LU/CRN AGAIN STA .P2 JUST IN CASE JSB CLD.R UNLOCK THE DISC (IGNORE ERROR) EXNOW CLA STA DS.DF STA DS.F1 FORCE A NEW READ OF DISC DIRECTORY JMP DC..,I * * EXD55 LDA .55 JMP EXDC * LSTRK EQU NN * END /  92070-18026 1941 S C0122 &PA..              H0101 RJSPL,L,O,M ! NAME: PA.. ! SOURCE: 92070-18026 ! RELOC: 92070-16026 ! PGMR: A.M.G. ! MOD: M.L.K. ! ! *************************************************************** ! * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * ! * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * ! * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* ! * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ! *************************************************************** ! NAME PA..(8) " 92070-1X026 REV.1941 790712" ! ! ! EXTERNAL SUBROUTINES LET EXEC BE SUBROUTINE,EXTERNAL LET ECHO BE SUBROUTINE,EXTERNAL ! EXTERNAL FUNCTIONS LET IFTTY BE FUNCTION,EXTERNAL ! EXTERNAL VARIBLES LET CAM.O BE INTEGER,EXTERNAL LET C.BUF BE INTEGER,EXTERNAL LET ECH BE INTEGER,EXTERNAL LET NO.RD BE INTEGER,EXTERNAL LET CAD. BE INTEGER,EXTERNAL ! INTERNAL VARIBLES LET LU BE INTEGER ! ! PA..: SUBROUTINE(N,PLIST,ERR) GLOBAL LET N,PLIST,ERR BE INTEGER LU _ @PLIST + 1 IFNOT $LU THEN $LU _ CAM.O !DEFAULT TO LOG. IF PLIST=3 THEN GO TO ERX !IF PRAM IS FILE ERROR IFNOT IFTTY($LU) THEN [ \IF DEVICE NOT ERX: ERR _ 20; RETURN] !INTERACTIVE, ERROR. IFNOT PLIST THEN PLIST _ 1 IFNOT ($LU XOR CAM.O) AND 77K THEN[ \IF LOG DEVICE CALL ECHO ;GO TO EX] !PRINT ONLY IF NOT ECHOED EXEC(2,$LU,C.BUF,ECH ) !PRINT THE COMMAND. EX: N,CAD.,NO.RD _ 1 !SET UP FOR TR. RETURN END END END$ (  92070-18027 1941 S C0122 &PK..              H0101 ]JSPL,L,O,M ! NAME: PK.. ! SOURCE: 92070-18027 ! RELOC: 92070-16027 ! PGMR: G.A.A. ! MOD: G.L.M. ! ! *************************************************************** ! * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * ! * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * ! * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* ! * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ! *************************************************************** ! ! NAME PK..(7) " 92070-1X027 REV.1941 790911" ! ! MODIFIED 750416 TO NOT MOVE EXTENTS IF THEY ALREADY RESIDE AT ! THE DESTINATION AND ALSO TO CORRECTLY HANDLE FILES TO 32K SECTORS ! PK.. IS THE PACKING ROUTINE FOR THE ! RTE FMGR PROGRAM. ! ! IT PACKS RTE FILES AS FOLLOWS: ! ! ! 1. EACH FILE IS MOVED DOWN (IF NECESSARY). ! AFTER EACH FILE IS MOVED ITS DIRECTORY ! ENTRY IS UPDATED. ! (THUS NO MORE THAN ONE FILE IS ! LOST BY A CRASH.) ! ! 2. AFTER ALL FILES ARE MOVED A NEW DIRECTORY ! IS CREATED PACKING OUT ALL THE PURGED ! ENTRIES AND THIS IS WRITTEN ON THE DISC DIRECTLY AFTER ! REQUESTING A LOCK VIA D.RTR ! ! THIS ROUTINE IS ENTERED BY THE COMMAND: ! ! PK,CR ! ! WHERE CR IS OPTIONAL AND RESTRICTS ! THE PACK TO DISC CR. ! ! ! EXTERNAL SUBROUTINES LET CONV. BE SUBROUTINE,EXTERNAL LET D.RIO BE SUBROUTINE,EXTERNAL LET DR.RD BE SUBROUTINE,EXTERNAL LET EXEC BE SUBROUTINE,EXTERNAL LET FM.ER BE SUBROUTINE,EXTERNAL LET IER. BE SUBROUTINE,EXTERNAL,DIRECT LET JER. BE SUBROUTINE,EXTERNAL,DIRECT LET LIMEM BE SUBROUTINE,EXTERNAL LET LOCK. BE SUBROUTINE,EXTERNAL LET MSS. BE SUBROUTINE,EXTERNAL LET MVW BE SUBROUTINE,EXTERNAL LET READF BE SUBROUTINE,EXTERNAL LET RWNDF BE SUBByROUTINE,EXTERNAL LET SY.TR BE SUBROUTINE,EXTERNAL LET WRITF BE SUBROUTINE,EXTERNAL ! EXTERNAL FUNCTIONS LET GTOPN BE FUNCTION,EXTERNAL ! EXTERNAL VARIBLES LET .E.R BE INTEGER,EXTERNAL LET D.SDR BE INTEGER,EXTERNAL LET DS.LU BE INTEGER,EXTERNAL LET I.BUF BE INTEGER,EXTERNAL LET O.BUF BE INTEGER,EXTERNAL LET PK.DR BE INTEGER,EXTERNAL ! INTERNAL SUBROUTINES LET BADTR BE SUBROUTINE LET SETAD BE SUBROUTINE ! INTERNAL VARIBLES LET BTL(6) BE INTEGER LET MS(3) BE INTEGER LET MS2 BE INTEGER LET MS3 BE INTEGER LET MS4 BE INTEGER INITIALIZE MS TO "DISC =" ! INTERNAL CONSTANTS LET READI BE CONSTANT( 1) LET WRIT BE CONSTANT( 2) LET A BE CONSTANT( 3) LET B BE CONSTANT( 1) ! ! PK..: SUBROUTINE(N,LIS,ER) GLOBAL !ENTRY POINT PACK_$(@LIS+1) !GET THE PACK LUPT_@D.SDR !GET ADRS OF CART DIR PAKAD_@PK.DR !SET DIREC. BUFFER ADRS CALL LIMEM(1,FWAM,WRDS) !SEE IF MEMORY AVAIL. WRDS_WRDS AND 77600K !FULL SECTOR BOUNDS PK1: D.RIO(READI) !READ CART DIR TO D.SDR ! AGAIN:DIS_[IF PACK THEN PACK,ELSE -$LUPT] !PACK PARM OR CART LIST IFNOT DIS THEN [CALL LIMEM(-1); \END OF DISC DIRECTORY RETURN] !RETURN MEMORY AND EXIT CALL JER. !CHECK FOR BREAK LOCK.(DIS,3)?[MSS.(-8); \LOCK DISC/PRINT THE ERROR IF DIS<0 THEN[ \IF LU NEGATIVE DNO_ -DIS; \MAKE POSITIVE MS2_ "- "], \ ELSE[  \POSITIVE ALREADY DNO_ DIS; \ MS2_ " "]; \ CONV.(DNO,MS4,5); \CONVERT NUMBER TO ASCII FM.ER(2,MS,6); \WRITE CRN GOTO NXDIS] !GOTO NEXT SY.TR(DIS,T,1,HITRK,HISEC) !HI DISC ADRS IN USE BY SYSTE ! DR.RD(READI,DIS,0)?[ER_-32;RETURN] !READ 1ST DIR BLK ! FILCO_0 !CLEAR FILE COUNT SETAD !SET PTRS TO NXT ENTRY LU_ $$@DS.LU !GET DISC LU ! ! SET UP DCBS FOR PACKING ! DCB5_[NXSEC_[NXTR_[DCB2_[\ ! DCB_@O.BUF]+2]+1]+1]+1 ! DCB21_[DCB20_[DCB19_[OBUF_[DCB9_[DCB8_[DCB7_[DCB6_ \ DCB5+1]+1]+1]+1]+7]+3]+1]+1 ! ! TBUF_ DCB+32 ! O.BUF_ 0 ! MVW(DCB,DCB+1,31) !CLEAR FIRST 31 ENTRIES $DCB_LU !SET LU INTO DCB $DCB2_1 !SET TYPE 1 (FORCE TO 1) $DCB6_128 !SET RECORD SIZE $DCB7_100200K !SECURITY FLAG $DCB8_$PKD6 AND 377K !SET #SECT TRACK $DCB9_GTOPN !AND OPEN FLAG MVW(DCB,OBUF,16) !COPY TO 2ND DCB ! ! THE DISC IS LOCKED AND WE MAY START ! PACKING - WE MUST HAVE A BUFFER ! AND ITS SIZE. IF LIMEM GOT MORE ! THAN 256 WORDS USE THAT MEMORY; ! ELSE USE O.BUF+32 (256 WDS) ! ! ! WRDS AND FWAM WERE SET UP BY CALL TO LIMEM UPON ENTRY ! IF WRDS>256 THEN[ \ BUFAD_ FWAM; \SET POINTER TO PACK BUF LN_ WRDS; ] \SET LENGTH OF BUFFER GOTO PK5] !USE LARGER BUF FOR SPEED ! PK3: LN_ 256 !USE INTERNAL BUFFER BUFAD_ TBUF !OF O.BUF/I.BUF PK5: SECSZ_ LN-<10 !SET SECTOR COUNT ! ! BUFFER AND LENGTH ARE SET NOW ! START TO PACK ! $NXTR_ $PKD4 !SET TO 1ST FMP TRACK FOR T_ @BTL TO @BTL+5 DO[ \SET UP BAD PKD9_PKD9+1; \TRACK LIST $T_ $PKD9] ! $NXSEC_ 0 !INIT SECTOR BLK_ 0 !INIT BLOCK COUNTER GOTO NXFIL !SKIP HEADR BLOCK ! NXBLK:DR.RD(READI,DIS,BLK)?[GO TO CLEAN] !READ DIRECTORY BLOCK FILCO_0 !RESET DIRECTORY PTR ! NXFIL:SETAD?[GO TO WRBLK] !SET PKD PTRS TO NX FILE ! IFNOT $PKD THEN GOTO CLEAN !TEST FOR 0 AT END OF DIRECT IFNOT $PKD3 THEN GOTO NXFIL !SKIP TYPE 0 ! SEK_ $PKD5 AND 377K !GET SECTOR FROM DIRECTORY IF $PKD4 < HITRK THEN GOTO SKIP !SKIP UNTIL HI TRACK IF $PKD4 = HITRK THEN[ \IF BELOW HIGHEST BOUNDRY IF SEK <= HISEC THEN[ \CALCULATE NEW SKIP: $NXTR_ ((SEK+$PKD6)->1)/($DCB8->1)+$PKD4;\NEXT TRACK $NXSEC_ $B + $B; \AND SECTOR GOTO NXFIL]] !AND GO WORK ON NEXT FILE ! IF $PKD<0 THEN GOTO NXFIL !PURGED ! IF [T_ ($PKD >-8)] >= 60K THEN[ \IF 1ST CHAR IS NUMERIC IF T <= 71K THEN[ \THEN FILE IS A SCRATCH FILE WRFL,$PKD_ -1; \PURGE SCRATCH FILES GOTO WRBLKV]] !AND UPDATE DIRECTORY ! ! IF THE FILE CONTAINS A BAD TRACK ! PURGE IT AND CONTINUE ! BADTR($PKD4,[$DCB20_$PKD5 AND 377K],$PKD6)?[WRFL,$PKD_ -1;\IF 'FROM' GO TO WRBLK] !HAS BAD TRK, PURGE IT ! ! ! COMPUTE NEW LOCATION ! NEWLO:BADTR($NXTR,$NXSEC,$PKD6)?[ \IF 'TO' FILE HAS BAD $NXTR_$BT+1;$NXSEC_0;GO TO NEWLO] !TRK, SKIP TRK ! ! IF NEW LOCATION SAME AS OLD THEN ! GO TO NEXT FILE ! IF $NXTR=$PKD4 THEN[ \IF TO & FROM TRKS IF $NXSEC=$DCB20 THEN \AND SECTORS MATCH GOTO PK11] !SKIP COPY ! ! FAKE OPEN THE FILES ! WRFL_ -1 !SET 'WRITTEN-ON' FLAG CO,$DCB5,$DCB21_ $PKD6 !SET # OF SECTORS $DCB19_ $PKD4 !START TRACK RWNDF(O.BUF,.E.R) !SET REST OF FROM DCB IER. !CHECK FOR ERRORS RWNDF($OBUF,.E.R) !SET REST OF TO DCB IER. !CHECK FOR ERRORS PK10: XFER_[IF CO>SECSZ THEN LN,ELSE CO-<6] !SET # OF WRDS TO XFER READF($OBUF,.E.R,$BUFAD,XFER) !READ FROM FILE IER. !CHECK FOR ERRORS WRITF(O.BUF,.E.R ,$BUFAD,XFER) !WRITE 'TO' FILE IER. !CHECK FOR ERRORS IF [CO_CO-(XFER-<10)] THEN GOTO PK10 !SET REMAINING SIZE $PKD4_ $NXTR !SET IN NEW DIRECT ADRS $PKD5_ $NXSEC+($PKD5 AND 177400K) !FOR COPIED FILE PK11: $NXTR_NTR !UPDATE PTRS FOR $NXSEC_ NSEC !NEXT FILE ! ! PONTERS ARE UPDATED ! ! FILE IS MOVED - UPDATE DIRECTORY ! THEN GO DO NEXT FILE. ! nWRBLK:IF WRFL THEN[ \IF 'WRITTEN-ON' FLAG DR.RD(WRIT,DIS,BLK); \SET WRITE OUT UPDATED WRFL_ 0] !DIRECTORY INFO IF FILCO=128 THEN[ \IF DIR PTR AT BLK_ BLK+1; \END OF DIR BLK GOTO NXBLK], \SET UP FOR NEXT ELSE GOTO NXFIL !ELSE UPDATE PTRS ! ! ! --- THIS SECTION PACKS THE DIRECTORY ---------------------------------- ! ! CLEAN:TCNT,FCNT,FBLK,TBLK_ 0 !INITIALIZE POINTERS FBF_ @PK.DR !SET ADDRESS OF DIR BUF TBF_ @O.BUF !SET ADRS OF OUTPUT BUF ! TOP: DR.RD(READI,DIS,FBLK)?[GO TO EED] !READ DIR BLOCK !GOTO END IF LAST + 1 IF FBLK THEN GOTO PCK !IF NOT 1ST, CONTINUE ! FILCO_0 !CLEAR FILE COUNT FOR SETAD SETAD !THIS IS THE DIR ID $PKD9_$NXTR !SET NEXT TRACK $PKD5_$NXSEC !SET THE NEXT SECTOR GO TO MOK !MOVE THIS ENTRY ! ! PCK: IFNOT [T_$(FBF+FCNT)] THEN GOTO EED !GET OUT IF END OF DIR IF [NXTR_ $(FBF+FCNT+4)] < HITRK THEN GOTO MOK !BELOW, MOVE IT IF NXTR = HITRK THEN[ \BELOW PACK BOUNDRY IF ($(FBF+FCNT+5) AND 377K) <= HISEC THEN \OR ON IT, MOVE GOTO MOK] !ENTRY IF T<0 THEN GOTO NEX !IF PURGED-TRY NEXT ONE ! MOK: MVW(FBF+FCNT,TBF+TCNT,16) !MOVE DIR ENTRY TO SAVE BUF IF [TCNT_TCNT+16]=128 THEN[ \BUMP OUT COUNT-IF FULL TCNT_0; \RESET OUT COUNT DR.RD(-2,DIS,TBLK);  \WRITE THE BLOCK TBLK_TBLK+1] !BUMP THE BLOCK CONUT ! NEX : IF [FCNT_FCNT+16]=128 THEN[ \BUMP IN COUNT-IF EMPTY FCNT_0; \RESET IN COUNT FBLK_ FBLK+1; \BUMP BLOCK COUNT GOTO TOP], \GO READ NEXT BLOCK ELSE GOTO PCK !ELSE DO NEXT ENTRY ! ! --- CLEAR REMAINDER OF DIRECTORY --- ! EED: $(TBF+TCNT)_ 0 !CLEAR "CURRENT" FW OF BUF T_(128-TCNT)-1 !CALCULATE # WORDS TO MOVE !TO CLEAR REST OF BUFFER MVW(TBF+TCNT,TBF+TCNT+1,T) !CLEAR REST OF BUFFER WIPE: DR.RD(-2,DIS,TBLK) !WRITE IT OUT TBLK_TBLK+1 !BUMP BLOCK COUNT ! ! IFNOT FBLK < TBLK THEN[ \CLEAR REST OF DIRECTORY IFNOT TCNT THEN GOTO WIPE, \CONT AT WIPE IF ELSE[ \ELSE CLEAR FULL BUFFER TCNT_0; \ GOTO EED]] ! ! PK26: LOCK.(DIS,5) !UNLOCK DISC NXDIS:I.BUF_ 0 !CLEAR FW SO CLOSE WON'T !GET SCREWED UP IFNOT PACK THEN [LUPT_LUPT+4;GOTO AGAIN] CALL LIMEM(-1) RETURN END ! !---------------------------------------------------------------------- ! ! SETAD SETS THE ADDRESSES FOR THE NEXT FILES ENTRY ! IN PK.DR - IF NONE THEN AN FRETURN IS MADE. ! SETAD:SUBROUTINE FEXIT ! IF FILCO=128 THEN FRETURN PKD9_[PKD8_[PKD6_[PKD5_[PKD4_[PKD3_[PKD_\ PAKAD+FILCO]+3]+1]+1]+1]\ +2]+1 FILCO_FILCO+16 RETURN END ! !-----------------^0.*------------------------------------------------------ ! ! BADTR RETURNS FALSE IF THE CURRENT FILE ! AREA CONTAINS A BAD TRACK. ! BADTR:SUBROUTINE(TRAK,SECT,NOSEC)FEXIT NTR_((SECT+NOSEC)->1)/($DCB8->1)+TRAK !COMPUTE (ROTATE TO AVOID NSEC_$B+$B !NEXT TRACK & SECTOR (32K SECTORS SIGN PROB.) ! ! CHECK EACH TRACK AGAINST THE BAD LIST. ! FOR T_TRAK TO[IF NSEC THEN 0,ELSE -1]\ + NTR DO[\ FOR BT_@BTL TO @BTL+5 DO[ \ IF $BT THEN[IF T=$BT THEN FRETURN]]] RETURN END END END$ ! }0  92070-18028 1941 S C0122 &PU..              H0101 hJSPL,L,O,M ! NAME: PU.. ! SOURCE: 92070-18028 ! RELOC: 92070-16028 ! PGMR: G.A.A. MOD. M.L.K. ! ! *************************************************************** ! * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * ! * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * ! * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* ! * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ! *************************************************************** ! ! NAME PU..(7) " 92070-1X028 REV.1941 790906" ! ! ! PURGE FILE ROUTINE FOR THE RTE FILE MANAGER ! ! ENTERED AFTER A: ! ! PU,NAMR ! ! W H E R E: ! ! NAMR IS THE FILE'S NAMR WHICH CAN CONTAIN: ! ! CR (OPTIONAL) IS THE CARTRIDGE ID. ! ! SC (OPTIONAL) IS THE FILE SECURITY CODE. ! ! ! EXTERNAL SUBROUTINES LET CLOSE BE SUBROUTINE,EXTERNAL LET EXEC BE SUBROUTINE,EXTERNAL LET IER. BE SUBROUTINE,EXTERNAL,DIRECT LET LOCK. BE SUBROUTINE,EXTERNAL LET MSS. BE SUBROUTINE,EXTERNAL LET OPEN BE SUBROUTINE,EXTERNAL LET PURGE BE SUBROUTINE,EXTERNAL ! EXTERNAL VARIBLES LET .E.R BE INTEGER,EXTERNAL LET %IDA BE INTEGER,EXTERNAL LET %IDNM BE INTEGER,EXTERNAL LET %IDSZ BE INTEGER,EXTERNAL LET %SWLU BE INTEGER,EXTERNAL LET O.BUF BE INTEGER,EXTERNAL LET N.OPL BE INTEGER,EXTERNAL ! INTERNAL SUBROUTINES LET PUIT BE SUBROUTINE,DIRECT ! INTERNAL CONSTANTS LET READI BE CONSTANT (1) LET WRIT BE CONSTANT (2) ! ! PU..: SUBROUTINE(NCAM,PLIST,ER) GLOBAL !ENTRY POINT ! LET ER BE INTEGER LET NCAM BE INTEGER LET PLIST BE INTEGER ! DCB8_[DCB7_[DCB5_[DCB4_[DCB3_[DCB1_[DCB0_@O.BUF]+1]+2]+1]+1]+2]+1 ! T_@N.OPL+1 BLK_ @PLIST+1 !  PUIT !GO PURGE IT ! LU _ $DCB0 AND 77K !SAVE LU OF DISC IF .E.R = -6 THEN .E.R_ -2006 !SET UNDEFINED ERROR IF .E.R = -16 THEN GOTO ZPURG !TYPE 0 PURGE IF .E.R = -37 THEN GOTO TYPE6 !TYPE 6 PURGE IER. RETURN ! ! PURGE TYPE 0 FILE ! ZPURG:LOCK.(-LU,3)?[RETURN] !SET LOCK ON DISC PUIT !FORCE CURRENT DIR. ADDRESS !TO BE SET INTO DCB0,1 ! DSLU_ LU + 7700K !PROTECTED DISC LU TR_(($DCB0 AND 177700K) -> 6) !ISOLATE TRACK SECT_$DCB1 AND 377K !SECTOR OFFSET_(($DCB1 AND 177400K) -> 8) !AND OFFSET OF DIR ENT ! EXEC(READI,DSLU,O.BUF,128,TR,SECT) !READ BLOCK HOLDING ENTRY IF $1 #128 THEN \ !MUST GET FULL BLOCK [MSS.(1,LU); RETURN ] $(DCB0+OFFSET)_-1 !SET THE ENTRY AS PURGED EXEC(WRIT,DSLU,O.BUF,128,TR,SECT) !WRITE IT BACK OUT ! O.BUF_0 !CLEAR FOR CLOSE LOCK.(-LU,5) !CLEAR THE LOCK RETURN ! ! PURGE TYPE 6 FILES ! TYPE6:OPEN(O.BUF,ER,$BLK,0,N.OPL,$T) !OPEN EXCLUSIVELY IF ER < 0 THEN RETURN, ELSE ER_ 0 !IF OPEN ERROR, RETURN IF $DCB7 >= 0 THEN[ \IF SECURITY CODES DON'T ER_ -7; \MATCH, SET ERROR -7 RETURN] !AND RETURN TRAK_ $DCB3 !SET UP TRACK IF LU = $%SWLU THEN[ \SAME AS SWAP LU? IF TRAK = $(%SWLU+1) THEN[ \SAME AS SWAP TRACK? IF $DCB4 = $(%SWLU+2) THEN GOTO ER38]] ! SAME SECT, ERROR! IF [SE, CT_ $DCB4+2] = $DCB8 THEN[ \SET & INCREMENT SECTOR TRAK_ TRAK+1; \IF TRACK OVERFLOW, INCREMENT SECT_ 0] !AND SET SECTOR TO 0 ! IDPTR_ $%IDA + 27 - $%IDSZ !SET POINTER TO ID SEGMENTS FOR I_1 TO $%IDNM DO[ \SCAN ID SEGMENTS IDPTR_ IDPTR + $%IDSZ; \POINT TO NEXT ID IFNOT $(IDPTR-15) THEN GOTO NDLP; \IF ID DORMANT, SKIP IF ($IDPTR AND 377K)= LU THEN[ \LU'S MATCH? IF $(IDPTR-1)= TRAK THEN[ \TRACKS MATCH? SEK_ ($(IDPTR-2) AND 377K) <- 1; \GET LOGCL SECTOR FROM ID IF SEK = SECT THEN[ \SECTORS MATCH? ER38: MSS.(38); \ERROR, ITS ACTIVE! RETURN]]];NDLP:] !EXIT CLOSE(O.BUF,.E.R,($DCB5)/2) !CLOSE AND TRUNCATE RETURN END ! ! PUIT:SUBROUTINE DIRECT PURGE(O.BUF,.E.R,$BLK,N.OPL,$T) RETURN END END END$ X  92070-18029 1941 S C0122 &RN..              H0101 bLSPL,L,O,M ! NAME: RN.. ! SOURCE: 92070-18029 ! RELOC: 92070-16029 ! PGMR: G.A.A. MOD. M.L.K. ! ! *************************************************************** ! * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * ! * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * ! * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* ! * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ! *************************************************************** ! ! NAME RN..(7) " 92070-1X029 REV.1941 790712" ! ! THE RN ROUTINE ALLOWS THE OPERATOR TO ! CHANGE FILE NAMES. ! ! COMMAND: ! ! RN,NAMR,NEWNAME ! ! WHERE NAMR IS THE FILES NAME REFERENCE ! INCLUDING SECURITY CODE AND ! CARTRIDGE ID IF APPROPIATE ! ! NEWNAME IS THE NEW FILE NAME ! ! ! EXTERNAL SUBROUTINES LET IER. BE SUBROUTINE,EXTERNAL,DIRECT LET NAMF BE SUBROUTINE,EXTERNAL ! EXTERNAL INTEGERS LET .E.R BE INTEGER,EXTERNAL LET O.BUF BE INTEGER,EXTERNAL LET N.OPL BE INTEGER,EXTERNAL ! ! RN..: SUBROUTINE (N,LI,E) GLOBAL L5_[L1_@LI+1]+4 NAMF(O.BUF,.E.R ,$L1,$L5,N.OPL,$(@N.OPL+1)) IER. RETURN END END END$ o  92070-18030 1941 S C0122 &RP..              H0101 [MSPL,L,O,M ! NAME: RP.. ! SOURCE: 92070-18030 ! RELOC: 92070-16030 ! PGMR: M.L.K. ! ! *************************************************************** ! * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * ! * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * ! * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* ! * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ! *************************************************************** ! ! NAME RP..(7) " 92070-1X030 REV.1941 790712" ! ! EXTERNAL SUBROUTINES LET .DFER BE SUBROUTINE,EXTERNAL LET EXEC BE SUBROUTINE,EXTERNAL LET IDRPL BE SUBROUTINE,EXTERNAL LET IER. BE SUBROUTINE,EXTERNAL,DIRECT LET MSS. BE SUBROUTINE,EXTERNAL LET OPEN. BE SUBROUTINE,EXTERNAL LET PR.IT BE SUBROUTINE,EXTERNAL ! EXTERNAL INTEGERS LET .E.R BE INTEGER,EXTERNAL LET %FWBG BE INTEGER,EXTERNAL LET BUF. BE INTEGER,EXTERNAL LET I.BUF BE INTEGER,EXTERNAL LET N.OPL BE INTEGER,EXTERNAL ! ! RP..: SUBROUTINE(NUM,PRAM,ERR) GLOBAL LET ERR BE INTEGER !ERROR CODE LET NUM BE INTEGER !PARAMETER COUNT LET PRAM(64) BE INTEGER !PARSED PARAMETERS ! IF PRAM(1) # 3 THEN[ \IF 1ST PRAM NOT ASCII ER56: ERR_ 56; \SET BAD PARAMETER RETURN] !AND RETURN IF PRAM(5) = 0 THEN[ \IF 2ND PRAM NULL FOR I_ 1 TO 4 DO[ \ COPY PARM 1 TO PRAM(I+4)_ PRAM(I)]] ! PARM 2 IF PRAM(5) # 3 THEN GOTO ER56 !IF 2ND PRAM NOT ASCII !ERROR 56 ! OPEN.(I.BUF,PRAM(2),N.OPL,5) !OPEN & FORCE TO TYPE 1 IER. @o   !TEST FOR READ ERRORS IDRPL(I.BUF,ERR,PRAM(6),1) !PERMANENT RP TEMP_ .B. !GET ID ADDRESS IF ERR = 40 THEN[ \IF SOMEONE THERE MSS.(40); \PRINT ERROR 40 PR.IT(TEMP,1); \PRINT PROGRAM NAME ERR_ 0] !DON'T RE-ISSUE ERROR EXEC(100034K,PRAM(6)) !TRY AND LOAD IT RETURN !ALL DONE RETURN !JUST IN CASE OF ERROR END END END$ F   92070-18031 1941 S C0122 &RU..              H0101 aMSPL,L,O,M ! NAME: RU.. ! SOURCE: 92070-18031 ! RELOC: 92070-16031 ! PGMR: M.L.K. ! ! *************************************************************** ! * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * ! * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * ! * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* ! * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ! *************************************************************** ! ! NAME RU..(7) " 92070-1X031 REV.1941 790712" ! ! EXTERNAL SUBROUTINES LET .DFER BE SUBROUTINE,EXTERNAL,DIRECT LET CLOSE BE SUBROUTINE,EXTERNAL LET EXEC BE SUBROUTINE,EXTERNAL LET FM.ER BE SUBROUTINE,EXTERNAL LET IDRPL BE SUBROUTINE,EXTERNAL LET IER. BE SUBROUTINE,EXTERNAL,DIRECT LET MSS. BE SUBROUTINE,EXTERNAL LET OPEN. BE SUBROUTINE,EXTERNAL LET PR.IT BE SUBROUTINE,EXTERNAL LET RMPAR BE SUBROUTINE,EXTERNAL ! EXTERNAL FUNCTIONS LET IDSGA BE FUNCTION,EXTERNAL LET LOGLU BE FUNCTION,EXTERNAL ! EXTERNAL INTEGERS LET .E.R BE INTEGER,EXTERNAL LET %TMP1 BE INTEGER,EXTERNAL LET BUF. BE INTEGER,EXTERNAL LET C.BUF BE INTEGER,EXTERNAL LET CAD. BE INTEGER,EXTERNAL LET ECH BE INTEGER,EXTERNAL LET G0..(48) BE INTEGER,EXTERNAL LET I.BUF BE INTEGER,EXTERNAL LET N.OPL BE INTEGER,EXTERNAL LET NO.RD BE INTEGER,EXTERNAL ! INTERNAL SUBROUTINES LET RU.. BE SUBROUTINE LET XQ.. BE SUBROUTINE ! INTERNAL VARIBLES LET ABEND(4) BE INTEGER LET ABX(7) BE INTEGER INITIALIZE ABEND,ABX TO " ABEND XXXXX ABORTED " LET SC BE INTEGER LET A05 BE INTEGER INITIALIZE SC,A05 TO "SC","05" ! ! XQ..: SUBROUTINE(NM,PRM,ER) GLOBAL ER_ -1  !SET XQ FLAG RU..(NM,PRM,ER) !CALL RU SUBROUTINE RETURN END ! ! RU..: SUBROUTINE(NUM,PRAM,ERR) GLOBAL LET ERR BE INTEGER !ERROR PARAMETER LET NUM BE INTEGER !NUMBER OF PARAMETERS LET PRAM(64) BE INTEGER !PARSED PARAMETERS ! CODE_ 100027K !PRE-SET TO RU IF ERR = -1 THEN [CODE_ 100012K ; ERR_0] !IF XQ CHANGE CODE IF PRAM(1) # 3 THEN [ ERR_ 56; RETURN] !CHECK FOR ASCII NAME IF IDSGA(PRAM(2)) THEN GOTO SCHED !IF PROG EXISTS, RUN IT ! ! RP THE PROGRAM ! RPIT: OPEN.(I.BUF,PRAM(2),N.OPL,5) !OPEN & FORCE TO TYPE 1 IER. !TEST FOR READ ERROR IDRPL(I.BUF,ERR,PRAM(2),0) !TEMPORARY RP TEMP_ .B. !SAVE ID ADDRESS IF ERR = 40 THEN[ \IF SOMEONE ALREADY THERE MSS.(40); \ISSUE ERROR PR.IT(TEMP,1); \PRINT PROGRAM NAME ERR_ 0; \DON'T RE-ISSUE ERROR RETURN] !EXIT IF ERR THEN RETURN !RETURN ON ERROR CLOSE(I.BUF) !CLOSE TYPE 6 ! ! SCHEDULE THE PROGRAM ! SCHED:IFNOT PRAM(5) THEN[ \IF 1ST PRAM DEFAULT PRAM(6)_ [IF G0..(1)=1 THEN G0..(2), \USE 0G IF NUMERIC ELSE LOGLU(D)]] !ELSE USE CRT LU $1_ -1 !PRESET THE B REGISTER EXEC(CODE,PRAM(2),PRAM(6),PRAM(10),PRAM(14), \SCHEDULE PROGRAM PRAM(18),PRAM(22),C.BUF,ECH);GOTO SCER !NO ABORT IF $1 # -1 THEN RMPAR(G0..(42)) !PICK UP PARAMETERS .E.R_ 0 IF $$%TMP1 = 100000K THEN[ \IF PROG  ABORTED .DFER(ABX,PRAM(2)); \SET THE NAME IN MESSAGE FM.ER(2,ABEND,11)] !AND PRINT EXEC(14,1,C.BUF,40); ECH_ .B. !GET RETURN STRING IFNOT ECH THEN RETURN !IF NO STRING, RETURN IF (C.BUF AND 177400K) = 35000K THEN[ \IF BEGINS WITH ":" NO.RD_ -1; \DON'T READ ANOTHER COMMAND C.BUF_ C.BUF - 15000K] !REPLACE ":" WITH RETURN !ALL DONE ! SCER: T1_ .A. !GET ERROR CODE T2_ .B. !FROM A & B REG IF T1 = SC THEN[ \IF NO ID SEG ERROR IF T2 = A05 THEN GOTO RPIT] !TRY AGAIN ERR_ 49 !CAN'T RUN PROGRAM RETURN END END END$ +  92070-18032 1941 S C0122 &SE..              H0101 RNSPL,L,O,M ! NAME: SE.. ! SOURCE: 92070-18032 ! RELOC: 92070-16032 ! PGMR: A.M.G. ! MOD: M.L.K. ! ! *************************************************************** ! * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * ! * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * ! * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* ! * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ! *************************************************************** ! NAME SE..(8) " 92070-1X032 REV.1941 790712" ! ! LET G0.. BE INTEGER,EXTERNAL ! LET GLOBS BE SUBROUTINE ! LET PTR,PTR0,PTR1,PTR2 BE INTEGER ! ! SE..: SUBROUTINE(NUM,PLIST,ERR) GLOBAL LET NUM,PLIST,ERR BE INTEGER CALL GLOBS(NUM,PLIST,0) ? [ERR _ 48] RETURN END ! GLOBS: SUBROUTINE(NUMB,GLOBL,IND) GLOBAL,FEXIT LET GLOBL,NUMB,IND BE INTEGER LET G0.. BE INTEGER,EXTERNAL PTR,PTR2 _ @GLOBL IF NUMB > 9 THEN NUMB _ 9 !TOO MANY PARAMETERS? IF NUMB THEN GOTO GLOB2 !IF THERE ARE NONE IF IND THEN GOTO GLOB2 !AND THIS IS A "SET" PTR1 _ @G0.. + 3 !THEN NULL ALL THE FOR I _ 1 TO 36 DO [ \GLOBALS. $[PTR1 _ PTR1 + 1] _ 0] RETURN GLOB2: PTR _ PTR + 2 !SET POINTERS. PTR1 _ [PTR0 _ @G0.. + 4] + 2 FOR I _ 1 TO NUMB DO [ \MOVE ALL NON-NULL IF $PTR2 = 0 THEN GOTO GLOB3; \PARAMETERS TO THE $[REAL]PTR0 _ $[REAL]PTR2; \GLOBALS IN THE MAIN. $[REAL]PTR1 _ $[REAL]PTR; \ GLOB3: PTR _ [PTR2 _ PTR2 + 4] + 2; \ PTR1 _ [PTR0 _ PTR0 + 4] + 2] RETURN END END END$     92070-18033 1941 S C0122 &ST.DU              H0101 xSPL,L,O,M ! NAME: ST.DU ! SOURCE: 92070-18033 ! RELOC: 92070-16033 ! PGMR: G.A.A. ! MOD: M.L.K. ! ! *************************************************************** ! * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * ! * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * ! * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* ! * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ! *************************************************************** ! ! NAME ST.DU(7) " 92070-1X033 REV.1941 790712" ! ! THIS IS THE RTE FMP FMGR ROUTINE TO STORE ! AND DUMP FILES. ! ! DU,NAME,LU,OP1,OP2,OP3 ! ! O R ! ! ST,LU,NAME,OP1,OP2,OP3,OP4 ! ! ! W H E R E: ! ! ST IS STORE. ! DU IS DUMP. ! ! NAME ! NAME IS THE FILE TO BE STORED OR DUMPED. ! ! LU IS EITHER THE SOURCE OR DESTINATION ! DEVICE AND MAY BE A FILE REFERENCE. ! ! OP1 IS A MEDIUM ASC CODE AS FOLLOWS: ! AS ASCII DATA ! BR BINARY RELOCATABLE DATA ! BA BINARY ABSOLUTE DATA ! MT MAG TAPE NORMAL FORMAT ! MS MAG TAPE SIO FORMAT ! ! OP2 IS AN END OF FILE OPTION ! FLAG -- TWO ASC CHARACTERS: ! SA SAVE END OF FILES IN THE ! NEW FILE. ! IN INHIBIT ALL LEADER, TRAILER, ! END OF FILE TRANSFERS; ! DOES NOT APPLY TO FINAL ! EOF ON A DISC FILE. ! ! OP3 IS THE NUMBER OF THE FIRST FILE ! TO BE TRANSFERRED (APPLIES TO ! FILES OF TYPE ZERO) (DEFAULT=1) ! ! OP4 IS THE NUMBER OF FILES TO BE ! TRANSFERRED (APPLIES TO FILES !  OF TYPE ZERO) (DEFAULT= ) ! ! N O T E: OP3 AND OP4 ARE RELATIVE TO CURRENT POSITION. ! ! EXTERNAL SUBROUTINES LET CK.SM BE SUBROUTINE,EXTERNAL LET CLOSE BE SUBROUTINE,EXTERNAL LET CREA. BE SUBROUTINE,EXTERNAL LET EXEC BE SUBROUTINE,EXTERNAL LET IER. BE SUBROUTINE,EXTERNAL,DIRECT LET LOCF BE SUBROUTINE,EXTERNAL LET MSS. BE SUBROUTINE,EXTERNAL LET OPEN. BE SUBROUTINE,EXTERNAL LET READF BE SUBROUTINE,EXTERNAL LET RWNDF BE SUBROUTINE,EXTERNAL LET WRITF BE SUBROUTINE,EXTERNAL ! EXTERNAL FUNCTIONS LET IFBRK BE FUNCTION,EXTERNAL ! EXTERNAL INTEGERS LET .E.R BE INTEGER,EXTERNAL LET BUF. BE INTEGER,EXTERNAL LET I.BUF BE INTEGER,EXTERNAL LET N.OPL BE INTEGER,EXTERNAL LET O.BUF BE INTEGER,EXTERNAL ! LET DU..,ST.. BE SUBROUTINE ! LET AS BE CONSTANT (40523K) LET BR BE CONSTANT (41122K) LET BN BE CONSTANT (41116K) LET BA BE CONSTANT (41101K) LET MT BE CONSTANT (46524K) LET MS BE CONSTANT (46523K) LET IH BE CONSTANT (44510K) LET SA BE CONSTANT (51501K) ! ST..: SUBROUTINE(NPD,LISTO,ERD) GLOBAL ERD_ -1 !SET DUMP FLAG DU..(NPD,LISTO,ERD) !CALL DUMP SUBR RETURN END ! DU..: SUBROUTINE(NPS,LISTS,ERS) GLOBAL LI12_[LIS8_[LIS4_@LISTS+4]+4]+4 ! LIS21_[LIS17_[LIS13_[LIS9_[LIS5_[LIS1_\ @LISTS+1]+4]+4]+4]+4]+4 COPY_ 0 !SET COPY FLAG FALSE ! ! PRESET DEFAULT OPTIONS ! OBUF,SPDCB_@O.BUF !SET DCB ADDRESS FOR SPACING IBUF_ @I.BUF !SET INPUT DCB ADDRESS BUFF,BUFA,BF_@BUF. DO[F1,SIOI,EOFF,CK,SIO,FLG,LDR_0] DO[SUBF_410K;F2,TYP,DUMP_1] IFNOT ERS+1 THEN [ERS,DUMP_0;SPDCB_IBUF] !SET STORE OPTIONS IF NPS<2 THEN [ERS_55;RETURN] DT_3 !SET DEFAULT TYPE ! ! ANALYZE OPTIONS ! ! FIRST THE TYPE FLAG ! IFNOT $LIS8 THEN GO TO ST3 !NULL,SO GO TO CHECK NEXT IF $LIS9 = MS THEN [SIO_1;BUFA_BF+1;\ LIS9_LIS9+1] IF $LIS9=" " THEN GO TO ST3 IF $LIS9 = AS THEN [SUBF_410K;GO TO ST3] IF $LIS9 = BR THEN[CK,SUBF_110K;\ DT_5; GO TO ST3] IF $LIS9 = BN THEN[SUBF_110K; \ GO TO ST3] IF $LIS9 = BA THEN[CK,SUBF_2110K;TYP_0;\ DT_7;GO TO ST3] IF $LIS9 = MT THEN GO TO ST3 IF $LIS9 = SA THEN[EOFF_1;GO TO ST2] IF $LIS9 = IH THEN[LDR_20000K;GO TO ST2] ! STER1:DO[ERS_56; RETURN] ! ! CHECK FOR OP2 ! ST3: IF $LI12#3 THEN GO TO ST2 ! IF $LIS13 = SA THEN[EOFF_1;GO TO ST5] IF $LIS13 = IH THEN[LDR_20000K;GO TO ST5] ! GO TO STER1 !ILLEGAL OPTION ! OPT2 WAS FOUND IN OP1 LOCATION SO ! ADJUST ADDRESSES AND SKIP ! OPT2 CHECK. ! ! ST2: DO[LIS21_[LIS17_LIS13]+4] ST5: OPEN.(I.BUF,$LIS1,N.OPL ,SUBF+1) LOCF(I.BUF,.E.R ,ID,ID,ID,ISZ,ILU,INTY,ISZ2) IER. IF $LIS17>0 THEN F1_$LIS17-1 IF $LIS21>0 THEN F2_$LIS21, ELSE \ [IFNOT $LIS21 THEN [IF$LIS17>0 THEN GOTO ST6,ELSE[\ IF INTY THEN F2_9999]]] ! ST6: SUBF_(SUBF AND 110K)+LDR \SET OUTPUT FUNCTION OR[IF (INTY AND 177775K)=5 THEN 110K,ELSE 0] IF INTY=6 THEN SUBF_ SUBF OR 110K IF $LIS9=AS THEN SUBF_SUBF AND 177677K ! ! IF A STORE OPERATION CREAT THE FILE ! SZ1_[SZ_[TY_[OPLS_@N.OPL+5]+2]+1]+1 ! IFNOT ERS+2 THEN[ \COPY, THE FILE IS OPEN ERSv_ 0; \ COPY_ 1; \ GOTO ST12] ! IF DUMP THEN GO TO ST10 !DUMP, DON'T CREATE THE FILE ! ! SET DEFAULTS ! IFNOT $TY THEN $TY_[IF INTY THEN INTY,\ ELSE DT] IFNOT $SZ THEN $SZ_[IF INTY THEN ISZ->1,\ ELSE 24 ] !NOTE THIS DEFAULT !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IFNOT $SZ1 THEN[IF INTY THEN $SZ1_ISZ2] ! ! CREAT THE FILE ! CREA.(O.BUF,$LIS5,$OPLS)?[GO TO ST10] GO TO ST12 ST10: IFNOT SUBF AND 177760K THEN SUBF_ SUBF AND 7 OPEN.(O.BUF,$LIS5,$OPLS,SUBF) !OPEN FILE FOR DUMP ST12: LOCF(O.BUF,.E.R ,ID,ID,ID,ISZ,OLU,OUTY) IER. IF INTY=6 THEN $(IBUF+2),INTY_1 IF OUTY=6 THEN $(OBUF+2),OUTY_1 ! ! BOTH IN AND OUT ARE OPEN -- ! LEADER HAS BEEN PUNCHED IF NOT SUPPRESSED. ! ! IF SIO STORE THEN SET IT UP ! IF SIO THEN [IFNOT DUMP THEN[\ SIO_0; SIOI_1;BUFF_[BUFA_BF]+1]] ! UNTIL F1=0 DO[READF($SPDCB,.E.R ,$BUFA,128,ALN);IER.;\ IF ALN<1 THEN[F1_F1- 1; IF IFBRK() THEN GO TO BRK]] ST15: READF(I.BUF,.E.R ,$BUFA,128,ALN) IF IFBRK() THEN[ \IF BREAK THEN BRK: MSS.(0); \SEND BREAK ERROR GOTO KILL] !AND FLUSH FILE IF .E.R = -12 THEN [ALN_ -1;GO TO ST16] IER. IF ALN>0 THEN GO TO ST20 !DATA? ! ! NO DATA -- EITHER EOF OR ZERO REG ! END OF XFER? ! ST16: IFNOT ALN+1 THEN[IF INTY THEN[F2_0;\ GO TO ST18]] !TRUE EOF-QUIT ! IF [F2_F2-1] THEN [IF EOFF THEN[ALN_-1;\ GO TO ST22],ELSE GO TO ST25] ST18: ALN_-1 IFNOT LDR THEN GO TO ST22 !IF INHIBIT NOT REQUESTED--EO GO TO EXIT !DONE - NBDO EOF REQUIRED ! ST20: DO [IF SIOI THEN [ALN_[\ IF $BUFA<0 THEN-$BUFA,ELSE\ ($BUFA+1)>-1];ID_BUFA+1],ELSE\ ID_BUFA ;IF CK THEN[\ CK.SM($ID,TYP)?[GO TO ABO];ALN_($ID-<8)+(1-TYP)*3]] FLG_1 !INDICATE RECORD WRITTEN ST22: IF ALN>0 THEN[IF SIO THEN[$BUFF_-ALN;ALN_ALN+1]],\ ELSE[IF F2 THEN[IF OUTY THEN ALN_0]] WRITF(O.BUF,.E.R ,$BUFF,ALN) IF .E.R = -6 THEN[MSS.(.E.R );GO TO KILL] IER. IF ALN= -1 THEN[IFNOT F2 THEN GOTO EXIT,\ ELSE GO TO ST25 ] IF ALN THEN GO TO ST15 ST25: EXEC (13, ILU,DVT6) !GET THE DEVICE TYPE IF(DVT6 AND 37400K)=6000K THEN[ \IF PHOTO-READER MSS.(2006); \PRINT ERROR EXEC(7)] !PAUSE FOR NEXT TAPE GO TO ST15 ! ABO: MSS.(7) !SEND CHECK SUM ERROR KILL: ID_ -1 !SET TO ABORT THE FILE IF COPY THEN [ERS_22; RETURN] !NOTIFY COPY OF BREAK ENDIT:IF DUMP THEN RETURN IFNOT OUTY THEN RETURN IF ID<0 THEN RWNDF(O.BUF) !REWIND TO BE SURE OF PURGE CLOSE(O.BUF,.E.R ,$SZ-ID-1) !CLOSE AND IER. RETURN ! EXIT: LOCF(O.BUF,.E.R ,T,ID,IOF) IER. IF OUTY < 3 THEN[ \IF TYPE 1 OR 2 IFNOT IOF THEN ID_ ID-1] !ADJUST RB FOR 0 !OFFSET IFNOT FLG THEN ID_-1 GO TO ENDIT END ! ! END END$ _  92070-18034 1941 S C0122 &SY..              H0101 hNASMB,R,L,C * NAME: SY.. * SOURCE: 92070-18034 * RELOC: 92070-16034 * PGMR: M.L.K. * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * * NAM SY..,7 92070-1X034 REV.1941 790717 * * ENT SY.. * EXT .ENTR,C.BUF,CNOPT,CAM.O,MESSS,ECH * ***** ***** SYSTEM COMMAND PROCESSOR ***** * * SYN NOP SYLST NOP SYER NOP SY.. NOP JSB .ENTR DEF SYN ADJUST RETURN ADDRESS * LDA ECH FETCH INPUT LENGTH ADA A DOUBLE IT FOR BYTE COUNT STA SYN SAVE IT IN TEMP * * PASS THE COMMAND TO THE SYSTEM * JSB MESSS DEF *+3 DEF C.BUF BUFFER ADDRESS DEF SYN BYTE COUNT * CMA,INA,SZA,RSS IF NO RESPONSE JMP SY..,I THEN WE ARE ALL DONE * CLE,ERA DIVIDE BY 2 TO GET WORD COUNT STA ECH SAVE THE WORD COUNT JSB CNOPT GO PRINT THE RESPONSE ON LOG DEF *+5 DEF .2 DEF CAM.O DEF C.BUF DEF ECH JMP SY..,I * .2 DEC 2 A EQU 0 * END G7  92070-18035 1941 S C0122 &TR..              H0101 bOSPL,L,O,M ! NAME: TR.. ! SOURCE: 92070-18035 ! RELOC: 92070-16035 ! PGMR: G.A.A., A.M.G ! ! *************************************************************** ! * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * ! * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * ! * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* ! * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ! *************************************************************** ! NAME TR..(8) " 92070-1X035 REV.1941 790712" ! ! LE GRAND TR ROUTINE ! ! EXTERNAL SUBROUTINES LET EX.. BE SUBROUTINE,EXTERNAL !FMGR EXIT ROUTINE LET GLOBS BE SUBROUTINE,EXTERNAL !SET UP GLOBALS LET IER. BE SUBROUTINE,EXTERNAL,DIRECT !CHECK ERROR (FM.CM) LET OPEN. BE SUBROUTINE,EXTERNAL !FILE OPEN OR FAKE OPEN LET READF BE SUBROUTINE,EXTERNAL !READ RECORD ! EXTERNAL INTEGERS LET .E.R BE INTEGER,EXTERNAL !GLOBAL ERROR CODE LET CAM.I BE INTEGER,EXTERNAL !COMMAND INPUT DCB LET CAMS. BE INTEGER,EXTERNAL !TRANSFER STACK LET N.OPL BE INTEGER,EXTERNAL !SUB-PARAMETER STORAGE LET P.TR BE INTEGER,EXTERNAL !TRANSFER STACK POINTER ! ! TR..: SUBROUTINE(N,LIS,ERR) GLOBAL !TRANSFER SUBROUTINE DCB14_[DCB2_@CAM.I+2]+12 !ADDRESS OF RECORD COUNT, TYPE ! PLIST_[NFI,NFA_@LIS+1]+3 !GET PARAMETER ADDRESSES. IFNOT $NFA THEN $NFA_ -1 !MAKE UNIFORM BACK UP IF $NFA < 0 THEN [ \IF WE ARE GOING BACK BADFILE: PTR_P.TR+6*($NFA-1); \PULL GOODIES FROM IF PTR < @CAMS. THEN PTR _ @CAMS.; \IF TOO FAR, GO TO FIRST RC_ $([CR_[NFI_PTR+1]+3]+2); \SET REST OF STACK IF N.OPL < 0 THEN RC_RC+N.OPL; \IF BACK SPACE REQUESTED IF RC < 0 THEN RC_0; \SET IT UP RS_$[P.TR_PTR]], ^   \LOOKS GOOD LETS BUY IT ELSE [ \GOING FORWARD RC_0; \SET POINTERS FOR RETURN CR,PTR_@N.OPL; \AND THE CALL IF P.TR-@CAMS. > 48 THEN [ \IF TOO DEEP ERR _ 13; RETURN] \TAKE GAS. ] !LOOKS GOOD , LETS DO IT CALL GLOBS(N-1,$PLIST,1) ? \SET UP GLOBALS. [ERR _ 48; RETURN] !ERROR IN GLOBAL SET. OPEN.(CAM.I,$NFI,$CR ,411K) !OPEN NEW INPUT FILE. IF .E.R < 0 THEN[ \IF ERROR AND HERE THEN SV>3 N.OPL,$NFA_0;GO TO BADFILE] !MUST REOPEN ORGIONAL FILE $PTR_RS !RESET RECORD COUNT IF RC THEN [ \IF NEEDED. IF $DCB2 THEN[ \(MUST NOT BE TYPE ZERO) UNTIL $DCB14 = RC DO [ \READ AS MANY RECORDS READF(CAM.I,.E.R ,C.BUF,1); \AS NECESSARY FOR IER.]]] !POSITIONING. RETURN END ! END END$   92070-18036 1941 S C0122 &??..              H0101 P:ASMB,R,L,C HED FMGR ERROR EXPANDER MODULE PART OF RTE FMP * NAME: ??.. * SOURCE: 92070-18036 * RELOC: 92070-16036 * PGMR: G.A.A. * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * NAM ??..,8 92070-1X036 REV.1941 790803 ENT ??.. EXT REIO,TMP.,WRITF,O.BUF,.ENTR,P.6,.E.R EXT CAM.O,IER.,BUF. EXT FM.AB,OPEN. SUP N NOP LST NOP SPC 1 ??.. NOP ENTRY POINT JSB .ENTR GEN PRAMS DEF N SPC 1 LDB P.6 GET ERROR PRAM ASR 16 EXTEND THE SIGN BIT DIV .1000 DIVIDE LDA B ERROR CODE TO A LDB LST,I GET FLAG ISZ LST STEP TO SZB IF NOT SUPPLIED USE .E.R LDA LST,I ELSE USE FIRST PRAM CPA AL IF PRAM = ALL JMP ALL THEN PRINT ALL CODES ON LIST CPA .99 IF PRAM=99 JMP ALL THEN PRINT ALL CODES ON LIST STA N SAVE CODE ADA MOSNG TEST FOR SSA DEFINED CODE JMP UDF TOO NEGATIVE LDA N GET ERROR CODE AGAIN ADA NMPOS TEST FOR TOO HIGH SSA,RSS JMP UDF TO HIGH - UNDEFINED PRINT LDA N GET N ALS DOUBLE ADA TBAD ADD TABLE ADDRESS PR LDB A,I GET MESSAGE ADDRESS STB MSAD SET AS POINTER INA GET LDB A,I MESSAGE STB A LENGTH CMA,INA SET FOR STA N MOVE ADB .2 AND STB LST OUTPUT DLD FMGR SET FMGR BF DST BUF. AT LDA BUF.D HEAD RSS LDA A,I OF RAL,CLE,SLA,ERA MESSAGE JMP *-2 GET ADA .2 BUFFER ADDRESS AND MOVE LDB MSAD,I MOVE STB A,I MESSAGE INA TO ISZ MSAD THE ISZ N BUFFER JMP MOVE JSB REIO PRINT DEF FMRTN ON DEF .2 LOG DEF CAM.O BUF.D DEF BUF. DEVICE DEF LST FMRTN LDB P.6 IF CLA CLEAR ERROR CODE STA P.6 CPB .60 60 JMP FM.AB THE ABORT JMP ??..,I ELSE, RETURN SPC 2 UDF LDA DFUDF PICK UNDEFINED JMP PR AND SEND IT. SKP ALL LDA TMP.D RSS POSSIBLE LDA A,I ERROR RAL,CLE,SLA,ERA CODES. JMP *-2 GET PARAMETER ADA .3 ADDRESS STA LST AND JSB OPEN. OPEN DEF OPRTN LIST DEF O.BUF FILE TMP.D DEF TMP. DEF LST,I DEF .0 OPRTN DLD PTRS SET THE DST CPTRS POINTERS FOR LENGTH/BUFFER AD WRIT LDA CPTRS GET CURRENT ERROR RAL,CLE,ERA CLEAR INDIRECT BIT LDA A,I GET MESSAGE ADDRESS CPA AUDN EQUAL TO UNDEFINED? JMP NEXT YES, DON'T PRINT JSB WRITF WRITE DEF WRRTN THE DEF O.BUF MESSAGE DEF .E.R ON CPTRS NOP THE NOP LIST WRRTN JSB IER. DEVICE NEXT LDA CPTRS+1,I IF CURRENT LENGTH SSA NEGATIVE THEN JMP FMRTN DONE - RETURN. ISZ CPTRS ISZ CPTRS STEP THE ISZ CPTRS+1 ISZ CPTRS+1 BUFFER AND LENGTH POINTERS JMP WRIT ELSE GO WRITE NEXT MESSAGE SPC 3 .1000 DEC 1000 .99 DEC 99 .2 DEC 2 .3 DEC 3 .60 DEC 60 AL ASC 1,AL SPC 1 A EQU 0 B EQU 1 MSTN EQU 103 MOST NEGATIVE ERROR CODE MPOS EQU 62 HIGHEST ERROR CODE MOSNG ABS MSTN MOST NEG. CODE NMPOS ABS -MPOS-1 NEG. OF MOST POSITIVE SPC 1 BFPT NOP MSAD NOP DFUDF DEF *+1 DEF UDN ABS LUDN FMGR ASC 2,FMGR TBAD DEF MS00 PTRS DEF LSHED,I DEF LSHED+1 SKP LSHED DEF HEAD THIS LIST ABS LHEAD IS IN DEF BLNK THE ABS LBLNK ORDER DEF HD2 OF ABS LHD2 PRINTING DEF BLNK AND ABS LBLNK ALSO SPC 2 DEF EM103 ABS LM103 DEF EM102 ABS LM102 DEF EM101 ABS LM101 DEF EM100 ABS LM100 DEF ERM99 ABS LM99 DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF ERM46 ABS LM46 DEF ERM45 ABS LM45 DEF ERM44 ABS LM44 DEF ERM43 ABS LM43 DEF ERM42 ABS LM42 AUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF ERM38 ABS LM38 DEF ERM37 ABS LM37 DEF ERM36 ABS LM36 DEF UDN ABS LUDN DEF UDN ABS LUDN DEF ERM33 ABS LM33 DEF ERM32 ABS LM32 DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF ERM18 ABS LM18 DEF ERM17 NUMERICAL ABS LM17 ORDER DEF ERM16 ABS LM16 DEF ERM15 ABS LM15 DEF ERM14 ABS LM14 DEF ERM13 ABS LM13 DEF ERM12 ABS LM12 DEF ERM11 ABS LM11 DEF ERM10 ABS LM10 DEF ERM9 ABS LM9 DEF ERM8 ABS LM8 DEF ERM7 ABS LM7 DEF ERM6 ABS LM6 DEF ERM5 ABS LM5 DEF ERM4 ABS LM4 DEF ERM3 ABS LM3 DEF ERM2 ABS LM2 DEF ERM1 ABS LM1 MS00 DEF ER0 ABS L0 DEF ER1 ABS L1 DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF ER6 ABS L6 DEF ER7 ABS L7 DEF UDN ABS LUDN DEF UDN ABS LUDN DEF ER10 ABS L10 DEF UDN ABS LUDN DEF ER12 ABS L12 DEF ER13 ABS L13 DEF ER14 ABS L14 DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF ER18 ABS L18 DEF ER19 ABS L19 DEF ER20 ABS L20 DEF ER21 ABS L21 DEF ER22 ABS L22 DEF ER23 ABS L23 DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF ER33 ABS L33 DEF ER34 ABS L34 DEF ER35 ABS L35 DEF ER36 ABS L36 DEF ER37 ABS L37 DEF ER38 ABS L38 DEF ER39 ABS L39 DEF ER40 ABS L40 DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF UDN ABS LUDN DEF ER48 ABS L48 DEF ER49 ABS L49 DEF ER50 ABS L50 DEF ER51 ABS L51 DEF UDN ABS LUDN DEF ER53 ABS L53 DEF UDN ABS LUDN DEF ER55 ABS L55 DEF ER56 ABS L56 DEF ER57 ABS L57 DEF UDN ABS LUDN DEF UDN ABS LUDN DEF ER60 ABS L60 DEF ER61 ABS L61 DEF ER62 ABS L62 DF100 DEF EM100 EOF RECORD DEC -1 .0 NOP END OF THE LIST SKP * ERROR TABLE -CODESH ARE ENTERED IN ANY ORDER. ER0 ASC 5, 000 BREAK L0 EQU *-ER0 ERM1 ASC 8, -01 DISC ERROR LM1 EQU *-ERM1 ERM2 ASC 12, -02 DUPLICATE FILE NAME LM2 EQU *-ERM2 ERM3 ASC 11, -03 BACKSPACE ILLEGAL LM3 EQU *-ERM3 ERM4 ASC 19, -04 MORE THAN 32767 RECORDS IN A TYPE ASC 20, 2 FILE OR IN USE OF A DOUBLE WORD CALL LM4 EQU *-ERM4 ERM5 ASC 13, -05 RECORD LENGTH ILLEGAL LM5 EQU *-ERM5 ERM6 ASC 10, -06 FILE NOT FOUND LM6 EQU *-ERM6 ERM7 ASC 14, -07 BAD FILE SECURITY CODE LM7 EQU *-ERM7 ERM8 ASC 16, -08 FILE OPEN OR LOCK REJECTED LM8 EQU *-ERM8 ERM9 ASC 19, -09 ATTEMPT TO USE APOSN OR FORCE TO ASC 8,1 A TYPE 0 FILE LM9 EQU *-ERM9 ERM10 ASC 13, -10 NOT ENOUGH PARAMETERS LM10 EQU *-ERM10 ERM11 ASC 9, -11 DCB NOT OPEN LM11 EQU *-ERM11 ERM12 ASC 11, -12 EOF OR SOF ERROR LM12 EQU *-ERM12 ERM13 ASC 8, -13 DISC LOCKED LM13 EQU *-ERM13 ERM14 ASC 10, -14 DIRECTORY FULL LM14 EQU *-ERM14 ERM15 ASC 9, -15 ILLEGAL NAME LM15 EQU *-ERM15 ERM16 ASC 14, -16 ILLEGAL TYPE OR SIZE=0 LM16 EQU *-ERM16 ERM17 ASC 19, -17 ILLEGAL READ/WRITE ON TYPE 0 FILE LM17 EQU *-ERM17 ERM18 ASC 21, -18 ILLEGAL LU. LU NOT ASSIGNED TO SYSTEM LM18 EQU *-ERM18 ERM32 ASC 12, -32 CARTRIDGE NOT FOUND LM32 EQU *-ERM32 ERM33 ASC 17, -33 NOT ENOUGH ROOM ON CARTRIDGE LM33 EQU *-ERM33 ERM36 ASC 13, -36 LOCK ERROR ON DEVICE LM36 EQU *-ERM36 ERM37 ASC 24, -37 ATTEMPT TO PURGE ACTIVE TYPE 6 OR SWAP FILE LM37 EQU *-ERM37 ERM38 ASC 16, -38 ILLEGAL SCRATCH FILE NUMBER LM38 EQU *-ERM38 ERM42 ASC 10, -42 SWAPPING ACTIVE LM42 EQU *-ERM42 ERM43 ASC 18, -43 SYSTEM DOES NOT ALLOW SWAPPING LM43 EQU *-ERM43 ERM44 ASC 15, -44 WRONG FILE TYPE FOR SWAP LM44 EQU *-ERM44 ERM45 ASC 12, -45 SWAP FILE TOO SMALL LM45 EQU *-ERM45 ERM46 ASC 15, -46 GREATER THAN 255 EXTENTS LM46 EQU *-ERM46 ERM99 ASC 22, -99 DIRECTORY MANAGER EXEC REQUEST ABORTED LM99 EQU *-ERM99 EM100 ASC 15,-100 BOOT DISC NOT INITIALIZED LM100 EQU *-EM100 EM101 tASC 18,-101 ILLEGAL PARAMETER IN D.RTR CALL LM101 EQU *-EM101 EM102 ASC 16,-102 ILLEGAL D.RTR CALL SEQUENCE LM102 EQU *-EM102 EM103 ASC 14,-103 DISC DIRECTORY CORRUPT LM103 EQU *-EM103 SPC 1 ER1 ASC 14, 001 DISC ERROR-LU REPORTED L1 EQU *-ER1 ER6 ASC 10, 006 FMGR SUSPENDED L6 EQU *-ER6 ER7 ASC 10, 007 CHECKSUM ERROR L7 EQU *-ER7 ER10 ASC 8, 010 INPUT ERROR L10 EQU *-ER10 ER12 ASC 16, 012 DUPLICATE DISC LABEL OR LU L12 EQU *-ER12 ER13 ASC 11, 013 TR STACK OVERFLOW L13 EQU *-ER13 ER14 ASC 17, 014 REQUIRED ID-SEGMENT NOT FOUND L14 EQU *-ER14 ER18 ASC 12, 018 PROGRAM NOT DORMANT L18 EQU *-ER18 ER19 ASC 20, 019 FILE NOT SET UP FOR CURRENT SYSTEM L19 EQU *-ER19 ER20 ASC 11, 020 ILLEGAL TYPE 0 LU L20 EQU *-ER20 ER21 ASC 14, 021 ILLEGAL DISC SPECIFIED L21 EQU *-ER21 ER22 ASC 10, 022 COPY TERMINATED L22 EQU *-ER22 ER23 ASC 14, 023 DUPLICATE PROGRAM NAME. L23 EQU *-ER23 ER33 ASC 18, 033 DISC HAS MORE THAN 1024 TRACKS L33 EQU *-ER33 ER34 ASC 26, 034 ATTEMPT TO CHANGE TIME WHEN TIME LIST NOT EMPTY L34 EQU *-ER34 ER35 ASC 21, 035 WRONG INTERFACE TYPE FOR REASSIGNMENT L35 EQU *-ER35 ER36 ASC 19, 036 TIME VALUES NOT ENTERED WITH 'IT' L36 EQU *-ER36 ER37 ASC 8, 037 DEVICE BUSY L37 EQU *-ER37 ER38 ASC 18, 038 ATTEMPT TO REMOVE ACTIVE TYPE 6 ASC 7, OR SWAP FILE L38 EQU *-ER38 ER39 ASC 11, 039 CANNOT RP PROGRAM L39 EQU *-ER39 ER40 ASC 22, 040 ANOTHER PROGRAM ALREADY IN MEMORY AREA L40 EQU *-ER40 ER48 ASC 14, 048 GLOBAL SET OUT OF RANGE L48 EQU *-ER48 ER49 ASC 14, 049 CAN'T RUN RP'ED PROGRAM L49 EQU *-ER49 ER50 ASC 13, 050 NOT ENOUGH PARAMETERS L50 EQU *-ER50 ER51 ASC 17, 051 ILLEGAL MASTER SECURITY CODE L51 EQU *-ER51 ER53 ASC 14, 053 ILLEGAL LABEL OR ILABEL L53 EQU *-ER53 ER55 ASC 11, 055 MISSING PARAMETER L55 EQU *-ER55 ER56 ASC 9, 056 BAD PARAMETER L56 EQU *-ER56 ER57 ASC 16, 057 BAD TRACK NOT IN FILE AREA L57 EQU *-ER57 ER0.*60 ASC 19, 060 DO YOU REALLY WANT TO PURGE THIS ASC 9,DISC? (YES OR NO). L60 EQU *-ER60 ER61 ASC 18, 061 DO A "DC" AND A "MC" ON THIS CR. L61 EQU *-ER61 ER62 ASC 15, 062 CARTRIDGE DIRECTORY FULL L62 EQU *-ER62 SPC 2 HEAD ASC 9, FMGR ERROR CODES LHEAD EQU *-HEAD HD2 ASC 9, ERROR MEANING LHD2 EQU *-HD2 BLNK ASC 1, LBLNK EQU *-BLNK UDN ASC 9, ERROR NOT DEFINED LUDN EQU *-UDN ORG * PROGRAM LENGTH END k0  92070-18037 2001 S C0122 &D.RTR              H0101 cASMB,R,L,C * NAME: D.RTR * SOURCE: 92070-18037 * RELOC: 92070-16037 * PGMR: G.A.A. MOD G.L.M. M.L.K. * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * NAM D.RTR,6,1 92070-16037 REV.2001 800103 * ENT D.RTR * EXT EXEC,$CDIR,$MDSP EXT $LIBR,$LIBX,$IDA,$IDSZ,$ID# * * SUP * RTE FMP DIRECTORY ROUTINE * * THIS PROGRAM IS THE CENTRAL MANAGER OF THE RTE FILE MANAGEMENT * SYSTEM. IT OWNS THE DIRECTORY AND PERFORMS ALL WRITES * ON IT. THIS PROGRAM MUST BE IN THE RESIDENT LIBRARY AND ONLY * ONE COPY CAN EXIST. * * PROGRAM WISHING TO ACCESS THE DIRECTORY * CALL THIS PROGRAM. * * CALLS ARE AS FOLLOWS (P1,P2... ETC. ARE THE PASSED PARAMETERS): * * * 1. OPEN * P0. OPEN FLAG * P1. FUNCTION CODE =9 * P2. -LU,+CR,0 * P3. E,NAME(1,2) E(BIT 15) INDICATES EXCLUSIVE OPEN IF SET * P4. 0,NAME(3,4) S(BIT 15) INDICATES SCRATCH FILE PURGE. * P5. 0,NAME(5,6) * * 2. CLOSE * P0. OPEN FLAG * P1. FUNCTION CODE =0 * P2. TR,LU * P3. OFFSET,SECTOR /DIRECTORY ADDRESS * P4. 0,-(NO. SECTORS TO BE DELETED),+ PURGE EXTENTS ONLY * * 3. CREAT * P0. OPEN FLAG * P1. FUNCTION CODE =1 * P2. -LU,+CARTRIDGE,0 * P3. NAME (1,2) * P4. NAME (3,4) * P5. NAME (5,6) * P6. TYPE \ TYPE=0 * P7. FILE SIZE \ 0 * P8. REC SIZE \ NOT PASSED * P9. SEC CODE \ NOT PASSED * * 4. CHANGE NAME * P0. OPEN FLAG * P1. FUNCTION CODE=2 * P2. TR,LU (FROM DCB WD 1) * P3. OFFSET,SECTOR (FROM DCB WD 2 OF FILE BEING RENAMED) * P4. NEW 6NAMME(1) * P5. NEW NAMME(2) * P6. NEW NAMME(3) * * 6. SET,CLEAR LOCK ON DISC * P0. OPEN FLAG * P1. FUNCTION = 3 FOR SET, 5 FOR CLEAR * P2. -LU,+CARTRIDGE (0 NOT LEGAL) DISC TO BE LOCKED * * 7. MOUNT,DISMOUNT,UPDATE CALL * P0. OPEN FLAG * P1. FUNCTION =7 * P2. -LU,+CR * P3. LU * P4. LAST TRACK * P5. CARTRIDGE REFERENCE * P6. LOCK WORD * P7. SUBFUNCTION CODE: -1=UPDATE DRN ONLY * 0=DISMOUNT CALL * -2=MOUNT CALL * * 8. EXTENSION OPEN * P0. OPEN FLAG * P1. FUNCTION CODE= 6(READ), 8(WRITE) * P2. TR,LU \ * P3. OFFSET,SECTOR \DIRECTORY ADDRESS OF MASTER ENTRY * P4. EXTENSION NUMBER * * 9. RETURN PARAMETERS * R1. ERROR CODE (IF POSITIVE, THEN # OF SECTORS IN FILE) * R2. TR,LU * R3. OFFSET,SECTOR * R4. TR (LU IF TYPE 0) * R5. NUMBER OF SECTORS/TRACK * * * ROUTINES WHICH CALL D.RTR: * OPEN LOCK. * CLOSE MCDC. * CREAT CR.. * CRETS CREA. * NAMF SKP * * WORD FORMATS FOR DOUBLE DUTY WORDS * * 15...6 5..0 15...8 7...0 15...8 7...0 * TRACK ^ LU OFFSET^SECTOR #SEC/TR^SECTOR * * ERROR CODES * 12 DUPLICATE CRN ON MOUNT * 0 NO ERROR * -1 DISC DOWN * -2 DUPLICATE NAME * -5 READ EXTENT OPEN AND EXTENT NOT FOUND * -6 FILE NOT FOUND * -8 FILE IS CURRENTLY OPEN (ALSO FOR REJECT LOCK) * -11 FILE NOT OPEN (CLOSE) * -13 DISC LOCKED * -14 DIRECTORY FULL * -16 ILLEGAL TYPE OR SIZE = 0 * -32 DISC CARTRIDGE NOT FOUND * -33 NOT ENOUGH ROOM ON DISC CARTRIDGE * * -100 BOOTUP AND LU 2 DOES NOT REFERENCE INITIALIZED * FMGR DISK * -101 ILLEGAL PARAMETERS IN CALL * -102 ILLEGAL CALL SEQUENCE (LOCK NOT REQUESTED FIRST) * -103 DISC DIRECTORY CORRUPT * * * * OPEN FLAG FORMAT: * ------------------------------------- * !EX! SEQ ! CPU ! ID SEG # ! * ------------------------------------- * 15 14 11 10 8 7 0 * * WHERE: * EX = EXCLUSIVE BIT * SEQ = SEQUENCE COUNT FROM ID SEGMENT * ID SEG# = ID SEGMENT NUMBER (1 TO N) * CPU = RESERVED SKP D.RTR NOP ENTRY POINT JSB $LIBR CALL SYSTEM AS DEF TDB A RE-ENTRANT SUBROUTINE * LDA OFTST GET OFF TEST FLAG SZA,RSS COMPLETED NORMALLY LAST TIME? JMP ENTRD YES, CONTINUE * CLA NO, SET UP TO CLEAR STA RDPS ALL TEMPOYARY LDA RDPSA AND IN CORE LDB A GET SAME ADDRESS INB AND INCREMENT BY ONE CCE AND FLAGS JSB MOVE DEC -20 * ENTRD CCA SET OFF TEST FLAG STA OFTST TO "ENTERED" LDA RTNAD,I GET ADDRESS OF PASSED PARAMETERS ISZ RTNAD POINT TO RETURN PARAMETERS LDB IDA SET DESTINATION ADDRESS FOR MOVE CCE SET E=1 TO MOVE PARAMETERS JSB MOVE NOW MOVE THEM DEC -12 MOVE THE FIRST 12 * LDA RTNAD,I GET ADDRESS OF THE RETURN BUF STA ADRTN AND STORE IT ISZ RTNAD NOW POINT TO RETURN ADDRESS * LDA $CDIR GET FIRST WORD OF DIRECTORY TABLE SSA IF IT IS NEG INITR JMP INIT THEN GO INITIALIZE DISC * CLB STB FIRST CLEAR THE FIRST FLAG STB TMP1 * * FETCH ADDRESS OF CARTRIDGE DIRECTORY. * LDA CRDIR SET LOCK SEARCH FOR FIRST STA DIRAD ENTRY SKP * THE LOCK ROUTINE SEARCHES THE DISC DIRECTORY FOR THE * REFERENCED DISC. * * FOR THE FIRST CALL DIRAD SHOULD POINT AT THE * DFIRST WORD IN $CDIR. SUBSEQUENTLY LOCK * WILL UPDATE DIRAD EACH CALL. * * WITH THE EXCEPTION OF THE DISC DIRECTORY UPDATE THE DISC * MUST BE FOUND. IN THIS CASE, EXIT IS TO THE CREAT ROUTINE * * ON EXIT ATRAK CONTAINS THE DIRECTORY TRACK * ALU CONTAINS THE DIRECTORY LU * A CONTAINS THE LOCK WORD * * ON SUBSEQUENT CALLS IF THE DISC ID WAS 0, THE NEXT * DISC IS RETURNED. IF THE DISC ID WAS NOT 0, * A NOT FOUND EXIT IS TAKEN. * NEXT LDA P2 FETCH LU LDB P1 FETCH FUNCTION CCE,SLB,RSS IS FUNCTION EVEN? JMP LOCK3 YES; GO EXTRACT LU CMA,CCE,SSA,INA E_0 INDICATES CARTRIDGE LABEL CMA,CLE,INA E_1 INDICATES LU(SET +) LDB TMP1 GET PREVIOUS ID STA TMP1 STORE ID CME,SZB IF NOT A ZERO, ID ON SECOND JMP CKERR GO DETERMINE WHAT ERROR TYPE SPC 1 RAL,ERA SET SIGN BIT IF A LABEL SEARCH STA TMP2 AND SET FOR COMPARE SPC 1 LOCK6 LDA TMP2 SET THE FOUND BIT IN E IF CMA,CLE,INA A ZERO ID LDB DIRAD GET CURRENT DIRECTORY ADD. LOCK2 CPB $MDSP END OF DIRECTORY? JMP LOCK5 YEP--GO CHECK FOR TYPE 7 CALL LDA B,I GET FIRST WORD SZA,RSS IF 0 THEN END JMP LOCK5 SO GO CHECK FOR DIRECTORY UPDATE STA ALU ELSE SAVE LU CPA TMP2 IS THIS THE REQUIRED DISC? CCE YES SET E TO 1 TO INDICATE FOUND INB STEP TO TRACK ADDRESS AND LDA B,I SET STA ATRAK IN ATRAK INB STEP TO LDA B,I LABEL AND FETCH IOR SIGN SET SIGN FOR COMPARE SEZ,INB,RSS STEP TO LOCK ADDRESS SKIP IF FOUND CPA TMP2 IS THIS THE REQUESTED DISC? JMP LOCK4 YES; GO EXIT INB NO; STEP TO NEXT ONE JMP LOCK2 AND GO CHECK IT SPC 2 * LU AND TRACK IN (A) * LOCK3 _AND B77 MASK TO LU STA TMP2 SAVE LU STA B SAVE LU IN B FOR TEST XOR P2 MASK TO TRACK ALF,RAL ROTATE TO RAL,ALF LOW A AND STA DITR SAVE THE TRACK JMP LOCK6 GO LOOK FOR DISC SPC 1 B77 OCT 77 SPC 1 LOCK4 STB DIRAD FOUND LDA B,I LOCK TO A * JSB VALID GO CHECK VALIDITY OF LOCK WORD RSS VALID RETURN STA DIRAD,I NOT VALID, CLEAR LOCK WORD ISZ DIRAD UPDATE DIRECTORY PTR FOR NEXT SEARCH SZA IF NOT LOCKED CPA ID OR LOCKED TO CALLER JMP DECOD SKIP LDA TMP1 ELSE IF SZA,RSS MULTI-DISC SEARCH JMP NEXT CONTINUE JMP EX13 ELSE EXIT LOCKED DISC SPC 2 DECOD CCA SET THE NONE FOUND YET STA R1 FOR RE-USABLE DISC SPACE ROUTINE (CKRUS) LDA P1 FETCH FUNCTION CODE SSA CHECK REQUEST CODE JMP EX101 NEGATIVE - EXIT ADA N10 SSA,RSS JMP EX101 GREATER THAN 9 - EXIT ADA TABAD INDEX INTO THE FUNCTION JMP A,I GO EXECUTE THE FUNCTION SPC 2 TABAD DEF TABA+10 TABA JMP CLOSE 0 CLOSE JMP CREAT 1 CREATE JMP CNAM 2 CHANGE NAME JMP RLOCK 3 LOCK DISC JMP EX101 4 ERROR JMP ULOCK 5 UNLOCK DISC JMP EXOPN 6 EXTENT OPEN JMP MDUDT 7 MOUNT, DISMOUNT, UPDATE JMP EXOPN 8 EXTENT OPEN JMP OPEN 9 OPEN SKP * OPEN ACTION ROUTINE * * OPEN DLD P4 SET NAME WORDS 2 AND 3 ELA,CLE,ERA CLEAR POSSIBLE SCRATCH PURGE BIT DST NAME+1 INTO THE NAME BUFFER LDA P3 SET NAME WORD1 RAL,CLE,ERA LESS POSSIBLE SIGN BIT STA NAME INTO THE NAME BUFFER JSB SETDR SET UP TO READ THE DIRECTORY JSB N.SHR GO FIND THE FILE JMP NEXT NOT FOUND - TRY NEXT DISC JSB SETAD FOUND - GO SET THE ADDRESSES JSB FLAG CHECK THE OPEN FLAGS LDB COUN2 IF 7 OPENS * * IF SCRATCH PURGE MUST HAVE CLEARED SC PU BIT EARLIER * NOW MUST MAKE SURE ONLY 1 PROG OPEN TO IT(ELSE EX 101?) * THEN CLEAR OPEN FLAG * JMP PURGE * LDA P4 FETCH POSSIBLE SCR PURGE FLAG SSA,RSS IF SIGN NOT SET JMP OPEN1 CONTINUE ADB N2 ELSE, FORCE PURGE - CHECK OPEN FLAG COUNT SSB,RSS IF JUST ONE, OK JMP EX101 ELSE EXIT MORE THAN 1 PROG OPEN TO IT CLA STA FLAGA,I CLEAR FLAG,IF ANY JMP PURGE * OPEN1 CPB .7 THEN NO ROOM SO JMP EX8 EXIT LDA P3 IF EXCLUSIVE OPEN CLE,SSA,RSS THEN SKIP JMP OPEN3 NON EXCLUSIVE SKIP CCE,SZB IF ANY OPENS THEN JMP EX8 REJECT EXCLUSIVE OPEN OPEN3 LDB SC GET THE FLAG ADDRESS LESS ONE OPEN5 INB SEARCH FOR OPEN SPOT IN FLAG LIST LDA B,I GET FLAG WORD SSA IF SIGN BIT SET THEN JMP EX8 FILE IS EXCLUSIVELY OPEN TO SOME ONE SZA THIS WORD? JMP OPEN5 NO; GO TRY NEXT ONE LDA ID YES; GET THE ID ADDRESS RAL,ERA SET THE EXCLUSIVE/NON-EXCLUSIVE STA B,I FLAG AND PUT IN THE DIRECTORY STA WCS SET TO WRITE THE BLOCK OPEN4 LDA TYPE,I SET UP THE RETURN PARAMETERS SZA IF TYPE ZERO SEND BACK ZERO CODE LDA #SEC,I ELSE SEND BACK THE FILE SIZE JMP CREX SKP * * EXTENT OPEN ACTION ROUTINE * * EXOPN JSB DIRCK GO READ IN THE MASTER DIRECTORY ENTRY CLA CLEAR THE STA ID OPEN FLAG WORD LDA P4 SET THE SZA,RSS IF AFTER THE MAIN THEN JMP OPEN4 WE HAVE IT ALREADY * AND B377 EXTENT NUMBER > 255? CPA P4 ALF,SLA,ALF EXTENSION NUMBER FOR POSSIBLΔE JMP EX46 ERROR, TOO MANY EXTENTS * STA GSEC EXTENSION CREAT JSB EXSHR SEARCH FOR THE REQUIRED EXTENT JMP EXOPT NOT FOUND SO GO TEST IF READ ALF,ALF EXTENT NO TO A AND B377 MASK CPA P4 THIS IT? JMP OPEN4 YES SO GO RETURN THE PRAMS CSER LDA TYPE NO SO CONTINUE JMP NSHR4 THE SEARCH SPC 1 EXOPT LDB P1 IF EXTENT OPEN IS FOR CPB .8 WRITE THE GO CREAT THE EXTENT JMP CREA0 GO EXIT LDA N5 ELSE RETURN ILLEGAL RECORD ERROR JMP CREX GO EXIT SPC 2 N2 DEC -2 SKP * * CLOSE ACTION ROUTINE * * CLOSE JSB DIRCK CLOSE; GET THE SECTOR LDA N7 SET FOR 7 ENTRIES CLOS1 LDB FLAGA,I FIND RBL,CLE,ERB CALLERS CPB ID FLAG JMP CLOS2 FOUND ISZ FLAGA NOT; YET TRY NEXT ONE INA,SZA MORE? JMP CLOS1 YES; OK JMP EX11 NO; ERR - NOT OPEN TO CALLER SPC 2 CLOS2 CLA FOUND; CLEAR THE STA FLAGA,I FLAG LDA P4 GET TRUNCATE CODE SZA IF ZERO THEN SKIP NO ACTION SEZ,RSS EXCLUSIVE OPEN? JMP EXIT3 NO; EXIT SSA,RSS IF POSITIVE THEN JMP EXPUR GO PURGE THE EXTENTS ADA #SEC,I CALCULATE NEW FILE SIZE SLA,RSS IGNOR IF ODD SECTOR COUNT SSA IF RESULT LESS THAN ZERO JMP EXIT3 THEN IGNOR IT CCE,SZA,RSS IF ZERO JMP PURGE GO PURGE STA TMP2 SAVE THE NEW SIZE JSB LAST? LAST FILE? CLE,RSS NO, CLEAR E SKIP CCE YES; SET E LDA TMP2 SET THE NEW SIZE STA #SEC,I IN THE DIRECTORY SEZ,RSS IF NOT THE LAST ENTRY JMP EXPUR GO PURGE ANY EXTENTS JMP PURG8 ELSE GO UPDATE DISC PRAMS SKP * * PURGE (PART OF CLOSE) * * PURGE CCA STkA DIRA,I SET PURGE FLAG JSB LAST? LAST FILE? JMP EXPUR NO; GO CHECK FOR EXTENTS PURG2 STA DIRA,I MAKE ENTRY AVAILABLE LDA DIRA IS THIS THE FIRST STA WCS SET TO WRITE CURRENT BLOCK CPA ABUF ENTRY IN THE CURRENT BLOCK? JMP PURG5 YES; GO READ PREVIOUS BLOCK PURG7 ADA N16 NO; BACK UP TO PREVIOUS JSB SETAD ENTRY; FIND FIRST UNPURGED LDB TYPE,I CHECK TYPE LDA DIRA,I ENTRY SZB TYPE ZERO - IF SO SKIP INA,SZA,RSS PURGED? JMP PURG2 YES; TRY PREVIOUS ENTRY SPC 1 SSA FOUND ENTRY - IS IT THE JMP PURG3 DISC SPEC ENTRY? - YES JUMP PURG8 JSB NXT/S NO; CACULATE THE NEXT TRACK AND SECT JMP CREA6 GO SET, WRITE & EXIT SPC 2 PURG3 LDA TRAKA,I SET TO SHOW CLB NEXT AVAILABLE SECT JMP CREA6 IS FIRST SECTOR SPC 1 PURG5 JSB WCSR WRITE CURRENT SECTOR LDB SECT GET SECTOR ADDRESS SZB,RSS IF START OF TRACK ISZ TRACK DIRECTORY TRACK ADB N14 SUBTRACT 14 SECTORS SSB IF NEGATIVE THEN ADB ##SEC ADD THE NO. PER TRACK STB SECT SET NEW SECTOR ADDRESS JSB RWSUB READ THE BLOCK LDA ABUF SET ADDRESS FOR ADA .128 LAST ENTRY JMP PURG7 IN THE BLOCK SPC 2 EXPUR JSB EXSH SEARCH FOR EXTENTS TO PURGE JMP PURGE GO PURGE EXTENT SPC 2 N14 DEC -14 SKP * * * CREATE ACTION ROUTINE * * CREAT LDA ID SET UP EXCLUSIVE OPEN FLAG IOR SIGN ADD THE EXCLUSIVE BIT STA ID SAVE IT CLA,CLE CLEAR THE EXTENT FLAG STA GSEC SAVE IT FOR THE DIRECTORY CPA P7 IS SIZE = 0 ? CPA P6 YES, IS IT TYPE 0? RSS ITS OK, CONTINUE JMP EX16 ZERO LENGTH FILE, ILLEGAL! * * LDA P3A MOVE IT ^JSB MOVE1 THE SAVE AREA JSB SETDR SET TO READ THE DIRECTORY JSB N.SHR SEARCH FOR THE NAME CREA0 CCE,RSS NOT FOUND SKIP JMP EX2 FOUND - TAKE DUP NAME EXIT * LDB R1 WAS A RE-USABLE ENTRY FOUND? SSB,RSS WELL! JMP RUSE YES, GO SET IT UP * SZA DIRECTORY FULL? JMP CRSET NO, GO SET UP ADDRESSES LDB TMP1 GET DISC SPECS SZB MULTI DISC SEARCH? JMP EX14 NO, REPORT DIRECTORY FULL LDA P1 GET FUNCTION CODE CPA .8 IS IT EXTENT WRITE (CREATE) JMP EX14 YES, EXIT DIRECTORY FULL JMP NEXT NO, GO TRY NEXT DISC * CRSET JSB SETAD SET THE ADDRESSES CCE LDA DIRA MOVE IN JSB MOVE1 LDA ID SET THE OPEN FLAG STA FLAGA,I LDB BTRA SET THE BAD TRACK POINTER CHKBT LDA B,I IF END OF LIST SZA,RSS THEN JMP EOL CONTINUE CMA,CLE ELSE SET ADA NXTR BADTR TO SEZ,RSS POINT TO JMP EOL FIRST BAD TRACK INB => NXTR JMP CHKBT EOL STB BADTR SET BAD TRACK POINTER LDB NXSEC GET THE NEXT TRACK LDA NXTR AND SECT CREA1 STA TRAKA,I SET THE TRACK ADB GSEC ADD THE EXTENT WORD STB SECTA,I SET THE SECT/EXTENT LDB #SEC,I GET REQUESTED FILE SIZE LDA BADTR,I AND THE FIRST BAD TRACK SZA IF GOOD SKIP SSB,RSS ELSE IF REST OF DISC SKIP JMP CREA2 GO CALCULATE SIZE CREA3 INA BAD TRACK ON REST OF DISC RQ ISZ BADTR SET FILE ABOVE IT AND CLB TRY AGAIN JMP CREA1 SPC 2 CREA2 SSB IF REST OF DISC JMP CREA5 JMP * CREA7 JSB NXT/S COMPUTE THE NEXT TRACK AND SECTOR STA SETAD SECTOR - SAVE LAST TRACK LDA BADTR,I GET LAST AVAILABLE TRACK SZA,RSS IF NTOT BAD LDA LASTR THE LAST ON DISC+1 CMA SUBTRACT FROM SZB BUMP TRACK INA IF SOME OF IT USED ADA SETAD LAST FILE TRACK SSA 0 OR +? JMP CREA4 YES; IT FITS LDA BADTR,I NO; WON'T FIT SZA WAS IT A BAD TRACK? JMP CREA3 YES; TRY ABOVE IT * STA DIRA,I NO CLEAR THE ENTRY FROM BUFFER LDA GSEC IF EXTENT CREAT SZA,RSS THEN SKIP TO ERROR EXIT JMP NEXT ELSE TRY NEXT DISC JMP EX33 NO ROOM FOR EXTENT EXIT SPC 1 CREA4 LDA SETAD IT FIT SO CREA6 STA NXTR UPDATE THE NEXT STB NXSEC TRACK AND SECTOR ISZ WCS SET THE WRITE FLAG LDA #SEC,I GET THE RETURN PRAM JSB RPRM AND GO SET UP THE RETURN CCA SET FIRST TO AVOID STA FIRST RESETING THE #SECTORS/TRACK JSB SETDR SET UP TO READ FIRST STA FIRST DIRECTORY BLOCK JSB RDNXB READ IT .2 DEC 2 CCE MOVE NEW JSB DPMM NEXT TRACK AND SECT WORDS ISZ WCS IN - SET TO WRITE JMP EXIT AND EXIT SPC 1 CREA5 LDA TRAKA,I REQUEST FOR REST OF DISC CMA,INA COMPUTE THE ADA LASTR NUMBER OF LDB SECTA,I GET THE NUMBER OF SECTORS CMB,INB USED THIS TRACK STB TMP3 AND SAVE MPY ##SEC SECTORS ADA TMP3 SUBTRACT NUMBER USED THIS TRACK SZB,RSS IF MORE THAN 32K SSA THEN LDA MAXSZ SET TO MAX ALLOWABLE(32K) STA #SEC,I SET IN THE FILE ENTRY SZA IF NON-ZERO JMP CREA7 GO WRAP IT UP * STA DIRA,I CLEAR ENTRY JMP NEXT TRY NEXT DISC SPC 3 * * WE HAVE A RE-USABLE ENTRY IN THE DIRECTORY AND WE NEED IT * SO THE DIRECTORY BLOCK IS READ BACK IN (IF REQUIRED) AND * THE ENTRY IS SET UP. * RUSE STB TRACK B HAS TR5ACK FROM EXISTANCE TEST LDB R2 GET THE SECTOR AND STB SECT SET IT JSB RWSUB READ THE BLOCK TO CORE IF REQUIRED LDA N16 GET THE OFFSET (IT WAS SAVED +16) ADA R3 AND SET UP THE ADDRESSES JSB SETAD LDA TRAKA,I SET THE FILE ADDRESSES STA NAME+4 IN THE ENTRY LDA SECTA,I AND B377 PURGE POSSIBLE EXTENT FLAG ADA GSEC ADD IN POSSIBLE NEW EXTENT FLAG STA NAME+5 LDA DIRA MOVE THE ENTRY INTO THE BUFFER CCE JSB MOVE1 LDA ID SET POSSIBLE OPEN FLAG STA FLAGA,I IN THE ENTRY ISZ WCS SET THE WRITE FLAG LDA #SEC,I SEND BACK THE FILE SIZE JMP CREX EXIT SPC 2 MAXSZ OCT 77776 SKP * * CHANGE NAME ACTION ROUTINE * * CNAM LDA P4A MOVE NEW NAME TO CLE GO THE RIGHT WAY JSB MOVE2 LOCAL SAVE AREA LDA P4A SET UP THE NAME CLE SET ADDRESSES JSB MOVE1 FOR DUP CHECK JSB SETDR SET UP TO READ THE DIRECTORY JSB N.SHR SEARCH FOR DUPLICATE NAME RSS NOT FOUND SO SKIP JMP EX2 TAKE DUP NAME EXIT JSB DIRCK GO GET DIRECTORY ENTRY LDA FLAGA,I OPEN EXCLUSIVELY RAL,CLE,ERA CLEAR EXCLUSIVE BIT AND SAVE IN E CPA ID TO CALLER? SEZ,CCE,RSS YES SKIP JMP EX102 NO; REJECT CNAM1 LDA DIRA YES; MOVE JSB MOVE2 THE NEW NAME IN JSB EXSH SEARCH FOR EXTENT OF THIS FILE JMP CNAM1 YES GO SET NEW NAME SKP * * LOCK ACTION ROUTINE * * RLOCK LDA TMP1 DISC MUST BE SPECIFIED SZA,RSS JMP EX101 NOT SPECIFIED - EXIT * JSB TSTDR TEST LEGAL DIRECTORY JMP ROCK4 NOT LEGAL, ALLOW LOCK BUT RETURN -103 SZA ANY OPEN FLAGS? JMP EX8 YES, DON'T ALLOW LOCK SPC 2 ROCK4 STA R1 SAVE ERRpWOR CODE LDB DIRAD LOCK GRANTABLE ADB N1 BACK UP TO LOCK WORD LDA ID USE ID ADDRESS AS LOCK WORD STA B,I STORE IN LOCK WORD LDA R1 GET ERROR CODE IN A JMP CREX EXIT SKP * * UNLOCK ACTION ROUTINE * * ULOCK CLA FORCE A NEW READ STA LDRLU OF THE DIRECTORY JSB TSTDR TEST DIRECTORY JMP CREX CORRUPT! EXIT CLA CLEAR ID FOR STORE STA ID INTO CARTRIDGE DIRECTORY JMP ROCK4 AND GO SET IT SKP * * MOUNT ACTION ROUTINE * * LOCK5 LDA P7 FETCH SUBFUNCTION CODE LDB P1 FETCH FUNCTION CPB .7 IF MASTER DIRECTORY UPDATE, SSA,RSS AND NOT "DC" CALL--CONTINUE JMP CKER ELSE EXIT--AND DETERMINE ERR TYPE * * THIS IS THE WAY "IN" (DISC REF UPDATE) AND MOUNT * CARTRIDGE GET IN. * LDB CRDIR FETCH MASTER DIRECTORY ADDRESS CPA N1 IF SUBFUNCTION=-1 JMP MDNXT THEN GO UPDATE DISKETTE REF * * ELSE DO MOUNT WORK * FIRST SEARCH FOR DUPLICATE LABEL * LOCK ROUTINE HAS ALREADY SEARCHED FOR DUPLICATE LU. * IF FOUND WILL GO TO MDUDT * MCLB? LDA B,I FETCH FIRST ENTRY SZA,RSS END? JMP OKMC YEP--B=AVAILABLE SPACE * ADB .2 ADVANCE TO LABEL LDA B,I FETCH IT CPA P5 MATCH? JMP EX12 YES--DUPLICATE LABEL EXIT * ADB .2 ADVANCE TO NEXT ENTRY CPB $MDSP OUT OF ROOM? JMP EX14 YEP-BYE BYE JMP MCLB? GO CHECK THIS ENTRY * * * B=DESTINATION ADDRESS * OKMC LDA P3A FETCH ADDRESS OF NEW DIRECTORY ENTRIES JSB $LIBR GO PRIVILEDGED TO AVOID PROBLEMS NOP WITH BEING OFF'D * MV4 CCE SET E TO MOVE PARAMETERS JSB MOVE GO MOVE IT DOWN N4 DEC -4 JSB $LIBX FINISHED WITH PRIVILEDGED DEF *+1 PR_OCESSING DEF EXIT4 OK-- ALL DONE SO EXIT SPC 2 .7 DEC 7 SKP * * UPDATE ACTION ROUTINE * * * UPDATE DISC REFERENCE # * A CHECK FOR DUPLICATE LABEL HAS JUST BEEN DONE IN LOCK * NOW JUST FIND THE CORRECT LU AND DROP THE NEW LABEL IN. * * MDNXT LDA B,I FETCH FIRST ENTRY CPA P3 THIS THE RIGHT LU? JMP GTIT YUP YUP YUP * ADB .4 NOPE--SO ADVANCE TO NEXT ENTRY CPB $MDSP END OF DIRECTORY JMP EX32 DISC NOT FOUND EXIT JMP MDNXT GO CHECK THIS ONE * * GTIT ADB .2 ADVANCE TO LABEL WORD LDA P2A,I ADDRESS OF WORD HOLDING NEW LABEL * STA B,I JMP EXIT4 SPC 2 .4 DEC 4 SKP * * DISMOUNT ACTION ROUTINE * * MDUDT LDA P7 FETCH SUBFUNCTION SZA THIS ENTRY IS USED BY "DC" ONLY JMP EX12 DUPLICATE LU OR LABEL * * LDB ALU IF SAME LU AS LAST ONE REF CPB LDRLU CLEAR IT TO PREVENT STA LDRLU MISTAKEN ID. * * CALCULATE LEGNTH OF MOVE(TO CLOSE UP GAP)B=NEXT ADDRESS IN DIRECTORY * LDB DIRAD GET ADDRESS OF CARTRIDGE + 4 CMB,INB SET ADDRESS NEGATIVE ADB $MDSP ADD TO STOP ADDRESS CMB,INB COMPLEMENT LENGTH STB LN1 SAVE THE LEGNTH LDA DIRAD FETCH "FROM" ADDRESS LDB A "TO" ADDRESS ADB N4 = "FROM" -4 * JSB $LIBR GO PRIVILEDGED NOP JSB MOVE LN1 NOP CLOSE UP THE GAP * * CLEAR FIRST WORD IN LAST ENTRY OF DIRECTORY * CLR LDB $MDSP FETCH STOP ADDRESS ADB N4 BACK UP TO BEGINING OF LAST ENTRY LDA DZERO ADDRESS OF A ZERO * JMP MV4 GO MOVE IT * SKP * EXIT CODE * EX2 LDA .2 RSS EX6 LDA .6 RSS EX8 LDA .8 RSS EX13 LDA .13 RSS EX14 LDA .14 CMA,INA,RSS EX11 LDA N11 RSS EX<12 LDA .12 JMP CREX EXIT3 ISZ WCS SET WRITE FLAG EXIT4 CLA AND TAKE JMP CREX ACCEPT EXIT EX16 LDA N16 JMP CREX EX32 LDA N33 DISC NOT FOUND EXIT INA,RSS EX33 LDA N33 NO ROOM EXIT JMP CREX EXIT EX46 LDA N46 JMP CREX EX99 LDA N99 JMP CREX EX101 LDA N102 INA,RSS EX102 LDA N102 CREX JSB RPRM SET THE RETURN PRAMS * EXIT JSB WCSR WRITE THE SECTOR LDA R1A SET SOURCE ADDRESS FOR MOVE LDB ADRTN SET DESTINATION ADDRESS FOR MOVE CCE SET MOVE PARAMETERS JSB MOVE MOVE RETURN PARAMETERS INTO USER'S AREA N5 DEC -5 CLA CLEAR FLAG FOR SUCCESSFUL COMPLETION STA OFTST JSB $LIBX CALL THE SYSTEM TO RETURN DEF TDB AS A RE-ENTRANT SUBROUTINE DEC 0 SPC 3 CKER LDA P2 GET -LU/CRN PARAMETER SZA IS IT 0 (MULTI-DISC SEARCH)? JMP EX32 NO, MUST HAVE NOT FOUND DISC CKERR LDA P1 GET FUNCTION CODE PARAMETER CPA .1 CREATE CALL? JMP EX33 YES, MUST NOT HAVE BEEN ENOUGH ROOM JMP EX6 MUST HAVE NOT FOUND FILE FOR OPEN CALL SKP * * CONSTANTS * .1 DEC 1 .6 DEC 6 .8 DEC 8 .12 DEC 12 .13 DEC 13 .14 DEC 14 .20 DEC 20 * B377 OCT 377 B170K OCT 170000 * N1 DEC -1 N7 DEC -7 N8 DEC -8 N33 DEC -33 N46 DEC -46 N99 DEC -99 N102 DEC -102 * SIGN OCT 100000 * * ADDRESSES * R1A DEF R1 CRDIR DEF $CDIR+0 ANAME DEF NAME ADIRA DEF DIRA ABUF3 DEF BUF3 ANXSC DEF NXSEC NXSCA DEF BUF+5 BTRA DEF BAD1 DZERO DEF ZERO P1A DEF P1 P2A DEF P2 P3A DEF P3 P4A DEF P4 RDPSA DEF RDPS IDA DEF ID SKP * * VARIBLES * THE FOLLOWING ARE IN THE TEMPORARY DATA BUFFER (TDB) * TDB NOP DEC 92 SIZE OF THE TEMPORARY DATA BLOCK RTNAD NOP RETURN ADDRESS OFTST NOP VALID EXIT FLAG # * ADRTN NOP USER'S RETURN PARAMETERS ADDRESS * ATRAK NOP * ID NOP PASSED PARAMETER #0 (OPEN FLAG) P1 NOP PASSED PARAMETER #1 P2 NOP PASSED PARAMETER #2 P3 NOP PASSED PARAMETER #3 P4 NOP PASSED PARAMETER #4 P5 NOP PASSED PARAMETER #5 P6 NOP PASSED PARAMETER #6 NOP NOP P7 NOP PASSED PARAMETER #7 P8 NOP PASSED PARAMETER #8 P9 NOP PASSED PARAMETER #9 * R1 NOP RETURN PARM #1 R2 NOP RETURN PARM #2 R3 NOP RETURN PARM #3 R4 NOP RETURN PARM #4 R5 NOP RETURN PARM #5 * #FMT DEC 14 SECTOR SKIP VALUE FOR DIRECTORY N#FMT DEC -14 NEGATIVE OF #FMT ##SEC NOP NUMBER OF SECTORS/TRACK * COUN1 NOP COUN2 NOP * GSEC NOP EXTENT FLAG VALDF NOP VALID FLAG (OPEN FLAG/LOCK WORD) * TMP1 NOP TMP2 NOP TMP3 NOP * FROM NOP SOURCE ADDRESS FOR MOVE COUNT NOP LOOP INDEX FOR MOVE * NAME BSS 9 BUFFER USED BY MOVE1 CSEC EQU NAME+5 * BUF3 BSS 3 BUFFER USED BY MOVE2 * DIRA NOP - THESE MUST REMAIN IN ORDER NOP ! NOP ! TYPE NOP ! TRAKA NOP ! SECTA NOP ! #SEC NOP ! RL NOP ! SC NOP ! FLAGA NOP - * NXSEC NOP - THE NEXT 11 WORDS MUST REMAIN IN ORDER #SECT DEC 96 ! LASTR NOP ! #TRK NOP ! NXTR NOP ! BAD1 NOP ! BAD2 NOP ! BAD3 NOP ! BAD4 NOP ! BAD5 NOP ! BAD6 NOP ! * * THE FOLLOWING VARIBLES ARE CLEARED IF D.RTR IS "OF'ED" AND * DOESN'T COMPLETE NORMALLY * RDPS NOP CURRENT DISC POINTER RW NOP READ/WRITE FLAG USED BY RWSUB DRLU NOP DIRECTORY LU PDSLU NOP DISC LU WITH PROTECT BITS LDRLU NOP LAST DIRECTORY LU LTRAC NOP LAST TRACK LSECT NOP LAST SECTOR READ/WRITTEN BY RWSUB LTR NOP FIRST NOP BADTR NOP * DIRAD NOP - THESE MUST REMAIN IN ORDER TRACK NOP ! SECT NOP ! WCS NOP ! ALU NOP ! DITR NOP ! ZERO NOP ! NOP ! NOP ! NOP - * A EQU 0 B EQU 1 SKP * DIRCK READ A DIRECTORY ENTRY - SET FLAGS * CHECK OPEN FLAGS ETC. * DIRCK NOP LDA ALU DO WE ALREADY CPA RDPS HAVE THE DISC SPECS? RSS YES SO SKIP SET UP JSB SETPR SET UP THE DISC PARAMETERS LDA DITR SET STA TRACK TRACK LDA P3 GET THE PASSED AND B377 SECTOR STA SECT AND SET IT XOR P3 NOW GET THE ALF,ALF OFFSET ADA ABUF ADD THE BUFFER ADDRESS JSB SETAD SET DIRECTORY ADDRESSES JSB RWSUB READ THE BLOCK LDA DIRA MOVE THE ENTRY TO LOCAL JSB MOVE1 STORAGE CLE CLEAR E JUST IN CASE ANYBODY EXPECTS IT JMP DIRCK,I SKP * DPMM MOVE DISC PARAMETERS FOR CURRENT UNIT * CALLING SEQUENCE * * E=0 - SAVE PARAMETERS * E=1 - MOVE PARAMETERS BACK * * DPMM NOP LDA NXSCA GET SOURCE ADDRESS (BUF+5) LDB ANXSC GET DESTINATION ADDRESS (NXSEC) SEZ,CCE CHANGE THE DIRECTION OF MOVE? SWP YES JSB MOVE NOW MOVE PARAMETERS N11 DEC -11 LDB #TRK ADB TRACK COMPUTE THE ADDRESS OF TRACK STB LTR ELSE SET THE ADDRESS LDB DRLU SAVE THE CURRENT LU STB RDPS FOR CORE RESIDENT SPEED * * ISOLATE AND SAVE THE SECTOR OFFSET AND #SECTORS / TRACK * * THE HIGH EIGHT BITS FORM THE OFFSET * THE LOW EIGHT FORM THE #SECT/TRACK * LDA #SECT FETCH THE #SECT/TRACK&OFFSET ALF,ALF POSITION * THE SKIP FACTOR TO LOW END AND B377 ISOLATE IT SZA,RSS ZERO DEFAULTS TO 14 LDA .14 STA #FMT SAVE IT CMA,INA SET IT NEGATIVE (SO YOU CAN SEE BLOCK 0) STA N#FMT SAVE IT ALSO * LDA #SECT FETCH THE ORIGIONAL WORD AND B377 ISOLATE THE SECTORS/TRACK INFO STA ##SEC SAVE ANOTHER ONE JMP DPMM,I SKP EXSH NOP DIRECTOR SEARCH FOR EXTENTS TO MODIFY ISZ WCS SET THE WRITE FLAG JSB EXSHR SEARCH FOR EXTENT JMP EXIT4 NOT FOUND SO EXIT JMP EXSH,I FOUND RETURN SPC 5 EXSHR NOP EXTENT SEARCH ROUTINE LDB DEF SET RETURN ADDRESS IN STB N.SHR NAME SEARCH ROUTINE JMP NSHR0 GO TO NAME SEARCH DEF DEF *+1 RETURN ADDRESS FOR NAME SEARCH JMP EXSHR,I NOT FOUND SO EXIT JSB SETAD FOUND SET THE ADDRESSES LDB EXSHR STEP THE RETURN ADDRESS CCE,INB AND LDA SECTA,I MAKE SURE THIS IS NOT THE MAIN CPA CSEC SAME AS MAIN? CCA,RSS JMP B,I RETURN * STA R1 AFTER WE CLEAR THE FOUND FLAG JMP CSER CONTINUE THE SEARCH SKP * * FID TEST CARTRIDGE HEADER FOR LEGALITY * FID NOP LDB DIRA,I FIRST WORD SSB,RSS MUST HAVE SIGN SET JMP FID,I NOT INITIALIZED * LDB TYPE,I CRN MUST BE SSB,RSS POSITIVE AND SZB,RSS NON-ZERO JMP FID,I NOT LEGAL * LDB SC,I NUMBER OF DIRECTORY SSB,RSS TRACKS MUST BE NEGATIVE JMP FID,I NOT LEGAL * LDB RL,I GET LOWEST DIRECTORY TRACK CMB,INB SET NEGATIVE ADB TRAKA,I FIRST AVAILABLE TRACK SSB,RSS MUST BE < DIRECTORY JMP FID,I NOT LEGAL * M LDB FLAGA,I NEXT AVAIL. FMP TRACK SSB MUST BE POSITIVE JMP FID,I (NOT LEGAL) CMB,INB ADB RL,I AND LESS THAN OR EQUAL SSB TO LOWEST DIRECTORY TRACK JMP FID,I (NOT LEGAL) * ISZ FID LEGAL, RETURN P+1 JMP FID,I RETURN SKP * * FLAG CHECKS FOR VALID OPEN FLAGS - ASSUMES FLAGA POINTS * TO THE FLAG AREA * FLAG NOP CLA CLEAR NUMBER OF STA COUN2 OPEN FLAGS LDA N7 SET UP COUNT STA COUN1 FOR NUMBER OF POSSIBLE OPEN FLAGS LDA FLAGA GET FLAG AREA STA TMP3 AND SAVE AS POINTER * FLAG1 LDA TMP3,I GET NEXT OPEN FLAG SZA,RSS IF FLAG IS ZERO JMP FLAG4 THEN CHECK THE NEXT FLAG RAL,CLE,ERA CLEAR EXCLUSIVE OPEN BIT CPA ID IF FLAG IS EQUAL TO CURRENT PROGRAM JMP FLAG2 THEN FORCE CLOSED * * CHECK IF SEQUENCE # IS THE SAME * LDA TMP3,I GET OPEN FLAG AGAIN JSB VALID GO CHECK VALIDITY OF OPEN FLAG JMP FLAG3 VALID, INCREMENT COUNT * * CLEAR OPEN FLAG * FLAG2 CLA INVALID, SO CLEAR OPEN FLAG STA TMP3,I AND STORE IN FLAG ISZ WCS SET WRITTEN-ON FLAG JMP FLAG4 SKIP INCREMENT OF VALID OPEN FLAGS * FLAG3 ISZ COUN2 INCREMENT VALID OPEN FLAG COUNT FLAG4 ISZ TMP3 INCREMENT OPEN FLAG POINTER ISZ COUN1 INCREMENT LOOP COUNTER, DONE? JMP FLAG1 NO, LOOP JMP FLAG,I YES, EXIT SKP LAST? NOP LDB TYPE,I IF TYPE ZERO SZB,RSS FILE * JMP LAST?,I AS NOT LAST JSB NXT/S COMPUTE THE NEXT TRACK AND SECTOR CPA NXTR SAME TRACK? CCA YES; A_1 CPB NXSEC SAME AS NEXT SECTOR? INA,SZA YES; WAS IT SAME TRACK ALSO? JMP LAST?,I NO; NOT LAST FILE EXIT P+1 ISZ LAST? YES; LAST FILE JMP uLAST?,I EXIT P+2 SPC 5 * MOVE SUBROUTINE * A = SOURCE B = DESTINATION E = 0, SET ADDRESSES * 1, MOVE PARAMETERS * JSB MOVE * DEC -N N = NUMBER OF PARAMETERS * MOVE NOP STA FROM STORE SOURCE ADDRESS LDA MOVE,I GET THE COUNT STA COUNT AND SAVE IT ISZ MOVE POINT TO RETURN ADDRESS SSA,RSS IS COUNT ZERO OR POSITIVE? JMP MVOUT YES, DON'T DO MOVE * LOOP LDA FROM GET SOURCE ADDRESS SEZ MOVE ADDRESSES OR PARAMETERS LDA A,I PARAMETERS! STA B,I STORE IN DESTINATION INB INCREMENT DESTINATION ISZ FROM INCREMENT SOURCE ADDRESS ISZ COUNT INCREMENT COUNT JMP LOOP LOOP IF NOT DONE * MVOUT LDA FROM PUT NEXT ADDRESS IN A JMP MOVE,I EXIT SKP * MOVE1/2 TO MOVE DIRECTORY ENTRIES TO/FROM * THE LOCAL SAVE AREAS * * CALLING SEQUENCE: * * IF E=0, THEN A=SOURCE AND B=DESTINATION * IF E=1, THEN A=DESTINATION AND B=SOURCE * * MOVE1 MOVES 9 WORDS * MOVE2 MOVES 3 WORDS * MOVE1 NOP LDB ANAME SET B TO ADDRESS OF NAME BUFFER SEZ,CCE CHANGE DIRECTION OF MOVE? (ALSO E=1 TO MOVE PARAMETERS) SWP YES, SO SWITCH CONTENTS OF A AND B JSB MOVE NOW MOVE PARAMETERS DEC -9 9 PARAMETERS REQUIRED JMP MOVE1,I RETURN SPC 5 MOVE2 NOP LDB ABUF3 SET B TO ADDRESS OF 3 WORD BUFFER SEZ,CCE CHANGE DIRECTION OF MOVE? (ALSO E=1 TO MOVE PARAMETERS) SWP YES, SO SWITCH CONTENTS OF A AND B JSB MOVE NOW MOVE PARAMETERS N3 DEC -3 3 PARAMETERS REQUIRED JMP MOVE2,I RETURN SKP * N.SHR DIRECTORY SEARCH ROUTINE * TARGET NAME IN NAME * RETURNS: * P+1 END OF DIRECTORY A=NEXT A7DDR. (IF A=0 END OF SPACE) * P+2 FOUND RETURN A=ENTRY ADDR. * N.SHR NOP NSHR JSB RDNXB READ THE DIRECTORY JMP N.SHR,I END OF DISC RETURN NSHR0 LDA ABUF SET A TO THE BUFFER ADDRESS LDB N8 SET COUNT FOR THE NO. IN A BLOCK STB COUN1 NSHR1 CCE SET FOUND FLAG (E=1) LDB ANAME SET THE NAME ADDRESS STB TMP2 IN TMP2 LDB N3 SET FOR 3-WORD NAME STB COUN2 LDB A,I IF PURGED ENTRY INB,SZB,RSS THEN JMP CKRUS CHECK IF REUSABLE * NSHR2 LDB A,I GET A NAME WORD SZB,RSS IF ZERO - END OF DIRECTORY JMP N.SHR,I SO EXIT * CPB TMP2,I MATCH? INA,RSS YES - SET FOR NEXT WORD SKIP CLE,INA NO - SET NOT FOUND - STEP NAME ISZ TMP2 STEP LOCATIONS ISZ COUN2 AND COUNT MORE NAME JMP NSHR2 YES; GO DO IT * CLB,SEZ,CCE,INB NO; FOUND? JMP NSHR3 YES; GO TAKE FOUND EXIT * NSHR4 ADA .13 NO; SET FOR NEXT ENTRY NSHR5 ISZ COUN1 DONE WITH BLOCK? JMP NSHR1 NO; DO NEXT ENTRY JMP NSHR YES; GO READ NEXT BLOCK NSHR3 ADB N.SHR FOUND - STEP RETURN ADDRESS ADA N3 ADJUST TO START OF ENTRY JMP B,I RETURN SPC 3 CKRUS ADA .6 TO BE REUSABLE IT MUST BE THE LDB A,I SAME SIZE ADA .10 SET A FOR FAILURE CPB NAME+6 SAME SIZE? JMP CKRU1 YES, GO CHECK FURTHER JMP NSHR5 NO, CONTINUE SEARCH * CKRU1 LDB R1 IF ALREADY HAVE ONE SSB,RSS THEN JUST JMP NSHR5 CONTINUE * LDB TRACK ELSE SAVE THE DIRECTORY STB R1 ADDRESS (MUST SAVE A FOR LDB SECT CONTINUATION OF SCAN) STB R2 R1,R2 = DISC ADDRESS STA R3 R3 = OFFSET +16 JMP NSHR5 CONTINUE THE SCAN SPC 2 .10 DEC 10 SKP * NXT/S NOP CACULATE THE NEXT TR*hACK AND SECTOR LDB #SEC,I GET THE FILE SIZE LDA SECTA,I GET THE STARTING SECTOR OF THE FILE AND B377 ISOLATE ADB A SUM LSR 16 EXTEND TO A DIV ##SEC DIVIDE BY THE NO SECT PER TRACK ADA TRAKA,I ADD THE CURRENT TRACK ADDRESS JMP NXT/S,I RETURN A=NEXT TRACK,B=NEXT SECTOR SPC 5 * RDNXB READ NEXT DIRECTORY BLOCK * RDNXB NOP JSB UDAD UPDATE THE ADDRESSES JMP RDNXB,I END OF DIRECTORY RETURN JSB RWSUB READ THE BLOCK ISZ RDNXB STEP TO OK RETURN ISZ FIRST FIRST BLOCK? JMP RDNXB,I NO; SO RETURN SPC 1 CLE JSB DPMM JMP RDNXB,I RETURN SPC 3 * RPRM SET RETURN PARAMETERS RPRM NOP STA R1 SET FIRST RETURN PRAM LDA TRACK TRACK,LU LSL 6 TO ADA ALU RETURN STA R2 TWO LDA ABUF OFFSET CMA,INA AND ADA DIRA SECTOR ALF,ALF TO ADA SECT RETURN STA R3 3 LDA TRAKA,I TRACK OF FILE TO STA R4 RETURN 4 LDA SECTA,I GET THE SECTOR ADDRESS AND B377 ISOLATE IT LDB ##SEC GET THE NUMBER OF SECTORS /TRACK BLF,BLF ROTATE AND ADA B COMBINE WITH THE SECTOR STA R5 RETURN 5 JMP RPRM,I SKP * RWSUB ROUTINE TO READ OR WRITE A TWO-SECTOR BLOCK * RWSUB NOP LDA RW FETCH THE NEW POINTERS SLA,RSS IF WRITE THEN JMP RWSU1 GO DO IT LDB DRLU CPB LDRLU ELSE IF (TEST LU) LDB N7 SAME BLOCK AS LDA TRACK CURRENT ONE CPA LTRAC THEN (TEST TRACK) INB LDA SECT NO CPA LSECT ACTION IS (TEST SECTOR) CLE,INB CPB N5 REQUIRED SO JMP RWSUB,I RETURN (IT IS SAME AS LAST SECTOR READ) RWSU1 JSB EXEC NOT SAME BLOCK CALL EXEC DEF RTN RETURN DEF RW READ WRITE CODE DEF PDSLU LU (WITH PROTECT BITS) ABUF DEF BUF BUFFER DEF .128 128 WORDS DEF TRACK ON TRACK & DEF SECT SECTOR RTN JMP EX99 ABORT RETURN, EXIT CLA,CLE CLEAR THE WRITE STA WCS FLAG LDA DRLU SET UP LAST POINTERS FOR NEXT TIME STA LDRLU LDA TRACK SAVE THE TRACK STA LTRAC ADDRESS AND THE LDA SECT SECTOR STA LSECT ADDRESS CPB .128 DISC ERR? JMP RWSUB,I NO - RETURN STA LDRLU YES; SET NOT IN CORE FLAG LDA N1 YES - TAKE DISC ERR EXIT JMP CREX SPC 2 .128 DEC 128 SKP * SETAD TO SET UP ADDRESSES FOR DIRECTORY ENTRY IN BUF AT * ADDRESS POINTED TO BY A * * SETAD NOP LDB ADIRA SET B TO DESTINATION ADDRESS CLE SET E TO SET UP ADDRESSES JSB MOVE N10 DEC -10 10 ADDRESSES REQUIRED JMP SETAD,I RETURN SPC 5 * SETDR ROUTINE TO SET UP TO READ A DIRECTORY * SETDR NOP JSB WCSR WRITE CURRENT SECT LDA .128 PRESET # SET TO AVOID DIVIDE (VALUE DOESN'T MATTER) ISZ FIRST (EXCEPT WHEN REWRITING) STA ##SEC PROBLEMS CCA SET FIRST STA FIRST FLAG TO INDICATE FIRST BLOCK LDA ATRAK SET THE TRACK STA TRACK ADDRESS LDA ALU AND THE LU STA DRLU ADDRESS ADA B7700 ADD IN PROTECT BITS STA PDSLU STORE AS PROTECTED DISC LU * LDA N#FMT ADD SECTOR BUMP FACTOR(=14 UNTIL1ST BLK READ) STA SECT SET THE SECTOR JMP SETDR,I RETURN SPC 5 SETPR NOP READ AND SET UP THE DISC PARAMETERS JSB SETDR SET UP TO ACCESS THE DIR JSB RDNXB READ AND SET PRAMS N16 DEC -16 JMP SETPR,I RETURN TO CALLER SPC 2 B7700 OCT 7700 SKP * * }o TSTDR - TEST DIRECTORY FOR OPEN FLAGS AND FILE SIZE AND ADDRESS * CONSISTENCY. CALLED BY LOCK AND UNLOCK ROUTINES. * * JSB TSTDR * * * * TSTDR NOP TEST DIRECTORY SUBROUTINE JSB SETDR SET TO SEARCH DIRECTORY JSB RDNXB SET UP POINTERS TO READ CARTRIDGE HEADER NOP EOD RETURN NOT USED LDA ABUF GET POINTER TO CARTRIDGE HEADER JSB SETAD SET UP POINTERS IN DIRA BUFFERS JSB FID LEGAL HEADER? JMP ILDIR ILLEGAL DIRECTORY, EXIT LDA TRAKA,I GET LOWEST TRACK IN USE FROM HEADER STA CALTR AND PUT IN CALCULATED TRACK VALUE CLA SET 0 INTO STA CALSC CALCULATED SECTOR STA FLGCT CLEAR FLAG COUNT LDA N8 SET COUNTER FOR 8 ENTRIES STA TCNT SAVE LOOP COUNTER JMP NXFIL GO PROCESS FIRST ENTRY * TDIR1 JSB RDNXB READ NEXT ENTRY BLOCK JMP EODIR END OF DIRECTORY CHECKS LDA N8 SET COUNTER FOR 8 ENTRIES STA TCNT SAVE LOOP COUNT LDA ABUF SET A TO ADDRESS OF FIRST TDIR2 JSB SETAD SET UP DIRECTORY ENTRY ADDRESSES LDA DIRA,I GET FIRST NAME WORD SZA,RSS END OF DIRECTORY? JMP EODIR YES, GO MAKE FINAL CHECKS * LDA TYPE,I GET FILE TYPE SZA,RSS IF TYPE 0, DON'T DO DIRECTORY JMP CNTOP ADDRESS CHECKS * LDA #SEC,I GET FILE SIZE SZA FILE SIZE 0? SSA OR NEGATIVE? JMP ILDIR YES, ILLEGAL DIRECTORY * LDA TRAKA,I GET CURRENT TRACK ADDRESS CMA,INA TEST IF IT IS GREATER THAN ADA CALTR THE CALCULATED NEXT TRACK SSA IS IT? JMP ADROK YES, GO DO NEXT TEST LDA TRAKA,I IS CURRENT TRACK EQUAL CPA CALTR TO THE CALCULATED TRACK? RSS YES, HAVE TO TEST THE SECTOR ADDRESS JMP ILDIR NO, CURRENT < CALCULATED, ERROR LDA SECTA,I GET SECTOR ADDRESS FOR COMPARISON AND B377 MASK OFF EXTENT NUMBER ADA CALSC COMPARE TO CALCULATED SECTOR (COMPLEMENTED) SSA IS CALC SECT =< CURRENT SECT? JMP ILDIR NO, ERROR * ADROK JSB NXT/S CALCULATE NEXT TRACK AND SECTOR CMB,INB COMPLEMENT SECTOR VALUE STA CALTR SAVE CALCULATED TRACK STB CALSC SAVE COMPLEMENTED SECTOR * CNTOP JSB FLAG COUNT OPEN FLAGS LDA COUN2 GET NUMBER OF OPEN FLAGS ADA FLGCT ADD TO TOTAL FLAG COUNT STA FLGCT SAVE TOTAL COUNT * NXFIL LDA DIRA GET CURRENT ENTRY'S ADDRESS ADA .16 STEP TO NEXT ENTRY ISZ TCNT END OF BLOCK? JMP TDIR2 NO, TEST NEXT ENTRY JMP TDIR1 YES,READ NEXT BLOCK * EODIR LDA NXTR GET NEXT AVAIL. TRACK FROM CART. HEADER CPA CALTR SAME AS CALCULATED? RSS YES, CHECK SECTORS JMP ILDIR NO, DIRECTORY ILLEGAL LDA CALSC GET COMPLEMENT OF CALCULATED NEXT SECT. ADA NXSEC ADD NEXT AVAIL. SECT FROM HEADER SZA SAME? JMP ILDIR NO, DIRECTORY ILLEGAL * LDA FLGCT RETURN WITH FLAG COUNT IN A ISZ TSTDR DIRECTORY OK, STEP RETURN ADDRESS JMP TSTDR,I RETURN * ILDIR LDA N103 RETURN WITH A = -103 JMP TSTDR,I RETURN * * CALTR NOP CALCULATED NEXT TRACK CALSC NOP CALCULATED NEXT SECTOR TCNT NOP TEMPORARY COUNTER FLGCT NOP OPEN FLAG COUNT * .16 DEC 16 N103 DEC -103 SKP * UDAD -- UPDATE THE DIRECTORY ADDRESS * * * THE SECTOR OFFSET MUST BE KEPT ON THE DISK ITSELF * * CKECK ALL REFS TO IT BEFORE CHANGING * * * UDAD NOP JSB WCSR WRITE CURRENT BLOCK LDA #FMT SET SECTOR BUMP FACTOR(=14 UNTIL 1ST BLK READ) ADA SECT ADD 7 TO THE SECTOR CLB PREPARE FOR DIVIDE DIV ##SEC DIVIDE BY THE NO OF SECTORS/TRACK STB SECT SET THE NEW SECTOR ADDRESS SZA IF NO ROLLOVER OR SZB IF SECTOR IS ZERO THEN SKIP (NEW TRACK) JMP UDAD1 ELSE GO EXIT SPC 1 CCB SET TO DECREMENT TRACK CLA SET A FOR ERROR RETURN ADB TRACK ADDRESS CPB LTR OUT OF DIRECTORY? JMP UDAD,I YES SO RETURN STB TRACK SET THE NEW TRACK UDAD1 ISZ UDAD STEP RETURN JMP UDAD,I TAKE OR RETURN SKP * * SUBROUTINE VALID CHECKS THE VALIDITY OF OPEN FLAGS AND LOCK WORDS * VALID NOP STA VALDF SAVE THE OPEN FLAG/LOCK WORD SZA,RSS IF FLAG IS ZERO JMP NVEXT THEN NOT VALID AND B377 ISOLATE ID NUMBER ADA N1 SUBTRACT 1 FOR ID'S FROM 0 TO 255 LDB $ID# GET NUMBER OF ID SEGMENTS CMB,INB SET NEGATIVE ADB A ADD CURRENT SEGMENT NUMBER SSB,RSS IS IT TOO LARGE? JMP NVEXT YES, EXIT NOT VALID MPY $IDSZ MULTIPLY NUMBER BY SIZE ADA $IDA ADD ID STARTING ADDRESS ADA .8 POINT TO POINT OF SUSPENSION LDB A,I GET POINT OF SUSPENSION SZB,RSS ZERO (DORMANT)? JMP NVEXT YES, INVALID! ADA .20 NO, POINT TO SEQ # LDA A,I GET WORD FROM ID SEGMENT AND B170K ISOLATE SEQ # FROM ID SEGMENT STA B SAVE SEQUENCE NUMBER LDA VALDF NOW GET OPEN FLAG AGAIN RAL POSITION SEQUENCE IN HIGH ORDER BITS AND B170K ISOLATE SEQ # FROM OPEN FLAG CPA B SEQUENCE NUMBERS MATCH? JMP VEXIT YES, EXIT VALID * NVEXT CLA NOT VALID, CLEAR A ISZ VALID POINT TO NOT VALID RETURN POINT JMP VALID,I RETURN * VEXIT LDA VALDF RETURN WITH VALID OPEN FLAG JMP VALID,I RETURN SPC 5 * WCSR WRITE CURRENT BLOCK * WCSR NOP LDA WCS GET WRITE FLAG ISZ RW SET REQUEST CODE TO WRITE SZA IF NOT WRITTEN ON SKIP JSB RWSUB ELSE WRITE THE BLOCK CLA,INA RESET REQUEST CODE TO ADA SIGN SET NO ABORT BIT STA RW READ JMP WCSR,I AND EXIT SKP * * SECTOR BUFFER FOR DISC READS AND WRITES * BUF BSS 128 ORG BUF PUT INITIALIZE CODE IN BUFFER AREA * INIT CMA,INA CONVERT THE LU TO POSITIVE STA TLU SAVE THE LU NUMBER IOR ZBIT PUT IN Z BIT IN CONWD STA ZLU AND SAVE FOR STATUS REQUEST LDA TLU GET DISC LU AGAIN IOR PBITS ADD IN DISC PROTECT BITS STA PLU SAVE FOR EXEC CALLS * JSB EXEC GET STATUS OF LU DEF STRTN TO DETERMINE TYPE AND LAST TRACK DEF XCOD NO ABORT STATUS REQUEST DEF ZLU LU WITH Z BIT SET DEF DVT6 CONTAINS DEVICE TYPE DEF IFT6 DEF XTBUF ARRAY FOR NUMBER OF TRACKS DEF X.6 STRTN JMP BAD IF LU UNDEFINED, EXIT. * LDA DVT6 GET DEVICE TYPE ALF,ALF POSITION TO LOW BITS AND XB77 ISOLATE DEVICE TYPE ADA BN30 IS IT LESS SSA THAN 30? JMP BAD NOT A DISC! ADA XN8 IS IT GREATER SSA,RSS THAN 37? JMP BAD NOT DISC EITHER! * LDA XTRAK GET NUMBER OF TRACKS ADA N1 SUBTRACT 1 FOR LAST TRACK ADDRESS STA XTRK SAVE FOR CARTRIDGE DIRECTORY * JSB EXEC READ FIRST ENTRY ON LAST TRACK DEF XRTN FOR CARTRIDGE INFORMATION DEF X.1 NO ABORT READ DEF PLU PROTECTED DISC LU DEF XTBUF DEF X.9 DEF XTRK LAST TRACK DEF XZRO FIRST SECTOR XRTN JMP BAD ERROR RETURN * LDA XTBUF FETCH FIRST WORD OF ID CPB X.9 MUST HAVE 9 WOo[RDS SSA,RSS AND FIRST WORD MUST BE NEGATIVE JMP BAD NO GOOD--EXIT * LDA HD3 FETCH LABEL SSA MUST BE POSITIVE JMP BAD * STA TDRN SAVE IT LDA HD4 FETCH FIRST TRK CMA ADA HD7 SSA MUST BE LESS THAN FIRST DIR TRK JMP BAD * LDA HD8 FETCH #DIR TRKS SSA,RSS MUST BE NEGATIVE JMP BAD * LDA DTRK LDB CRDIR CCE,INB MOVE PARMS / POINT TO 2ND WORD JSB MOVE STORE CARTRIDGE INFO INTO DEC -3 TBLFP LDA TLU STORE LU LAST TO GUARENTEE AN 'OF' WILL STA $CDIR NOT CAUSE PROBLEMS * BGCLR CLA CLEAR JUMP TO THIS INITIALIZATION STA INITR ROUTINE IF THIS SUCCESSFUL JMP INITR NOW RETURN * BAD LDA X.100 EXIT WITH ERROR -100, DISC JMP CREX NOT INITIALIZED OR NOT A DISC * XN1 OCT -1 X.1 OCT 100001 NO ABORT READ XCOD OCT 100015 NO ABORT STATUS REQUEST XB77 OCT 77 X.9 DEC 9 X.100 DEC -100 BN30 OCT -30 X.6 DEC 6 XN8 DEC -8 * TLU NOP XTRK NOP TDRN NOP XZRO NOP * DTRK DEF XTRK XTBUF NOP NOP NOP HD3 NOP HD4 NOP XTRAK NOP NOP HD7 NOP HD8 NOP * DVT6 NOP STATUS WORD IFT6 NOP ZLU NOP DISC LU WITH Z BIT SET ZBIT OCT 10000 PLU NOP PROTECTED DISC LU PBITS OCT 7700 DISC PROTECT BITS ORR LN EQU * * END 2  92070-18038 2011 S C0122 &APOSN              H0101 ASMB,R,L,C * NAME: APOSN * SOURCE: 92070-18038 * RELOC: 92070-16038 * PGMR: G.A.A. * MOD: M.L.K. * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * * NAM APOSN,7 92070-1X038 REV.2011 800319 * HED APOSN ENT APOSN,EAPOS EXT $KIP,NX$EC,RFLG$,.ENTR,LOCF EXT GTOPN,$DBLX SUP SPC 1 * THE APOSN ROUTINE DOES ABSOLUTE FILE POSITIONING * OF RTE FILES * * CALLING SEQUENCE: * * CALL APOSN(IDCB,IERR,IREC,IRS,IOFF) SPC 1 * WHERE: * * IDCB IS THE FILES DATA CONTROL BLOCK * * IERR IS AN ERROR RETURN FLAG. POSSIBLE ERRORS, * 0 NO ERROR * -1 DISC DOWN * -5 SPACING BEYOND END OF DEFINED EXTENT * -9 ATTEMPT TO POSITION TYPE ZERO FILE * -10 NOT ENOUGH PARAMETERS * -11 DCB NOT OPEN * -12 SOF IE IREC <1 * * IREC THE RECORD NUMBER TO BE READ NEXT * * IRS (REQUIRED FOR 3 & ABOVE ONLY) THE * RELATIVE BLOCK OF THE NEXT RECORD * * * IOFF THE BLOCK OFFSET OF THE NEXT * RECORD (REQUIRED FOR TYPE 3 AND * ABOVE ONLY) * SKP EAPOS NOP DOUBLE WORD ENTRY CCA SET DOUBLE WORD FLAG TRUE LDB EAPOS MOVE ENTRY ADDRESS JMP SETUP GO SETUP REST SPC 5 APOSN NOP CLA LDB APOSN GET RETURN ADDRESS SETUP STA DBLWD STORE DOUBLE WORD FLAG STB DPOSN STORE RETURN ADDRESS CLA CLEAR PARAMETER ADDRESSES STA IRC FOR ENOUGH PARAMETER STA IOFF TESTS JMP DPOSN+1 GO FETCH CALL PARMS SPC 5 * DCB NOP ER NOP IRC NOP IRS NOP IOFF NOP SPC 1 DPOSN NOP ENTRY POINT JSB .ENTR FETCH PRAM DEF DCB ADDRESSES * CLB,INB SET THE READ STB RFLG$ FLAG LDB DCB COMPUTE ADB .2 TYPE STB TYPE AND ADB .5 STEP TO BLOCK LENGTH LDA B,I FETCH ARS,ALR AND ALF,ALF CONVERT RAL TO NUMBER OF 128 WORD BLOCKS STA BLKSZ SAVE ADB .2 STEP TO OPEN FLAG JSB GTOPN GET CURRENT OPEN FLAG DEF *+1 CPA B,I IS IT SAME AS IN DCB? JMP OPIN YES, FILE OPEN LDA N11 NO, ERROR 11 JMP EXIT NOW EXIT * OPIN LDA N9 SET A= -9 LDB TYPE,I IS FILE TYPE SZB,RSS ZERO? JMP EXIT YES; EXIT ADB N3 IF TYPE 1 OR 2 STB TYPE SAVE FOR LATER LDA IRC TEST FOR RECORD PRAM SSB,RSS ELSE TEST LDA IOFF FOR FULL PRAM SZA,RSS LIST JMP ER10 NOT ENOUGH PRAMS - EXIT * ISZ DBLWD TEST DBL FLAG JMP SINGL SINGLE WORD, SKIP TESTS DLD IRC,I GET DOUBLE RECORD JSB $DBLX CHECK RANGE JMP EXIT ERROR (A=ERROR CODE) ISZ IRC POINT TO LOW BITS LDB TYPE GET TYPE INDICATION AGAIN SSB IF TYPE 1 OR 2, SKIP JMP RCSET DOUBLE TEST OF BLOCK DLD IRS,I GET DOUBLE SECTOR JSB $DBLX CHECK RANGE JMP EXIT ERROR ISZ IRS POINT TO LOW BITS * SINGL LDB TYPE GET TYPE INDICATOR AGAIN SSB IF 1 OR 2 JMP RCSET GO SET RECORD NO. SPC 1 JSB LOCF USE LOCF TO DEF LOCRT GET DEF DCB,I CURRENT DEF ER,I RELATIVE DEF RC N SECTOR DEF CIRS ADDRESS LOCRT CLB CALL LDA DCB SKIP JSB $KIP TO JMP EXIT SET UP NX$EC CLB CACULATE LDA CIRS THE RELATIVE DIV BLKSZ BLOCK CMA,INA NUMBER STA CIRS CLB LDA IRS,I DESIRED DIV BLKSZ AND SWP SET FOR ADB CIRS NX$EC CALL SZB,RSS IF ALREADY THERE JMP RCSET SKIP POSITION CALL JSB NX$EC POSITION WITH NX$EC JMP EXIT ERROR - EXIT RCSET RRL 7 LDB DCB GET DCB ADB .12 COMPUTE BUFFER POINTER ADDRESS STB CIRS ADB IOFF,I COMPUTE DESIREDED ADB .4 CONTENTS ADB A ADD THE NO OF 128 WORD BLOCKS STB CIRS,I AND SET ISZ CIRS STEP TO THE ISZ CIRS RECORD NUMBER LDB IRC,I SET RECORD NUMBER SZB ZERO SSB OR NEG JMP ER12 EXIT ERROR STB CIRS,I SET THE RECORD NUMBER LDB DCB GET DCB ADDRESS ADB .13 POSITION TO EOF FLAG LDA B,I GET WRITTEN-ON/EOF/IN BUFFER FLAG RAR,CLE,RAR CLEAR EOF ELA,RAL READ FLAG STA B,I STORE IN DCB CLA,RSS OK - EXIT ER10 LDA N10 EXIT STA ER,I SET ERROR CODE JMP DPOSN,I RETURN. SPC 2 ER12 LDA N12 SEND EOF ERROR JMP EXIT SPC 2 * STORAGE SPC 1 N3 DEC -3 N9 DEC -9 N11 DEC -11 N12 DEC -12 .2 DEC 2 .4 DEC 4 .5 DEC 5 .12 DEC 12 .13 DEC 13 N10 DEC -10 BLKSZ NOP CIRS NOP DBLWD NOP TYPE NOP RC EQU TYPE SPC 2 A EQU 0 B EQU 1 SPC 1 END EQU * SPC 1 END g'  92070-18039 1941 S C0122 &CLOSE              H0101 ASMB,R,L,C * NAME: CLOSE * SOURCE: 92070-18039 * RELOC: 92070-16039 * PGMR: G.A.A. * MOD: M.L.K. * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * * NAM CLOSE,7 92070-1X039 REV.1941 790709 * HED CLOSE ENT CLOSE,ECLOS EXT .ENTR,R/W$,CLD.R,.P1,.P2,.P3,.P4,.R1 EXT GTOPN,$DBLX,LURQ SUP * * THIS IS THE CLOSE SUBROUTINE--A PART OF THE * REAL-TIME FILE MANAGEMENT PACKAGE * * THE ASSEMBLY CALL TO CLOSE A FILE IS: * * JSB CLOSE * DEF RTN RETURN ADDRESS * DEF IDCB DATA CONTROL BLOCK ADDRESS * DEF IERR (OPTIONAL) ERROR CODE RETURNED HERE AND IN A REG * DEF IRX (OPTIONAL) NO. OF 128 WORD DOUBLE *RTN SECTORS TO BE DELETED FROM THE FILE * * ERRORS ARE: * 0 NONE * -1 DISC DOWN * -10 NOT ENOUGH PARAMETERS * -11 FILE NOT OPEN * -13 DISC LOCKED * * * SKP ECLOS NOP DOUBLE WORD ENTRY CCA SET DBL FLAG LDB ECLOS SET UP RETURN ADDRESS JMP SETUP FINISH SET UP SPC 5 CLOSE NOP CLA SET DBL FLAG FALSE LDB CLOSE GET RETURN ADDRESS SETUP STA DBLWD SAVE DBL FLAG STB DLOSE SAVE RETURN ADDRESS LDA DZERO STA IDCB STA IRX LDA DM STA IERR CLA STA ZERO STA .P1 FUNCTION CODE FOR CLOSE JMP DLOSE+1 * * * IDCB DEF ZERO DCB ADDRESS IERR DEF IDCB ERROR CODE ADDRESS IRX DEF ZERO TRUNICATE CODE ADDRESS SPC 1 DLOSE NOP ENTRY POINT {1 JSB .ENTR TRANSFER THE ADDRESSES DM DEF IDCB ISZ DBLWD TEST DBL FLAG JMP SINGL SINGLE ENTRY, SKIP TESTS DLD IRX,I GET DOUBLE TRUNC CODE JSB $DBLX CHECK RANGE JMP EXIT ERROR (A = ERROR CODE) ISZ IRX POINT TO LOW BITS * SINGL LDA IDCB IF NO PARAMETERS CPA DZERO THEN JMP ER10 ERROR EXIT INA STEP TO WORD TWO LDB A,I FETCH OFFSET SECTOR STB .P3 SAVE FOR D.RTR CALL ADA .8 ADD 8 TO GET THE THE OPEN FLAG STA OPNFL SAVE THE OPEN FLAG ADDRESS ADA N2 BACK UP TO THE STA SC SAVE THE SECURITY CODE ADDRESS JSB GTOPN GET CURRENT OPEN FLAG DEF *+1 CPA OPNFL,I COMPARE TO FILE'S, OK? CLE,RSS YES, SKIP JMP ER11 NO, ERROR EXIT * LDB IDCB GET THE DCB ADDRESS * LDA B,I IF DUMMY LU OPEN CPA FAKE DON'T CALL D.RTR JMP DUMMY JUST CLOSE DCB AND GET OUT * JSB R/W$ CALL TO FLUSH THE BUFFER JMP EXIT DISC ERROR EXIT LDB IDCB GET THE TYPE FLAG ADB .2 LDA B,I A SZA IF ZERO NO TRUNCATE LDA IRX,I DISC FILE SET TRUNCATE CODE ALS ADJUST FOR 64 WORD SECTORS ADB .13 STEP TO EXTENT WORD LDB B,I IF NOT SZB FIRST EXTENT CLA DO NOT ALLOW TRUNCATION LDB SC,I GET THE SECURITY FLAG SSB,RSS IF BAD SC CLA DIS ALLOW TRUNCATION CMA,INA SET NEGATIVE STA .P4 SAVE FOR D.RTR * LDA IDCB,I SET DIRECTORY ADDRESS FOR D.RTR STA .P2 JSB CLD.R SCHED D.RTR LDB .R1 GET ERROR RETURN RSS SKIP DUMMY LU EXIT WORK * DUMMY CLB STB IRX SAVE ERROR CODE * CLA STA OPNFL,I CLEAR THE OPEN FLAG * * UNLOCKy TYPE 0 LU'S * LDB IDCB GET DCB ADDRESS ADB .2 POINT TO FILE TYPE LDA B,I GET TYPE SZA IF NOT TYPE 0 JMP EXI THEN DONE, EXIT * INB POINT TO LU LDA B,I GET LU AND B77 ISOLATE LU STA LU AND SAVE ADB .12 POINT TO LOCK/UNLOCK FLAG (DCB 15) LDA B,I AND GET FLAG SZA SHOULD WE UNLOCK? JMP EXI NO, EXIT JSB LURQ CALL TO UNLOCK DEF *+4 DEF B40K UNLOCK NO ABORT DEF LU DEF .1 NOP ERROR RETURN (IGNORE) * EXI LDA IRX RESTORE ERROR CODE * EXIT STA IERR,I SET THE ERROR CODE JMP DLOSE,I EXIT ERROR CODE IN A SPC 3 ER10 CLA,RSS NOT ENOUGH PRAMS - ERROR 10 ER11 CCA FILE NOT OPEN - ERROR 11 ADA N10 JMP EXIT GO EXIT SPC 3 FAKE OCT 177700 B40K OCT 40000 B77 OCT 77 N10 DEC -10 N2 DEC -2 .1 DEC 1 .2 OCT 2 .8 DEC 8 .12 DEC 12 .13 DEC 13 SC NOP OPNFL NOP ZERO NOP \ THESE TWO ARE DUMMY PARAMETERS NOP / TWO NECESSARY FOR DOUBLE WORD DZERO DEF ZERO DBLWD NOP DOUBLE WORD FLAG LU NOP SPC 2 A EQU 0 B EQU 1 SPC 1 END EQU * SPC 1 END   92070-18040 1941 S C0122 &CREAT              H0101 pASMB,R,L,C * NAME: CREAT * SOURCE: 92070-18040 * RELOC: 92070-16040 * PGMR: G.A.A. * MOD: M.L.K. * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * * NAM CREAT,7 92070-1X040 REV.1941 790709 * HED CREAT ENT CREAT,ECREA EXT CLOSE,$OPEN,.ENTR,GTOPN EXT CLD.R,.P1,.P2,.P3,.P4,.P6,.P7,.P8,.P9 EXT NAM..,$DBLX,.R1,.R2,.R3,.R5 SUP * * * CREAT IS THE FILE CREATION MODULE OF THE REAL TIME * FILE MANAGEMENT PACKAGE. * * THE FORTRAN CALLING SEQUENCE IS: * * CALL CREAT(IDCB,IERR,NAME,ISIZE,ITYPE,IS,ILU,IBLK,JSIZ) * O R * IER = CREAT(IDCB,IERR,NAME,ISIZE,ITYPE,IS,ILU,IBLK,JSIZ) * * W H E R E: * * IDCB IS THE ADDRESS OF A 144-WORD ARRAY WHICH * CREAT WILL USE AS A SCRATCH AREA. IF * ISIZE<0 THEN THE CREATED FILE IS ALSO * OPENED TO THIS DATA CONTROL BLOCK. * * IERR IS THE ADDRESS TO WHICH THE ERROR CODE * IS RETURNED. THIS INFORMATION IS ALSO * RETURNED IN THE A REGISTER. * * ERROR CODES ARE: * * >0 THE CREAT WAS SUCCESSFUL - THE #SECTORS IS RETURNED * -1 THE DISC IS DOWN * -2 DUPLICATE NAME * -4 FILE TOO LONG * -6 CARTRIDGE NOT FOUND * -10 NOT ENOUGH PARAMETERS IN THE CALL * -13 DISC LOCKED * -14 DIRECTORY FULL * -15 ILLEGAL NAME * -16 ILLEGAL TYPE OR SIZE * * * * NAME IS A 3-WORD ARRAY CONTAINING THE NEW FILE'S NAME. * THE NAME MUST CONTAIN ONLY LEGAL ASCII * CHARACTERS nlINCLUDING EMBEDDED BLANKS. COMMAS, * + SIGN, - SIGN ARE NOT ALLOWED. * IN ADDITION THE FIRST * CHARACTER MUST BE NON-NUMERIC AND NON-BLANK. * * ISIZE A TWO-WORD ARRAY. WORD 1 IS THE SIZE IN * 124-WORD DOUBLE SECTORS. WORD 2 IS USED * ONLY FOR TYPE 2 FILES AND IS THE RECORD LENGTH. * * ITYPE IS THE FILE TYPE--MUST BE >0. * * IS (OPTIONAL); IS THE FILE'S SECURITY CODE. * IF IS>0 THE FILE IS WRITE PROTECTED. * IF IS<0 THE FILE IS OPEN PROTECTED. * IF IS=0 OR IS NOT CODED THE FILE IS PUBLIC. * * ILU (OPTIONAL); DIRECTS THE CREAT TO: * IF ILU<0 THEN THE DISC AT LOGICAL UNIT (-ILU). * IF ILU>0 THEN THE DISC WITH LABEL ILU. * IF ILU=0 OR NOT CODED, THE FIRST AVAILABLE * DISC WITH ENOUGH ROOM IS USED. * * IBLK (OPTIONAL); SPECIFIES A DCB BUFFER AREA OF * IBLK WORDS. (NORMALLY 128 IS USED.) MUST BE A * MULTIPLE OF 128. THE BUFFER MUST BE AN EVEN * DIVISOR OF THE FILE SIZE SO ONLY PART OF * THE SPECIFIED SIZE MAY BE USED. THE USED SIZE IS: * USED SIZE=FILE SIZE/N WHERE * N=(FILE SIZE/IBLK)+(IF REMAINDER THEN 1,ELSE 0) * * JSIZ (OPTIONAL, FOR ECREA ONLY) FOR A SUCCESSFUL FILE * CREATION, THE FILE SIZE IS RETURNED IN THE DOUBLE * WORD AT JSIZ. * * SCHEDULE PARAMETERS FOR D.RTR * * P1. FUNCTION CODE (1) * P2. +CR\-LU * P3. NAME 1,2 * P4. 3,4 * P5. 5,6 * P6. TYPE * P7. FILE SIZE * P8. RECORD SIZE * P9. SEC CODE * SKP ECREA NOP DOUBLE WORD ENTRY CCA SET DOUBLE WORD FLAG LDB ECREA SET UP RETURN ADDRESS JMP SETUP GO FINISH SPC 5 CREAT NOP CLA SET FALSE FOR DBL FLAG LDB CREAT GET RETURN ADDRESS SETUP STA DBLWD  STORE DOUBLE FLAG STB DREAT STORE RETURN ADDRESS LDA DZERO STA SC STA LU STA TYPE STA IBLK STA SCFLG LDA DDMSZ STA FSIZ JMP DREAT+1 SPC 5 DCB NOP IERR NOP NAME NOP SIZE NOP TYPE DEF ZERO SC DEF ZERO LU DEF ZERO IBLK DEF ZERO FSIZ NOP NOP SCFLG DEF ZERO SCRATCH FILE CREATE FLAG SPC 1 DREAT NOP ENTRY POINT JSB .ENTR TRANSFER THE PARAMETERS DEF DCB LDA TYPE MAKE SURE THERE ARE CPA DZERO ENOUGH JMP ER10 NO - ERROR EXIT * LDA DBLWD GET DBL FLAG SZA,RSS DOUBLE OR SINGLE? JMP SINGL SINGLE, SKIP TESTS DLD SIZE,I DID USER PASS -1 ? ADA B ADD A AND B TO CHECK FOR -1 PASSED CPA N2 RESULT EQUAL TO -2? JMP STBZ YES, JUST STORE THEN DLD SIZE,I NO, GET SIZE AGAIN TO JSB $DBLX CHECK RANGE JMP EXIT ERROR (A = ERROR CODE) STBZ STB DSIZE SAVE LO ORDER BITS LDA TYPE,I IS THIS TYPE CPA .2 TYPE 2 ? RSS YES, MUST CHECK SIZE JMP UPDAT NO ISZ SIZE POINT TO SECOND ISZ SIZE DOUBLE WORD OF PAIR DLD SIZE,I NOW GET SIZE JSB $DBLX CHECK RANGE JMP EXIT ERROR RETURN STB DSIZ2 SAVE SIZE UPDAT LDA ADSIZ POINT TO INTERNAL STA SIZE SIZE ARRAY * SINGL JSB CLOSE GO CLOSE THE DCB (IF OPEN) DEF *+2 DEF DCB,I SZA NO ERROR CPA N11 AND NOT OPEN ERROR - OK RSS SO SKIP IF THIS IS THE CASE JMP EXIT ELSE EXIT SOME CLOSE ERROR * * * JSB GTOPN GET CURRENT OPEN FLAG DEF *+1 CPA SCFLG,I IS THE SCRATCH FLAG SET AND CORRECT? JMP SETNM YES, THEN SKIP NAME CHECK JSB NAM.. GO CHECK THE NAME DEF *+2 DEF NAME,I SZA IF^ OK SKIP JMP EXIT ELSE EXIT ERROR * SETNM LDA NAME,I GOOD NAME SO STA .P3 SET ISZ NAME UP DLD NAME,I SKELETON DIRECTORY DST .P4 ENTRY IN BUF LDA TYPE,I SZA TYPE MUST BE SSA >0 JMP ER16 NOT >0 ; ERR STA .P6 LDB SIZE,I GET THE SIZE SZB,RSS IF SIZE IS ZERO, JMP ER16 THEN ERROR SSB,RSS IF POSITIVE JMP POSTV GO CHECK SIZE CCB NEGATIVE, SET SIZE TO -1 FOR D.RTR JMP STRP7 GO STORE .P7 POSTV RBL DOUBLE SIZE TO PHYSICAL SECTORS SSB REQUEST > 32K JMP ER16 YES, ERROR STRP7 STB .P7 SET ISZ SIZE STEP TO RECORD SIZE CPA .2 IF NOT TYPE TWO CLA,RSS THEN JMP CREA4 SKIP SIZE TEST LSR 10 SHIFT TO A FOR DIVIDE DIV SIZE,I IF OVER FLOW THE RECORD SIZE TO SMALL SOC IF OK SKIP JMP ER4 ELSE ERROR FILE TOO LARGE CREA4 LDA SIZE,I LDB .P6 GET TYPE CPB .1 IF TYPE=1 LDA .128 SET SIZE TO 128 CPB .2 IF TYPE TWO SIZE MUST BE GIVEN SSA,RSS SIZE GIVEN? RSS YES; OR NOT TYPE TWO SKIP JMP ER4 ELSE ERROR ADB N3 TYPE 3 OR GREATER SSB,RSS YES, THEN CLA CLEAR RECORD SIZE STA .P8 SET RECORD SIZE LDA SC,I SET STA .P9 SECURITY CODE CLA,INA SET STA .P1 FUNCTION CODE LDA LU,I SET STA .P2 THE LU/CR WORD JSB CLD.R GO CALL D.RTR * LDA .R1 GET D.RTR COMPLETION SSA CODE - OK JMP EXIT NO; TAKE EXIT LDA .R2 YES; SET UP STA DCB,I TO CALL LDB DCB $OPEN CLE,INB TO LDA .R3 OPEN STA B,I THE 9 LDA DCB FILE LDB SC,I STO SET UP FOR A UPDATE OPEN JSB $OPEN SET UP REST OF DCB DEF IBLK,I ADDRESS OF BLOCK SIZE DEF .R5 ADDRESS OF NO OF SECTORS/TRACK JMP EXIT DISC ERROR - EXIT LDA TYPE,I GET TYPE ADA N3 IF 3 OR MORE SSA SKIP TO WRITE EOF JMP EXIT0 NOT RANDOM ACCESS FILE LDA FLAGS SET WRITTEN ON FLAG IN DCB LDB DCB GET WRITE FLAG ADB .13 ADDRESS STA B,I SET WRITTEN ON FLAG ADB .3 STEP TO THE BUFFER CCA AND SET EOF STA B,I IN FIRST WORD OF BUFFER EXIT0 LDA .R1 NO; USE D.RTR RETURN FOR ERROR EXIT STA IERR,I SET SINGLE WORD ERROR CODE ISZ DBLWD TEST DBL FLAG JMP DREAT,I SINGLE WORD EXIT SSA ERROR? JMP DREAT,I YES, RETURN CLB SET B FOR NORMAL COMPLETION (HI BITS 0) SWP PUT HI BITS IN A, LO IN B DST FSIZ,I STORE FILE SIZE STA IERR,I STORE 0 IN ERROR CODE JMP DREAT,I DOUBLE WORD EXIT SPC 3 ER4 LDA N4 SET ERROR JMP EXIT CODE ER10 LDA N10 AND JMP EXIT EXIT ER16 LDA N16 GET THE ERROR CODE JMP EXIT TAKE EXIT SKP N16 DEC -16 N10 DEC -10 N11 DEC -11 N2 DEC -2 N3 OCT -3 N4 OCT -4 .1 OCT 1 .2 DEC 2 .3 OCT 3 .13 DEC 13 .128 DEC 128 FLAGS OCT 100001 IB AND WR FLAGS ZERO NOP \ THESE TWO ARE DUMMY ZERO FOR NOP / FOR DOUBLE WORD DZERO DEF ZERO DSIZE NOP \ DUMMY SIZE IS DSIZ2 NOP / TWO WORDS ADSIZ DEF DSIZE ADDRESS TO INTERNAL SIZE PARAMETER DBLWD NOP DOUBLE WORD FLAG DDMSZ DEF DUMSZ ADDRESS OF DUMMY SIZE DUMSZ BSS 2 DUMMY RETURN SIZE FOR ECREA * A EQU 0 B EQU 1 SPC 1 END EQU * SPC 1 END .$"$  92070-18041 1941 S C0122 &CRETS              H0101 ASMB,R,L,C * NAME: CRETS * SOURCE: 92070-18041 * RELOC: 92070-16041 * PGMR: M.L.K. * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * * NAM CRETS,7 92070-1X041 REV.1941 790709 * HED CRETS ENT CRETS EXT .ENTR,GTOPN,ECREA EXT CLD.R,.P1,.P2,.P3,.P4,.R1 SUP * * * CRETS IS THE SCRATCH FILE CREATION MODULE OF THE REAL TIME * FILE MANAGEMENT PACKAGE. * * THE FORTRAN CALLING SEQUENCE IS: * * CALL CRETS(IDCB,IERR,NUM,NAME,ISIZE,ITYPE,IS,ILU,IBLK,JSIZ) * O R * IER = CRETS(IDCB,IERR,NUM,NAME,ISIZE,ITYPE,IS,ILU,IBLK,JSIZ) * * W H E R E: * * IDCB IS THE ADDRESS OF A 144-WORD ARRAY WHICH * CRETS WILL USE AS A SCRATCH AREA. IF * ISIZE<0 THEN THE CREATED FILE IS ALSO * OPENED TO THIS DATA CONTROL BLOCK. * * IERR IS THE ADDRESS TO WHICH THE ERROR CODE * IS RETURNED. THIS INFORMATION IS ALSO * RETURNED IN THE A REGISTER. * * ERROR CODES ARE: * * >0 THE CRETS WAS SUCCESSFUL - THE #SECTORS IS RETURNED * -1 THE DISC IS DOWN * -2 DUPLICATE NAME * -4 FILE TOO LONG * -6 CARTRIDGE NOT FOUND * -10 NOT ENOUGH PARAMETERS IN THE CALL * -13 DISC LOCKED * -14 DIRECTORY FULL * -15 ILLEGAL NAME * -16 ILLEGAL TYPE OR SIZE * -38 ILLEGAL FILE NUMBER * * * NUM THE SCRATCH FILE NUMBER TO CREATE * * * NAME IS A 3-WORD ARRAY CONTAINING THE NEW FILE'S NAME * WHICH CRETS HAS CREATED. NOTE: THIS IS A RETURNED ‹* PARAMETER. * * ISIZE A TWO-WORD ARRAY. WORD 1 IS THE SIZE IN * 124-WORD DOUBLE SECTORS. WORD 2 IS USED * ONLY FOR TYPE 2 FILES AND IS THE RECORD LENGTH. * THE DEFAULT SIZE IS 30 BLOCKS. * * ITYPE IS THE FILE TYPE--MUST BE >0. THE DEFAULT IS TYPE 3. * * IS (OPTIONAL); IS THE FILE'S SECURITY CODE. * IF IS>0 THE FILE IS WRITE PROTECTED. * IF IS<0 THE FILE IS OPEN PROTECTED. * IF IS=0 OR IS NOT CODED THE FILE IS PUBLIC. * * ILU (OPTIONAL); DIRECTS THE CRETS TO: * IF ILU<0 THEN THE DISC AT LOGICAL UNIT (-ILU). * IF ILU>0 THEN THE DISC WITH LABEL ILU. * IF ILU=0 OR NOT CODED, THE FIRST AVAILABLE * DISC WITH ENOUGH ROOM IS USED. * * IBLK (OPTIONAL); SPECIFIES A DCB BUFFER AREA OF * IBLK WORDS. (NORMALLY 128 IS USED.) MUST BE A * MULTIPLE OF 128. THE BUFFER MUST BE AN EVEN * DIVISOR OF THE FILE SIZE SO ONLY PART OF * THE SPECIFIED SIZE MAY BE USED. THE USED SIZE IS: * USED SIZE=FILE SIZE/N WHERE * N=(FILE SIZE/IBLK)+(IF REMAINDER THEN 1,ELSE 0) * * JSIZ (OPTIONAL) THE SIZE OF THE FILE CREATED IF * SUCCESSFUL. THIS IS A DOUBLE WORD VALUE * SKP CRETS NOP ENTRY POINT LDA CRETS MOVE THE STA DRETS RETURN ADDRESS LDA DZERO GET DUMMY 0 FOR DEFAULT STA NAME STA SC STA LU STA IBLK LDA DFLTS GET DEFAULT SIZE STA SIZE (=24 BLOCKS) LDA DFLTT GET DEFAULT TYPE STA TYPE (= 3) LDA DDMSZ GET POINTER TO DUMMY SIZE STA FSIZ STORE AT PARAMETER ADDRESS JMP DRETS+1 GO SET UP PARAMETERS SPC 3 DCB NOP IERR NOP NUM NOP NAME NOP SIZE NOP TYPE NOP SC NOP LU NOP IBLK NOP FSIZ NOP * DRETS NOP JSB .ENTR DEF DCB * LDA NAME TEST FOR ENOUGH CPA DZERO PARAMETERS JMP ER10 NOT ENOUGH! ERROR LDA NAME GET POINTER TO USER'S NAME BUFFER INA INCREMENT TO SECOND WORD STA NAME2 AND SAVE INA INCREMENT TO THIRD WORD STA NAME3 AND SAVE * JSB GTOPN GET CURRENT OPEN FLAG DEF *+1 STA OPFLG SAVE IT FOR LATER AND B377 ISOLATE THE ID NUMBER JSB CHAR CONVERT TO ASCII STB NAME2,I STORE TEMPORARILY IN LOW BITS JSB CHAR CONVERT THE NEXT CHAR OF ID # STB NAME,I STORE IN LOW BITS JSB CHAR CONVERT 100'S DIGIT BLF,BLF SHIFT TO HIGH BYTE ADB NAME,I ADD 10'S DIGIT STB NAME,I AND STORE IN USER'S BUFFER * LDB NAME2,I GET 1'S DIGIT LDA OPFLG AND RESTORE OPEN FLAG AND B3400 ISOLATE THE CPU# LSL 8 SHIFT BYTES INTO POSITION IN B ADB B60 ADD 60B TO CONVERT TO ASCII STB NAME2,I STORE IN USER'S BUFFER * LDA NUM,I TEST SCRATCH FILE NUMBER SSA TEST IF NEGATIVE JMP ER38 YES, ERROR 38 ADA M100 TEST FOR TOO LARGE SSA,RSS JMP ER38 YES, ERROR 38 * LDA NUM,I GET NUMBER AGAIN JSB CHAR CONVERT 1'S TO ASCII STB NAME3,I STORE IN USER'S BUFFER JSB CHAR CONVERT UPPER CHARACTER BLF,BLF SHIFT UP ADB NAME3,I ADD LOWER CHARACTER STB NAME3,I AND STORE IN USER'S BUFFER * * CALL ECREA * CREAT JSB ECREA CALL DOUBLE WORD CREATE DEF RTN DEF DCB,I DEF IERR,I DEF NAME,I DEF SIZE,I DEF TYPE,I DEF SC,I DEF LU,I DEF IBLK,I DEF FSIZ,I DZERO DEF ZERO DEF OPFLG * RTN SZA,RSS TEST FOR ERROR JMP EXIT NO ERROR, EXIT CPA M2 A -2 ERROR? JMzNP PURGE YES, DO SCRATCH FILE PURGE EXIT STA IERR,I NO, EXIT WITH CREAT ERROR CODE JMP DRETS,I * * * PURGE LDA .9 SET UP D.RTR CALLING PARAMETERS STA .P1 FOR SCRATCH FILE PURGE ON OPEN LDA LU,I STA .P2 SET UP LU LDA NAME,I GET FIRST TWO CHARACTERS STA .P3 STORE IN D.RTR CALLING PARAMETER DLD NAME2,I GET LAST FOUR CHARACTERS OF NAME IOR SIGN SET SCRATCH FILE PURGE BIT DST .P4 STORE IN .P4 AND .P5 JSB CLD.R CALL D.RTR * LDA .R1 GET ERROR PARAMETER CPA M101 IS IT -101 ? JMP EXIT YES, ERROR, CAN'T PURGE JMP CREAT NO, GO TRY TO CREATE THE FILE AGAIN * * ER38 LDA M38 SET ILLEGAL FILE NUMBER RETURN JMP EXIT * ER10 LDA M10 SET NOT ENOUGH PARAMETERS JMP EXIT * * CHARACTER CONVERSION SUBROUTINE * CHAR NOP CLB CLEAR UPPER BITS DIV .10 CONVERT TO DECIMAL CHARACTER ADB B60 CONVERT TO ASCII JMP CHAR,I RETURN SKP * * CONSTANTS * .9 DEC 9 .10 DEC 10 B60 OCT 60 B377 OCT 377 B3400 OCT 3400 M38 DEC -38 M100 DEC -100 M101 DEC -101 M2 DEC -2 M10 DEC -10 SIGN OCT 100000 ZERO NOP NOP TWO NECESSARY FOR DOUBLE WORD DFLTS DEF DSIZE DSIZE NOP DEFAULT SIZE DEC 24 = 24 BLOCKS DFLTT DEF DTYPE DTYPE DEC 3 = 3 DDMSZ DEF DUMSZ * * VARIBLES * NAME2 NOP NAME3 NOP OPFLG NOP DUMSZ BSS 2 DUMMY RETURN SIZE * END EQU * END V  92070-18042 1941 S C0122 &FCONT              H0101 pASMB,R,L,C * NAME: FCONT * SOURCE: 92070-18042 * RELOC: 92070-16042 * PGMR: G.A.A. * MOD: M.L.K. * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * * NAM FCONT,7 92070-1X042 REV.1941 790709 * HED FCONT ENT FCONT EXT .ENTR,EXEC,GTOPN * * THIS IS THE TYPE ZERO CONTROL ROUTINE OF * THE RTE FILE MANAGEMENT PACKAGE. * * A STANDAD RTE CONTROL REQUEST IS ISSUED * TO THE DEVICE VIA THE EXEC IF THE * DCB IS OPEN TO A TYPE ZERO FILE. * CALLING SEQUENCE * CALL FCONT(IDCB,IERR,ICON1,ICON2) * WHERE: * IDCB IS THE DATA CONTROL BLOCK FOR * THE FILE. * IERR IS THE LOCATION FOR RETURNED * ERRORS. * POSSIBLE ERRORS ARE: * 0 NO ERRORS * -10 NOT ENOUGH PARAMETERS * -11 DCB NOT OPEN * >0 NOT A TYPE ZERO FILE (IERR=TYPE) * ICON1 IS CONTROL WORD #1 - THE DEVICE * LU IS MURGED INTO THE LOW * 6 BITS OF THIS WORD * ICON2 IS CONTROL WORD TWO - OPTIONAL * ZERO IS USED IF NOT SPECIFIED * ON RETURN A = IERR * B = DEVICE STATUS SKP FCONT NOP LDB DZERO RESET X REP 7 ENTRY STB *-X+IDCB ADDRESS CLB CLEAR DUMMY STB ZERO ZERO LDA FCONT STA DCONT MOVE PARM ADDRESS TO DUMMY ENTRY JMP DCONT+1 * * IDCB DEF ZERO PARAMETER IERR DEF ZERO ADDRESS ICNWD DEF ZERO AREA IPRM1 DEF ZERO IPRM2 DEF ZERO IPRM3 -DEF ZERO IPRM4 DEF ZERO SPC 1 DCONT NOP ENTRY POINT JSB .ENTR FETCH PARAMETERS DEF IDCB * LDA N10 FETCH ERROR CODE LDB ICNWD FOR NOT ENOUGH PARMS CPB DZERO OK????? JMP EXIT NOPE--GET OUT * LDB IDCB GET DCB ADB .2 ADDRESS STB TYPE OF TYPE ADB .7 AND JSB GTOPN GET CURRENT OPEN FLAG DEF *+1 CPA B,I IS IT THE SAME AS IN DCB? JMP OK YES, CONTINUE LDA N11 NO; SEND NOT OPEN ERROR EXIT STA IERR,I TO CALLER LDB STAT STATUS TO B AND JMP DCONT,I RETURN SKP OK LDA TYPE,I GET FILE TYPE SZA ZERO? JMP EXIT NO; EXIT : TYPE IN A SPC 1 ISZ TYPE YES; STEP TO WORD WITH LU LDA TYPE,I GET LU AND B77 AND ISOLATE THEN STA B SAVE LDA ICNWD,I GET THE FUNCTION AND B1777 MAKE SURE THE LOW END IS ZERO IOR B PUT THEM TOGETHER STA ICNWD SET FOR CALL JSB EXEC CALL EXEC TO DEF EXRTN DO DEF FUNC THE DEF ICNWD CONTROL DEF IPRM1,I FUNCTION DEF IPRM2,I DEF IPRM3,I DEF IPRM4,I EXRTN JMP EXM17 ERROR RETURN FROM EXEC STA STAT SAVE STATUS FOR RETURN JMP EXIT GO; EXIT * * EXM17 LDA N17 JMP EXIT SKP * * CONSTANT AREA * FUNC OCT 100003 B1777 OCT 177700 B200 OCT 200 N17 DEC -17 .2 OCT 2 TYPE NOP .7 DEC 7 N10 DEC -10 N11 DEC -11 DZERO DEF ZERO ZERO NOP STAT NOP B77 OCT 77 SPC 2 A EQU 0 B EQU 1 SPC 1 END EQU * SPC 1 END A    92070-18043 1941 S C0122 &FSTAT              H0101 tASMB,R,L,C * NAME: FSTAT * SOURCE: 92070-18043 * RELOC: 92070-16043 * PGMR: M.L.K. * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * * NAM FSTAT,7 92070-1X043 REV.1941 790709 * HED FSTAT ENT FSTAT EXT .ENTR,.MVW,$CDIR,$MDSP * SPC 3 FSTAT NOP DUMMY ENTRY POINT LDA D125 GET DEFAULT LENGTH STA STAT STORE TO TEST FOR PARAMETER SENT STA LEN STORE HERE FOR DEFAULT LDA FSTAT STA DSTAT JMP DSTAT+1 * * STAT NOP LEN NOP * DSTAT NOP JSB .ENTR DEF STAT LDA N10 PRESET ERROR LDB STAT CHECK FOR ARRAY ADDRESS CPB D125 SAME AS DEFAULT? JMP DSTAT,I YES, ERROR -10, NOT ENOUGH PARAMETERS * LDA DCDIR GET ADDRESS OF START OF DIRECTORY LDB $MDSP GET END OF DIRECTORY ADDRESS CMA,INA MAKE STARTING ADDRESS NEGATIVE ADB A CALCULATE SIZE INB ADD ONE FOR TERMINATION WORD LDA LEN,I GET USER'S BUFFER LENGTH CMA,INA SET A NEGATIVE ADA B ADD TO DIRECTORY SIZE SSA,RSS USE WHICH SIZE? LDB LEN,I USE PASSED PARAMETER STB LENTH STORE FOR CALL * LDA DCDIR LOAD A SOURCE ADDRESS LDB STAT LOAD B DESTINATION ADDRESS JSB .MVW CALL MOVE DEF LENTH WITH NUMBER OF PARAMETERS TO MOVE NOP (FOR COMPATIBILITY) * CLA SET NO ERROR JMP DSTAT,I SKP N10 DEC -10 D125 DEF .125 .125 DEC 125 LENTH NOP DCDIR DEF $CDIR+0 * A W4   EQU 0 B EQU 1 * END EQU * END    92070-18044 1941 S C0122 &IDCBS              H0101 gASMB,R,L,C * NAME: IDCBS * SOURCE: 92070-18044 * RELOC: 92070-16044 * PGMR: G.A.A. * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * * NAM IDCBS,7 92070-1X044 REV.1941 790709 * HED IDCBS ENT IDCBS EXT .ENTR,GTOPN * IDCB NOP IDCBS NOP JSB .ENTR FETCH PARAM ADDR DEF IDCB LDB IDCB ADB D9 OFFSET TO OPEN FLAG JSB GTOPN GET CURRENT OPEN FLAG DEF *+1 CPA B,I IS IT THE SAME AS IN DCB? JMP OPEND YES, ITS OPEN LDA MD11 JMP EXIT EXIT ERROR -11 * OPEND ADB MD7 BACK UP TO WORD 2 LDA B,I CPA D1 FILE TYPE 1? CLA OR 0? SZA,RSS YES, SET BUFFER SIZE=0 * JMP RTNOK * ADB D5 ADVANCE TO WORD 7 LDA B,I GET SIZE WORD ARS,ALR BUT CLEAR BITS 0 AND 15 RTNOK ADA D16 ADD 16 TO BUFFER SIZE EXIT JMP IDCBS,I RETURN DCB SIZE IN A * A EQU 0 B EQU 1 D1 DEC 1 D5 DEC 5 D9 DEC 9 D16 DEC 16 MD11 DEC -11 MD7 DEC -7 * END   92070-18045 2001 S C0122 &LOCF              H0101 tTASMB,R,L,C * NAME: LOCF * SOURCE: 92070-18045 * RELOC: 92070-16045 * PGMR: G.A.A. * MOD: M.L.K. * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * * NAM LOCF,7 92070-1X045 REV.2001 800103 * HED LOCF ENT LOCF,ELOCF EXT P.PAS,.ENTR,GTOPN SUP SPC 2 * * * LOCF RETURNS THE CURRENT STATUS OF A * RTE FILE TO THE CALLER. * SPC 1 * * THE FORTRAN CALLING SEQUENCE IS: * SPC 1 * CALL LOCF(IDCB,IERR,IREC,IRS,IOFF,JSEC,JLU,JTY,JREC) * SPC 1 * * W H E R E: * SPC 1 * IDCB IS THE DATA CONTROL BLOCK FOR THE FILE. * * IERR IS THE ERROR CODE RETURN. * POSSIBLE CODES ARE: * 0 - NO ERROR * -11 - DCB NOT OPEN * -10 - NOT ENOUGH PARAMETERS * * IREC IS THE RECORD NUMBER OF THE NEXT RECORD. * * IRS IS THE RELATIVE SECTOR OF THE NEXT RECORD./2 * * IOFF IS THE OFFSET IN THE SECTOR OF THE NEXT RECORD. * * JSEC IS THE NO. OF SECTORS IN THE FILE (OR EXTENT). * * JLU IS THE FILE'S LOGICAL UNIT. * * JTY IS THE FILE'S TYPE. * * JREC IS THE RECORD SIZE. * SPC 1 * ALL PARAMETERS AFTER IREC ARE OPTIONAL. * SKP ELOCF NOP DOUBLE WORD ENTRY POINT CCA SET DOUBLE WORD FLAG LDB ELOCF AND GET RETURN ADDRESS JMP SETUP GO FINISH SET UP SPC 3 LOCF NOP CLA CLEAR DOUBLE WORD FLAG LDB LOCF GET RETURN ADDRESS SETUP STA DBLWD STORE DBL FLAG STB DOCF STORE RETURN ADDRESS LDA DFDM STA IER STA IREC STA IRS STA IOFF STA JSEC STA JLU STA JTY STA JREC JMP DOCF+1 SPC 3 DCB NOP IER DEF DM IREC DEF DM IRS DEF DM IOFF DEF DM JSEC DEF DM JLU DEF DM JTY DEF DM JREC DEF DM * DOCF NOP ENTRY JSB .ENTR GET DEF DCB PARAMETERS ADDRESSES LDA N10 NOT ENOUGH LDB IREC PRAM CPB DFDM TEST JMP EXIT NOT ENOUGH - EXIT * ISZ DBLWD TEST DOUBLE FLAG JMP SINGL SINGLE WORD ENTRY CLA STORE UPPER BITS STA IREC,I AS ZERO IN STA IRS,I DOUBLE WORD STA JSEC,I PARAMETERS ISZ IREC THEN POINT THEM ISZ IRS TO THE SECOND ISZ JSEC HALF OF THE INTEGER * SINGL LDA DCB SET A TO GET DCB CLB,CCE SET TO GET ERB,CLE ACTUAL WORDS JSB P.PAS CALL TO PASS N16 DEC -16 DCB LU NOP PARAMETERS AD NOP TYP NOP TRK NOP SEC NOP #SEC NOP SIZE NOP COUNT NOP SEC/T NOP OPCLS NOP CTRK NOP CSEC NOP BUFPT NOP TMP NOP REC NOP EXNO NOP JSB GTOPN GET CURRENT OPEN FLAG DEF *+1 IS IT THE SAME AS IN DCB? CPA OPCLS JMP OK YES, IT IS OPEN LDA N11 NO, SET ERROR -11 EXIT STA IER,I NO; SET EXIT CODE JMP DOCF,I EXIT SPC 3 OK LDB REC GET AND STB IREC,I SET RECORD NO. LDB #SEC SET STB JSEC,I THE FILE SIZE IN SECTORS LDA TYP GET THE TYPE CMA,INA,SZA,RSS SET NET AND TEST FOR ZERO JMP TYPST ZERO SO JUMP ADA .2 IF THREE OR GREATER SSA THEN JMP NOTRA JUMP NOT RANDOM ACCESS CCA COMPUTE THE OFFSET ADA REC AND BLOCK MPY SIZE FOR STA TMP TYPE AND Ǵ B177 ONE AND STA IOFF,I TWO XOR TMP FILES ASR 7 NOW JMP STRS GO STORE IT NOTRA LDA DCB COMPUTE CMA,INA CURRENT ADA BUFPT BUFFER OFFSET ADA N16 ADJUST FOR BUFFER ADDRESS CLB RE ADDJUST OFFSET TO DIV .128 128 WORD BLOCK BASE STB IOFF,I STA TMP SAVE OVERFLOW LDA #SEC GET AND CLE,ERA DIVIDE BY TWO TO GET BLOCKS MPY EXNO COMPUTE EXTENT OFFSET STA EXNO AND SAVE LDA TRK COMPUTE RELATIVE CMA,INA SECTOR ADA CTRK CTRK-TRK MPY SEC/T (CTRK-TRK)*#SEC/TRACK LDB SEC CMB,INB ADA B (CTRK-TRK)*#S/TR-SEC ADA CSEC (CTRK-TRK)*#S/TR-SEC+CSEC CLE,ERA CONVERT TO BLOCKS ADA EXNO ADD #BLOCKS IN PREVIOUS EXTENTS ADA TMP ADD THE BLOCK OVER FLOW STRS STA IRS,I AND PASS TO CALLER TYPST LDB TYP GET AND SET STB JTY,I TYPE LDA LU GET LU (DISC FILE) SZB,RSS IS IT A DISC FILE? LDA TRK NO; USE TYPE 0 LU AND B77 MASK STA JLU,I AND SET LDA SIZE GET THE RECORD STA JREC,I SIZE AND SET IT CLA NO ERRORS JMP EXIT RETURN SPC 4 B177 OCT 177 .128 DEC 128 .2 DEC 2 N10 DEC -10 N11 DEC -11 B77 OCT 77 DFDM DEF *+1 DM NOP \ THESE TWO ARE DUMMIES (TWO FOR NOP / DOUBLE INTEGER) DBLWD NOP DOUBLE WORD FLAG A EQU 0 B EQU 1 END EQU * SPC 1 END 8  92070-18046 1941 S C0122 &NAMF              H0101 jiASMB,R,L,C * NAME: NAMF * SOURCE: 92070-18046 * RELOC: 92070-16046 * PGMR: G.A.A. * MOD: M.L.K. * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * * NAM NAMF,7 92070-1X046 REV.1941 790709 * HED NAMF EXT .ENTR,CLOSE,NAM..,OPEN EXT CLD.R,.P1,.P2,.P3,.P4,.P6,.R1 ENT NAMF SUP * * NAMF IS THE FILE NAME CHANGE MODULE OF THE * RTE FILE MANAGEMENT PACKADGE. * * CALLING SEQUENCE: * * CALL NAMF(IDCB,IERR,NAME,NNAME,IS,ILU) * * WHERE: * IDCB IS A 144 WORD DATA CONTROL BLOCK * THIS AREA IS FREE AFTER THE CALL. * * IERR IS THE ERROR RETURN LOCATION * ERRORS ARE RETURNED HERE AND IN * THE A REGISTER. * DEFINED ERRORS ARE: * * * 0 NO ERROR * -1 DISC DOWN * -2 DUPLICATE NAME * -6 CARTRIDGE OR FILE NOT FOUND * -7 INVALID SECURITY CODE * -8 FILE CURRENTLY OPEN * -10 NOT ENOUGH PARAMETERS * -13 THE REQUIRED DISC IS LOCKED * -15 ILLEGAL NEW NAME * * NNAME THE NEW 6 CHARACTER FILE NAME * * IS OPTIONAL - THE FILE SECURITY CODE * * ILU OPTIONAL - THE FILES DISC ID. SKP NAMF NOP ENTRY POINT LDA DZERO X REP 3 STA *-X+NNAME CLA STA ZERO LDA NAMF STA DAMF JMP DAMF+1 * * DCB DEF ZERO IERR DEF ZERO NAME DEF ZERO NNAME DEF ZERO IS DEF ZERO ILU DEF ZERO * * DAMF NOP JSB .ENTR FETCH PARAM ADDRESSES DEF DCB TO LOCAL LIST SPC 1 LDA N10 LOAD FOR NOT ENOUGH PRAM REJECT LDB NNAME NEW NAME SUPPLIED? CPB DZERO JMP EXIT NO; GO EXIT SPC 1 JSB NAM.. YES;NEW NAME DEF NAM.R LEGAL DEF NNAME,I FOR A FILE NAME? NAM.R SZA JMP EXIT NO; EXIT JSB OPEN CALL DEF OPRTN TO DEF DCB,I OPEN DEF IERR,I THE DEF NAME,I FILE DEF ZERO EXCLUSIVELY DEF IS,I WITH DEF ILU,I USER PRAMS OPRTN SSA SUCESSFUL OPEN? JMP EXIT NO; EXIT LDA DCB YES; CHECK ADA .7 THE LDB A,I SECURITY LDA N7 CODE SSB,RSS MATCH? JMP CLOEX NO; CLOSE AND EXIT * LDA .2 STA .P1 LDB DCB LDA B,I STA .P2 INB LDA B,I STA .P3 DLD NNAME,I DST .P4 LDA NNAME ADA .2 LDA A,I STA .P6 JSB CLD.R * LDA .R1 ERROR FLAG TO A STA NAME SAVE IT SPC 1 RSS SKIP ERROR ENTRY CLOEX STA NAME SAVE ERROR CODE JSB CLOSE CLOSE DEF CLOR1 THE DEF DCB,I FILE CLOR1 LDB NAME GET ERROR CODE SZB IF NONE SKIP LDA B ELSE USE IT EXIT STA IERR,I SET RETURN ERROR JMP DAMF,I EXIT TO USER SPC 3 * CONSTANTS * ZERO NOP DZERO DEF ZERO N7 DEC -7 .7 DEC 7 N10 DEC -10 .2 DEC 2 A EQU 0 B EQU 1 END EQU * PROG. LENGTH SPC 1 END q   92070-18047 2009 S C0122 &OPEN              H0101 aASMB,R,L,C * NAME: OPEN * SOURCE: 92070-18047 * RELOC: 92070-16047 * PGMR: G.A.A. * MOD: M.L.K. * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * * NAM OPEN,7 92070-1X047 REV.2009 800225 SUP * HED OPEN ENT OPEN EXT LURQ,CLOSE,IFTTY,$OPEN EXT .ENTR,.P1,.P2,.P3,.P4,CLD.R EXT .R1,.R2,.R5 * * OPEN IS THE FILE OPEN ROUTINE OF THE REAL TIME * FILE MANAGEMENT PACKAGE * * THE FORTRAN CALLING SEQUENCE IS: * * CALL OPEN(IDCB,IERR,NAME,IOP,IS,ILU,IBLK) * * W H E R E: * * IDCB IS A 144-WORD DATA CONTROL BLOCK (ARRAY) * TO BE USED WITH ALL ACCESS TO THE FILE * UNDER THIS OPEN. * * IERR IS THE RETURN ERROR CODE (ALSO RETURNED IN A) * * NAME IS THE 6-CHARACTER (3 WORD) NAME ARRAY. * * IOP (OPTIONAL); IS THE OPEN OPTION FLAG WORD * OPTIONS ARE: * BIT MEANING IF SET * 0 NON-EXCLUSIVE OPEN * 1 UPDATE OPEN * 2 FORCE TO TYPE 1 OPEN * 3 USE SUB FUNCTION IN BITS 6-11 * IF TYPE 0. * * IS (OPTIONAL); IS THE EXPECTED SECURITY CODE. * * ILU (OPTIONAL); IS THE DISC SPECIFIED. * IF ILU >0 THEN USE DISC LABELED ILU * IF ILU <0 THEN USE DISC AT LOGICAL UNIT (-ILU) * * IBLK (OPTIONAL); SPECIFIES A DCB BUFFER AREA OF * IBLK WORDS. (NORMALLY 128 IS USED.) MUST BE A * E MULTIPLE OF 128. THE BUFFER MUST BE AN EVEN * DIVISOR OF THE FILE SIZE SO ONLY PART OF * THE SPECIFIED SIZE MAY BE USED. THE USED SIZE IS: * USED SIZE=FILE SIZE/N WHERE * N=(FILE SIZE/IBLK)+(IF REMAINDER THEN 1,ELSE 0) * * OPEN ERRORS ARE AS FOLLOWS: * * -1 DISC ERROR * -6 FILE NOT FOUND * -7 WRONG SECURITY CODE * -8 FILE IS CURRENTLY OPEN (IF EXCLUSIVE REQUEST) OR * IS CURRENTLY OPEN TO 7 OTHER PROGRAMS * -9 ATTEMPT TO OPEN TYPE 0 AS TYPE 1 * -10 NOT ENOUGH PARAMETERS * -13 DISC LOCKED * -36 LOCK ERROR SKP * * OPEN NOP LDA DZERO PRESET ENTRY PARMS STA NAME STA OP STA SC STA LU STA IBLK CLA RESET ZERO WORD STA ZERO LDA OPEN STA DPEN JMP DPEN+1 * * MIGHT NEED TO CLEAR ZERO * DCB NOP ERR NOP NAME DEF ZERO OP DEF ZERO SC DEF ZERO LU DEF ZERO IBLK DEF ZERO SPC 1 DPEN NOP ENTRY POINT JSB .ENTR TRANSFER PARAMETERS DEF DCB TO LOCAL AREA LDA N10 LDB NAME DID WE GET CPB DZERO ENOUGH PARAMETERS? JMP EXIT NO; ERROR - EXIT SPC 1 JSB CLOSE CLOSE DEF *+2 IF DEF DCB,I OPEN SZA SKIP IF NO ERRORS CPA N11 OR IF NOT OPEN CLE,RSS JMP EXIT ELSE TAKE ERR EXIT * LDA NAME,I LDB OP,I AND OPTION ERB EXCLUSIVE BIT TO E CME INVERT AND RAL,ERA SET IN SIGN OF A STA .P3 SET FOR CALL TO D.RTR STA LOCK STORE FOR LOCK TEST ISZ NAME GET DLD NAME,I REST OF SZA,RSS CHECK FOR NULL FROM ON PROCESSOR LDA BLK FILL WITH BLANK SZB,RSS SAME CHECK LDB BLK FILL WITH BLANKS DSbT .P4 LDA .9 FETCH OPEN CODE STA .P1 SET IN CALL LDA LU,I FETCH CR\LU STA .P2 SET IN CALL JSB CLD.R GO GET D.RTR * LDA .R1 GET ERROR WORD STA TMP SAVE FILE LENGTH OR 0 IF TYPE 0 SSA IF ERROR JMP EXIT EXIT DLD .R2 ELSE SET DST DCB,I THE DCB FOR $OPEN CLO SET O LDA OP,I TO RAR,SLA,RAR INDICATE STO UPDATE OPTION ERA AND E FOR TYPE 1 OVER-RIDE STA LU SAVE FLAG LDA DCB GET DCB ADDRESS LDB SC,I AND SECURITY CODE JSB $OPEN AND GO SET UP THE DCB DEF IBLK,I ADDRESS OF BLOCK SIZE DEF .R5 ADDRESS OF NO OF SECTORS PER TRACK JMP OPEN1 ERROR - CLOSE AND EXIT SSA IF OPEN PROTECT SSB AND CODE MISMATCH THEN SKIP JMP OPEN2 ELSE GO EXIT - GOOD OPEN SPC 2 LDA N7 SET EXIT CODE OPEN1 STA TMP IN TEMP JSB CLOSE ILLEGAL OPEN SO CLOSE DEF *+2 THE DEF DCB,I FILE OPEN2 LDA TMP GET FILE LENGTH, ERROR CODE OR 0 IF TYPE 0 SZA IF NOT TYPE ZERO JMP EXIT THEN EXIT SPC 1 LDB LU GET SUB FUNCTION FLAG AND ERB SET E AS SUB FUNCTION FLAG LDB DCB CACULATE DCB SUB FUNCTION ADB .3 ADDRESS STB SC SAVE IT LDA OP,I GET THE OPTIN SUB FUNCTION AND B477K MASK IT OFF STA B AND SAVE IT LDA SC,I GET THE CURRENT WORD AND B77 SAVE THE LU STA LU SAVE FOR LOCK ADA B ADD IN THE NEW SUB FUNCTION SEZ IF SUB FUNTION NOT SET USE FROM FILE STA SC,I SET IT IN THE DCB LDB DCB GET DCB ADDRESS ADB .15 POINT TO WORD 15 STB SC AND SAVE CLA,INA DEFAULT TO DON'T STB SC,I UNLOCK THE LU LDA LOCK LOCK THE LU? SSA,RSS TEST SIGN JMP LUEX DON'T LOCK, EXIT JSB IFTTY TEST IF LU IS DEF *+2 INTERACTIVE DEF LU SZA INTERACTIVE? JMP LUEX YES, DON'T LOCK! * JSB LURQ DEF *+4 DEF OPTN OPTION WORD DEF LU LU WORD DEF .1 ONE LU JMP ER18 ERROR ON LOCK SSA NO RN? JMP LCKER RIGHT, ERROR STA SC,I STORE LOCK WORD IN DCB15 LUEX CLA CLEAR A AND EXIT SPC 1 EXIT LDB DCB IF NO ERRORS, ADB .2 THEN REPLACE THE SIZE SSA,RSS WITH THE TYPE LDA B,I IF NO ERRORS EXIT2 STA ERR,I SET THE ERROR CODE JMP DPEN,I AND RETURN * * LCKER LDB DCB CLEAR THE OPEN ADB .9 FLAG (GET ADDRESS) CLA STA B,I FILE NOT OPEN LDA N36 COULDN'T LOCK ERROR JMP EXIT2 * * ER18 LDA N18 ILLEGAL LU JMP EXIT2 SKP DZERO DEF ZERO N10 DEC -10 N11 DEC -11 N7 DEC -7 ZERO NOP .1 OCT 1 .2 DEC 2 .3 DEC 3 .9 DEC 9 B77 OCT 77 BLK ASC 1, .15 DEC 15 N18 DEC -18 N36 DEC -36 TMP NOP LOCK NOP OPTN OCT 140001 B477K OCT 47700 SPC 3 A EQU 0 B EQU 1 SPC 3 END EQU * END   92070-18048 1941 S C0122 &OPENF              H0101 ASMB,R,L,C * NAME: OPENF * SOURCE: 92070-18048 * RELOC: 92070-16048 * PGMR: M.L.K. * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * * NAM OPENF,7 92070-1X048 REV.1941 790906 SUP * HED OPENF ENT OPENF EXT EXEC,CLOSE,GTOPN EXT .ENTR,OPEN,LURQ * * OPENF IS THE FILE OPEN ROUTINE OF THE REAL TIME * FILE MANAGEMENT PACKAGE * * THE FORTRAN CALLING SEQUENCE IS: * CALL OPENF(IDCB,IERR,NAME,IOP,IS,ILU,IBLK) * * W H E R E: * * IDCB IS A 144-WORD DATA CONTROL BLOCK (ARRAY) * TO BE USED WITH ALL ACCESS TO THE FILE * UNDER THIS OPEN. * * IERR IS THE RETURN ERROR CODE (ALSO RETURNED IN A) * * NAME IS THE 6-CHARACTER (3 WORD) NAME ARRAY OR LU * TO OPEN. * * IOP (OPTIONAL); IS THE OPEN OPTION FLAG WORD * OPTIONS ARE: * BIT MEANING IF SET * 0 NON-EXCLUSIVE OPEN * 1 UPDATE OPEN * 2 FORCE TO TYPE 1 OPEN * 3 USE SUB FUNCTION IN BITS 6-11 * IF TYPE 0. * * IS (OPTIONAL); IS THE EXPECTED SECURITY CODE. * * ILU (OPTIONAL); IS THE DISC SPECIFIED. * IF ILU >0 THEN USE DISC LABELED ILU * IF ILU <0 THEN USE DISC AT LOGICAL UNIT (-ILU) * * IBLK (OPTIONAL); SPECIFIES A DCB BUFFER AREA OF * IBLK WORDS. (NORMALLY 128 IS USED.) MUST BE A * MULTIPLE OF 128. T]HE BUFFER MUST BE AN EVEN * DIVISOR OF THE FILE SIZE SO ONLY PART OF * THE SPECIFIED SIZE MAY BE USED. THE USED SIZE IS: * USED SIZE=FILE SIZE/N WHERE * N=(FILE SIZE/IBLK)+(IF REMAINDER THEN 1,ELSE 0) * * OPENF ERRORS ARE AS FOLLOWS: * * -1 DISC ERROR * -6 FILE NOT FOUND * -7 WRONG SECURITY CODE * -8 FILE IS CURRENTLY OPEN (IF EXCLUSIVE REQUEST) OR * IS CURRENTLY OPEN TO 7 OTHER PROGRAMS * -9 ATTEMPT TO OPEN TYPE 0 AS TYPE 1 * -10 NOT ENOUGH PARAMETERS * -13 DISC LOCKED * -18 ILLEGAL LU * -36 LOCK ERROR SKP OPENF NOP LDA DZERO PRESET ENTRY PARMS STA NAME STA OP STA SC STA LU STA IBLK CLA RESET ZERO WORD STA ZERO LDA OPENF STA DPENF JMP DPENF+1 * * MIGHT NEED TO CLEAR ZERO * DCB NOP ERR NOP NAME DEF ZERO OP DEF ZERO SC DEF ZERO LU DEF ZERO IBLK DEF ZERO SPC 1 DPENF NOP ENTRY POINT JSB .ENTR TRANSFER PARAMETERS DEF DCB TO LOCAL AREA LDA N10 LDB NAME DID WE GET CPB DZERO ENOUGH PARAMETERS? JMP EXIT NO; ERROR - EXIT SPC 1 JSB CLOSE CLOSE DEF *+2 IF DEF DCB,I OPEN SZA SKIP IF NO ERRORS CPA N11 OR IF NOT OPEN CLE,RSS JMP EXIT ELSE TAKE ERR EXIT * LDA NAME,I GET FILE NAME SSA POSITIVE? JMP ER18 NO, ILLEGAL LU ADA N64 IS IT LESS SSA THAN 64 JMP OPNLU YES, LEGAL LU ADA N17K IS IT SSA A NAME? JMP ER18 NO, ASSUME ILLEGAL LU * JSB OPEN NO, ASSUME ITS A FILE DEF OPRTN AND OPEN IT DEF DCB,I DEF ERR,I DEF NAME,I DEF OP,I DEF SC,I DEF LU`X,I DEF IBLK,I OPRTN JMP DPENF,I EXIT SKP OPNLU JSB EXEC CALL FOR STATUS AND DEF STRTN DEVICE TYPE DEF STAT DEF NAME,I DEF DVT6 DEF SELCD STRTN JMP ER18 ILLEGAL LU ERROR RETURN * LDA SELCD GET IFT 6 AND B77 ISOLATE SELECT CODE STA SELCD SAVE SELECT CODE FOR BIT BUCKET TEST * LDA DVT6 GET STATUS WORD AND TYPE ISOLATE DEVICE TYPE STA DVT6 SAVE CLB ASL 8 POSITION DEVICE TYPE TO LOWER BYTE OF B STB DEVTP * LDA MNDSC GET MINIMUM DISC TYPE ADA B IF LESS, OK SSA JMP NOTDS OK, NOT DISC * LDA MXDSC GET MAXIMUM DISC TYPE + 1 ADA B TEST VALUE SSA,RSS JMP NOTDS OK, NOT DISC * LDA N17 ERROR - DISC LU JMP EXIT * * SET UP DCB * NOTDS LDA DCB GET DCB POINTER STA DCBPT AND SAVE IT LDA DUMMY GET DUMMY DCB FLAG STA DCBPT,I AND STORE IN DCB0 ISZ DCBPT INCREMENT TO NEXT DCB WORD * * SET DEVICE TYPE * LDA DVT6 GET DEVICE TYPE AND STA DCBPT,I STORE IN DCB1 ISZ DCBPT INCREMENT TO NEXT DCB WORD * * SET FILE TYPE * CLA SET FILE TYPE TO 0 STA DCBPT,I AND STORE IN DCB2 ISZ DCBPT INCREMENT TO NEXT DCB WORD * * SET LU AND SUBFUNCTION * CLB PRESET B FALSE (NOT INTERACTIVE) LDA M8 TEST WITH MAX INTERACTIVE + 1 ADA DEVTP TEST DEVICE FOR INTERACTIVE SSA INTERACTIVE? CCB YES,SET B TRUE (#0 I.E. INTERACTIVE) STB INT SAVE FOR LATER LDA OP,I GET THE OPTION WORD RAR,RAR PUT THE FUNCTION CODE BIT (#3) RAR,ERA INTO E REGISTER LDA OP,I GET THE OPTION WORD AGAIN AND FMASK ISOLATE FUNCTION BITS SEZ FUNCTION SET? a JMP ADDLU YES, USE FUNCTION CODE FROM A REGISTER CLA NO, DEFAULT TO JUST LU UNLESS SZB INTERACTIVE? LDA ECHO YES, THEN DEFAULT TO ECHO ADDLU IOR NAME,I ADD IN THE LU STA DCBPT,I AND STORE IN DCB3 ISZ DCBPT INCREMENT TO NEXT DCB WORD * * SET EOF CODE * LDA PAGE GET PAGE EJECT CODE LDB N12 TEST DEVICE TYPE AGAINST 13 (+1) OCTAL ADB DEVTP SSB IS IT IN RANGE 0-13 OCTAL? JMP STEOF YES, GO SET EOF * LDA LEADR PRESET A TO LEADER FUNCTION CODE LDB DEVTP GET DEVICE TYPE AND TEST CPB B26 AGAINST PAPER TAPE DEVICES JMP STEOF PAPER TAPE? CPB B27 JMP STEOF PAPER TAPE? * LDA EOF EVERTHING ELSE USES EOF STEOF IOR NAME,I ADD IN THE LU STA DCBPT,I AND STORE IN DCB4 ISZ DCBPT INCREMENT TO NEXT DCB WORD * * SET SPACING * LDA BOTH PRESET A TO BOTH LDB M16 TEST IF ABOVE BOUNDRY ADB DEVTP SSB CLA BELOW BOUNDRY,SET NEITHER STA DCBPT,I STORE IN DCB5 ISZ DCBPT INCREMENT TO NEXT DCB WORD * * SET READ/WRITE FLAG TO BOTH * LDA BOTH SET BOTH READ AND WRITE FLAGS LDB SELCD GET SELECT CODE SZB,RSS IS IT ZERO? CLA,INA YES, BIT BUCKET! ALLOW WRITE ONLY!! STA DCBPT,I STORE IN DCB6 ISZ DCBPT INCREMENT TO NEXT DCB WORD * * SET SECURITY CODE MATCH AND OPEN MODE TO UPDATE * LDA BOTH SET BOTH SEC AND OPEN MODE STA DCBPT,I STORE IN DCB7 * * SET OPEN FLAG * JSB GTOPN GO GET CURRENT OPEN FLAG DEF *+1 LDB DCBPT INCREMENT DCB POINTER TO ADB .2 WORD 9 STB OPNPT SAVE OPEN FLAG LOCATION STA B,I STORE OPEN FLAG IN DCB9 * * SET RECORD COUNT TO 1 * ADB .5 INCREMENT TO WORD 14 CLA,INA SET 1 STA B,I STORE IN DCB14 INB POINT TO DCB15 STB DCBPT AND SAVE * * LOCK THE DEVICE IF NOT INTERACTIVE * CLA,INA SET A TO 1 STA DCBPT,I SET DEFAULT TO "DON'T UNLOCK" LDA OP,I GET OPEN OPTION SLA EXCLUSIVE OPEN? JMP EXOK NO, EXIT OK LDA INT TEST THE INTERACTIVE FLAG SZA INTERACTIVE? JMP EXOK INTERACTIVE SO DON'T LOCK * JSB LURQ LOCK CALL DEF *+4 DEF OPTN OPTION WORD DEF NAME,I LU WORD DEF .1 ONE LU JMP ER18 ERROR ON LOCK SZA CHECK IF ITS NON ZERO JMP LCKER YES, ERROR NO RN'S OR ALREADY LOCKED * STA DCBPT,I STORE LOCK SUCCESSFUL IN DCB14 EXOK CLA SET NO ERROR EXIT STA ERR,I STORE IN ERROR CODE JMP DPENF,I RETURN * * ERROR RETURNS * LCKER CLA CLEAR THE OPEN FLAG STA OPNPT,I FLAG IN DCB LDA N36 LOCK NOT GRANTED JMP EXIT * ER18 LDA N18 JMP EXIT SKP * * CONSTANTS * DZERO DEF ZERO DUMMY PARAMETER ZERO NOP DUMMY 0 N10 DEC -10 N11 DEC -11 N12 DEC -12 N64 DEC -64 N17K OCT -17700 USED FOR LEGAL LU TEST STAT OCT 100015 STATUS EXEC W/ SIGN TYPE OCT 37400 MNDSC DEC -24 NEGATIVE TYPE 30 MXDSC DEC -32 NEGATIVE TYPE 40 DUMMY OCT 177700 DUMMY DCB FLAG M8 DEC -8 ECHO OCT 400 ECHO BIT FOR CONWD PAGE OCT 1100 PAGE EJECT CONTROL REQUEST LEADR OCT 1000 PUNCH/READER CNTRL REQUEST EOF OCT 100 STANDARD EOF CONTROL REQUEST B26 OCT 26 B27 OCT 27 B77 OCT 77 BOTH OCT 100001 M16 DEC -16 .1 DEC 1 .2 DEC 2 .5 DEC 5 OPTN OCT 140001 N36 DEC -36 N18 DEC -18 N17 DEC -17 FMASK OCT 43700 BU/TR/EC/BI MASK * * VARIBLES * DVT6 NOP STORAGE FOR DVT6 SELCD NOP STORAGE FOR IFT6 ('1$"CONTAINS SELECT CODE) DEVTP NOP DEVICE TYPE DCBPT NOP DCB POINTER INT NOP INTERACTIVE FLAG 0=NOT INT, #0=INT OPNPT NOP OPEN FLAG LOCATION POINTER * A EQU 0 B EQU 1 * END EQU * END r$  92070-18049 1941 S C0122 &POSNT              H0101 ASMB,L,R,C * NAME: POSNT * SOURCE: 92070-18049 * RELOC: 92070-16049 * PGMR: G.A.A. * MOD: G.L.M * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * * NAM POSNT,7 92070-1X049 REV.1941 790709 * HED POSNT ENT POSNT,EPOSN EXT EXEC,.ENTR,RFLG$,P.PAS,READF,$KIP EXT GTOPN,$DBLX SUP * * POSNT IS THE FILE POSITION ROUTINE FOR THE * RTE FILE MANAGEMENT PACKAGE * * CALLING SEQUENCE: * CALL POSNT (IDCB,IERR,NP,IR) * WHERE: * IDCB IS THE FILES DATA CONTROL BLOCK * ADDRESS * IERR IS THE ERROR RETURN ADDRESS * POSNT ERRORS ARE: * 0 NONE * -1 DISC DOWN * -5 AN ILLEGAL RECORD WASENCOUNTERED * (LENGTHS AT EACH END DID NOT MATCH * -10 NOT ENOUGH PARAMETERS * -11 DCB NOT OPEN * -12 EOF OR SOF SENSED * -17 CONTROL REQUEST FAILED * NP IF >0 THEN SKIP NP RECORDS * IF <0 THEN BACK SPACE NP RECORDS * IF =0 THEN NO OPERATION * IR (OPTIONAL) IF NOT CODED OR ZERO * NP IS RELATIVE OTHERWIZE * NP IS ABSOLUTE (NP MUST BE>0) SKP EPOSN NOP DOUBLE WORD ENTRY POINT CCA SET DBL FLAG TRUE LDB EPOSN GET RETURN ADDRESS JMP SETUP GO FINISH SET UP SPC 3 POSNT NOP SINGLE WORD ENTRY CLA SET DBL FLAG FALSE LDB POSNT GET RETURN ADDRESS SETUP STA DBLWD STORE DBL FLAG Z> STB DOSNT STORE RETURN ADDRESS LDA DFZER PRE-SET OPTIONAL ENTRY PARMS STA NP STA IR CLA STA ZERO JMP DOSNT+1 GO FETCH CALL PARMS SPC 3 DCB NOP ER NOP NP DEF ZERO IR DEF ZERO SPC 1 DOSNT NOP ENTRY POINT JSB .ENTR FETCH DEF DCB ADDRESSES LDA N10 ENOUGH LDB NP PRAMS CPB DFZER SUPPLIED? JMP EXIT NO,EXIT ISZ DBLWD DOUBLE OR SINGLE ENTRY? JMP SINGL SINGLE, SKIP RANGE TESTS DLD NP,I GET DOUBLE INTEGER JSB $DBLX CHECK RANGE JMP EXIT ERROR RETURN (A= ERROR CODE) ISZ NP POINT TO LOWER BITS * SINGL STB RFLG$ FORCE READS WHILE SPACING CLB,CLE SET LDA DCB UP JSB P.PAS LOCAL DEC -15 DCB RCOU NOP ADDRESSES DUM NOP TYPE NOP TYPE LU NOP LU FOR TYPE 0 EOF NOP EOF CODE FOR TYPE 0 SPACE NOP SPACING LEGAL FLAGE TYPE 0 CONND NOP LN NOP DSTAT NOP OPEN NOP OPEN FLAG ABRC NOP RCLN NOP BFPT NOP BUFFER POINTER TYPE 3AND ABOVE RWFLG NOP READ/WRIE /EOF FLAG RC NOP RECORD COUNT JSB GTOPN GET CURRENT OPEN FLAG DEF *+1 CPA OPEN,I SAME AS IN DCB? JMP OPIN YES, IT'S OK LDA N11 NO, NOT OPEN JMP EXIT SO LEAVE OPIN CCE SET E FOR LATER LDA BFPT GET BUFFER POINTER ADDRESS RAL,ERA SET INDIRECT BIT STA BFPT RESET POINTER * LDA NP,I GET RECORD NUMBER SZA,RSS IS IT 0? JMP EXOK YES, NOP EXIT * LDA IR,I GET RELATIVE /ABSOLUTE FLAG CLB ASSUME ABSOLUTE SZA,RSS RELATIVE? LDB RC,I YES; GET CURRENT RECORD NO. ADB NP,I ADD THE REQUESTED MOVEMENT STB ABRC SAƶVE NEW ABSOLUTE ADDRESS CMB,INB SET NEGATIVE AND ADB RC,I COMPUTE RELATIVE RECORD NUMBER CMB,INB,SZB,RSS SET TO RIGHT SIGN - ZERO? JMP EXOK YES - GO EXIT STB RCOU NO; SET COUNT SPC 1 LDA TYPE,I GET TYPE OF FILE CMA,INA,SZA,RSS TYPE ZERO? JMP TYP0 YES; GO TO TYPE ZERO ROUTINE INA,SZA TYPE; 1 INA,SZA,RSS OR 2 JMP TY1/2 YES; GO TO RANDOM ACESS POSITION SPC 1 CMB,SSB,INB TYPE 3 OR ABOVE - FORWARD JMP FSRC SPACE - YES GO DO IT. SPC 2 * TYPE 3 AND ABOVE BACKSPACE ROUTINE SPC 1 BSRC LDA BFPT,I GET CURRENT POSITION INA,SZA IS IT EOF? JMP BSRC3 NO; GO BACKSPACE LDA RWFLG,I YES; GET THE READ/WRITE RAR,CLE,RAR FLAG AND CLEAR THE EOF BIT ELA,RAL THEN STA RWFLG,I RESTORE THE FLAG SEZ WAS IT SET? JMP BSRC5 YES; COUNT AS A RECORD BSRC3 CCB NO; BACKSPACE 1 LDA DCB WORD JSB $KIP WITH THE JMP EXIT SKIP ROUTINE LDA BFPT,I GET THE RECORD LENGTH STA RCLN SAVE IT CMA BACK SPACE TO STA B THE LDA DCB TWIN JSB $KIP WITH THE JMP EXIT SKIP ROUTINE LDA BFPT,I GET TWIN CPA RCLN TWINS MATCH? BSRC5 CCA,RSS YES; SKIP JMP ER5 NO; ERROR -5 ADA RC,I DECREMENT THE STA RC,I RECORD COUNT ISZ RCOU STEP BACKSPACE COUNT ; DONE? JMP BSRC3 NO; DO THE NEXT ONE JMP EXOK * FORWARD SPACE TYPE ZERO AND 3 AND ABOVE FILES * FSRC STB RCOU SET COUNT FSRC1 JSB READF READ DEF REART A DEF DCB,I RECORD DEF ER,I TO DEF DUM LOCAL DUMMY DEF .1 ONE WORD BUFFER DEF LN REART SSA IF ERROR JMP EXIT EXIT LDB )mLN SSB JMP EOFEX ISZ RCOU JMP FSRC1 JMP EXIT SKP * TYPE ZERO SPACE ROUTINE SPC 1 TYP0 CMB,SSB,INB IF FORWARD SPACE JMP FSRC GO TO READ ROUTINE SPC 1 LDA N3 PRESET FOR ERROR LDB SPACE,I BACK SPACE GET SSB,RSS LEGAL CODE JMP EXIT BACK SPACE NOT LEGAL-EXIT SPC 1 LDA LU,I GET AND AND B77 ISOLATE LU ADA B200 ADD BACK SPACE FUNCTION STA CONND SET FOR CALL ADA B400 MAKE A DYNAMIC STATUS RQ STA DSTAT SET IT CCA SET FIRST EOF RECORD FLAG SPC0 STA OPEN IN OPEN JSB EXEC CALL EXEC DEF EXRTN TO DEF .3I BACK DEF CONND SPACE EXRTN JMP ER17 EXEC ERROR JSB EXEC DO DYNAMIC STATUS DEF STRTN DEF .3I DEF DSTAT STRTN JMP ER17 EXEC ERROR AND B200 MASK EOF BIT CCB DECREMENT ADB RC,I THE RECORD COUNT STB RC,I CCB SET B TO FORWARD SPACE 1 SZA,RSS IF EOF TEST FOR FIRST JMP *+3 ELSE SKIP TO COUNT THE RECORD ISZ OPEN SKIP IF EOF ON FIRST RECORD JMP FSRC ELSE GO FORWARD SPACE ISZ RCOU DONE? JMP SPC0 NO; DO NEXT ONE JMP EXOK YES; GO EXIT SKP * TYPE 1 AND TWO SPACE ROUTINE * THE NEW RECORD NO. IS SET ONLY * NO EOF CHECK IS DONE * NEGATIVE OR ZERO RECORD * NUMBERS ARE REPLACED * WITH 1 AND SOF ERROR SENT * TY1/2 LDA ABRC GET THE ABSOLUTE RECORD NO. CCE,SZA IF ZERO SSA OR NEGATIVE CLA,CLE,INA SET TO ONE STA RC,I SET NEW RECORD NO. SEZ IF FORCED TO ONE TAKE SOF EXIT SPC 2 EXOK CLA,RSS GOOD EXIT EOFEX LDA N12 EOF/SOF EXIT Y SPC 1 EXIT STA ER,I SET ERROR AND JMP DOSNT,I RETURN SPC 2 ER17 LDA N17 JMP EXIT SPC 2 ER5 LDA N5 JMP EXIT SKP * STORAGE SPC 2 .1 DEC 1 .3I OCT 100003 N12 DEC -12 N10 DEC -10 N11 DEC -11 DFZER DEF ZERO ZERO NOP \THESE TWO ARE DOUBLE NOP / DUMMY ZERO DBLWD NOP DOUBLE WORD FLAG N3 DEC -3 N17 DEC -17 N5 DEC -5 B200 OCT 200 B400 OCT 400 B77 OCT 77 SPC 2 A EQU 0 B EQU 1 SPC 1 END EQU * SPC 1 END O  92070-18050 1941 S C0122 &POST              H0101 rASMB,R,L,C * NAME: POST * SOURCE: 92070-18050 * RELOC: 92070-16050 * PGMR: G.A.A. * MOD: G.L.M * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * * NAM POST,7 92070-1X050 REV.1941 790709 * HED POST - CLEAR THE DCB BUFFER ENT POST EXT .ENTR,R/W$,GTOPN * * * THE POST ROUTINE CLEARS THE DCB BUFFER BY POSTING ANY * DATA THAT NEEDS TO BE WRITTEN ON THE DISC. IT WILL IN * ALL CASES CLEAR THE INCORE FLAG SO THE NEXT FILE * ACCESS WILL FORCE A DISC READ. * * POST IS TO BE USE WITH THE RN LOCK FEATURE AS * FOLLOWS: * * POST * LOCK * * DO YOUR THING * * POST * UNLOCK * * CALLING SEQUENCE: * * CALL POST(DCB,ER) * * WHERE: * * DCB IS THE DCB ARRAY * ER IS THE OPTIONAL RETURN ERROR CODE * * POST NOP CLA PRE-SET STA ER CALL LDA POST PARMS STA DOST MOVE PARM ADDRESS JMP DOST+1 TO DUMMY ENTRY POINT * DCB NOP ER NOP DOST NOP ENTRY POINT JSB .ENTR GET THE PRAM ADDRESSES DEF DCB JSB GTOPN GET CURRENT OPEN FLAG DEF *+1 LDB DCB GET DCB ADDRESS AND POINT ADB D9 TO IT'S OPEN FLAG CPA B,I IS IT THE SAME AS CURRENT? JMP OK YES, IT'S OPEN! * LDA N11 NO RETURN ERROR EREX STA ER,I SET THE ERROR CODE CLB SET ER ADDRESS STB ER FOR NEXT TIME JMP DOST,I EXIT * OK LDB DCB GET THE DCB ADDRESS CLE SET E FOR g  WRITE JSB R/W$ GO POST THE BUFFER JMP EREX DISC ERROR GO EXIT * CLA ALL IS GOOD SET OK ERROR CODE JMP EREX AND GO EXIT * D9 DEC 9 N11 DEC -11 A EQU 0 B EQU 1 END    92070-18051 1941 S C0122 &PURGE              H0101 zASMB,L,R,C * NAME: PURGE * SOURCE: 92070-18051 * RELOC: 92070-16051 * PGMR: G.A.A. * MOD: M.L.K. * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * * NAM PURGE,7 92070-1X051 REV.1941 790709 * HED PURGE ENT PURGE EXT OPEN,.ENTR,CLOSE,$SWLU * * SUP * * PURGE IS THE FILE DELETION ROUTINE FOR THE RTE * FILE MANAGEMENT PACKAGE * * THE FORTRAN CALLING SEQUENCE IS: * * CALL PURGE(IDCB,IERR,NAME,IS,ILU) * * W H E R E: * * IDCB IS A 144-WORD DATA CONTROL BLOCK * WHICH IS USED BY PURGE AS A * WORKING BUFFER. IDCB IS FREE * FOR OTHER USE AFTER A PURGE. * * IERR IS THE ERROR RETURN LOCATION. * * NAME IS THE NAME OF THE FILE TO BE PURGED. * * IS IS THE FILE'S SECURITY CODE. * * ILU IS THE DISC THAT THE FILE IS ON. * IF ILU >0 THEN ON DISC LABELED ILU * IF ILU <0 THEN ON DISC AT LOGICAL UNIT (-ILU) * * ERRORS RETURNED BY PURGE ARE: * * CODE REASON * 0 NO ERRORS * -1 DISC READ/WRITE ERROR * -6 FILE (OR DISC) NOT FOUND * -7 ILLEGAL SECURITY CODE * -8 FILE IS OPEN TO SOME OTHER PROGRAM * -10 NOT ENOUGH PARAMETERS * -13 DISC LOCKED * -16 ATTEMPT TO PURGE A TYPE 0 FILE * -37 ATTEMPT TO PURGE A TYPE 6 OR SWAP FILE * * SKP PURGE NOP LDA DZERO STA NAME STA SC STA LU LDA PURGE STA DURGE JMP DU/oRGE+1 * * DCB NOP IERR NOP NAME DEF ZERO SC DEF ZERO LU DEF ZERO SPC 1 DURGE NOP ENTRY POINT JSB .ENTR DO ENTRY ROUTINE DEF DCB LDA N10 NOT ENOUGH PRAM LDB NAME ERROR CPB DZERO ? JMP EXIT YES-EXIT CLA CLEAR THE TRUNCATE WORD STA LNG AND SPC 1 JSB OPEN NO; GO DEF OPRTN OPEN DEF DCB,I EXCLUSIVELY DEF IERR,I TO DEF NAME,I CALLER DZERO DEF ZERO DEF SC,I PASS THE SECURITY CODE DEF LU,I AND THE DISC ID OPRTN SSA OPEN ERROR? JMP EXIT YES; EXIT SZA,RSS NO; TYPE ZERO JMP EX16 YES - ILLEGAL PURGE SPC 1 CPA .6 IS THIS A TYPE 6 FILE? JMP EX37 YES, ERROR, MAKE THEM USE THE PU CMND SPC 1 LDA DCB,I GET DIRECTORY ADDRESS AND B77 ISOLATE DISC LU CPA $SWLU SWAP FILE ON THIS DISC? RSS YES, CHECK IF ITS THIS FILE JMP SECCD NO, GO CHECK SECURITY CODE LDA DCB GET DCB ADDRESS ADA .3 POINT TO TRACK ADDRESS LDB A,I GET TRACK ADDRESS CPB ATRAK,I COMPARE TO SWAP FILE'S, SAME? RSS YES, BETTER CHECK SECTOR JMP SECCD NO, GO CHECK SECURITY CODE INA POINT TO SECTOR ADDRESS LDB A,I GET SECTOR ADDRESS CPB ASEC,I SAME AS SWAP FILE'S? JMP EX37 YES, ERROR, CAN'T PURGE * SECCD LDA DCB GET ADDRESS ADA .7 OF LDB A,I SECURITY SSB,RSS IF MISMATCH JMP EX7 GO SET ERROR EXIT SPC 1 ADA N2 ADDRESS OF FILE LENGTH LDA A,I GET FILE LENGTH ARS SET TO BLOCK LENGTH STA LNG SET FOR TRUNCATE CODE SPC 1 CLOS JSB CLOSE CLOSE THE FILE AND TRUNCATE TO ZERO DEF Tz *+4 (I.E. PURGE IT) DEF DCB,I FILE DEF LU DUMMY ERROR RETURN DEF LNG TRUNCATE WORD ADDRESS LDB IERR,I GET CURRENT ERROR CODE SSB IF NONE SKIP LDA B ELSE USE IT EXIT STA IERR,I SET THE ERROR CODE JMP DURGE,I AND EXIT SPC 2 EX7 LDA .7 SET ERROR CMA,INA,RSS CODE AND SKIP EX16 LDA N16 STA IERR,I SET CODE IN USER AREA JMP CLOS GO CLOSE THE FILE EX37 LDA N37 STA IERR,I JMP CLOS SPC 3 N2 DEC -2 N10 DEC -10 .3 DEC 3 .6 DEC 6 .7 DEC 7 N16 DEC -16 N37 DEC -37 B77 OCT 77 ATRAK DEF $SWLU+1 ASEC DEF $SWLU+2 LNG NOP ZERO NOP A EQU 0 B EQU 1 SPC 2 END EQU * END   92070-18052 1941 S C0122 &READF              H0101 hASMB,R,L,C * NAME: READF * SOURCE: 92070-18052 * RELOC: 92070-16052 * PGMR: G.A.A. * MOD: M.L.K. * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * * NAM READF,7 92070-1X052 REV.1941 790803 * HED READF ENT READF,WRITF,EREAD,EWRIT EXT EXEC,R/W$,.ENTR,P.PAS EXT RW$UB,$KIP,REIO,$DBLX EXT D$XFR,RFLG$,GTOPN SUP * * * THIS IS THE RTE FILE MANAGEMENT PACKAGE * READ/WRITE SUBROUTINE. * * THIS ROUTINE WILL READ OR WRITE ANY TYPE FILE. * * * CALLING SEQUENCE: * * CALL READF(IDCB,IERR,IBUF,IL,L,N) * * O R * * IER = READF(IDCB,IERR,IBUF,IL,L,N) * * TO READ, O R * * CALL WRITF(IDCB,IERR,IBUF,IL,N) * * O R * * IER = WRITF(IDCB,IERR,IBUF,IL,N) * * TO WRITE. * * * W H E R E: * * IDCB IS THE 144 WORD DATA CONTROL BLOCK * FOR THE REFERENCED FILE. * * IERR IS THE ERROR RETURN LOCATION * ERRORS ARE AS FOLLOWS: * * CODE ERROR CONDITION * 0 OR >0 NO ERROR * -1 A REQUIRED DISC OR DEVICE IS DOWN * -5 ILLEGAL RECORD NUMBER OR * ATTEMPT TO READ A RECORD NOT WRITTEN * -7 INVALID SECURITY CODE FOR * WRITE (FILE IS READ ONLY) * -10 A REQUIRED PARAMETER IS MISSING * -11 THE DCB IS NOT OPEN * -12 SOF OR EOF SENSED ON READ * -17 ILLEGAL REQUEST TO A TYPE ZERw0 FILE * * IER SEE IERR - RETURNED AS FUNCTION * * IBUF IS THE BUFFER TO BE USED TO READ OR WRITE. * * IL IS THE REQUESTED TRANSFER LENGTH IN WORDS. * * L IS THE LENGTH AS READ IN WORDS. * * N IS THE REQUESTED RECORD NUMBER * IF N>0 OR IF N<0 THE RELATIVE RECORD * NUMBER FROM THE CURRENT POSITION. * N IS LEGAL ON TYPE 1 AND 2 FILES ONLY. * * * O P T I O N S: * * IL IS OPTIONAL ON TYPE 1 AND 2 FILES. * ON TYPE 1 FILES, 128 IS USED; * ON TYPE 2 FILES THE RECORD LENGTH IS USED. * * L IS OPTIONAL AT ALL TIMES. * * N IS OPTIONAL AND IS IGNORED ON FILES * OF TYPES OTHER THAN 1 AND 2. IF NOT * SUPPLIED, ZER0 IS USED. * THE FIRST RECORD IN A FILE IS RECORD #1. * * * E X T E R N A L S: * * RW$UB IS USED TO READ OR WRITE WORDS * FROM OR TO FILES OF TYPE 2 OR * ABOVE. IT HANDLES ALL SECTOR, * TRACK, AND EXTENT SWITCHING FOR * THESE FILES AND ALSO WRITES AND/OR * READS BLOCKS FROM THE FILE AS * REQUIRED. READS ARE CONDITIONAL * ON RFLG$. A GLOBAL FLAG WHICH * MUST BE NON-ZER0 BEFORE A READ * IS EXECUTED. * * RW$UB CALLING SEQUENCE IS: * * LDB #WORDS * LDA DCB ADDRESS * CLE/CCE WRITE/READ * JSB RW$UB CALL * DEF UBUF ADDRESS OF USER'S BUFFER * JMP ERROR ERROR RETURN (A = CONDITION) * -- NORMAL RETURN SKP EREAD NOP DBL WORD READ ENTRY CCB SET DBL FLAG LDA EREAD GET RETURN ADDRESS STA DEADF STORE RETURN ADDRESS CCA SET A TO READ JMP RST GO FINISH SET UP * EWRIT NOP DBL WRITE ENTRY CCB SET DBL FLAG ҪLDA EWRIT GET RETURN ADDRESS STA DEADF AND SAVE IT JMP RST * WRITF NOP WRITE ENTRY POINT CLB SET DBL FLAG TO FALSE LDA WRITF TRANSFER RETURN ADDRESS STA DEADF TO READ ENTRY JMP RST AND GO TO PRESET ENTRY PARMS * READF NOP READ ENTRY POINT CLB SET DBL FLAG TO FALSE LDA READF FETCH AND STA DEADF TRANSFER RETURN ADDRESS TO DUMMY ENTRY CCA SET RST STA ENTFG ENTRY FLAG(POS FOR WRITF/NEG FOR READF) STB DBLWD SAVE DBL FLAG * * * PRE-SET ENTRY PARMS * LDA N17 STA BUF LDA DMBUF STA IL LDA DZER0 STA L STA N CLA STA ZER0 STA DM JMP DEADF+1 GO FETCH CALL PARMS * * SKP DCB NOP DCB POINTER IERR NOP ERROR BOX BUF OCT -17 USER BUFFER ADDRESS IL DEF DM REQUEST LENGTH L DEF ZER0 RETURN LENGTH N DEF ZER0 RECORD NUMBER * * DEADF NOP READ ENTRY POINT JSB .ENTR TRANSFER THE DEF DCB PARAMETERS LDA DCB SET UP THE CLB,CLE DCB JSB P.PAS ADDRESSES N17 DEC -17 TMP NOP USE FIRST TWO AS BFSZ EQU TMP # OF BLOCKS IN THE DCB TMP1 NOP TEMP STORAGE TYPE NOP ADDRESS OF TYPE LU0 NOP LU (FOR 0 FILE) TRACK EQU LU0 ALSO TRACK EOF0 NOP EOF CODE (0 FILE) BSECT EQU EOF0 ALSO SECTOR SPAC NOP SPACING CODE (0 FILE) SIZE EQU SPAC ALSO FILE SIZE RL NOP RECORD LENGTH SCMO NOP SECURITY/OPEN MODE #SC/T NOP SECTORS/TRACK OCFLG NOP OPEN FLAG TR NOP CURRENT TRACK SECT NOP CURRENT SECTOR BUFPT NOP CURRENT POSITION RWFLG NOP READ/WRITE FLAG RC NOP RECORD COkUNT TMP2 NOP BUFD NOP SPC 2 LDA BUFPT GET CURRENT BUFFER POINTER STA TDCBP AND SAVE IN CASE OF EOD DLD BUFPT,I GET BUFPT AND RWFLG DST TBUFP AND SAVE IN CASE OF EOD ON EXTENT * LDA N10 PRESET FOR MISSING PRAM ERROR LDB BUF BUFFER MUST BE SSB SUPPLIED JMP EXIT ELSE MISSING PRAM * JSB GTOPN GET CURRENT OPEN FLAG DEF *+1 CPA OCFLG,I IS IT THE SAME AS IN DCB JMP OPIN YES, FILE OPEN TO US LDA N11 NO, FILE NOT OPEN JMP EXIT SO EXIT * OPIN ISZ DBLWD TEST DBL FLAG JMP SINGL SINGLE ENTRY, SKIP RANGE TEST LDA ENTFG READ OR WRITE? SSA JMP CHEKN READ DLD L,I GET RETURN LENGTH JSB $DBLX CHECK RANGE JMP EXIT ERROR RTN (A = ERROR CODE) ISZ L POINT TO LOW BITS JMP SINGL * CHEKN DLD N,I CHECK RECORD NUMBER JSB $DBLX TEST RANGE JMP EXIT ERROR RTN ISZ N POINT TO LOW BITS * SINGL LDB ENTFG GET READ WRITE FLAG LDA SCMO,I AND SECURITY CODE ARS,ALR CLEAR LEAST AND SIGN BITS STA BFSZ SAVE BLOCK LENGTH XOR SCMO,I GET THE SECURITY CODE/UDATE FLAG SSB,RSS IF WRITE SSA AND JMP SCOK BAD SECURITY * LDA N7 THEN EXIT STA IERR,I SET THE ERROR CODE CPA N33 ERROR -33? (END OF DISC ON EXTENT CREATE) JMP EOD CPA N14 ERROR -14? (END OF DIR ON EXTENT CREATE) JMP EOD GO RE-SET DCB JMP DEADF,I RETURN * EOD CCB SET -1 INTO STB TBUFP,I LAST POSITION IN DCB DLD TBUFP NOW RESTORE BUFFER AND DST TDCBP,I FLAG WORDS LDA IERR,I RE-SET ERROR CODE JMP DEADF,I NOW RETURN * ENTFG NOP TBUFP NOP TEMPORARY BUFFER STORAGE TFLAG NOP TEMPORARY FLAG STORAGE TDCBP NOP TEMPORARY DCB BUFFER POINTER SPC 2 SCOK RRL 1 SHIFT SIGN TO LOW A STA RFLG$ USE A READ FLAG LDB L,I GET N FOR WRITE SLA,ARS IF READ LDB N,I GET READ N LDA TYPE,I GET TYPE CPA .2 TWO JMP LTEST GO TEST FOR EOF * CPA .1 IF TYPE ONE CLA,RSS SKIP JMP EOFTS ELSE GO TO EOF TEST SKP * TYPE 1 -- RANDOM ACCESS FILE SPC 1 STA RWFLG,I INHIBIT R/W$ WRITE FOR TYPE 1 FILES LDA .128 FORCE LENGTH TO 128 FOR TYPE 1 FILES STA RL,I FOR THE POSITION ROUTINE STA BFSZ FORCE BUFFER SIZE TO 128 SPC 1 LTEST LDA IL,I GET THE REQUEST LENGTH SSA IF EOF REQUEST THEN (EOF = -1) JMP EXIOK GO EXIT NO ACTION * SZB POSITION OPTION? (B CONTAINS REC #) SSB YES IF <0 ADB RC,I ADD CURRENT POSITION STB TMP2 SAVE RESULT CCA ADA B MULTIPLY RECORD LENGTH SSA IF NEG RECORD NO JMP EOFEX TAKE ERROR EXIT * MPY RL,I BY THE DESIRED RECORD DIV BFSZ COMPUTE THE BLOCK AND OFFSET STB OCFLG SAVE THE OFFSET CLB NOW COMPUTE THE SECTOR ADDRESS MPY BFSZ OF THE BLOCK ASR 6 EVEN SECT ADDRESS TO A STA TMP SAVE CMA CHECK FOR ADA SIZE,I EOF SSA IF NOT EOF SKIP JMP EOFEX TAKE ERROR EXIT * LDA TMP RESTORE A ADA BSECT,I ADD THE BASE SECTOR DIV #SC/T,I DIVIDE BY NO. SECT/TRACK ADA TRACK,I ADD BASE TRACK-A = TRACK DST TMP SAVE NEW TR/SECTOR ADDRESS CPA TR,I IF SAME CCA AS CPB SECT,I CURRENT LDB 0 POSITION CLE,SSB THEN JMP RACS SKIP * LDB DCB ELSE Zv JSB R/W$ WRITE THE CURRENT BLOCK JMP EXIT IF NECESSARY * DLD TMP THEN SET DST TR,I THE NEW SPC 2 ADDRESS RACS LDA OCFLG SET THE OFFSET ADA BUFD ADD BUFFER ADDRESS STA BUFPT,I AND SET THE POINTER LDA TMP2 SET THE STA RC,I NEW RECORD NUMBER SPC 2 EOFTS LDA BUFPT SET THE INDIRECT ADA MSIGN BIT ON STA BUFPT THE BUFFER POINTER LDA TYPE,I GET FILE TYPE CMA,INA,SZA,RSS IF 0 JMP TYP00 OR 1 * INA,SZA,RSS GO DO 0/1 THING JMP .1TYP * INA,SZA,RSS IF TYPE 2 JMP TWOTY GO DO READ TEST * INTS LDA RWFLG,I GET THE IN CORE FLAG CCE,SZA IF IN CORE JMP TWOSP GO TEST FOR TWO * LDB DCB ELSE READ JSB R/W$ THE BLOCK JMP EXIT ERROR EXIT SPC 2 TWOSP LDA TYPE,I GET THE TYPE AGAIN TWORW LDB RL,I GET THE RECORD LENGTH (TYPE 2) CPA .2 IF TYPE 2 JMP .2RW GO DO READ WRITE SPC 2 * * TYPE 3 AND ABOVE READ/WRITE LOOP * LDA ENTFG SET READ WRITE FLAG ELA IN E 0=> WRITE 1=>READ LDB BUFPT,I GET CURRENT WORD SSB,RSS IF <0 THEN EOF JMP RDLEN NO <0 - SKIP * LDA RWFLG,I EOF RAR,RAR SET (READ) OR CLEAR (WRITE) ELA,RAL EOF SENT STA RWFLG,I BIT IN DCB LDA ENTFG GET THE DIRECTION AGAIN SSA,RSS IF WRITE JMP SWRI GO BACK UP THE COUNT IF REQUIRED * * READ AT EOF * EOFT0 STA L,I FOR EOF HERE WITH A = -1 CLA,SEZ IF FIRST EOF SKIP EOFEX LDA N12 ELSE EOF ERROR SSA,RSS IF FIRST EOF THEN ISZ RC,I STEP THE RECORD COUNT JMP EXIT GO EXIT * * WRITE AT EOF * SWRI CLA,SEZ IF THE EOF WAS PASSED TO THE USER CCA THEN BACK UP THE RECORD COUNT a ADA RC,I SO WE DON'T COUNT TWO OF STA RC,I THEM CLB,CLE RECOVER THE E BIT FOR WRITE STB RFLG$ CLEAR THE READ FLAG RDLEN CCB,SEZ IF READ JMP RDLE1 SKIP WRITE CHECKS * LDA IL,I GET REQUEST LENGTH CMA,CCE,SSA,INA,RSS IF WRITE EOF JMP EOFWR GO WRITE EOF * ADA BUFPT,I COMPARE NEW LENGTH TO OLD LDB RFLG$ GET READ FLAG CLE,SZA IF NEW LENGTH = OLD SZB,RSS OR IF NOT UPDATE JMP RDLE2 CONTINUE WRITE SPC 1 ERR5 LDA N5 ELSE UPDATE ERROR JMP EXIT GO EXIT SPC 1 RDLE1 LDA DMBUF GET LENGTH RETURN ADDRESS RDLE2 CLB,SEZ,INB,RSS IF WRITE LDA IL USE REQUEST LENGTH STA BUA SET ADDRESS OF BUFFER LDA DCB SET THE DCB ADDRESS JSB RW$UB GO READ FIRST LENGTH WORD BUA DEF L,I JMP EXIT ERROR EXIT * LDB A .2RW LDA ENTFG GET READ/WRITE FLAG ELA TO E CLA,SEZ,RSS IF WRITE THEN SKIP JMP WRIT WRITE SO SKIP * LDA IL CHECK IF LENGTH SUPPLIED CPA DMBUF IF COMPARE THEN NO LENGTH CLA,RSS NOT SUPPLIED SO FORCE TRANSFER LDA B SUPPLIED SO CHECK FOR RECORD CMA,INA TOO LONG FOR ADA IL,I BUFFER SSA SKIP IF OK LDB IL,I TOO LONG SO USE SUPPIED LENGTH STB L,I SET AS RETURN LENGTH WRIT STA SKIP SAVE RESIDUE FOR SKIP AFTER READ LDA DCB DCB TO A JSB RW$UB READ THE RECORD DEF BUF,I TO USER BUFFER JMP EXIT ERROR EXIT * LDB TYPE,I GET FILE TYPE CPB .2 IF 2 JMP EXIOK-1 THEN DONE - GO EXIT * LDA DCB SET UP TO SKIP LDB SKIP THE RESIDUE CMB,SSB,INB SET + NO WORDS SKIP IF >0 JMP NOSKP <0 SO DON'T SKIP * JSB $KIP GO SKIP THE WORDS JMP EXIT I ERROR EXIT * NOSKP LDA ENTFG ELSE ELA SET TO CLA,SEZ,RSS READ /WRITE THE LDA IL TWIN WORD STA BUFAA WORD LDA DCB TO DUM CLB,INB OR FROM JSB RW$UB USER. BUFAA NOP JMP EXIT ERROR - EXIT * CPA BUA,I IF TWIN MISMATCH CCB,RSS JMP ERR5 THEN BAD RECORD - EXIT * LDA RFLG$ GET READ FLAG CLE,SZA,RSS IF NOT READING JMP EOFWR GO SET EOF IN FILE * EXT0 ISZ RC,I STEP THE RECORD COUNT EXIOK CLA DONE - OK SO JMP EXIT EXIT SPC 2 EOFWR STB BUFPT,I SET EOF IN DCB ELB,RBL SET UP THE EOF READ FLAG AND THE STB RWFLG,I WRITTEN ON AND EOF FLAG IN THE DCB JMP EXT0 GO EXIT SPC 2 TWOTY LDB RFLG$ GET READ WRITE FLAG SZB IF READING JMP INTS GO TEST FOR IN CORE * JMP TWOSP ELSE GO WRITE. SKP * * TYPE 0 OR 1 FILE -- TRANSFER FROM CORE * .1TYP LDA IL GET LENGTH ADDRESS LDB A,I GET LENGTH CPA DMBUF IF NOT SUPPLIED THEN LDB .128 USE 128 STB IL SAVE LOCALLY ADB B177 ROUND UP LSR 7 GET # OF SECTORS COVERED STB SKIP SAVE ROUNDED LENGTH ADB RC,I = # OF 128 WORD RECORDS STB TMP SAVE NEW RECORD # ADB N1 SUBTRACT 1 (RECORD #'S START AT 1) BLS CONVERT TO 64 WORD SECTORS CMB,INB SUBTRACT ADB SPAC,I FROM FILE SIZE SSB IF OUT OF FILE JMP EOFEX TAKE EOF EXIT SPC 2 LDA SKIP GET ROUNDED LENGTH LSL 7 SET TO CORRECT POSITION LDB ENTFG AND SSB,RSS RESET IF STA IL WRITE LDA IL GET XFER LENGTH FOR D$XFR SSB IF READ THEN STA L,I SET THE RETURN LENGTH ELB SET E FOR D$XFR CALL ,LDB BUF GET THE BUFFER ADDRESS STB BUFA SET IT IN THE CALL LDB DCB GET THE DCB ADDRESS JSB D$XFR GO DO THE TRANSFER BUFA NOP JMP EXIT ERROR RETURN * LDA TMP SET THE NEW STA RC,I RECORD COUNT JMP EXIOK AND EXIT SPC 1 TYP00 LDB ENTFG IF READ STB TMP SET READ WRITE FLAG FOR EOF TEST LDA RL,I GET THE READ WRITE LEGAL FLAG SSB,RSS IF WRITE RAR SHIFT THE WRITE FLAG TO BIT 15 SSA,RSS TEST THE FLAG JMP EX17 ILLEGAL REQUEST GO EXIT SPC 1 CCA IF READ SSB THEN JMP TYP01 SKIP * CPA IL,I EOF? (LEN = -1 IS EOF) JMP EOFW0 YES; GO MAKE CONTROL RQ SPC 1 TYP01 CLA,CCE,INA SET UP THE REQUEST CODE SSB,RSS FOR THE CALL INA AND ELA,RAR STA RQ IT. JSB REIO CALL DEF RTN THE DEF RQ EXEC DEF LU0,I FOR DEF BUF,I I/O DEF IL,I TO/FROM USER BUFFER. RTN JMP EX17 DRIVER REJECTED CALL - ERROR. ISZ TMP TEST READ WRITE JMP EXT0 GO EXIT IF WRITE * STB L,I SET THE RETURN LENGTH SPC 1 RAL,CLE,ELA PUT THE DOWN BIT IN E ALF,RAL SHIFT THE EOF BIT RAL TO BIT 15 SSA IF EOF BIT SET JMP EOF00 GO DO EOF THING * SZB IF ZER0 WORDS READ THEN SKIP JMP EXT0 ELSE GO EXIT GOOD XFER * AND B70 MASK THE HIGH ORDER TYPE BIT SEZ,CCE,SZA IF NOT DOWN OR IF TYPE <10 THEN EOF JMP TYP00 ELSE RETRY THE XFER SPC 1 EOF00 CCA,CLE JMP EOFT0 DO EOF TYPE ZER0 EXIT SPC 2 EOFW0 JSB EXEC WRITE TYPE ZER0 EOF DEF EOFRT RETURN ADDRESS DEF .3I CATCH ERRORS DEF EOF0,I DEF N1 EOFRT RSS IF ERRGk<:6OR RETURN THE CODE JMP EXIOK SPC 3 EX17 LDA N17 SET UP ILLEGAL REQUEST FLAG JMP EXIT GO EXIT SKP * * * C O N S T A N T S N1 OCT -1 .1 OCT 1 .2 OCT 2 .3I DEF 3,I .128 DEC 128 MSIGN DEF 0,I DZER0 DEF ZER0 ZER0 NOP \THESE TWO ARE DOUBLE NOP / DUMMY ZERO DBLWD NOP DBL FLAG DMBUF DEF DM DM NOP N11 DEC -11 N10 DEC -10 N7 OCT -7 N12 DEC -12 N14 DEC -14 N5 OCT -5 N33 DEC -33 B177 OCT 177 B70 OCT 70 SPC 5 SKIP NOP RQ NOP SPC 3 A EQU 0 B EQU 1 SPC 1 END EQU * END  <  92070-18053 1941 S C0122 &RWNDF              H0101 {ASMB,R,L,C * NAME: RWNDF * SOURCE: 92070-18053 * RELOC: 92070-16053 * PGMR: G.A.A. * MOD: M.L.K. * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * * NAM RWNDF,7 92070-1X053 REV.1941 790709 * HED RWNDF ENT RWNDF EXT .ENTR,RWND$,EXEC EXT R/W$,GTOPN * THE MODULE OF THE RTE FILE MANAGER PERFORMS * THE REWIND OR RESET FUNCTION * * A FILE IS RESET TO EXTENT 0 RECORD 1 VIA RWND$ * A TYPE ZERO UNIT IS REWOUND VIA AN EXEC CALL * * * CALLING SEQUENCE * * CALL RWNDF(IDCB,IER) * * WHERE: * * IDCB IS THE FILES DATA CONTROL BLOCK ARRAY * * IER IS THE ERROR RETURN LOCATION. * ERRORS ARE RETURNED IN THE A REG * ALSO. * ERRORS CODES ARE: * 0 NO ERROR * -11 DCB NOT OPEN * * SKP RWNDF NOP LDB DFDM PRESET STB DCB ENTRY STB IER ADDRESSES LDA RWNDF MOVE RETURN ADDRESS STA DWNDF TO DUMMY ENTRY POINT JMP DWNDF+1 GO DO IT * DCB DEF DCB IER DEF DCB SPC 1 DWNDF NOP ENTRY POINT JSB .ENTR FETCH DFDM DEF DCB PRAM ADDRESSES SPC 1 LDB DCB GET DCB ADDRESS ADB .2 INDEX TO TYPE AND STB TYPE SET ADDRESS ADB .7 INDEX TO OPEN FLAG AND JSB GTOPN GET CURRENT OPEN FLAG DEF *+1 CPA B,I SAME AS IN DCB? CLA,INA,RSS YES; SET AWRWND RECORD COUNT/SKIP JMP NOOPN NO; TAKE ERROR EXIT ADB   .5 INDEX TO RECORD COUNT AND STA B,I SET RECORD COUNT LDA TYPE,I GET TYPE CLE,SZA IF NOT ZERO JMP DISC GO DO DISC THING SPC 1 ISZ TYPE TYPE =0 -STEP TO LU LDA TYPE,I FETCH LU AND AND B77 ISOLATE IT THEN ADA B400 ADD THE REWIND BIT STA TYPE AND SAVE FOR EXEC SPC 1 JSB EXEC CALL EXEC TO DEF RTN REWIND DEF .3I TYPE DEF TYPE ZERO FILE RTN JMP ER17 EXEC ERROR EXRTN CLA,RSS SET ERROR CODE AND SKIP TO EXIT NOOPN LDA N11 NOT OPEN- EXIT -11 EXIT STA IER,I SET ERROR CODE JMP DWNDF,I RETURN * ER17 LDA N17 ILLEGAL CONTROL REQUEST JMP EXIT SPC 2 DISC LDB DCB SET UP AND JSB R/W$ WRITE THE BLOCK IF NECESSARY JMP EXIT IF ERROR EXIT SPC 1 LDB DCB DISC FILE-CALL CLA RWND$ JSB RWND$ TO SET UP DCB JMP EXIT ERROR RETURN JMP EXRTN NORMAL RETURN SKP * CONSTANT AREA SPC 1 .3I OCT 100003 TYPE NOP .2 DEC 2 .5 DEC 5 .7 DEC 7 N17 DEC -17 B77 OCT 77 B400 OCT 400 N11 DEC -11 SPC 2 A EQU 0 B EQU 1 SPC 1 END EQU * SPC 1 END u   92070-18054 1941 S C0122 &CK.SM              H0101 mSPL,L,O,M ! NAME: CK.SM ! SOURCE: 92070-18054 ! RELOC: 92070-16054 ! PGMR: G.A.A. ! ! *************************************************************** ! * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * ! * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * ! * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* ! * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ! *************************************************************** ! ! NAME CK.SM(7) " 92070-1X054 REV.1941 790712" ! ! CK.SM:SUBROUTINE(BF,TYP)GLOBAL,FEXIT !CHECKSUM ROUTINE ! ! A CHECKSUM IS DONE ON BUFFER BF FOR ! RECORD TYPE TYP(1=RELOCATABLES, 0=>ABS) ! FEXIT IF BAD CHECKSUM ! IF [TT_BF-<8]>377K THEN GOTO RTNF CSS_ $(@BF+2) !INITIALIZE CHECKSUM CS_ $(@BF+1) IF TYP THEN BFBP_ -1, \SET OFFSET AND IF ABS ELSE[ \ BFBP_ 1; \ADD WORD CS_ CSS+CS] !TO CS CLN_TT +@BF+BFBP !SET LAST WORD ADDRESS AND IFNOT TYP THEN CSS_$(CLN+1) !IF ABS, SET CHECKSUM FOR BFPT_@BF+3 TO CLN DO[CS_CS+$BFPT] !SUM IF CS=CSS THEN RETURN !CHECK AND RETURN RTNF: FRETURN END END END$ 4  92070-18055 1941 S C0122 &CLD.R              H0101 \ASMB,R,L,C * NAME: CLD.R * SOURCE: 92070-18055 * RELOC: 92070-16055 * PGMR: M.L.K. * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * * NAM CLD.R,7 92070-1X055 REV.1941 790709 * * * THIS ROUTINE PROVIDES A CENTRAL CALLING POINT * FOR D.RTR * ENT CLD.R ENT .P1,.P2,.P3,.P4,.P5,.P6,.P7,.P8,.P9 ENT .R1,.R2,.R3,.R4,.R5 * EXT D.RTR,GTOPN SUP SPC 3 CLD.R NOP JSB GTOPN GET CURRENT OPEN FLAG DEF *+1 STA .P0 STORE IN 1ST PARAMETER JSB D.RTR NOW CALL DEF .P0 PASSED PARAMETERS DEF .R1 RETURNED PARAMETERS JMP CLD.R,I RETURN SPC 3 .P0 NOP .P1 NOP .P2 NOP .P3 NOP .P4 NOP .P5 NOP .P6 NOP NOP NOP .P7 NOP .P8 NOP .P9 NOP * .R1 NOP .R2 NOP .R3 NOP .R4 NOP .R5 NOP * END EQU * END "  92070-18056 1941 S C0122 &CR.LU              H0101 uASMB,R,L,C * NAME: CR.LU * SOURCE: 92070-18056 * RELOC: 92070-16056 * PGMR: M.L.K. * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * * NAM CR.LU,7 92070-1X056 REV.1941 790709 * * * THIS ROUTINE IS USED TO CONVERT A NEGATIVE LU OR A * POSITIVE CRN INTO THE CORRESPONDING DISC LU. IF THE * REQUESTED LU OR CRN IS NOT FOUND, A=0 AND E=1 (FRETURN). * SKP ENT CR.LU EXT .ENTR,$CDIR SPC 3 CRNLU NOP * CR.LU NOP JSB .ENTR SET UP PARAMETER DEF CRNLU * LDA CRNLU,I GET CR/LU PASSED CCE,SZA,RSS IS IT 0? (SET FAILED EXIT) JMP CR.LU,I YES,EXIT * SSA IS IT POSITIVE OR NEGATIVE? JMP LU NEGATIVE, MUST BE LU STA CRNLU POSITIVE, IT'S A CRN LDA N2 SET TO BACKUP WHEN STA OFSET CRN IS FOUND LDB .2 OFFSET INTO TABLE BY 2 * SERCH ADB DCDIR GET ADDRESS OF FIRST CRN/LU LOOP LDA B,I GET CRN/LU SZA,RSS END OF LIST? JMP CR.LU,I YES, EXIT NOT FOUND * CPA CRNLU THIS THE ONE WE'RE LOOKING FOR? JMP FOUND YES, GO GET LU ADB .4 NO, TRY NEXT ONE JMP LOOP * FOUND CLE SET FOUND EXIT ADB OFSET BACKUP IF NECESSARY LDA B,I GET LU JMP CR.LU,I AND EXIT * LU CMA,INA CONVERT TO POSITIVE STA CRNLU AND SAVE CLB CLEAR FOR NO STB OFSET OFFSET JMP SERCH GO SEARCH CARTRIDGE LIST * * N2 DEC -2 .2 DEC 2 .4 DEC 4 DCDIR DEF $CDIR+0 * OFSET NOP A EQU \K  0 B EQU 1 END EQU * END ,   92070-18057 1941 S C0122 &CREA.              H0101 weSPL,L,O,M ! NAME: CREA. ! SOURCE: 92070-18057 ! RELOC: 92070-16057 ! PGMR: G.A.A. ! MOD: M.L.K. ! ! *************************************************************** ! * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * ! * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * ! * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* ! * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ! *************************************************************** ! ! NAME CREA.(7) " 92070-1X057 REV.1941 790906" ! ! EXTERNAL SUBROUTINES LET CREAT BE SUBROUTINE,EXTERNAL LET IER. BE SUBROUTINE,EXTERNAL,DIRECT ! EXTERNAL INTEGERS LET .E.R BE INTEGER,EXTERNAL ! ! CREA.:SUBROUTINE(DCBR,LUR,PPLIS) GLOBAL,FEXIT IF LUR <20000K THEN FRETURN !IF NAME LU, FEXIT DCB3_[DCB2_[DCB1_@PPLIS+1]+1]+1 !SET UP DCB POINTERS CREAT(DCBR,.E.R ,LUR,$DCB3,$DCB2,PPLIS,$DCB1) !CREAT THE FILE IER. !TEST FOR ERRORS $DCB3_.E.R >- 1 !SET ACTUAL SIZE !FOR TRUNCATE OPTION RETURN END END END$ ]^  92070-18058 1941 S C0122 &FID.              H0101 \YSPL,L,O,M ! NAME: FID. ! SOURCE: 92070-18058 ! RELOC: 92070-16058 ! PGMR: G.A.A. ! MOD: G.L.M. ! ! *************************************************************** ! * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * ! * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * ! * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* ! * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ! *************************************************************** ! ! NAME FID.(7) " 92070-1X058 REV.1941 790712" ! ! EXTERNAL SUBROUTINES LET DR.RD BE SUBROUTINE,EXTERNAL LET NAM.. BE SUBROUTINE,EXTERNAL ! EXTERNAL INTEGERS LET D.LT BE INTEGER,EXTERNAL !DISC LAST TRACK LET PK.DR BE INTEGER,EXTERNAL !DISC BUF FOR DR.RD ! CONSTANTS LET READI BE CONSTANT (1) ! ! FID.: FUNCTION (DS)GLOBAL ! THIS ROUTINE RETURNS FALSE IF A FILE SYSTEM EXISTS ON DS ! DR.RD(READI,DS,0)?[GO TO RETF] !READ THE DIRECTORY ! PDIR8_[PDIR7_[PDIR6_[PDIR5_[PDIR3_[PDIR_@PK.DR]\ +3]+2]+1]+1]+1 TX_$PDIR $PDIR_ TX AND 77777K NAM..(PK.DR) !CHECK ASCII LABEL AREG_ $0 $PDIR_ TX IF AREG THEN GOTO RETF !IF ILLEGAL OR FLAG IF TX>0 THEN GOTO RETF !NOT SET THEN NO FILE IF $(PDIR3 )<0 THEN GOTO RETF !IF LABEL < 0 IF $(PDIR7 )-$(PDIR8 )-1 #$D.LT THEN GOTO RETF !LTR MAKE IF $(PDIR6 )<$(PDIR5 ) THEN GO TO RETF FID.V_ 0 RETURN RETF: FID.V_ 1 RETURN END ! END END$   92070-18059 1941 S C0122 &FM.UT              H0101 wSPL,L,O,M ! NAME: FM.UT ! SOURCE: 92070-18059 ! RELOC: 92070-16059 ! PGMR: G.A.A. ! MOD: G.L.M. ! ! *************************************************************** ! * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * ! * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * ! * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* ! * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ! *************************************************************** ! ! NAME FM.UT(7) " 92070-1X059 REV.1941 790712" ! ! ! ! EXTERNAL SUBROUTINES LET EXEC BE SUBROUTINE,EXTERNAL LET MSS. BE SUBROUTINE,EXTERNAL ! EXTERNAL FUNCTIONS LET GTOPN BE FUNCTION,EXTERNAL ! EXTERNAL LABELS LET FM.AB BE LABEL,EXTERNAL ! EXTERNAL INTEGERS LET O.BUF BE INTEGER,EXTERNAL ! GLOBAL INTEGERS LET D.LB BE INTEGER,GLOBAL !DISC LABEL LET D.LK BE INTEGER,GLOBAL !DISC LOCK LET D.LT BE INTEGER,GLOBAL !DISC LAST TRACK LET D.SDR(128)BE INTEGER,GLOBAL !DIRECTORY BUFFER LET DFMT BE INTEGER,GLOBAL ! LET DS.DF BE INTEGER,GLOBAL ! LET DS.F1 BE INTEGER,GLOBAL ! LET DS.LU BE INTEGER,GLOBAL !DISC LU LET DS.SC BE INTEGER,GLOBAL !DISC SECURITY CODE LET PK.DR(128)BE INTEGER,GLOBAL !DR.RD BUFFER LET TBLEN BE INTEGER,GLOBAL ! INITIALIZE DS.DF,DS.F1 TO 0,0 ! CONSTANTS LET A BE CONSTANT (0) !A REGISTER LET B BE CONSTANT (1) !B REGISTER LET READI BE CONSTANT (1) !EXEC READ LET WRIT BE CONSTANT (2) !EXEC WRITE ! N1: ASSEMBLE "OCT -1" D124: ASSEMBLE "DEC 124" %DSDR: ASSEMBLE "DEF D.SDR" ASSEMBLE "EXT $CDIR,.MVW,.DRCT,$MDSP" ! D.rRIO:SUBROUTINE(RCODE) GLOBAL !READ MASTER DIRECTORY ! ! IF DS.DF THEN [DS.DF_0;RETURN]!IF READ INHIBIT FLAG(DS.DF) SET !USE CURRENT CONTENTS OF D.SDR !CLEAR INHIBIT FLAG FOR NEXT TIME ! ! FETCH DIRECT ADDRESS OF MASTER DIRECTORY AND ! SET ADDRESS OF END OF DIRECTORY IN MDSTP,SET TABLE ! LENGTH INTO TBLEN. ! ! ASSEMBLE "JSB .DRCT FETCH DIRECT ADDRESSES" ASSEMBLE "DEF $CDIR" ASSEMBLE "LDB $MDSP FETCH IT" ASSEMBLE "CMA,INA CALCULATE LEGNTH" ASSEMBLE "ADB 0" ASSEMBLE "STB TBLEN AND SAVE FOR MOVE" ! ! CHECK FOR MORE THAN 31 POSSIBLE DISC'S(TBLFP>124) ! ASSEMBLE "CMB,INB SET NUMBER NEG" ASSEMBLE "ADB D124 ADD TO MAX LEN" ASSEMBLE "SSB,RSS SKIP IF BAD " ASSEMBLE "JMP MVR GO MOVE HER IN" ! ASSEMBLE "LDB D124 ELSE MAX=31 DISCS" ASSEMBLE "STB TBLEN SAVE FOR MOVE" MVR: ASSEMBLE "CMA,INA SET FW OF DIRECTORY POSITIVE" ASSEMBLE "LDB %DSDR FETCH ADDRESS OF D.SDR" ASSEMBLE "JSB .MVW MOVE MASTER DIRECTORY TO LOCAL BUFFER" ASSEMBLE "DEF TBLEN ADDRESS OF WORD HOLDING LENGTH" ASSEMBLE "NOP MAKE THE MICRO CODE HAPPY" ! ASSEMBLE "CLA" ASSEMBLE "STA 1,I SET END OF TABLE+1=0" DIR02: ASSEMBLE "STA DS.DF FORCE NEW READ TO PREVENT PROBLEMS IN MTM" RETURN !RETURN END ! ! ! DR.RD:SUBROUTINE(RCOD,DISID,BLK)FEXIT,GLOBAL ! ! THIS SUBROUTINE READS/WRITES THE DIRECTORY BLOCK ! SPECIFIED BY BLK FROM THE DISC IDENTIFIED ! BY DISID. FEXIT IS TAKEN IF THE ! DISC CANNOT BE FOUND OR IF THE END ! OF THE DIRECTORY IS REACHED. ! ! IF [RWCD_RCOD] < 0 THEN [\ !CHECK FOR WRITE FROM DBUF_@O.BUF;RWCD_-RCOD;GO TO DRRD1],\ !O.BUF--IF NEG RCOD ELSE DBUF_@PK.DR !USE O.BUF--ELSE USE PK.DR ! IF DISID=DS.F1 THEN[IF RWCD=WRIT THEN[IFNOT BLK THEN\ GOTO DIRR2];GOTO DRRD1] D.RIO(READI) !READ MASTER DIRECTORY INTO !INTO D.SDR ! !DETERMINE IF LU OR DISKETTE !REFERENCE IF DISID<0 THEN[DLU_-DISID;T_0], \ ELSE[DLU_DISID;T_2] ! !SEARCH FOR REQUESTED DISK !CONTINUE AT DIRR0 IF FOUND FOR I_0 TO TBLEN-4 BY 4 DO[IF$(@D.SDR+I+T)=DLU\ THEN GOTO DIRR0] ! ! !IF NOT FOUND--EXIT EXITF:FRETURN ! ! THE DISID HAS BEEN FOUND SO READ IN BLK0 DIRR0:D.LK_[D.LB_[D.LT_[DS.LU_@D.SDR+I]+1]+1]+1! SET POINTERS PDSLU_ $DS.LU + 7700K !PROTECTED DISC LU ! !IF WRITE AND IF BLOCK !ZERO--CONTINUE AT DIRR2 ! !READ BLOCK ZERO- IF RWCD=WRIT THEN[IFNOT BLK THEN GO TO DIRR2] EXEC(READI,PDSLU,PK.DR,128,$D.LT,0 ) !READ DISK ID INFO ! DO[BREG_$B;IF BREG#128 THEN[MSS.(1,$DS.LU);GOTO FM.AB]] DIRR2:DS.F1_DISID !SET UP DISC ID DISBL_0 !ALSO THE CURRENT BLOCK DISNT_$(@PK.DR+8) !AND # OF DIRECTORY TRACKS DS.SC_ ($(@PK.DR+6)AND 377K) !ISOLATE AND SET NO. OF SECTORS DFMT_ (($(@PK.DR+6)->8)AND 377K) !SAVE SECTOR SECTOR SKIP INFO IFNOT DFMT THEN DFMT_14 !DEFAULTS TO 14 (7 BLOCKS) ! IF (BLK=0) AND (RWCD=READI) THEN GO TO EXIT ! CALCULATE THE SECTOR ADDRESS DRRD1:TR_(BLK*DFMT)/DS.SC !COMPUTE THE SECTOR ADDRESS T_$1 !SET IN T ! !DIVIDE BY SECTOR SKIP/2 TR_TR/(DFMT->1) !RELATIVE TRACK TO TR IF (TR+DISNT)> -1 THEN GO TO EXITF TR_$D.LT-TR !SET THE TRACK ADDRESS IN TR ! ! READ/WRITE ! ! IF WRITE MUST HAVE LOCKED TGHE DISK ! IF RWCD=WRIT THEN[IF $D.LK# GTOPN THEN[MSS.(61);GOTO FM.AB]] ! DRRD4:EXEC(RWCD,PDSLU,$DBUF,128,TR,T) BREG_$B !TEST FOR ERRORS IF BREG#128 THEN[MSS.(1,$DS.LU); GOTO FM.AB] EXIT: RETURN !RETURN END END END$ 6  92070-18060 1941 S C0122 >OPN              H0101 ASMB,R,L,C * NAME: GTOPN * SOURCE: 92070-18060 * RELOC: 92070-16060 * PGMR: M.L.K. * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * * NAM GTOPN,7 92070-1X060 REV.1941 790709 * * THIS ROUTINE CALCULATES THE CURRENT OPEN FLAG FOR * FMGR AND FMP. THE FORMAT OF THE OPEN FLAG IS: * * ------------------------------------------------- * ! ! SEQ# ! CPU# ! ID SEGMENT # ! * ------------------------------------------------- * 15 14 11 10 8 7 0 * SKP ENT GTOPN EXT $IDA,$IDSZ,$XQT,$CPU SUP * GTOPN NOP ISZ GTOPN SET UP RETURN ADDRESS STB SAVB SAVE B REGISTER * CLB CLEAR B FOR DIVIDE LDA $IDA GET START OF ID SEGMENTS CMA,INA MAKE IT NEGATIVE ADA $XQT ADD CURRENT ADDRESS TO GET OFFSET DIV $IDSZ AND DIVIDE BY ID SIZE FOR ID# INA ADD ONE SO NUMBERED 1 TO N STA B * LDA $XQT GET CURRENT ID AGAIN ADA OFSET ADD OFFSET TO SEQUENCE NUMBER LDA A,I GET SEQUENCE NUMBER AND B170K ISOLATE SEQUENCE COUNT CLE,ERA MOVE SEQUENCE COUNT TO BITS 11 - 14 IOR B ADD IN THE ID NUMBER STA B * LDA $CPU GET CPU NUMBER AND B7 ALLOW 0 - 7 ALF,ALF MOVE TO BITS 8 - 10 IOR B ADD IN CPU NUMBER LDB SAVB RESTORE B REGISTER JMP GTOPN,I RETURN SKP OFSET DEC 28 B170K OCT 170000 B7 OCT 7 SAVB NOP * A EQU 0 B EQU 1 * END EQ  U * END (   92070-18061 1941 S C0122 &IDMEM              H0101 gASMB,R,L,C * NAME: IDMEM * SOURCE: 92070-18061 * RELOC: 92070-16061 * PGMR: M.L.K. * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * * NAM IDMEM,7 92070-1X061 REV.1941 790709 * SKP * * THIS MODULE WILL FIND ANY REAL-TIME PROGRAM WHOSE MEMORY * BOUNDS CONFLICT IN ANY WAY WITH THE MEMORY BOUNDS PASSED TO * IT. IT IS USED TO DETERMINE IF THERE EXITS A REAL TIME * PROGRAM WHOSE MEMORY BOUNDS WOULD CONFLICT WITH ONE WHICH IS * BEING SET UP BY RP. * * CALLING SEQUENCE: * IADDR = IDMEM(IADBF) * * WHERE * IADBF = POINTER TO A SKELETON ID SEGMENT FROM * A TYPE 6 FILE. * IDADR = 0 IF NO CONFLICT OR NOT A REAL-TIME * PROGRAM. * ID SEGMENT ADDRESS OF NAME OF CONFLICTING * PROGRAM. * * ENT IDMEM EXT .ENTR,$FWRT,$FWBG,$ID#,$IDA,$BGBP,$IDSZ SUP SKP NUID NOP * IDMEM NOP JSB .ENTR SET UP PARAMETERS DEF NUID * LDA $FWBG GET FIRST WORD OF BACKGROUND CMA,INA COMPLEMENT AND SAVE STA FWBG FOR REAL TIME/BACKGROUND TEST * * SET UP NEW ADDRESSES FROM CALLER'S ID SEGMENT * LDB NUID GET ID ADDRESS ADB .20 POINT TO WORD 21 LDA B,I GET NEW LOW MAIN STA NULO AND SAVE IT * ADB .3 NOW POINT TO WORD 24 LDA B,I AND GET LOW BASE PAGE AND B1777 AND ISOLATE IT STA NULOB STORE IT * ADB .9 POINT TO WORD 33. LOADER SET THIS LDA vB,I TO HIGHEST PROGRAM ADDRESS + 1 ADA M1 SUBTRACT 1 FOR HIGHEST ADDRESS STA NUHI SAVE IT * INB NOW POINT TO WORD 34. LOADR SETS THIS LDA B,I TO HIGH BP ADDRESS + 1 ADA M1 SUBTRACT 1 FOR HIGHEST BP ADDRESS STA NUHIB AND SAVE * * CHECK IF THIS IS A REAL-TIME PROGRAM * LDA NULO TEST IF THE LOW BOUND IS IN JSB BCHEK REAL-TIME AREA. IF SO, ASSUME DEF $FWRT+0 THE LOADR HAS CHECKED THE REST DEF $FWBG+0 OF THE BOUNDARIES SZA,RSS REAL-TIME? JMP EXIT NO, EXIT OK. * * INITIALIZE LOOP * LDA $ID# GET NUMBER OF ID SEGMENTS CMA,INA SET IT NEGATIVE STA COUNT AND SAVE FOR LOOP COUNT * LDA $IDA GET ADDRESS OF FIRST ID ADA .12 AND POINT TO NAME (FOR ACTIVE CHECK) STA IDPTR AND SAVE ID POINTER SKP * * TEST ID * LOOP LDB IDPTR,I GET FIRST NAME WORD SZB,RSS IF IT IS 0, THE ID NOT USED JMP NEXT NOT IN USE, DO NEXT * LDB IDPTR SET UP ID'S BOUNDS ADB .8 POINT TO LOW MAIN LDA B,I GET ADDRESS FROM ID STA MLO AND SAVE IN MAIN LOW ADA FWBG ADD THE NEGATIVE FIRST WORD OF BACKGROUND SSA,RSS THIS ID RT OR BG? JMP NEXT BG, SKIP IT, CAN'T CONFLICT * INB POINT TO HIGH MAIN+1 LDA B,I GET ADDRESS FROM ID STA MHI AND SAVE IN MAIN HIGH * ADB .2 POINT TO LOW BASE PAGE/#SEGMENTS LDA B,I GET ADDRESS FROM ID AND B1777 ISOLATE LOW BASE PAGE STA BLO SAVE IN BASE PAGE LOW LDA B,I GET WORD AGAIN ALF,ALF POSITION # OF SEGMENTS RAR,RAR TO LOW BITS AND B77 AND ISOLATE STA NUMSG SAVE NUMBER OF SEGMENTS * INB POINT TO HIGH BASE PAGE LDA B,I GET ADDRESS FROM ID  AND B1777 ISOLATE ADDRESS STA BHI SAVE IN BASE PAGE HIGH * LDA NUMSG GET NUMBER OF SEGMENTS SZA,RSS SEGMENTED? JMP CKBND NO, CHECK MEMORY BOUNDS LDA $FWBG USE BG BOUNDRY FOR SEGMENTED PROGS STA MHI SAVE HIGHEST MAIN ADDRESS LDA $BGBP USE BG BP BOUNDRY FOR SEGMENTED STA BHI SAVE HIGHEST BASE PAGE ADDRESS * CKBND LDA NULO CHECK NEW LOW BOUND JSB BCHEK CHECK BOUNDS DEF MLO DEF MHI STA BNDCK SAVE CONFLICT VALUE STB AB.BL SAVE ABOVE/BELOW INDICATOR LDA NUHI CHECK NEW HIGH BOUND JSB BCHEK DEF MLO DEF MHI ADA BNDCK ADD PREVIOUS CHECK SZA LOW AND HIGH BOUNDS OK? JMP ERBND NO, ERROR ADB AB.BL YES, NOW TEST IF BOTH BOUNDS ON SAME SIDE SZB,RSS OF THIS PROGRAM JMP ERBND NO, SPANS THIS PROGRAM, ERROR. * LDA NULOB NOW CHECK LOW BP BOUND JSB BCHEK DEF BLO DEF BHI STA BNDCK SAVE CONFLICT VALUE STB AB.BL SAVE ABOVE/BELOW INDICATOR LDA NUHIB NOW CHECK HIGH BP BOUND JSB BCHEK DEF BLO DEF BHI ADA BNDCK ADD PREVIOUS CHECK SZA LOW AND HIGH BP BOUNDS OK? JMP ERBND NO, RETURN ADB AB.BL YES, NOW TEST IF BOTH BOUNDS ON SAME SIDE SZB,RSS OF THIS PROGRAM JMP ERBND NO, NEW PROGRAM SPANS THIS ONE, ERROR * NEXT LDA IDPTR GET ID POINTER ADA $IDSZ AND INCREMENT TO NEXT ONE STA IDPTR SAVE FOR NEXT ROUND ISZ COUNT INCREMENT COUNT JMP LOOP DO IT AGAIN * EXIT CLA DONE, NO CONFLICTS JMP IDMEM,I EXIT * * ERBND LDA IDPTR ERROR IN BOUNDS. RETURN POINTER JMP IDMEM,I TO NAME AND EXIT SKP * * BOUNDS CHECK - TESTS WHETHER THE A REGISTER IS GREATER THAN * OR EQUAL TO THE FIRST PARAMETER AND LESS THAN THE SECOND * PARAMETER. * * * LDA BOUND * JSB BCHEK * DEF LO BOUND * DEF HI BOUND * A = 0 IF NOT BETWEEN BOUNDS, -1 IF BETWEEN * B = -1 IF BELOW LOWER BOUNDRY * +1 IF ABOVE UPPER BOUNDRY * * BCHEK NOP LDB BCHEK,I GET ADDRESS OF LOW BOUND STB LO STORE IN LOW ISZ BCHEK POINT TO UPPER BOUND LDB BCHEK,I GET ADDRESS OF HIGH BOUND STB HI ISZ BCHEK POINT TO RETURN ADDRESS * LDB LO,I GET LOW BOUND CMB,INB AND SET IT NEGATIVE ADB A ADD IN THE TEST BOUND SSB IS IT BELOW OR EQUAL OR ABOVE? JMP BELOW BELOW, ITS OK * LDB HI,I EQUAL OR ABOVE SO GET HIGH BOUND CMB,INB AND SET IT NEGATIVE ADB A ADD IN THE TEST BOUND SSB,RSS IS IT BELOW OR EQUAL OR ABOVE? JMP ABOVE EQUAL OR ABOVE, IT'S OK * CCA BELOW, IT'S IN THE RANGE CONFLICT JMP BCHEK,I RETURN * ABOVE CLB,INB OKEX CLA OK EXIT JMP BCHEK,I * BELOW CCB JMP OKEX SKP * * STORAGE * .20 DEC 20 .3 DEC 3 .12 DEC 12 .8 DEC 8 .9 DEC 9 .2 DEC 2 B77 OCT 77 B1777 OCT 1777 * NULO NOP NEW LOW BOUND NUHI NOP NEW HIGH BOUND NULOB NOP NEW LOW BP BOUND NUHIB NOP NEW HIGH BP BOUND MLO NOP MAIN LOW MHI NOP MAIN HIGH BLO NOP BASE LOW BHI NOP BASE HIGH COUNT NOP LOOP COUNTER IDPTR NOP POINTER TO NAME IN ID SEGMENT NUMSG NOP NUMBER OF SEGMENTS BNDCK NOP STORE RESULT OF BCHEK AB.BL NOP STORE ABOVE/BELOW RESULT OF BCHEK SPC 3 LO NOP LOW BOUNDRY FOR BCHEK HI NOP HIGH BOUNDARY FOR BCHEK SPC 3 M1 DEC -1 FWBG NOP NEGATIVE VALUE OF FIRST WORD OF BACKGROUND * A EQzU 0 B EQU 1 END EQU * END `^  92070-18062 1941 S C0122 &IDRPL              H0101 sASMB,R,L,C HED "IDRPL" FTN/SPL SUBROUTINE TO DO A FMGR ":RP,PROG" * SOURCE: 92070-18062 * RELOC: 92070-16062 * PGMR: M.L.K. * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * NAM IDRPL,7 92070-1X062 REV.1941 790709 * SKP * ENT IDRPL EXT EXEC,.ENTR,$LIBR,$LIBX,IDSGA,NAM.. EXT GTOPN,LOGLU,$CKSM,IDMEM,.MVW EXT $FWBG,$BGBP SUP * * * PURPOSE: * TO ACCOMPLISH THE EQUIVALENT OF A FMGR ":RP,PROG" IN A SUBROUTINE. * CALLED: * CALL IDRPL (IDCB,IERR,NAME,IPERM) * -OR- * IF (IDRPL (IDCB,IERR,NAME,IPERM).NE.0) GO TO IERROR * WHERE: * IERR = RETURN ERROR CODE (SAME AS ERROR CODES IN FMGR) * IDCB = AN OPEN DCB OF THE TYPE 6 FILE ON LU=2 OR LU=3 * NAME = 5 CHARACTER BUFFER OF THE PROGRAM NAME PUT IN ID SEGMENT * IPERM= 0 IF PROGRAM TO BE TEMPORARY, #0 IF TO BE PERMANENT * * WORDS SET BY IDRPL: * * LONG ID SEGMENT * 13-15 PROGRAM NAME FROM THIRD INPUT PARAMETER * 16 ID BIT SET ACCORDING TO IPERM PARAMETER * 25 BASE PAGE TRACK OFFSET FROM MAIN TRACK * 26 BASE PAGE SECTOR/MAIN SECTOR (IN 128 WORD SECTORS) * 27 MAIN TRACK * 28 DISC LU * 29 SEQUENCE NUMBER SET FROM THE CURRENT CONTENTS OF THE ID * SEGMENT TO BE USED. CONSOLE LU FROM LOGLU. * * * SHORT ID SEGMENT * 3 SEGMENT'S MAIN TRACK OFFSET FROM WORD 27 IN LONG ID * 6 SEGMENT'S BASE PAGE TRACK OFFSET FROM WORD 3 IN SHORT ID * 7 SEGMENT'S BASE PAGE/MAIN SECTOR ADDRESS (PHYSICAL SECTORS) * 8 SHORT ID SEGMENT'S CHECKSUM FOR 9OP SYSTEM. * * RETURN: * * IERR = 0 > SUCCESSFUL INSTALLATION OF IDSEGMENT INTO SYSTEM * E-REG = 1 IF ERROR, ELSE E-REG = 0 (FOR FRETURN SPL) * IERR = -1 > DISC ERROR * IERR = -11 > IDCB NOT OPEN * IERR = 14 > NO BLANK ID SEGMENTS OR EXTENSIONS AVAILABLE * IERR = -15 > ILLEGAL NAME * IERR = 19 > ID(34),ID(35) WORDS DID NOT CHECKSUM CORRECTLY. * IERR = 23 > DUPLICATE PROGRAM NAME. * IERR = 39 > CANNOT RP PROGRAM. DISC ADDRESS OUT OF RANGE * IERR = 40 > REAL TIME PROGRAM ALREADY IN CORRESPONDING AREA. * * NOTES: * * (1) A-REG = IERR ON RETURN, THEREFORE MAY BE USED AS FUNCTION * (2) IDRPL DOES NOT CLOSE THE FILE. * (3) RECOMMEND FILE BE NON EXECUTIVELY OPENED * (4) E-REG = 1, IF ERROR, E=0, IF NO ERROR(FOR SPL) * (5) ONLY THE 1ST 10 WORDS OF THE DCB ARE USED BY THIS SUBROUTINE. * (6) B REGISTER HAS THE ADDRESS OF THE PROGRAM NAME IN CONFLICT * IF ERROR 40 IS RETURNED. SKP IDRPL NOP DUMMY ENTRY POINT LDA DZERO STA PERM LDA IDRPL STA DRPL JMP DRPL+1 SPC 2 IDCB NOP OPEN DCB ADDRESS IERR NOP RETURNED ERROR CODE NAME NOP FIVE CHAR ASCII NAME TO GIVE PROGRAM PERM NOP PERMANENT OR TEMPORARY INDICATOR * DRPL NOP ENTRY JSB .ENTR DEF IDCB LDA IDCB,I GET TRACK-LU WORD FROM DCB AND B77 ISOLATE LU OF THE DISC STA LU AND SAVE FOR EXEC AND ID ADA B7700 ADD DISC PROTECT STA PDSLU TO ITS LU LDB IDCB CALCULATE FILE TRACK/SECTOR WORD ADB .3 ADDRESSES STB DCB3 POINTER TO TRACK OF FILE INB BUMP TO SECTOR OF FILE STB DCB4 AND SET INTO EXEC CALL ADB .4 BUMP TO SECT/TRACK WORD LDA B,I GET # OF 64 SECTORS PER TRACK STA #SC/T SAVE # OF 64 WORD SECTORS PER TRACK RAR SHIFT FOR # OF 128 WORD SE$CTORS STA SEC/T AND SAVE CCE,INB PREPARE E-REG IN CASE OF ERROR, B TO OPEN FLAG JSB GTOPN GET CURRENT OPEN FLAG DEF *+1 CPA B,I SAME AS IN DCB? RSS YES, SKIP JMP ERR11 NO, FILE NOT OPEN * JSB LOGLU GET CONSOLE LU DEF *+2 DEF CONLU DUMMY PARAMETER STA CONLU SAVE FOR FUTURE USE * JSB EXEC READ 1ST 34 WORDS OF FILE DEF *+7 DEF .1 READ DEF PDSLU PROTECTED DISC LU DEFID DEF IDBUF DESTINATION BUFFER ADDRESS DEF .34 BUFFER LENGTH DCB3 DEF * DISC TRACK DCB4 DEF * DISK SECTOR * CLA,CCE CLEAR SUM TOTAL JSB SUM CALCULATE CHECKSUM DEF IDBUF OF THE 1ST 31 WORDS OF FILE DEC -31 CPA ID+32 EQUAL TO WORD 32? CLA,RSS YES JMP ERR19 NO LDA $CKSM GET SYSTEM CHECKSUM CPA ID+31 COMPARE? JMP DORP YES, CONTINUE ERR19 LDA .19 NO, FMGR ERROR 19 JMP EREXT ERR39 LDA .39 JMP EREXT ER01 CCA SET DISC ERROR JMP EREXT ERR11 LDA .11 CMA,INA MAKE NEGATIVE EREXT CCE ERROR EXIT E-REG = 1 EXIT STA IERR,I TELL CALLER RETURN CODE JMP DRPL,I RETURN IERR = A-REG SKP * * SET UP MAIN ID SEGMENT * DORP LDA DCB3,I GET STARTING TRACK NUMBER STA TRACK INITIALIZE TRACK VALUE FOR BUMP STA TRAK INITIALIZE TRACK VALUE FOR SETPT LDA DCB4,I GET STARTING SECTOR NUMBER STA SEKTR INITIALIZE SECTOR VALUE FOR SETPT RAR SHIFT FOR PHYSICAL SECTORS STA SECTR INITIALIZE SECTOR VALUE FOR BUMP * * MAIN DISC ADDRESS * CLA,INA SET A TO 1 FOR HIGH ADDRESS CLB SET B TO 0 FOR LOW ADDRESS JSB BUMP NOW BUMP DISC ADDRESS BY ONE SECTOR PAST ID STB ID+27 STORE MAIN TRACK IN WORD 27 STA ID+26  STORE MAIN SECTOR IN LOW BYTE WORD 26 * * BASE PAGE DISC ADDRESS * LDA ID+22 GET THE HIGH MAIN ADDRESS LDB ID+21 GET THE LOW MAIN ADDRESS JSB BUMP CALCULATE THE DISC ADDRESS OF THE MAIN BASE PAGE ALF,ALF SHIFT BASE PAGE SECTOR TO HIGH BYTE IOR ID+26 ADD IN THE MAIN SECTOR STA ID+26 AND STORE AGAIN IN WORD 26 * LDA ID+27 GET MAIN TRACK CMA,INA AND SET IT NEGATIVE STA NEGMN SAVE THIS FOR LATER ADB A ADD THE CURRENT TRACK TO GET OFFSET LDA M64 TEST IF OFFSET IS GREATER THAN 63 ADA B SSA,RSS POSITIVE? JMP ERR39 YES, ERROR IN SETUP BLF,BLF NO, IT'S OK. SO SHIFT THE OFFSET RBL,RBL TO THE TOP SIX BITS LDA ID+25 GET ID WORD 25 IOR B AND ADD IN BP OFFSET STA ID+25 AND STORE AGAIN IN WORD 25 * * DISC LU * LDA LU GET LU STA ID+28 AND STORE IN WORD 28 * * SET UP ID NAME * JSB NAM.. CHECK FOR LEGAL NAME DEF *+2 DEF NAME,I SZA NAME OK? JMP EREXT NO, FMGR ERROR -15 * LDA NAME,I GET FIRST TWO CHARACTERS STA ID+13 STORE IN WORD 13 LDA NAME GET THE ADDRESS OF THE NAME INA POINT TO THE SECOND WORD DLD A,I AND GET THE REST STA ID+14 STORE THE SECOND WORD LDA B MOVE LAST CHARACTER TO A AND UBYTE CLEAR LOWER BYTE STA ID+15 AND STORE IN ID WORD 15 * * SET ID BIT IF NECESSARY * LDA IDBIT PRESET THE ID BIT LDB PERM,I NOW GET THE PERMANENT PARAMETER SZB PREMANENT OR TEMPORARY? CLA PERMANENT, DON'T SET ID BIT IOR ID+16 TEMPORARY, SET ID BIT STA ID+16 STORE BACK IN WORD 16 * * CHECK PRIORITY, SET TO 99 IF 0 * LDA ID+7 GET PRIORITY SZA,RSS IF IT IS ZERO DY LDA .99 THEN SET IT TO 99 STA ID+7 AND SET IN WORD 7 SKP * * SET UP SHORT ID SEGMENTS * * SET UP LOOP LDA ID+24 GET ID WORD 24 ALF,ALF SWAP BYTES RAR,RAR POSITION # OF SEGMENTS INTO LOWER BITS AND B77 AND ISOLATE SZA,RSS ANY SEGMENTS? JMP WRTID NO, GO WRITE ID SEG INTO MEMORY CMA,INA SET # SEG NEGATIVE STA LPCNT SAVE AS LOOP COUNTER CCA SET INIT TO -1 TO CAUSE STA INIT SETPT TO INITIALIZE THE SECTOR BUFFER * LDA $FWBG GET BG BOUNDRY IN CASE REAL TIME STA ID+33 STORE IN PLACE OF HI SEGMENT LDA $BGBP GET BG BP BOUNDRY IN CASE REAL TIME STA ID+34 STORE IN PLACE OF HI SEGMENT BP * LDA ID+24 GET MAIN LOW BASE PAGE ADDRESS AND B1777 ISOLATE LOW BASE PAGE STA B AND PUT INTO B LDA ID+25 GET MAIN HIGH BASE PAGE + 1 ADDRESS AND B1777 AND ISOLATE IT STA HMNBP STORE FOR LOOP IN HI MAIN BASE PAGE JSB BUMP POSITION TRACK AND SECTOR TO SEGMENT 0 * LOOP JSB SETPT SET UP POINTERS TO SHORT ID SEGMENT LDA SECTR GET CURRENT SECTOR OF THE SEGMENT'S MAIN STA SID7,I STORE IT IN THE SHORT ID WORD 7 LDB TRACK GET CURRENT TRACK OF THE SEGMENT'S MAIN STB TR SAVE A COPY TO CALCULATE BP OFFSET ADB NEGMN SUBTRACT THE MAIN'S TRACK TO GET OFFSET LDA M256 TEST WHETHER OFFSET IS GREATER THAN 255 ADA B AND WON'T FIT IN A BYTE SSA,RSS OK? JMP ERR39 NO, EXIT, CAN'T SET IT UP LDA SID3,I GET LAST LETTER OF NAME AND AND UBYTE ISOLATE IT IOR B PUT TRACK OFFSET IN WORD 3 STA SID3,I AND STORE IT BACK * * SET UP FOR SEGMENT'S BASE PAGE * LDA SID5,I GET THE SEGMENT'S MAIN HIGH ADDRESS + 1 LDB ID+22 USE THE MAIN'S HIGH ADDRESS AS LOW JSB BUMPf) UPDATE THE DISC POINTERS ALF,ALF POSITION THE BP SECTOR IN THE UPPER BYTE IOR SID7,I PUT IN THE SEGMENT'S MAIN SECTOR STA SID7,I AND STORE BACK IN WORD 7 LDB TR GET SEGMENT'S MAIN TRACK CMB,INB AND SET IT NEGATIVE ADB TRACK ADD THE SEGMENT'S BP TRACK LDA M64 TEST IF GREATER THAN 64 ADA B SSA,RSS TOO BIG? JMP ERR39 YES, EXIT. CAN'T SET IT UP BLF,BLF POSITION TRACK OFFSET TO UPPER RBL,RBL SIX BITS LDA SID6,I GET HIGH BP ADDRESS + 1 IN A AND B1777 ISOLATE HIGH BP ADDRESS + 1 ADB A PUT BP TRACK OFFSET IN STB SID6,I AND REPLACE IN WORD 6 * * NOW BUMP DISC ADDRESS TO NEXT SEGMENT * LDB HMNBP LOAD MAIN'S BP ADDRESS (A REG ALREADY SET) JSB BUMP NOW UPDATE DISC ADDRESSES * * CALCULATE THE SHORT ID'S CHECKSUM * LDA SID1 PUT THE SHORT ID SEGMENT'S ADDRESS STA SIDAD INTO CALL FOR CHECKSUM CLA CLEAR PENDING SUM JSB SUM CALCULATE SUM OF SHORT SIDAD NOP BEGINNING ADDRESS OF SHORT ID SEGMENT DEC -7 TO WORD 7 STA SID8,I STORE IN WORD 8 * * CHECK COUNT * ISZ LPCNT DONE YET? JMP LOOP NO, DO NEXT SEGMENT * * WRITE OUT LAST SECTOR * LDA ENDSB GET ADDRESS OF THE END OF THE SECTOR BUFFER ADA M8 AND SUBTRACT 8 AND STORE IN SID1. THIS WILL STA SID1 FORCE A WRITE OF THE CURRENT SECTOR. JSB SETPT NOW CALL TO DO WRITE SKP * * GO PRIVILEGED TO WRITE THE ID SEGMENT * * WRTID JSB $LIBR GO PRIVILEGED TO PREVENT NOP CONFLICTS WITH OTHER ROUTINES * JSB IDSGA SEARCH FOR DUPLICATE PROGRAM NAMES DEF *+2 DEF NAME,I SEZ,CME IF NOT FOUND, CLEAR E-REG AND A-REG JMP RTPRG AND GO FIND A BLANK ID SEGMENT LDA .23 IF FOUND, RETURN FMGXR 23 ERROR JMP PEXIT WITH E-REG = 1 * * TEST FOR REAL-TIME PROGRAM MEMORY CONFLICT * RTPRG JSB IDMEM TEST FOR REAL-TIME MEMORY BOUNDS DEF *+2 CONFLICTS DEF IDBUF PASS IT THE BUILT UP ID SEGMENT CCE,SZA,RSS IF NO CONFLICT FOUND (OR NOT REAL-TIME) JMP SERCH THEN SEARCH FOR FREE ID SEGMENT LDB A PUT NAME ADDRESS IN B LDA .40 OTHERWISE EXIT WITH FMGR 40 ERROR JMP PEXIT WITH E-REG = 1 * * SEARCH FOR FREE ID SEGMENT * SERCH JSB IDSGA CALL FOR MATCH OF BLANK NAME DEF *+2 DEF ZERO ARRAY OF THREE ZEROS SEZ,RSS IF FOUND, GO MOVE ID DOWN JMP MOVE LDA .14 OTHERWISE, EXIT. FMGR 14 JMP PEXIT E-REG = 1 * * MOVE ID SEGMENT INTO SYSTEM * MOVE STA B SAVE COPY OF ID ADDRESS ADA .28 POINT TO WORD 29 LDA A,I GET THE WORD WITH SEQUENCE NUMBER AND B170K ISOLATE SEQUENCE NUMBER IOR CONLU SET IN USER'S CONSOLE STA ID+29 AND SET BACK INTO ID 29 * LDA DEFID SET A TO SOURCE (B TO DESTINATION) JSB .MVW MOVE THE ID SEGMENT DEF .30 NOP (FOR COMPATIBILITY) CLA,CLE SET UP FOR GOOD RETURN * PEXIT JSB $LIBX DONE! DEF *+1 DEF EXIT SKP * * SETPT (SET UP POINTERS TO SHORT ID SEGMENT) - SETS UP POINTERS * SID1,SID3,SID5,SID6,SID7,SID8 TO THE CORRESPONDING WORDS IN THE * CURRENT ID SEGMENT. WILL WRITE OUT AND READ NEXT SECTOR IF * NECESSARY. * * ON ENTRY IF INIT = -1, INITIALIZES SUBROUTINE AND CLEARS INIT. * USES VARIBLES SECBF(128) SECTOR BUFFER * SEKTR DISC ADDRESS TO READ * TRAK WRITE TO * SEC/T NUMBER OF SECTORS/TRACK * SETPT NOP ISZ INIT IS THIS THE INITIALIZE CALL? RSS NO, GO SET UP ID POINTERS JMP REED YES, GO READ SECTOR WITH SHOrRT ID SEGMENTS * LDA SID1 GET CURRENT SHORT ID POINTER ADA .8 AND POINT TO THE NEXT ID CPA ENDSB AT THE END OF THE SECTOR? JMP RITE THEN WRITE IT OUT AND READ THE NEXT BLOCK SET STA SID1 ELSE, STORE FOR WORD 1 ADA .2 ADD 2 FOR STA SID3 WORD 3 ADA .2 ADD 2 FOR STA SID5 WORD 5 INA INCREMENT STA SID6 FOR WORD 6 INA INCREMENT STA SID7 FOR WORD 7 INA INCREMENT STA SID8 FOR WORD 8 JMP SETPT,I EXIT * * RITE JSB EXEC WRITE OUT SECTOR CONTAINING UPDATED DEF *+7 SHORT ID SEGMENTS DEF .2 WRITE DEF PDSLU PROTECTED DISC LU DEF SECBF SECTOR BUFFER DEF .128 WHOLE SECTOR DEF TRAK DISC TRACK DEF SEKTR DISC SECTOR CPB .128 CHECK FOR COMPLETE TRANSMISSION RSS OK, GO READ JMP ER01 DISC ERROR, EXIT * REED LDA SEKTR GET CURRENT SECTOR ADDRESS ADA .2 INCREMENT TO THE NEXT SECTOR (64 WORD) CPA #SC/T OVERFLOW THIS TRACK? CLA,RSS YES, SET SECTOR TO 0 RSS NO, SKIP TRACK INCREMENT ISZ TRAK INCREMENT TRACK ADDRESS STA SEKTR STORE SECTOR ADDRESS JSB EXEC READ NEXT SECTOR FROM THE DISC DEF *+7 WHICH CONTAINS THE SHORT ID SEGMENTS DEF .1 READ DEF PDSLU PROTECTED DISC LU DSCBF DEF SECBF SECTOR BUFFER DEF .128 WHOLE SECTOR DEF TRAK DISC TRACK DEF SEKTR DISC SECTOR CPB .128 CHECK FOR COMPLETE TRANSMISSION RSS OK JMP ER01 DISC ERROR, EXIT * LDA DSCBF GET ADDRESS OF SECTOR BUFFER JMP SET AND SET UP NEW POINTERS SKP * * BUMP - BUMP DISC POINTERS TO POINT AT THE VARIOUS MAINS, BASE PAGES, * AND SEGMENTS CONTAINED WITHIN A ETYPE 6 FILE. * * * CALLING SEQUENCE: * A = HIGH ADDRESS + 1 * B = LOW ADDRESS * JSB BUMP * A = SECTOR AND SECTR = SECTOR * B = TRACK AND TRACK = TRACK * SEC/T = SECTORS/TRACK * * BUMP NOP CMB,INB SET THE LOW ADDRESS NEGATIVE ADA B AND ADD TO HIGH ADDRESS. A = PROGRAM SIZE CLB CLEAR B FOR DIVIDE DIV .128 DIVIDE BY 128 FOR NUMBER OF SECTORS SZB IF REMAINDER IS ZERO, SKIP INA OTHERWISE ADD ONE TO SECTOR COUNT FOR A PARTIAL SECTOR ADA SECTR ADD IN CURRENT SECTOR CLB CLEAR B FOR DIVIDE DIV SEC/T DIVIDE BY SECTORS/TRACK STB SECTR STORE REMAINDER AS SECTOR ADA TRACK AND ADD QUOTIENT TO TRACK ADDRESS STA TRACK AND SAVE AS CURRENT TRACK ADDRESS SWP PUT SECTORS IN A AND TRACK IN B JMP BUMP,I RETURN SKP * * SUM - USED TO SUM THE WORDS IN ID SEGMENTS FOR CHECKSUM TESTS * * SUM NOP P+1 = ADDRESS, P+2 = NEGATIVE NUMBER OF WORDS LDB SUM,I ISZ SUM STB #MOVE SAVE START SUMMING ADDRESS LDB SUM,I GET NUMBER OF WORDS ISZ SUM POINT TO RETURN ADDRESS ADA #MOVE,I ACCUMULATE THE SUM ISZ #MOVE BUMP TO NEXT WORD INB,SZB DONE? JMP *-3 NO, ADD THE NEXT JMP SUM,I YES, RETURN SKP * * CONSTANTS * DZERO DEF ZERO ZERO NOP THIS ARRAY IS USED TO FIND NOP A BLANK NOP ID SEGMENT B77 OCT 77 .3 DEC 3 .4 DEC 4 .1 DEC 1 .34 DEC 34 .19 DEC 19 .11 DEC 11 M64 DEC -64 UBYTE OCT 177400 IDBIT OCT 2000 .39 DEC 39 .40 DEC 40 .99 DEC 99 B1777 OCT 1777 B7700 OCT 7700 M256 DEC -256 M8 DEC -8 .23 DEC 23 .14 DEC 14 .28 :<:6DEC 28 B170K OCT 170000 .30 DEC 30 .8 DEC 8 .2 DEC 2 .128 DEC 128 * * VARIBLES * LU NOP DISC LU PDSLU NOP PROTECTED DISC LU IDBUF BSS 34 ID SEGMENT BUFFER ID EQU IDBUF-1 TRACK NOP TRACK WORD FOR BUMP SECTR NOP SECTOR WORD FOR BUMP TRAK NOP TRACK WORD FOR SETPT SEKTR NOP SECTOR WORD FOR SETPT SEC/T NOP SECTORS/TRACK FOR DISC 'LU' #SC/T NOP LOGICAL SECTORS PER TRACK NEGMN NOP NEGATIVE VALUE OF MAIN TRACK HMNBP NOP HIGH MAIN BASE PAGE ADDRESS SECBF BSS 128 SECTOR BUFFER ENDSB DEF * END OF SECTOR BUFFER ADDRESS LPCNT NOP LOOP COUNTER TR NOP TEMPORARY TRACK WORD SID1 NOP SHORT ID POINTER TO WORD 1 SID3 NOP SHORT ID POINTER TO WORD 3 SID5 NOP SHORT ID POINTER TO WORD 5 SID6 NOP SHORT ID POINTER TO WORD 6 SID7 NOP SHORT ID POINTER TO WORD 7 SID8 NOP SHORT ID POINTER TO WORD 8 CONLU NOP CONSOLE LU #MOVE NOP USED BY SUM INIT NOP INITIALIZATION FLAG USED BY SETPT * * A EQU 0 B EQU 1 END EQU * END -<  92070-18063 1941 S C0122 &LOCK.              H0101 zmASMB,R,L,C * NAME: LOCK. * SOURCE: 92070-18063 * RELOC: 92070-16063 * PGMR: G.A.A. * MOD: G.L.M * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * * NAM LOCK.,7 92070-1X063 REV.1941 790713 * * * THIS ROUTINE OBTAINS A LOCK AND RELEASES IT ON THE * GIVEN DISC * ENT LOCK. EXT CLD.R,.P1,.P2,.R1,MSS.,DS.DF,DS.F1,.ENTR * * DSID NOP DSID= +CRN, -LU OF DISC TO LOCK RQ NOP RQ = 3 TO LOCK, 5 TO UNLOCK LOCK. NOP * JSB .ENTR DEF DSID * * SET UP CLD.R FOR CALL TO D.RTR * LDA RQ,I FETCH THE REQUEST CODE STA .P1 SET IT FOR CALL LDA DSID,I STA .P2 SET DISK ID JSB CLD.R * LDA .R1 ANY ERRORS? SZA,RSS WELL? JMP OK NOPE --GO CLEAR A FLAG AND GET OUT * STA .P1 SAVE ERROR CODE JSB MSS. ISSUE ERROR DEF MRTN DEF .P1 CODE MRTN CCE SET UP A SPL FRETURN JMP LOCK.,I * * OK CLA,CLE CLEAR STA DS.DF CORE FLAGS--FORCE NEW READ STA DS.F1 JMP LOCK.,I E=0=GOOD RETURN * B EQU 1 END 0  92070-18064 1941 S C0122 &MSC.              H0101 b`ASMB,R,L,C * NAME: MSC. * SOURCE: 92070-18064 * RELOC: 92070-16064 * PGMR: G.L.M. * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * * NAM MSC.,7 92070-1X064 REV.1941 790709 * EXT $XECM,.ENTR ENT MSC. * * THIS ROUTINE CHECKS THE PASSED PARAMETER AGAINST THE * SYSTEM MASTER SECURITY CODE * * ON RETURN: A=1 IF GOOD * A=0 IF BAD * MSEC NOP MSC. NOP JSB .ENTR DEF MSEC LDB $XECM FETCH SYSTEM MASTER SECUTITY CODE ISZ MSEC POINT TO SECURITY CODE (2ND WRD OF P.RAM) SZB FORCE MATCH IF OLD CODE=0 CPB MSEC,I MATCH? CLA,INA,RSS YES--RETURN A=1 CLA NO--RETURN A=0 JMP MSC.,I EXIT END v)  92070-18065 1941 S C0122 &NAM..              H0101 QyASMB,R,L,C * NAME: NAM.. * SOURCE: 92070-18065 * RELOC: 92070-16065 * PGMR: G.A.A. * MOD: G.L.M * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * * NAM NAM..,7 92070-1X065 REV.1941 790709 * ENT NAM.. EXT .ENTR SUP SPC 3 * THIS ROUTINE CHECK FOR A LEGAL FILE NAME * CALLING SEQUENCE: * * JSB NAM.. * DEF *+2 * DEF NAME * * ON RETURN A=0 IF A LEGAL NAME -15 IF NOT LEGAL * * LEGAL NAMES MUST START WITH A NON NUMERIC NON BLANK * ASCII CHARACTER * AND MUST NOT CONTAIN +, OR - AS ANY CHARACTER * SKP NAME NOP ADDRESS OF THE NAME NAM.. NOP ENTRY POINT JSB .ENTR GET THE PRAMS DEF NAME * DLD NAME,I FETCH 1ST 4 CHARS OF NAME LDB N6 SET TO CHECK STB COUNT 6 CHARACTERS LDB NAME RBL LDA NAME,I DO SPECIAL EXTRA CHECK ALF,CLE,ALF ON AND B377 FIRST CHARACTER ADA N60B IF NUMERIC OR BLANK SEZ,CME THEN ADA N10 TAKE SEZ THE CPA N20B ERR JMP ER15 EXIT CREA1 CLE,ERB GET THE NAME ADDRESS LDA B,I GET A NAME WORD ELB RESTORE ADDRESS FOR NEXT TIME SLB,INB,RSS INCREMENT SKIP IF ODD ELSE ALF,ALF ROTATE AND B377 MASK IT CPA COLON IF COLON CLA FOURCE ERROR ADA N40B BETWEEN " " SZA,RSS IF BLANK THEN JMP BLNK TAKE NOTE SEZ,CME AND ADA   N13B "*" SEZ,CLE,RSS INCLUSIVE? JMP CREA2 YES - OK ADA N3 NO; BETWEEN SEZ,CME "." AND ADA N62B "_" CREA2 ISZ NAME CHARACTER AFTER BLANK?? SEZ NO; LEGAL OTHER WISE?? JMP ER15 NO GO TAKE ERROR EXIT CREA3 ISZ COUNT DONE? JMP CREA1 NO; DO NEXT CHARACTER CLA,RSS GOOD NAME EXIT ER15 LDA N15 ERROR EXIT JMP NAM..,I SPC 1 BLNK CCA SET BLANK FLAG STA NAME SO WE CAN DETECT JMP CREA3 INBEDDED BLANKS SPC 2 COUNT NOP COLON OCT 72 N62B OCT -62 N3 DEC -3 N13B OCT -13 N40B OCT -40 B377 OCT 377 N20B OCT -20 N60B OCT -60 N6 DEC -6 N10 DEC -10 N15 DEC -15 A EQU 0 B EQU 1 END <   92070-18066 1941 S C0122 &$OPEN              H0101 wrASMB,L,C * NAME: $OPEN * SOURCE: 92070-18066 * RELOC: 92070-16066 * PGMR: G.A.A. * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * * NAM $OPEN,7 92070-1X066 REV.1941 790709 * HED $OPEN ENT $OPEN EXT EXEC,RWND$,GTOPN SUP * * $OPEN IS A ROUTINE OF THE RTE FILE MANAGEMENT PACKAGE. * * $OPEN IS CALLLED BY OPEN AND CREAT TO SET UP THE * DCB. IT READS THE DIRECTORY INFORMATION * AND TRANSFERS THE INFORMATION FROM THERE * TO THE DCB. IT ALSO INITIALIZES THE REST * OF THE DCB. * * CALLING SEQUENCE: * (IT IS ASSUMED THAT WORDS 1 & 2 OF THE DCB ARE SET UP.) * * A = DCB ADDRESS * B = SECURITY CODE (EXPECTED) * E = 1 IF TYPE 1 OVERRIDE * O = 1 IF AN UPDATE OPEN * * JSB $OPEN * DEF IBLK DEF OF LENGTH OF DCB OR ZERO * DEF #SECT DEF OF WORD CONTAINING #SEC/TRACK * IN THE HIGH HALF (PASSED FROM D.RTR) * JMP ERR ERROR RETURN * NORMAL RETURN * ON A NORMAL RETURN: * A = FILE SECURITY CODE * B = SECURITY CODE/UPDATE FLAG * * ON AN ERROR RETURN, EITHER * A = -1 DISC ERROR OR * A = -9 TYPE ZERO OVERRIDE ERROR * IN EITHER CASE THE DCB IS NOT SET UP. * * $OPEN NOP ENTRY STB SC SAVE THE SECURITY CODE SSB IF NEGATIVE CMB,INB SET POS STB SC2 AND SAVE STA DCB AND THE DCB ADDRESS STA DCB2 LDA A,I GET THE DIRECTORY AND B77 ADDRESS STA LU kp AND SET XOR DCB,I TO ALF,ALF READ RAL,RAL THE STA TRACK DIRECTORY LDA LU GET LU AGAIN ADA B7700 ADD IN THE DISC PROTECT BITS STA LU RESTORE ISZ DCB BLOCK LDA DCB,I GET THE SECTOR AND B377 MASK STA SECT AND XOR DCB,I SET ALF,ALF GET THE LDB DCB OFFSET ADB .4 AND SIZE STB SIZE ADB .11 AND STB BUF COMPUTE BUFFER ADDRESS ADB .3 AND ADB A OFFSET STB PRMA TO ISZ DCB THE PRAMS CLB,SEZ,INB IF TYPE 1 OVERRIDE STB DCB,I SET TYPE SEZ AND CCB THE STB TPFLG OVERRIDE SKIP FLAG JSB EXEC READ DEF RTN THE DEF .1 BLOCK DEF LU TO BUF NOP THE DEF .128 DCB DEF TRACK DEF SECT RTN CCA SET A FOR DISC ERROR CPB .128 DISC ERROR? CLB,RSS NO SKIP JMP EREX EXIT - ERROR ADA BUF COMPUTE THE EXTENT ADDRESS STB A,I AND SET THE EXTENT TO ZERO LDA N9 LDB PRMA,I GET FILE TYPE SZB,RSS IF ZERO ISZ TPFLG AND OVERRIDE FLAG SET RSS JMP EREX EXIT - ERROR SPC 1 LDB N5 OF - SET TO MOVE 5 NXT LDA PRMA,I PARAMETERS ISZ TPFLG IF OVERRIDE SET SKIP STA DCB,I SET PARAMETER ISZ DCB STEP ADDRESS ISZ PRMA STEP SOURCE INB,SZB AND COUNT - DONE? JMP NXT NO; DO NEXT ONE LDA PRMA,I CLE,SZA CPA SC CCE MATCH SO SET E CPA SC2 MATCH WITH POS OF NEG CCE YES SO SET E ERB  MATCH - SET FLAG SOC SET UPDATE INB FLAG STB SC SAVE SECURITY CODE LDA $OPEN,I GET THE SIZE IN WORDS LDB A,I TO THE B REG LSR 7 DIVIDE BY 128 TO GET BLOCKS SZB,RSS IF ZERO THEN INB USE ONE BLS CONVERT TO SECTORS NXBUF STB TPFLG SAVE IT LDA SIZE,I GET THE FILE SIZE CLB DIV TPFLG DIVIDE TO GET N SZB,RSS IF NO REMAINDER JMP BFOK THEN THE SIZE IS OK LDB N2 ELSE TRY ONE SMALLER ADB TPFLG THAN THE CURRENT JMP NXBUF ONE BFOK LDA TPFLG GET THE BUFFER SIZE LSL 6 CONVERT SECTORS TO WORDS ADA SC ADD THE SECURTITY CODE AND UPDATE FLAG STA DCB,I SET IN DCB ISZ $OPEN STEP TO NEXT PRAM ISZ DCB SET NUMBER OF SECTORS / TRACK ADD LDB $OPEN,I GET THE WORD LDB B,I FROM THE CALL LSR 8 SET TO LOW B STB DCB,I PUT IT IN THE DCB ISZ $OPEN STEP RETURN ADDRESS CLA OPEN EXTENT ZERO LDB DCB2 GET THE DCB ADDRESS JSB RWND$ SET REST OF DCB JMP $OPEN,I ERROR EXIT ADB N2 SET B TO THE RECORD NO ADDRESS CLA,INA SET THE RECORD NO STA B,I TO 1. ISZ DCB STEP TO THE OPEN FLAG ADDRESS JSB GTOPN GET CURRENT OPEN FLAG DEF *+1 STA DCB,I SET THE OPEN FLAG LDA PRMA,I RESTORE SECURITY CODE LDB SC AND MATCH - UPDATE FLAG RSS EREX ISZ $OPEN STEP TO ERROR RETURN ISZ $OPEN STEP AND JMP $OPEN,I AND RETURN SKP SIZE NOP SC2 NOP SC NOP DCB NOP DCB2 NOP LU NOP TRACK NOP B77 OCT 77 B377 OCT 377 B7700 OCT 7700 SECT NOP N9 DEC -9 .4 DEC 4 .11 DEC 11 .3 DEC 3 PRMA NOP TPFLG NOP .1 DEC 1 .128 DEC 128 N5 DEC -5 N2 OCT -2z SPC 2 A EQU 0 B EQU 1 SPC 1 END EQU * SPC 1 END   92070-18067 1941 S C0122 &P.PAS              H0101 SASMB,R,L,Z,C * NAME: P.PAS * SOURCE: 92070-18067 * RELOC: 92070-16067 * PGMR: G.A.A. * MOD: G.L.M * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * * NAM P.PAS,7 92070-1X067 REV.1941 790709 ENT P.PAS * HED P.PAS * P.PAS IS USED TO SET UP ADDRESS OR TO MOVE * INFORMATION FROM THE CALL AREA * * CALLING SEQUENCE: * * E=0 SET UP CALL AREA * E=1 MOVE FROM CALL AREA * B=0 SET ADDRESSES ONLY * B=100000 MOVE PARAMETERS * A = ADDRESS OF OTHER AREA OR FIRST ADDRESS * * JSB P.PAS * DEC -N N= NO. OF WORDS TO BE SET UP * BSS N CALL AREA BUFFER * IF B IS 0, THIS WILL BE A * LIST OF ADDRESSES; IF B=100000, * THIS WILL BE THE WORDS AT THE * ADDRESS PROVIDED IN A. * * P.PAS NOP ADB LOAD CONFIGURE THE LOAD STB NEXT AND SET IT LDB P.PAS,I GET THE COUNT STB COUNT AND SET ISZ P.PAS STEP TO PRAM AREA LDB P.PAS ADDRESS TO B SEZ IF FROM SWP SWAP ADDRESSES STB DEST SAVE THE DESTINATION ADDRESS NEXT LDB A GET ADDRESS OR IF LDB A,I STB DEST,I A WORD - SET IF ISZ DEST STEP DESTINATION INA STEP FROM ISZ COUNT STEP COUNT - DONE? JMP NEXT NO; GET NEXT ONE SEZ YES; EXIT TO JMP A,I END OF CALL JMP DEST,I SEQUENCE SPC 5 COUNT NOP DEST NOP LOAD LDB A TEST NOP SPC 2 A EQU 0 B EQ&  U 1 END EQU * END 1   92070-18068 1941 S C0122 &PMOVE              H0101 ASMB,R,L,C * NAME: PMOVE * SOURCE: 92070-18068 * RELOC: 92070-16068 * PGMR: G.L.M. * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * * NAM PMOVE,7 92070-1X068 REV.1941 790709 * ENT PMOVE EXT $LIBR,$LIBX,.MVW * * CALLING SEQUENCE: * A = SOURCE ADDRESS * B = DESTINATION ADDRESS * JSB PMOVE * DEF LENGTH * < RTN > * PMOVE NOP JSB $LIBR NOP JSB .MVW DEF PMOVE,I NOP ISZ PMOVE JSB $LIBX DEF PMOVE END t  92070-18069 1941 S C0122 &PR.IT              H0101 ASMB,R,L,C * NAME: PR.IT * SOURCE: 92070-18069 * RELOC: 92070-16069 * PGMR: M.L.K. * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * * NAM PR.IT,7 92070-1X069 REV.1941 790709 * * * THIS ROUTINE PRINTS A LIST OF PROGRAM NAMES FROM * AN ARRAY OF POINTERS TO ID SEGEMENTS. IT IS USED * IN CONJUNCTON WITH SY.TR TO LIST ACTIVE SYSTEM PROGRAMS. SKP ENT PR.IT EXT CAM.O,.ENTR,EXEC SUP SPC 3 ARRAY NOP ASIZE NOP * PR.IT NOP JSB .ENTR SET UP PARAMETERS DEF ARRAY * LDA ASIZE,I GET ARRAY SIZE CMA,INA SET IT NEGATIVE SSA,RSS IF IT WAS NEGATIVE OR 0 CCA SET IT TO -1 STA ASIZE NOW STORE IT * LOOP LDA ARRAY,I GET THE NEXT ARRAY ENTRY SZA,RSS IF IT IS 0, JMP PR.IT,I THEN EXIT * SSA IF IT'S NEGATIVE, IT'S SWAP JMP SWAP GO CHECK WHICH LDB N5 SET CHARACTER COUNT FOR EXEC WRIT STA BUF STORE BUFFER ADDRESS STB COUNT STORE LENGTH JSB EXEC CALL THE SYSTEM TO WRITE OUT THE NAME DEF *+5 DEF O2 WRITE DEF CAM.O TO LOG DEVICE BUF DEF * DEF COUNT * ISZ ARRAY INCREMENT TO NEXT ELEMENT ISZ ASIZE END OF ARRAY? JMP LOOP NO, WRITE NEXT JMP PR.IT,I YES, EXIT * SWAP LDA DSWPB GET SWAP BUFFER ADDRESS LDB .6 SET WORD COUNT JMP WRIT GO WRITE IT * * O2 OCT 2 N5 DEC -5 .6 DEC 6 DSWPB DEF SWPBF SWPBF ASC 6,SWAP AREA * COUNT NOP * A F   EQU 0 B EQU 1 END EQU * END   92070-18070 1941 S C0122 &R/W$              H0101 0zASMB,R,L,C * NAME: R/W$ * SOURCE: 92070-18070 * RELOC: 92070-16070 * PGMR: G.A.A. * MOD: M.L.K. * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * * NAM R/W$,7 92070-1X070 REV.1941 790709 * HED R/W$ ENT R/W$ ENT D$XFR EXT EXEC SUP * * R/W$ WRITES THE CURRENT SECTOR BLOCK IF IT HAS * BEEN WRITTEN ON OR READS UNCONDITIONALLY. * * CALL SEQUENCE: * * SET E=0 FOR WRITE E=1 FOR READ * LDB DCB SET B TO DCB ADDRESS * JSB R/W$ * JMP DERR ERROR RETURN (A = -1) * NORMAL RETURN * R/W$ NOP STB RC SAVE THE DCB ADDRESS ADB .7 INDEX TO THE BLOCK SIZE LDA B,I FETCH THE BLOCK SIZE ARS,ALR CLEAR THE LEAST AND SIGN BITS ADB .6 INDEX TO THE WRITTEN ON FLAG STB WOFLG SAVE ITS ADDRESS ADB .3 INDEX TO THE BUFFER ADDRESS STB BUFA SET IN CALL LDB WOFLG,I GET THE WRITTEN ON FLAG SEZ,SLB,RSS IF NOT WRITTEN ON (SKIP ON READ) JMP EXIT EXIT LDB RC GET THE DCB ADDRESS JSB D$XFR DO THE TRANSFER BUFA NOP JMP R/W$,I ERROR - RETURN LDB RC GET THE REQUEST CODE CCE,SLB,RSS IF THIS IS A WRITE CALL EXIT CLA,CLE CLEAR THE IN CORE FLAGS ERA,ALS CLEAR WRITTEN ON FLAG AND SET IF READ STA WOFLG,I RESET ISZ R/W$ TAKE OK JMP R/W$,I EXIT SPC 2 .3 DEC 3 .6 DEC 6 .7 DEC 7 .10 DEC 10 RC NOP TRACK NOP \AT K  TRACK (LEAVE IN THIS ORDER) SECT NOP /AND SECTOR LU NOP WOFLG NOP B77 OCT 77 B7700 OCT 7700 SKP * DISC TRANSFER CALL SEQUENCE * * E=0 FOR WRITE * E=1 FOR READ * B= DCB ADDRESS * A= LENGTH (NO. OF WORDS) * JSB D$XFR CALL TO HERE * DEF BUFR BUFFER ADDRESS (MUST BE DIRECT) * JMP ERR ERROR RETURN (A=-1) * NORMAL RETURN SPC 2 D$XFR NOP ENTRY POINT STA #WORD SAVE LENGTH CLA,SEZ,INA,RSS SET UP THE REQUEST CODE INA AND STA RC SET IT LDA B,I CONFIGURE THE CON WORD AND B77 GET LU FROM DCB 1 ADA B7700 ADD PROTECT BITS STA LU SAVE THE LU ADB .10 GET THE NUMBER OF SECTORS PER TRACK DLD B,I AND SECTOR ADDRESS THEN DST TRACK SAVE IT LDA D$XFR,I GET THE BUFFER ADDRESS STA BUF SAVE IT ISZ D$XFR STEP TO ERROR RETURN ADDRESS JSB EXEC CALL EXEC TO DEF ERTS DEF RC WRITE/READ DEF LU FROM THE DISC BUF NOP AT THE SPECIFIED BUFFER DEF #WORD SIZE DEF TRACK TRACK AND DEF SECT SECTOR ERTS CCA SET UP FOR ERROR EXIT CPB #WORD ERROR? CLA,RSS NO ERROR SKIP JMP D$XFR,I ERROR RETURN ISZ D$XFR END SO JMP D$XFR,I MAKE THE NORMAL RETURN SPC 2 #SC/T NOP ADDRESS OF # OF SECTORS/TRACK #WORD NOP NUMBER OF WORDS TO TRANSFER A EQU 0 B EQU 1 END EQU * SPC 1 END   92070-18071 1941 S C0122 &RW$UB              H0101 iASMB,L,R,C * NAME: RW$UB * SOURCE: 92070-18071 * RELOC: 92070-16071 * PGMR: G.A.A. * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * * NAM RW$UB,7 92070-1X071 REV.1941 790709 * HED RW$UB * * RW$UB READS AND WRITES A WORD OR BLOCK OF WORDS ON A RTE FILE * CALLING SEQUENCE: * SET E=1 FOR READ * E=0 FOR WRITE * LDA DCB SET A TO DCB ADDRESS * LDB COUNT SET B TO THE NO OF WORDS TO BE XFERED * JSB RW$UB CALL * DEF BUF BUFFER CONTAING (WRITE) OR RECIEVING (READ) * JMP ERROR ERROR RETURN CODE IN A * --- NORMAL RETURN * EXT RWND$,R/W$ EXT P.PAS EXT RFLG$ ENT RW$UB,NX$EC ENT $KIP RW$UB NOP ENTRY CMB,INB,SZB,RSS SET NEGATIVE SKIP IF NOT ZERO JMP ZER0 ZERO GO RETURN STB COUNT NEGATIVE CLB,SEZ,RSS COUNTER LDB RSS SET READ/WRITE SWITCH STB NEXTW RSS IF WRITE, ELSE NOP JSB PRAM GO GET THE PRAMETERS ADA B CALCULATE CMA,INA THE # ADA BUFPT,I OF REMAINING STA LEFT WORDS AND SET LDB BUFPT,I GET THE POINTER TO B LDA RW$UB GET USER BUFFER LDA A,I GET ADDRESS RAL,CLE,SLA,ERA IF INDIRECT JMP *-2 TRY AGAIN ISZ RW$UB STEP RETURN STA PTR SET USER POINTER NEXTW RSS OR NOP IF WRIT JMP READ DO READ THING LDA PTR,I WRITE; GET WORD STA B,I SET IT IN DCB RDW ISZ PTR STEP POINTER INB STEP DCB ADDRESS }ISZ LEFT ANY ROOM LEFT? RSS RSS YES; SKIP JMP ENDBL NO; GO WRITE IT OUT CONT ISZ COUNT STEP WORD COUNT-DONE? JMP NEXTW NO; DO NEXT WORD STB BUFPT,I RESET THE BUFFER POINTER LDB NEXTW IF WRITE SZB THEN STB FLAG,I SET THE WRITTEN ON FLAG EX ISZ RW$UB YES; STEP THE RETURN ADDRESS JMP RW$UB,I RETURN SPC 2 ZER0 ISZ RW$UB STEP FOR GOOD RETURN JMP EX EXIT SPC 2 ENDBL LDB TYPE,I IF TYPE TWO CPB .2 THEN LDB COUNT IF COUNT IS INB,SZB,RSS EXAUSTED JMP CONT JUST CONTINUE LDB NEXTW GET THE READ WRITE FLAG SZB IF WRITE THEN STB FLAG,I SET THE BIT IN THE DCB CLB,INB SET FOR NEXT BLOCK JSB NX$EC GO GET IT JMP RW$UB,I ERROR - RETURN LDB BLKLN OK - CMB,INB RESET STB LEFT LEFT COUNTER LDB BUFA AND BUFFER POINTER JMP CONT AND CONTINUE SPC 1 READ LDA B,I GET THE WORD STA PTR,I SET IN USER BUFFER JMP RDW RETURN TO WRITE CODE SPC 2 COUNT NOP BUFA NOP SPC 2 $KIP NOP SKIP ENTRY STB COUNT SAVE THE WORD COUNT JSB PRAM GO SET THE PRAMS CMA,INA COMPUTE THE BUFFER ADA BUFPT,I OFFSET ADA COUNT ADD THE COUNT STA B SET UP FOR DIVID ASR 16 EXTENT THE SIGN DIV BLKLN DIVIDE BY BLOCK LENGTH SSB SKIP IF POSITIVE ADA N1 ELSE ADDJUST THE BLOCK SSB IF NEGATIVE ADB BLKLN ADJUST TO POSITIVE ADB BUFA COMPUTE THE NEW BUFFER ADDRESS SWP PUT BUFFER ADDRESS IN A BLOCK IN B SZB,RSS IF ZERO THE GO TO EXIT JMP *+3 JSB NX$EC GO GET THE BLOCK JMP $KIP,I ERROR RETURN STA BUFPT,I SET THE BUFFER ADDRESS IN THE DCB ISKiZ $KIP SET TO NORMAL RETURN JMP $KIP,I MAKE NORMAL RETURN SKP PRAM NOP FETCH DCB ADDRESS SUBROUTINE CLB,CLE SET UP JSB P.PAS AND DEC -16 FETCH DCB NOP DCB TMP NOP TYPE NOP TR NOP SEC NOP #SEC NOP SAV NOP PTR NOP USED AS LOCAL SEC/T NOP LEFT NOP USED AS LOCAL ONLY CTRK NOP CSEC NOP BUFPT NOP FLAG NOP BLKLN NOP EXT# NOP LDB PTR,I GET THE BLOCK LENGTH WORD BRS,BLR CLEAR THE LEAST AND SIGN BITS STB BLKLN SET THE BLOCK LENGTH STA BUFA SET THE BUFFER ADDRESS JMP PRAM,I RETURN TO CALLER SKP * NX$EC COMPUTES THE ADDRESS OF THE NEXT SECTOR * FOR ALL READ/WRITE ACCESSES AND FOR * SEQUENTIAL POSITIONING. * * CALLING SEQUENCE: * * LDB RELATIVE BLOCK NO. * JSB NX$EC * DISC ERR/EOF RETURN (ON EXTENDABLE FILES EODISC) * NORMAL RETURN * * NX$EC WRITES THE CURRENT SECTOR BUT DOES NOT * SET THE RELATIVE POSITION POINTERS * THE TARGET BLOCK IS READ. * IF RFLG$ IS NON 0. * * * NX$EC NOP STA SAV SAVE THE A REG LDA B CONVERT BLOCKS CLB,CLE TO MPY BLKLN SECTORS ASR 6 AND STA SECOF SAVE LDB DCB GO WRITE THE CURRENT JSB R/W$ BLOCK JMP NX$EC,I IF ERROR RETURN LDA TR,I COMPUTE THE CMA,INA RELATIVE SECTOR ADA CTRK,I ADDRESS MPY SEC/T,I IN THE FILE LDB SEC,I AND CMB,INB THEN ADB A ADD ADB CSEC,I THE ADB SECOF CHANGE ASR 16 EXTEND TO A DIV #SEC,I DIVIDE BY FILE SIZE SSB IF NEGATIVE ADA N1 REMAINDER SSB CORRECT ADB #SEC,I RESULT SZA IF DIFFERENT EXTENT JMP EXTND GO GET ITS ADDRESS NX$E1 ADB SEC,I COMPUTE THE NEW LSR 16 TRACK AND DIV SEC/T,I SECTOR ADA TR,I ADDRESSES STA CTRK,I AND SET THEM STB CSEC,I IN THE DCB LDA RFLG$ IF FLAG CLEARED CCE,SZA,RSS THEN DO NOT JMP NORD READ LDB DCB SET UP TO JSB R/W$ READ AND DO IT JMP NX$EC,I ERROR RETURN NORD ISZ NX$EC STEP AND LDA SAV RESTOR A JMP NX$EC,I RETURN SPC 5 EXTND STB TMP SAVE THE RELATIVE SECTOR ADA EXT#,I ADD CURRENT EXTENT NUMBER LDB TYPE,I GET THE TYPE SSA,RSS IF LESS THAN ZERO CPB .2 OR IFIF TYPE 2 THEN JMP SOF END OF FILE LDB DCB GO SET UP JSB RWND$ THE EXTENT JMP NX$EC,I ERROR RETURN LDB TMP GET THE SECTOR OFFSET JMP NX$E1 AND GO COMPUTE THE ADDRESS SOF LDA N12 ELSE EOF JMP NX$EC,I RETURN SPC 2 SECOF NOP * N1 OCT -1 .2 DEC 2 N12 DEC -12 SPC 2 A EQU 0 B EQU 1 SPC 1 END EQU * SPC 1 END ~0  92070-18072 1941 S C0122 &RWND$              H0101 zuASMB,R,L,C * NAME: RWND$ * SOURCE: 92070-18072 * RELOC: 92070-16072 * PGMR: G.A.A. * MOD: G.L.M * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * * NAM RWND$,7 92070-1X072 REV.1941 790709 * HED RWND$ ENT RWND$,RFLG$ EXT CLD.R,.P1,.P2,.P3,.P4,.R1,.R4,.R5 * * RWND$ IS A MODULE OF THE REAL TIME FILE * MANAGEMENT PACKAGE. IT IS INVOKED * TO SET OR RESET WORDS 11 THROUGH 16 * OF THE DCB. THE RECORD COUNT IS RESET IF EXTENT 0. * * CALLING SEQUENCE: * * LDA EXTENT# SET A TO DESIRED EXTENT * LDB DCB SET B TO DCB ADDRESS * JSB RWND$ CALL * JMP ERR ERROR EXIT (A=CODE) * --- NORMAL RETURN * SPC 3 TMP NOP TMP2 NOP RWND$ NOP ENTRY POINT STA .P4 SET THE EXTENT# LDA B,I FETCH TRACK AND LU STA .P2 SAVE IT INB ADVANCE TO OFSET/SECTOR LDA B,I FETCH IT STA .P3 SAVE FOR D.RTR ADB .2 STB TMP ADB .12 INDEX TO EXTENT# LDA .P4 FETCH REQUESTED EXTENT# CPA B,I IF SAME - CONTINUE JMP SETUP WITH SETUP LDA RFLG$ GET READ WRITE FLAG LDB .6 GET READ EXTENT OPEN REQUEST CODE SZA,RSS IF WRITE ADB .2 ADD TWO TO GET WRITE EXTENT OPEN REQUEST STB .P1 SET IT FOR CALL TO D.RTR JSB CLD.R * LDA .R1 YES; ANY ERRORS? SSA FROM D.RTR? JMP RWND$,I YES; RETURN SPC 1 LDA .R6  4 GET TRACK STA TMP,I SET IN DCB LDA .R5 GET AND AND B377 MASK LDB TMP GET DCB ADDRESS INB SET STA B,I SECTOR IN DCB SETUP LDB TMP SET THE DCB FROM THE ADB .7 TRACK & SECTOR WORDS LDA TMP,I SET JSB SET TRACK ISZ TMP AND LDA TMP,I SECTOR JSB SET WORDS. LDA B SET THE ADA .4 BUFFER JSB SET ADDRESS. CLA CLEAR THE READ/ JSB SET WRITE FLAGS LDA .P4 GET EXTENT# INB SKIP JSB SET SET THE EXTENT # ISZ RWND$ STEP JMP RWND$,I AND RETURN SPC 3 SET NOP STA B,I SET THE WORD IN THE DCB INB STEP DCB ADDRESS JMP SET,I RETURN SPC 3 .2 OCT 2 .4 OCT 4 .7 OCT 7 .6 DEC 6 .12 DEC 12 B377 OCT 377 RFLG$ NOP GLOBAL READ WRITE FLAG A EQU 0 B EQU 1 SPC 1 END EQU * SPC 1 END e>   92070-18074 1941 S C0122 &ST.TR              H0101 ASMB,R,L,C * NAME: SY.TR * SOURCE: 92070-18074 * RELOC: 92070-16074 * PGMR: M.L.K. * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * * NAM SY.TR,7 92070-1X074 REV.1941 790709 * * * THIS ROUTINE SEARCHES THE ID SEGMENTS FOR ANY CURRENTLY * USING THE DISC PASSED AS A PARAMETER. IT ALSO TESTS THE * LOCATION OF THE SYSTEM FILE AND THE SWAP AREA. IT RETURNS * A LIST OF ADDRESSES POINTING TO THE ID SEGMENT NAMES USING * THE DISC AND THE HIGHEST DISC ADDRESS IN USE. * SKP ENT SY.TR EXT .ENTR,CR.LU,$ID#,$IDA EXT $IDSZ,$SWLU SUP SPC 3 DISC NOP ARRAY NOP ASIZE NOP TRACK NOP SECTR NOP * SY.TR NOP JSB .ENTR SET UP PARAMETERS DEF DISC * CLA INITIALIZE STA CNT CLEAR CONFLICT COUNT CCA SET TRACK STA TRACK,I AND SECTOR STA SECTR,I TO -1 TO INDICATE NOT USED LDA ASIZE,I SET UP TO COUNT THE ENTRIES IN THE ARRAY CMA,INA SET IT NEGATIVE SSA,RSS IF IT WAS NEGATIVE OR 0 CCA SET IT TO 1 STA ASIZE NOW STORE IT * JSB CR.LU GO GET DISC LU DEF *+2 DEF DISC,I SZA,RSS IF NOTHING FOUND, JMP SY.TR,I EXIT * STA DISC SAVE DISC LU LDA $ID# GET NUMBER OF ID SEGMENTS CMA,INA SET NEGATIVE FOR LOOP COUNTER STA LPCNT AND SAVE LDB $IDA GET START OF ID SEGMENTS STB IDPTR AND SAVE * LOOP ADB .27 POINT TO LU IN ID SEGMENT LDA B,I NOW GET IT FAND B377 AND ISOLATE LU CPA DISC THE ONE WE ARE LOOKING FOR? RSS YES, SKIP JMP NEXT NO, GO TRY THE NEXT ONE * ADB N15 BACK UP TO NAME AND PUT ITS ADDRESS LDA B,I GET NAME SZA,RSS ZERO (NO PROGRAM)? JMP NEXT YES, SKIP THIS ID SEGMENT JSB STUFF IN THE ARRAY BECAUSE IT CONFLICTS SECT ADB .13 POINT TO ID WORD WITH SECTOR (26) LDA B,I GET SECTOR AND B377 AND ISOLATE IT ALS SHIFT FOR LOGICAL SECTORS INB POINT TO MAIN TRACK WORD (27) LDB B,I AND GET IT JSB HIEST UPDATE HIGHEST DISC ADDRESS * NEXT LDB IDPTR GET CURRENT ID POINTER ADB $IDSZ AND INCREMENT TO THE NEXT ID SEGMENT STB IDPTR SAVE FOR NEXT ROUND ISZ LPCNT ARE WE DONE? JMP LOOP NO, CHECK NEXT ID SEGMENT * * CHECK FOR SWAPPING AREA * LDA $SWLU GET THE SWAPPING DISC'S LU CPA DISC SAME AS OURS? CCB,RSS YES, SET B TO INDICATE SWAP AREA JMP TERM NO, GO TERMINATE JSB STUFF PUT SWAP INDICATOR IN THE ARRAY LDA SSEC,I GET SWAP SECTOR LDB STRAK,I GET SWAP TRACK JSB HIEST UPDATE HIGHEST DISC ADDRESS * * PUT TERMINATING 0 IN BUFFER * TERM CLB PUT TERMINATING 0 IN THE ARRAY JSB STUFF LDA CNT GET CONFLICT COUNT ADA N1 SUBTRACT 1 FOR TERMINATING ZERO JMP SY.TR,I AND EXIT SKP * * THIS ROUTINE RECIEVES TEST DISC ADDRESSES IN A AND B (A = SECTOR * AND B = TRACK) AND COMPARES THEM AGAINST TRACK,I AND SECTOR,I. * IT THEN STORES THE HIGHEST DISC ADDRESS IN TRACK,I AND SECTR,I. * HIEST NOP STA TMP SAVE SECTOR FOR LATER LDA TRACK,I GET CURRENT TRACK CMA,INA SET IT NEGATIVE ADA B ADD THE NEW TRACK VALUE SSA POSITIVE OR NEGATIVE? JMP HIEST,I NEGA;K TIVE, SO EXIT * SZA,RSS SAME TRACK? JMP SECTS YES, TEST SECTOR * STB TRACK,I NEW TRACK IS GREATER SO STORE IT LDB TMP AND STORE NEW SECTOR STB SECTR,I JMP HIEST,I EXIT * SECTS LDA TMP GET NEW SECTOR LDB SECTR,I GET CURRENT SECTOR CMB,INB MAKE IT NEGATIVE ADB A SUBTRACT CURRENT FROM NEW SECTOR SSB,RSS IS THE NEW SECTOR GREATER OR EQUAL? STA SECTR,I YES, SO STORE IT JMP HIEST,I EXIT * TMP NOP SKP * * THIS ROUTINE ADDS THE CONTENTS OF THE B REGISTER TO THE * USER'S ID ARRAY. * STUFF NOP ISZ CNT INCREMENT CONFLICT COUNT LDA ASIZE GET THE REMAINING ARRAY SIZE SZA,RSS IS IT FULL? JMP STUFF,I YES, EXIT INA NO, INCREMENT THE NEGATIVE COUNT STA ASIZE AND SAVE FOR NEXT TIME STB ARRAY,I STORE B INTO ARRAY ISZ ARRAY AND POINT TO NEXT ENTRY JMP STUFF,I RETURN SKP N15 DEC -15 N1 DEC -1 .13 DEC 13 .27 DEC 27 B377 OCT 377 STRAK DEF $SWLU+1 SSEC DEF $SWLU+2 * LPCNT NOP IDPTR NOP CNT NOP CONFLICT COUNT * A EQU 0 B EQU 1 END EQU * END \  92070-18075 1941 S C0122 &$DBLX              H0101 roASMB,R,L,C * NAME: $DBLX * SOURCE: 92070-18075 * RELOC: 92070-16075 * PGMR: M.L.K. * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * * NAM $DBLX,7 92070-1X075 REV.1941 790709 * * * THIS ROUTINE IS USED TO TEST THAT DOUBLE WORD INTEGERS ARE * WITHIN THE RANGE +/- 0-32767. * * CALLING SEQUENCE: * * DLD * JSB $DBLX * * ENT $DBLX SUP SPC 5 $DBLX NOP SZA,RSS ARE THE HI ORDER BITS 0? SSB AND THE LO ORDER BITS POSITIVE? JMP NEGCK NO, CHECK FOR NEGATIVE * VALOK ISZ $DBLX POINT TO NORMAL RETURN JMP $DBLX,I RETURN * NEGCK CPA N1 ARE HI ORDER BITS = -1 SSB,RSS AND LO ORDER BITS NEGATIVE? JMP ER NO, ERROR JMP VALOK YES, VALUE IS OK * ER LDA N4 RETURN OUT OF RANGE JMP $DBLX,I TO ERROR RETURN POINT * * N1 DEC -1 N4 DEC -4 END   92070-18076 1941 S C0122 &COMND              H0101 ASMB,R,L,C HED AUXILIARY COMMANDS FOR RTE-L MEMORY BASED SYSTEM * NAME: COMND * SOURCE: 92070-18076 * RELOC: 92070-16076 * PGMR: M.L.K. * **************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * **************************************************************** * NAM COMND,1,35 92070-16076 REV.1941 790713 SUP * * GLOBAL DATA * ENT .E.R,C.BUF,CAM.I,CAM.O,ECH,INT.,O.BUF ENT TMP. * * GLOBAL ENTRY POINTS * ENT MSS.,OPEN.,WRITF * * EXTERNAL ROUTINES * EXT .ENTR,EXEC,IFTTY,LOGLU,PARSE,RMPAR,REIO EXT PNAME,BL..,CN..,IO..,LA..,PL..,TM.. EXT TO..,IT..,ON..,SY.. SKP * * INITIALIZATION * COMND JSB RMPAR GET SCHEDULING STRING DEF *+2 DEF CAM.I STORE STARTING AT CAM.I * JSB LOGLU GET CONSOLE LU DEF *+2 DEF CAM.O (ACTUALLY A DUMMY PARAMETER) STA CAM.O SET UP LOG LU * LDA TMP. TEST THE RANGE (1-63) JSB PCHEK OF THE LIST LU LDA CAM.O ILLEGAL RETURN, USE CONSOLE LU STA TMP. STORE VALUE OF LIST * LDA CAM.I TEST THE RANGE (1-63) JSB PCHEK OF INPUT LU TRLOG LDA CAM.O ILLEGAL RETURN, USE CONSOLE LU STA CAM.I STORE VALUE OF INPUT JSB IFTTY IS INPUT INTERACTIVE? DEF *+2 DEF CAM.I STA INT. STORE IN INTERACTIVE FLAG LDB A SAVE FLAG IN B LDA CAM.I GET INPUT LU SZB IS IT INTERACTIVE? IOR B400 YES, SET ECHO FLAG STA CAM.I SAVE IN INPUT FLAG ADA B10K ADD IN DOUBLE BUFFER BIT STA CAMII AND SAVE FOR WRITE/READ CALL JSB PNAME CALL FOR THE PROGRAM'S NAME DEF *+2 DEF PRMPT FOR USE AS THE PROMPT LDA PRMP3 GET 3RD CHARACTER IOR B72 PUT COLON IN PLACE STA PRMP3 SAVE SKP * * COMMAND LOOP * * READ COMMANDS * CLOOP LDB INT. GET INTERACTIVE FLAG SZB,RSS IS INPUT INTERACTIVE? JMP REED NO, GO READ * JSB REIO YES, WRITE PROMPT AND READ INPUT DEF *+7 FROM INPUT DEVICE DEF .1 DEF CAMII DOUBLE BUFFER WRITE/READ DEF C.BUF INPUT BUFFER DEF .40 INPUT LENGTH DEF PRMPT OUTPUT BUFFER DEF .4 OUTPUT LENGTH JMP RDRTN GO PROCESS INPUT * REED JSB REIO READ FROM INPUT DEVICE DEF *+5 DEF .1 DEF CAM.I USE INPUT DEVICE DEF C.BUF TO COMMAND BUFFER DEF .40 UP TO 40 WORDS RDRTN STB ECH STORE TRANSMISSION LOG SZB,RSS NOTHING ENTERED JMP EX NOTHING, EXIT AND B200 CHECK FOR EOF SZA,RSS EOF? JMP PARS NO, GO PARSE THE COMMAND JMP TRLOG EOF, TRANSFER TO LOG DEVICE * * PARSE THE COMMAND * PARS LDA INT. GET INTERACTIVE FLAG SZA IS INPUT INTERACTIVE? JMP PAR1 YES, SO GO PARSE * LDA C.BUF NO, GET FIRST WORD OF INPUT BUFFER AND B377 AND REMOVE THE PRECEEDING COLON IOR B20K STA C.BUF AND PLACE BACK INTO THE BUFFER * PAR1 LDA ECH GET WORD COUNT ADA ECH DOUBLE IT STA CCNT AND SAVE CHARACTER COUNT JSB PARSE USE SYSTEM'S PARSER DEF *+4 DEF C.BUF INPUT BUFFER DEF CCNT CHARACTER COUNT DEF MRSLT PARSED PARAMETER BUFFER CCA SUBTRACT ONE FROM THE ADA P.CNT PARAMETER COUNT SINCE NOT PASSING STA P.CNT THE COMMAND AS A PARAMETER * * CHANGE PARAMETER TYPE 2 TO 3 LDA N8 SET LOOPB COUNTER STA CNT TO 8 LDA DMRLT GET PARSE RESULT BUFFER ADDRESS PARLP LDB A,I GET PARAMETER TYPE CPB .2 IS IT 2? INB YES, INCREMENT IT TO 3 STB A,I STORE BACK INTO BUFFER ADA .4 INCREMENT TO NEXT PARAMETER ISZ CNT INCREMENT THE COUNT JMP PARLP GO DO NEXT PARAMETER * LDB DMRLT GET ADDRESS OF THE FIRST PARAMETER INB POINT TO ACTUAL PARAMETER LDB B,I GET PARAMETER STB OPP STORE AS STOP WORD IN COMMAND TABLE * * GET COMMAND ADDRESS * LDA C.TAB GET COMMAND TABLE ADDRESS CMND? CPB A,I IF COMMAND SAME AS IN TABLE JMP CALL THEN GO SET UP COMMAND ADDRESS (CAD.) ADA .2 SKIP ADDRESS AND POINT TO NEXT COMMAND JMP CMND? CHECK NEXT ENTRY IN TABLE * CALL INA GET POINTER TO COMMAND ADDRESS LDA A,I THEN FETCH COMMAND ADDRESS STA CAD. AND STORE * * CALL ACTION ROUTINE * CLA CLEAR ERROR CODE STA ER TO PASS TO ACTION ROUTINE JSB CAD.,I CALL ACTION ROUTINE DEF CALR DEF P.CNT PARAMETER COUNT DEF P.RAM PARAMETER LIST DEF ER ERROR CODE * CALR LDA ER DID THE ROUTINE PASS BACK SZA AN ERROR? JMP ELOG GO REPORT ERROR LDA INT. GET INTERACTIVE FLAG SZA INPUT INTERACTIVE? JMP EX YES, GO TERMINATE JMP CLOOP NO, READ AGAIN SKP * * COMMAND TABLE * C.TAB DEF *+1 ASC 1,BL DEF BL.. ASC 1,CN DEF CN.. ASC 1,IO DEF IO.. ASC 1,LA DEF LA.. ASC 1,PL DEF PL.. ASC 1,TM DEF TM.. ASC 1,TO DEF TO.. ASC 1,IT DEF IT.. ASC 1,ON DEF ON.. ASC 1,EX DEF EX.. * OPP NOP END OF TABLE DEF SY.. * COMM NOP &x COMMENTS LDA COMM,I JMP A,I SKP * * ERROR SUBROUTINE * MSER NOP MSS. NOP JSB .ENTR SET UP PARAMETERS DEF MSER LDA MSER,I GET ERROR CODE * ELOG LDB BLNK SET DEFAULT TO POSITIVE SSA POSITIVE OR NEGATIVE? LDB BSIGN NEGATIVE, GET MINUS SIGN STB ESGN SAVE ASCII SIGN SSA NEGATIVE? CMA,INA YES SET POSITIVE CLB CLEAR B FOR DIVIDE DIV .10 DIVIDE BY 10. TWO DIGIT ERRORS ONLY ADB B60 MAKE REMAINDER ASCII ADA B60 MAKE QUOTIENT ASCII ALF,ALF POSITION QUOTIENT TO UPPER HALF IOR B PUT IN SECOND DIGIT STA ERCDE PUT INTO ERROR MESSAGE JSB EXEC WRITE IT OUT DEF *+5 DEF .2 WRITE DEF CAM.O LOG DEVICE DEF ERBUF ERROR MESSAGE DEF .4 LENGTH JMP TRLOG TRANSFER TO LOG DEVICE * ERBUF ASC 2,CMND ESGN NOP SIGN ERCDE NOP ERROR CODE IN ASCII * BLNK ASC 1, BSIGN ASC 1, - SKP * * DUMMY OPEN CALL * ODCB NOP OLU NOP * OPEN. NOP JSB .ENTR DEF ODCB * LDA OLU,I GET PASSED LU SZA,RSS IF ZERO, ITS LEGAL JMP OKOPN SO STORE AND EXIT JSB PCHEK IS IT LEGAL LU? JMP EROPN NO, REPORT ERROR OKOPN STA ODCB,I YES, PUT INTO DCB JMP OPEN.,I RETURN * EROPN LDA N18 ERROR CODE -18 JMP ELOG GO REPORT IT SPC 5 * * PCHEK - INPUT PARAMETER CHECK OF RANGE * PCHEK NOP LDB A SAVE A SSA IS IT GREATER THAN 0? JMP PEXIT NO, ERROR SZA,RSS IS LU ZERO? JMP PEXIT YES, ERROR ADB N64 IS IT GREATER THAN 64? SSB ISZ PCHEK NO IT IS OK SO RETURN P+2 PEXIT JMP PCHEK,I SKP * * DUMMY WRITF ROUTINE * WDCB NOP WERR NOP WBUF NOP WLEN NOP WRITF NOP JSB .ENTR DEF WDCB * JSB EXEC DO WRITE DEF *+5 DEF .2 DEF WDCB,I LU IS IN DCB DEF WBUF,I DEF WLEN,I * CLA SET NO ERROR STA WERR,I INTO USER'S ERROR CODE JMP WRITF,I RETURN SKP * * EXIT ACTION ROUTINE * EX.. NOP EX JSB EXEC TERMINATE SAVING RESOURCES DEF *+4 DEF .6 DEF .0 DEF .1 JMP COMND SKP * * CONSTANTS * .0 DEC 0 .1 DEC 1 .2 DEC 2 .4 DEC 4 .6 DEC 6 .10 DEC 10 .40 DEC 40 N8 DEC -8 N18 DEC -18 N64 DEC -64 B60 OCT 60 B72 OCT 72 B200 OCT 200 B377 OCT 377 B400 OCT 400 B10K OCT 10000 B20K OCT 20000 * DMRLT DEF MRSLT * A EQU 0 B EQU 1 SPC 5 * * VARIBLES * CAM.I NOP INPUT DCB (MUST BE FIRST) TMP. NOP LIST LU CAM.O NOP LOG LU INT. NOP INTERACTIVE FLAG .E.R NOP GLOBAL ERROR FLAG * C.BUF BSS 40 INPUT STRING CAD. NOP COMMAND ADDRESS FORM C.TAB MRSLT BSS 4 \ ORDERED COMMAND PARAMETER P.RAM BSS 28 > PARAMETER LIST P.CNT NOP / PARAMETER COUNT ECH NOP INPUT WORD COUNT O.BUF NOP OUTPUT DCB CNT NOP LOOP COUNTER CCNT NOP CHARACTER COUNT ER NOP ERROR CODE FOR ACTION ROUTINES CAMII NOP COMMAND INPUT FOR WRITE/READ REQUEST PRMPT BSS 2 PROMPT BUFFER PRMP3 BSS 1 5TH & 6TH CHARACTERS OCT 20137 * LEN EQU * END COMND   92070-18077 2026 S C0122 &RTLGN              H0101 ~ASMB,L,Z,C *RTLGN USE 'ASMB,Z ' ALWAYS !! * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * HED RTE-L GENERATOR NAM RTLGN,3,100 92070-16077 REV.2026 800410 LOD 2,SG,4 * * NAME: RTE L GENERATOR MAIN * SOURCE: 92070-18077 * PGMR: B.C. * ENT RTLGN * * EXT EXEC,LOGLU,NAMR,.ENTR EXT OPEN,CLOSE,READF,WRITF,PRTN EXT IFBRK,.X.,.Y. EXT TH2.L,CNUMD,L.REL * ENT DSTRG,IPBUF,STRNG,SLONG,DONE?,ISTRC,DIPBF ENT DFTLU,FATAL,OP?,MSIZE,IPTN2,ABOR ENT EXIT,BREAK,ASTRX,LENTF * ENT F1,FILE1,TYPE1,F1SC,F1DSC,IERR1 ENT F2,FILE2,TYPE2,F2SC,F2DSC,IERR2 ENT F3,FILE3,TYPE3,F3SC,F3DSC,IERR3,OPSNP ENT F4,FILE4,TYPE4,F4SC,F4DSC,IERR4 ENT CDCB1,ODCB2,SDCB3,LDCB4,ADCB3 ENT SEGNM,PPREL,COMFG,LNKDR,BGFLG,SIDCK ENT FWFM,LWFM,BPFWA,LODPT,COMAD,COMLG,LWAPG ENT TDBP,LDBP,CSDBP,CUDBP,CSRBP,CURBP ENT NUMID,ADDID,#ENPT,NLIB,CROM,AFWBG,ABGBP * ENT READ,FLERR,NAMRR,DRKEY,SPACE,FCLOS,MOVE ENT CLOS1,CLOS2,CLOS3,CLOS4 ENT DLOCC,LOCC,DBLOC,BPLOC ENT CNV99,L.OUT,LDIPX,SRIPX,STCR1,MAXAD ENT ERRCT,CONSL,AINT,IP3,WRDCT,EFBUF,PRERR * SUP PRESS EXTRANIOUS LISTING * SKP SKP DSTRG DEF STRNG ADCB3 DEF SDCB3 DIPBF DEF IPBUF STRNG BSS 40 IPBUF BSS 10 OUTPUT PARSED BUFFER * RTLGN JSB LOGLU GET THE CONSOLE LU DEF *+2 DEF ANLU# IOR M400 MERGE ECHO BIT STA DFTLU AND SAVE * * JSB EXEC GET THE RUN STRING DEF *+5 DEF P14 DEF P1 DEF STRNG THIS IS A GET NOT A PUT DEF N80 * STB SLONG SLONG = STRING LENGTH IN + CHAR * * * * JSB EXEC DEF *+3 DEF P8 DEF SEG1 LOAD SEGMENT 1 NOP * SKP * SLONG NOP STRING LENGTH IN CHARS DONE? NOP =1 WHEN INPUT PRAMS CHECKED OUT * F1 DEF FILE1 FILE1 ASC 3,COMMAD COMMAND FILE NAME TYPE1 NOP F1SC NOP F1DSC NOP * F2 DEF FILE2 OUTPUT FILE NAME FILE2 ASC 3,SYSTEM DEFAULT FILE = SYSTEM TYPE2 OCT 3 F2SC NOP F2DSC NOP * F3 DEF FILE3 SNAP FILE NAME FILE3 ASC 3,SNAP DEFAULT FILE = SNAP TYPE3 OCT 3 F3SC NOP F3DSC NOP * F4 DEF FILE4 LIST FILE NAME FILE4 ASC 3,SYLIST DEFAULT FILE = SYLIST TYPE4 OCT 3 F4SC NOP F4DSC NOP * * GENERATOR BUFFER AREA * CDCB1 BSS 144 COMMAND DCB ODCB2 BSS 144 OUTPUT DCB SUP SDCB3 REP 144 SNAP DCB NOP LDCB4 BSS 144 LIST DCB * SEG1 ASC 3,RTLG1 * SKP SPC 1 * * EXIT LDA SEGNM CPA P128 NORMAL TERMINATION? RSS YES JMP ABOR NO , ABNORMAL TERMINATION EXIT2 JSB SPACE JSB CNUMD DEF *+3 DEF ERRCT+0 DEF ERRMS+1 LDA P18 STA CONSL LDB DERRM JSB DRKEY * JSB WRITF DEF *+6 DEF ODCB2 WRITE OUT CURRENT RECORD DEF IERR2 OF OUTPUT FILE DEF OTBUF DEF P128 DEF RECN * JSB FCLOS * LDA N4 ZERO OUT NEXT 4 WDS AFTER STA WRDCT ERRCT FOR PRTN CLA LDB DERRC ADDRESS OF ERRCT LP INB STA B,I ISZ WRDCT ANY MORE? JMP LP YES * JSB PRTN NO DEF *+2 DERRC DEF ERRCT+0 * JSB EXEC DEF *+2 DEF P6 * * DERRM DEF ERRMS ERRMS ASC 9,* ERRORS * SKP SKP SKP * * SET UP CALL FOR OUTPUT * * CALL SEQUENCE * * LDA DATA * LDB ADDRESS * JSB STCR1 * STCR1 NOP STB ADRR THIS IS THE ADDRESS STA VALU THIS IS THE VALUE OF THE ABOVE ADDRESS JSB L.OUT DEF *+3 DEF ADRR DEF VALU JMP STCR1,I RETURN * ADRR NOP VALU NOP * * * * PRINT ****** * ASTRX NOP LDA P6 LDB DASTX JSB DRKEY JMP ASTRX,I * * DASTX DEF *+1 ASC 3,****** * SKP *THE FCLOSE ROUTINE CLOSES ALL FILES OPEN TO THE *GENERATOR * FCLOS NOP JSB CLOS1 JSB CLOS3 JSB CLOS2 JSB CLOS4 JMP FCLOS,I * CLOS1 NOP JSB CLOSE CLOSE THE FILE DEF *+2 DEF CDCB1 JMP CLOS1,I * CLOS2 NOP JSB CLOSE YES DEF *+2 DEF ODCB2 JMP CLOS2,I * CLOS3 NOP JSB CLOSE YES DEF *+2 DEF SDCB3 JMP CLOS3,I * CLOS4 NOP LDA TYPE4 ERA,SLA RSS JMP CLOS4,I JSB CLOSE DEF *+2 DEF LDCB4 * CLA,INA SET UP THE STA TYPE4 NUMERIC FIELD IN THE TYPE WORD JMP CLOS4,I RETURN * * OPEN THE SNAP FILE * OPSNP NOP JSB OPEN DEF *+7 DEF SDCB3 DEF IERR3 DEF FILE3 DEF IPTN2 DEF F3SC DEF F3DSC JMP OPSNP,I * SKP * * READ THE COMMAND FILE * * JSB READ * EOR RETURN * NO ERROR RETURN * * SPC 1 * READ NOP FREAD JSB READF READ THE COMMAND FILE DEF *+6 DEF CDCB1 DEF IERR1 DEF STRNG DEF P40 DEF CLEN * LDA IERR1 SSA,RSS ANY ERRORS ? JMP FLCHK NO LDB F1 JSB FLERR YES FLCHK LDB CLEN GET LENGTH OF COMMAND JUST READ SZB,RSS WAS IT ZERO ? JMP FREAD YES, SO DO IT AGAIN SSB WAS IT NEGATIVE (IE END OF FILE) JMP READ,I YES, SO FINISH PROCESSING * CLE,ELB CONVERT TO CHAR COUNT (MULT BY 2) STB SLONG SAVE READ LENGTH FOR PARSING ROUTINE CLA,INA SET UP PARSING OFFSET TO STAT PARSING STA ISTRC AT THE FIRST CHARACTER JSB NAMRR PARSE THE OP CODE LDB IPBUF+1 GET 3RD & 4TH CHAR STB OP1? LDA IPBUF AND SAVE THE OPCODE STA OP? * JSB IECHO ECHO INPUT LDA OP? GET OPCODE AND HIMSK CPA ASTRK IS IT A COMMENT ? JMP FREAD YES , READ ANOTHER RECORD * JSB BREAK CHECK BREAK FLAG CLA STA PRERR CLEAR PRINT ERROR FLAG ISZ READ JMP READ,I * * * SKP * * PRINT MESSAGE ON LIST DEVICE * * THE DRKEY SUBROUTINE PRINTS A MESSAGE ON THE LIST OUTPUT DEVICE. * * CALLING SEQUENCE: * A = NO. CHARACTERS (POS.) TO BE PRINTED. * B = ADDRESS OF MESSAGE * JSB DRKEY * * RETURN: CONTENTS OF A AND B ARE DESTROYED * DRKEY NOP STA CHAR# SAVE THE # OF CHARACTERS * ADB N1 BACK THE ADDRESS UP BY ONE STB MADDR AND SAVE FOR LU WRITE STB MADDF OR FILE WRITE LDA B,I GET THE WORD PRIOR TO THE BUFFER STA LTEMP AND SAVE IT LDA BLNK2 GET A BLANK STA B,I AND PUT IT IN THE BUFFER * LDB CHAR# GET THE # OF CHARACTERS ADB P3 ALLIGN TO A WORD & ACCOUNT FOR THE BLANK CLE,ERB DIV BY 2 . NOW HAVE WORD COUNT STB COUNT SAVE FOR LU OR FILE WRITE * LDB CHAR# GET THE # OF CHARS SLB,INB,RSS ODD # ? JMP GOWRT NO, SO WRITE THE BUFFER OUT CLE,ERB INDEX ADB MADDR THE THE LAST WORD LDA B,I GET IT & PUT A BLANK AND HIMSK IN THE LOW END ADA P32 STA B,I * GOWRT LDA CONSL ECHO TO THE CONSOLE? SZA,RSS YES JMP WFILE NO , WRITE TO THE FILE * JSB EXEC REQUEST WRITE 3 DEF *+5 DEF P2 WRITE REQUEST CODE DEF DFTLU ADDR OF CONSOLE UNIT NO. MADDR DEF 0 BUFFER LOCATION DEF COUNT CURRENT WORD COUNT CLA STA CONSL * WFILE JSB WRITF DO THE FILE WRITE DEF *+5 DEF LDCB4+0 DEF IERR4+0 MADDF NOP BUFFER ADDRESS DEF COUNT BUFFER LENGTH * LDB LTEMP GET THE ALTERED WORD STB MADDR,I AND RESTORE IT SSA,RSS ANY FILE ERRORS JMP DRKEY,I NO, SO RETURN * LDA N6 LIST FILE ERROR JSB MOVE MOVE LIST FILE NAME DEF FILE4+0 SOURCE DEF EFBUF+10 DESTINATION LDA IERR4 CMA,INA JSB CNV99 STA EFBUF+4 * JSB EXEC DISPLAY ON CONSOLE FMP ERROR DEF *+5 OF DEF P2 LIST DEF DFTLU+0 FILE DEF EFBUF DEF P13 * JSB EXEC DEF *+2 DEF P6 SKP * * NEW LINE ON LIST OUTPUT DEVICE * * THE SPACE SUBROUTINE IS CALLED TO PAGE UP THE PRINTER. * * CALLING SEQUENCE: * A = IGNORED * B = IGNORED * JSB SPACE * * RETURN: CONTENTS OF A AND B ARE DESTROYED. * SPACE NOP CLA SET COUNT = 0. LDB ALBUF B = DUMMY ADDR. JSB DRKEY NEW LINE JMP SPACE,I RETURN * ALBUF DEF IPBUF * * * THE BREAK ROUTINE CATCHES ANY PROGRAM BREAKS AND DOES * A CLEAN TERMINATION. * BREAK NOP JSB IFBRK DEF *+1 SSA ANY BREAK INPUT ? JMP EXIT YES , SO EXIT THYSELF JMP BREAK,I NO SO JUST RETURN * * ABORT ROUTINE * ABOR LDA P6 LDB MESFL JSB DRKEY JSB ASTRX PRINT ****** JMP EXIT2 * MESFL DEF *+1 ASC 3,GEN AB * SKP * * THE IECHO ROUTINE ECHOS COMMAND FILE COMMANDS AND ECHOS * ANY BAD COMMANDS ENCOUNTERED IN THE COMMAND FILE * IT ASSUMES THE WORD COUNT IN ' CLEN( ' AND THE BUFFER * TO BE OUTPUT IN ' DSTRG '. * IECHO NOP LDA CLEN RAL WORD COUNT IS NOW CHAR COUNT LDB DSTRG GET THE BUFFER ADDRESS JSB DRKEY OUTPUT IT JMP IECHO,I RETURN TO CALLER * SKP * * *THE FLERR ROUTINE HANDLES ALL FILE ERRORS. CALLING SEQUENCE: * * LDA WITH ERROR CODE (NEGATIVE) * LDB WITH ADDRESS OF FILE * JSB FLERR * * *THIS ROUTINE WILL CLOSE ALL FILES FLERR NOP STA ERRSV SAVE ERROR CODE STB EFILE SAVE NAME OF FILE CMA,INA MAKE ERROR POSITIVE JSB CNV99 CONVERT TO ASCII STA EFBUF+4 PUT INTO ERROR MESSAGE LDA EFILE,I GET THE FILE NAME STA EFBUF+10 AND ISZ EFILE PUT LDA EFILE,I IT STA EFBUF+11 INTO ISZ EFILE THE LDA EFILE,I ERROR STA EFBUF+12 MESSAGE . * * LDA P26 GET THE CHAR COUNT STA CONSL ECHO TO THE CONSL LDB DEBUF AND THE ADDRESS JSB DRKEY NOW PRINT THE ERROR MESSAGE ISZ ERRCT BUMP UP THE ERROR COUNTER JSB ASTRX PRINT ****** * LDA ERRSV GET ERROR CODE CPA N6 FILE NOT FOUND? JMP FLERR,I YES , OK TO CONTINUE CPA N7 FILE SEC. CODE ERROR? JMP FLERR,I YES , OK TO CONTINUE CPA N32 CRN NOT FOUND? JMP FLERR,I OK , GO GET NEXT COMMAND * JMP ABOR ANY OTHER DISC ERROR ABORT * EFILE NOP DEBUF DEF EFBUF EFBUF ASC 13, FMGR -6 ON FILE COMAND ERRSV NOP SKP * * * THE NAMRR SUBROUTINE USES THE RELOCATABLE LIBRARY * PARSING ROUTINE NAMR. THE INPUT TO NAMR IS A STRING * OF ASCII CHARACTERS. * THE OUTPUT IS A 10 WORD BUFFER PARSED AS : * PRAM1,PRAM2,PRAM3,TYPE,S1,S2,S3,S4,S5,S6 * PARAMETERS BETWEEN COMMAS ARE PARSED. SUBPARAMETERS ARE * DELINEATED BY COLONS. THE TYPE WORD DESCRIBES ALL * PARAMEcTERS AS ASCII, NUMERIC, OR NULL. * THE TYPE WORD IS BROKEN UP INTO 2 BIT FIELDS TO DESCRIBE * THE INPUT. *15,14 13,12 11,10 9,8 7,6 5,4 3,2 1,0 *----------------------------------------------- * S6 ! S5 ! S4 ! S3 ! S2 ! S1 ! PRAM ! *----------------------------------------------- * * PRAM = 0 ...NULL PRAM1 = PRAM2 = PRAM3 = 0 * PRAM = 1....NUMERIC (ONLY PRAM1 USED) PRAM1 = # * PRAM = 2 ...NOT USED * PRAM = 3 ... ASCII (USES PRAM1,PRAM2,PRAM3 ) * * S1 - S6 ARE DEFINED THE SAME EXCEPT THEY ARE ONE WORD ONLY * NAMRR NOP JSB NAMR THIS IS THE RELO LIBR PARSING ROUTINE DEF *+5 RETURN ADDR DEF IPBUF ADDRESS OF 10 WORD PARSED BUFFER DEF STRNG ADDRESS OF BUFFER TO BE PARSED DEF SLONG CHARACTER LENGTH DEF ISTRC CHAR OFFSET IN STRNG FOR NEXT PRAM JMP NAMRR,I RETURN TO CALLER * * SKP SKP MOVE NOP WORD MOVE SUBROUTINE STA CNT1 SAVE WORD COUNT LDA MOVE,I GET SOURCE STA PTN1 SET IN POINTER 1 ISZ MOVE STEP TO DEST. ADDR LDA MOVE,I GET DEST. ISZ MOVE STEP TO RETURN ADDR MOV1 LDB PTN1,I GET A WORD STB A,I PUT IT AWAY ISZ PTN1 STEP SOURCE INA AND DEST. ADDRES ISZ CNT1 DONE? JMP MOV1 NO - CONTINUE JMP MOVE,I YES - EXIT * * * CONVERT TO DECIMAL ASCII (MAX VALUE = 99) * CALL SEQUENCE: LDA VALUE * JSB CNV99 * STA ASCII * CNV99 NOP QUICK CONVERSION CLB BINARY TO DECIMAL ASCII DIV P10 MAX VALUE = 99 SZA ADA M20 FORCE LEADING BLANK IF ZERO ADA M40 ALF,ALF PUT IN LEFT HALF IOR B IOR M60 JMP CNV99,I RETURN ASCII IN (A) SKP * * ROUTINE TO OUTPUT A WORD THAT HAS BEEN RELOCATED * * * JSB L.OUT * DEF *+3 * DEF ADDRESS ADDRrQESS OF ADDRESS * DEF VALUE ADDRESS OF VALUE * * DADD NOP DVAL NOP L.OUT NOP JSB .ENTR DEF DADD LDA DADD,I GET ADDRESS STA QTEMP CMA,INA NEGATE ADDRESS ADA CROM ADD TOP OF MEMORY SSA OUTPUT FILE OVERFLOW? JMP FILOV YES , GIVE ERROR ADA B1200 SUBTRACT 1200B SSA BOOTX OVERLAY? JSB BOOTX YES , GIVE ERROR MESSAGE LDA DVAL,I NO STA PTEMP * CLB CALCULATE RECORD # & WORD POSITION LDA QTEMP GET ADDRESS ADA P128 REC # = (ADDRESS+128)/128 DIV P128 QUOTIENT IN A = RECORD # STA RECN THIS THE RECORD # INB REMAINDER IN B + 1 = WORD POSITION STB WORDN THIS THE WORD POSITION IN THE RECORD * CPA RECNO NEW REC # EQUAL TO PREVIOUS REC #? JMP L.O10 YES , JUST DATE THE RECORD * JSB WRITF NO , WRITE OUT CURRENT REC DEF *+6 DEF ODCB2 DEF IERR2 DEF OTBUF DEF P128 DEF RECNO * SSA,RSS ANY ERROR? JMP L.003 NO , CONTINUE LDB F2 ADDRESS OF SYSTEM OUTPUT FILE NAME JSB FLERR * L.003 JSB READF READ THE NEW RECORD IN DEF *+7 DEF ODCB2 DEF IERR2 DEF OTBUF DEF P128 DEF RTEMP DEF RECN SSA,RSS ANY ERROR? JMP L.006 NO , CONTINUE LDB F2 ADDRESS OF SYSTEM OUTPUT FILE NAME JSB FLERR * L.006 LDA RECN STA RECNO SAVE IT AS THE CURRENT RECORD # * L.O10 LDA WORDN UPDATE THE RECORD ADA N1 WITH THE NEW WORD ADA AOTBF LDB PTEMP GET THE VALUE OF THE WORD STB A,I AND PLACE IT IN THE RECORD * * LDA QTEMP GET ADDRESS AGAIN ADA B2000 ADA -2000B SSA 2000B OR GREATER ? IE NOT ON BASE PAGE RSS NO , UPDATE BP JMP L.20 YES  INA ADA TDBP ADD TOP OF DUMMY BP LDB PTEMP GET VALUE STB A,I STORE VALUE IN DUMMY BP * L.20 LDA MAXAD GET CURRENT MAX ADDRESS CMA,INA ADA QTEMP ADD CURRENT ADDRESS SSA MAX ADDRESS BIGGER ? JMP L.OT YES LDA QTEMP NO , REPLACE CURRENT MAX ADDRESS STA MAXAD L.OT LDA TH2.L CURRENT HIGH ADDRESS + 1 OF THIS LOAD CMA,INA NEGATE ADA QTEMP ADD CURRENT OUTPUT ADDRESS SSA EQUAL OR GREATER? JMP L.OUT,I NO , RETURN LDA QTEMP YES , INA OUTPUT ADDRESS IS EQUAL OR LARGER STA TH2.L REPLACE IN TH2.L JMP L.OUT,I * FILOV LDA P6 LDB MESOV JSB DRKEY PRINT OUTPUT FILE OVERFLOW JSB ASTRX PRINT ****** ISZ ERRCT JMP EXIT * MESOV DEF *+1 ASC 3,OV MEM SYSTEM OUTPUT FILE OVERFLOWED * BOOTX NOP LDA PRERR SZA ERROR PRINTED PREVIOUSLY? JMP BOOTX,I YES , RETURN LDA P6 NO LDB MESBX JSB DRKEY PRINT BOOTX OVERLAYED ISZ ERRCT JSB ASTRX PRINT ****** CCA STA PRERR SET ERROR PRINTED FLAG JMP BOOTX,I * MESBX DEF *+1 ASC 3,OV BTX OVERFLOWED INTO BOOTX * RECN NOP WORDN NOP RECNO DEC 255 * * AOTBF DEF OTBUF OTBUF BSS 128 SKP * THE 3 WORD PROGRAM NAME IS PUT INTO THE RTLGN PROG * TABLE. THE NAMES ARE LOADED FROM THE TOP DOWN. * * CALLING SEQUENCE: * A = ADDRESS OF PROGRAM NAME * B = IGNORED * JSB LDIPX * RETURN: * (N+1) = ERROR * (N+2) = OK * * RETURN: A AND B ARE DESTROYED * LDIPX NOP STA IPXSV SAVE PROG NAME ADDRESS JSB INIPX INITIALIZE TO START OF TABLE LDA PROCT NUMBER OF ENTRIES CPA P10 EXCEED MAX? JMP LDIPX,I YES , ERROR RETURN ALS MULT X2 ADA PROCT PLU3S ONE TO MAKE IT X3 CMA,INA ADA BIDNT BUILD NEXT NAME ADDRESS STA BIDNT FOR SAVE JSB IPX INITIALIZE IP POINTERS LDA IPXSV,I GET N1-N2 STA IP1,I PUT IN TABLE ISZ IPXSV BUMP POINTER LDA IPXSV,I GET N3-N4 STA IP2,I SAVE ISZ IPXSV LDA IPXSV,I GET N5-XX STA IP3,I SAVE ISZ PROCT BUMP NUMBER OF NAMES ISZ LDIPX OK RETURN JMP LDIPX,I RETURN * * IPXSV NOP PROGRAM NAME ADDRESS * SKP * * INIPX SETS THE ADDRESS OF THE FIRST ENTRY IN THE * PROGRAM IDENT TABLE AS THE CURRENT ADDRESS. * * * CALLING SEQUENCE: * A = IGNORED * B = IGNORED * * RETURN: A AND B DESTROYED * INIPX NOP LDA APROG ADA N2 STA BIDNT JMP INIPX,I * * * * THE IPX ROUTINE ADDRESSES THE CURRENT 3 WORD ENTRY * IN THE INTERRUPT PROGRAM TABLE FROM THE ADDRESS OF * THE CURRENT ENTRY (BIDNT). THE TABLE START ADDRESS * IS LWAM. * * CALLING SEQUENCE: * A = IGNORED * B = IGNORED * JSB IPX * * RETURN, CONTENTS OF A AND B ARE DESTROYED * IPX NOP LDA BIDNT BUILD POINTERS STA IP1 INA STA IP2 INA STA IP3 ADA N5 STA BIDNT JMP IPX,I * BIDNT NOP ADDRESS OF FIRST IDENT IP1 NOP IP2 NOP IP3 NOP SKP * * SEARCH RTLGN PROG TABLE * * THIS IS A MULTIPLE ENTRY ROUTINE WHICH WILL EITHER * SEARCH FOR A NAME OR CONTINUE FROM THE LAST FIND. * * CALLING SEQUENCE: * A = ADDRESS OF NAME (3WORD) * B = IGNORED * JSB SRIPX * * RETURN: * (N+1) PROGRAM NAME WAS FOUND IN TABLE, IN IP1-3 * (N+2) REACHED THE END OF THE PROGRAM TABLE * SRIPX NOP LDB WRDCT SEARCH OR CONTINUE? SZB JMP SRIP1 CONTINUE STA SRISV INIT SEARCH JSB INIPX SET UP IP POINTERS LDA PROCT NUMBER OF ENTRIES CMA STcA WRDCT SAVE FOR LOOPING SRIP1 ISZ WRDCT ALL DONE? JMP *+3 NO, GO COMPARE NAMES ISZ SRIPX YES, BUMP RETURN JMP SRIPX,I JSB IPX SET POINTERS LDB IP1 NAME IN TABLE LDA SRISV LOOK FOR NAME JSB NACMP GO COMPARE JMP SRIP1 DOSN'T COMPARE, LOOK NEXT JMP SRIPX,I DOES COMPARE, RETURN * SRISV NOP * SKP * * ROUTINE TO COMPARE TWO NAME BUFFERS * * * CALLING SEQUENCE: * A = ADDRESS OF SOURCE NAME- 3 ENTRIES * B = ADDRESS OF TABLE 3 ENTRIES * JSB NACMP * * RETURN: A AND B ARE DESTROYED * (N+1) NAMES DO NOT COMPARE * (N+2) NAMES COMPARE * NACMP NOP STA TEMP1 SAVE SOURCE ADDRESS STB TEMP2 SAVE TABLE ADDRESS LDA N2 LOOP COUNT STA TEMP3 NACM1 LDA TEMP1,I SOURCE ENTRY CPA TEMP2,I TABLE COMPARE RSS YES,COMPARE, LOOK NEXT JMP NACMP,I NO IT DOESN'T RETURN ISZ TEMP1 BUMP SOURCE ISZ TEMP2 BUMP TABLE ISZ TEMP3 JMP NACM1 TRY AGAIN LDA TEMP2,I FIRST TWO COMPARE, LOOK LAST AND M400 LOOK UPPER ONLY STA B LDA TEMP1,I AND M400 CPA B ISZ NACMP BUMP RETURN FOR COMPARE! JMP NACMP,I * TEMP1 NOP TEMP2 NOP TEMP3 NOP * * BSS 29 PROGN NOP APROG DEF PROGN * SKP * * VARIABLES * #ENPT NOP ABGBP NOP ADDID NOP ADDRESS OF ID SEGMENT AFWBG NOP AINT NOP ADDRESS OF INT TABLE ANLU# NOP BGFLG NOP BPFWA OCT 100 1ST WORD OF BASE PAGE BPLOC NOP CHAR# NOP INPUT # OF CHARACTER CLEN NOP RECORD READ LENGTH CNT1 NOP COMAD NOP ADDRESS OF SYS COMMON OR 0 IF LOCAL COMFG NOP UNLABEL COMMON IN FLAG COMLG NOP LENGTH OF SYSTEM COMMON OR 0 CONSL NOP ECHO TO CONSOLE 1=YES 0=NO COUNT DEC 13 CURRENT MESSAGE LENGTH CROM OCT 37770 CONTENTS OF $ROM CSDBP NOP CURRENT SYS DUM BP CSRBP NOP CURRENT SYS REAL BP CUDBP NOP CURRENT USER DUM BP CURBP NOP CURRENT USER REAL BP DBLOC DEF BPLOC DLOCC DEF LOCC ERRCT NOP ERROR COUNTER FATAL NOP 0/1 NO FATAL ERROR / FATAL ERROR FWFM NOP 1ST WORD OF FREE MEMORY IERR1 NOP IERR2 NOP IERR3 NOP IERR4 NOP IPTN2 NOP OPEN OPTION LDBP NOP LOWER BOUND OF DUMMY BASE PAGE LENTF OCT 1 NO ENT PT / LIST ENT PT (DEFAULT) LNKDR NOP BP LINK DIRECTION -1 = SYS LINK , 1 = USER LINK LOCC NOP LODPT NOP LOAD POINT LTEMP NOP LWAPG NOP LAST WORD OF ADDRESS SPACE LWFM NOP LAST WORD OF FREE MEMORY MAXAD NOP CURRENT MAX ADDRESS MSIZE NOP MEMORY SIZE NLIB NOP # OF LIBRARY FILES NUMID NOP # OF ID SEGMENTS OP? NOP OP1? NOP PPREL NOP PRERR NOP 0/-1 PRINT ERROR/ERROR PRINTED PREVIOUSLY PROCT NOP PTEMP NOP PTN1 NOP QTEMP NOP RTEMP NOP SEGNM NOP SIDCK NOP SYSTEM ID CHECK TDBP NOP TOP OF DUMMY BASE PAGE WRDCT NOP SKP * * PRE-SET VARIABLES * DFTLU DEC 1 DEFAULT LU ISTRC DEC 1 POINTER TO CURRENT CHAR TO BE PARSE * * CONTANTS * P1 DEC 1 P2 DEC 2 P3 DEC 3 P6 DEC 6 P8 DEC 8 P10 DEC 10 P13 DEC 13 P14 DEC 14 P18 DEC 18 P26 DEC 26 P32 DEC 32 P40 DEC 40 P128 DEC 128 * N1 DEC -1 N2 DEC -2 N4 DEC -4 N5 DEC -5 N6 DEC -6 N7 DEC -7 N32 DEC -32 N80 DEC -80 * M20 OCT 20 M40 OCT 40 M60 OCT 60 M400 OCT 400 * B1200 OCT -1200 B2000 OCT -2000 * ASTRK OCT 25000 THIS IS A * HIMSK OCT 177400 * BLNK2 ASC 1, DOUBLE BLANK * * BASE PAGE COMMUNICATION VALUES * A EQU 0 B EQU 1 * * SPC 3 END RTLGN NLHHN  92070-18078 1941 S C0122 &RTLG1              H0101 ASMB,L,Z,C *RTLGN USE 'ASMB,Z ' ALWAYS !! * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * HED RTE L GENERATOR SEGMENT 1 NAM RTLG1,5 92070-1X078 REV.1941 790906 * * * NAME: RTE L GENERATOR SEGMENT 1 * SOURCE: 92070-18078 * PGMR: B.C. * ENT RTLG1 * * EXT EXEC,LOGLU,NAMR,.ENTR EXT OPEN,CLOSE,READF,WRITF,CREAT,RWNDF * EXT DSTRG,IPBUF,STRNG,SLONG,DONE?,ISTRC,DIPBF EXT DFTLU,FATAL,OP?,MSIZE,IPTN2,ABOR EXT CPL.L,EXIT,LIMEM * EXT FWFM,LWFM,BPFWA,LODPT,COMAD,COMLG,LWAPG EXT TDBP,LDBP,CSDBP,CUDBP * EXT READ,FLERR,NAMRR,DRKEY,SPACE,FCLOS,MOVE EXT CROM,ERRCT,ASTRX * EXT F1,FILE1,TYPE1,F1SC,F1DSC,IERR1 EXT F2,FILE2,TYPE2,F2SC,F2DSC,IERR2 EXT F3,FILE3,TYPE3,F3SC,F3DSC,IERR3 EXT F4,FILE4,TYPE4,F4SC,F4DSC,IERR4 EXT CDCB1,ODCB2,SDCB3,LDCB4 EXT EFBUF,CONSL,FTIME EXT CLOS2,CLOS3,CLOS4,OPSNP,CNV99 * SUP PRESS EXTRANIOUS LISTING * SKP SKP * * PARSE THE RU STRING * RTLG1 JSB NAMRR PARSE TWICE TO GET RID OF THE RU AND JSB NAMRR THE RTLGN. WE NOW HAVE PARAMETERS. * * JSB NAMRR NOW GET THE COMMAND FILE NAME SSA,RSS END OF STRING ? JMP GTCMD NO * NOCMD JSB EXEC NO DEF *+5 DEF P2 COMMAND DEF DFTLU+0 DEF EFBUF+0 FILE DEF COUNT * EXIT3 JSB EXEC EXIT DEF *+2 DEF P6 * * GTCMD LDA N6 GET THE NEG COUNT AGAIN JSB MOVE AND MOVE THE NAME TO THE CMND NAME BUFFER .8 DEF IPBUF+0 SOURCE OF MOVE DEF FILE1+0 COMMAND FILE NAME ADDRESS LDA TYPE1 GET THE PARSE TYPE WORD AND P3 KEEP ONLY THE LEAST TWO BITS STA TYPE1 AND SAVE FOR LATER CPA P3 COMMAND IS A FILE? RSS YES JMP NOCMD NO , EXIT NO COMMAND FILE * * OUTPUT FILE NAMR * JSB NAMRR NOW GET THE OUTPUT FILE NAME SSA END OF STRING JMP GTSNP YES LDA IPBUF+3 NULL INPUT? SZA,RSS NO JMP GTSNP YES , USE DEFAULT LDA N6 GET THE NEG COUNT FOR MOVE WORDS JSB MOVE TO THE OUTPUT FILE BUFFER DEF IPBUF+0 SOURCE OF MOVE DEF FILE2+0 OUTPUT FILE NAME ADDRESS LDA TYPE2 GET THE PARSE TYPE WORD AND P3 KEEP ONLY THE LEAST TWO BIT STA TYPE2 AND SAVE IT FOR LATER * * SNAP FILE NAMR * GTSNP JSB NAMRR GET THE SNAP FILE NAME SSA END OF STRING ? JMP GLST1 YES, GET LIST OR DEFAULT LDA IPBUF+3 NULL INPUT? SZA,RSS NO JMP GLST1 YES , USE DEFAULT LDA N6 GET THE NEG COUNT AGAIN JSB MOVE AND MOVE THE NAME TO THE SNAP FILE BUFER DEF IPBUF+0 SOURCE OF MOVE DEF FILE3+0 SNAP FILE NAME ADDRESS LDA TYPE3 GET THE PARSE TYPE WORD AND P3 KEEP ONLY THE LEAST TWO BIT STA TYPE3 AND SAVE FOR LATER * * LIST FILE NAMR * GLST1 JSB NAMRR GET THE LIST FILE SSA JMP OPNF4 END OF STRING , USE DEFAULT LDA N6 GET THE NEG COUNT AGAIN JSB MOVE AND MOVE THE NAME TO THE LIST BUFFER DEF IPBUF+0 SOURCE OF MOVE DEF FILE4+0 LIST FILE NAME ADDRESS LDA TYPE4 GET THE PARSE TYPE WORD AND P3 KEEP ONLY THE LEAST TWO BITS STA TYPE4 AND SAVE FOR LATER ERA,SLA IS IT A FILE OR AN LU ? JMP OPNF4 FILE, LET'S START * LIERR JSB EXEC yNO , ILLEGAL NAME DEF *+5 DEF P2 DEF DFTLU+0 DEF LSTER DEF P13 JMP EXIT3 * * PROCESS AND OPEN LIST FILE * OPNF4 LDA FILE4 AND HIMSK KEEP ONLY UPPER BYTE CPA ACENT IS IT A ' JMP OPEN4 YES , GO OPEN THE FILE * CRAT4 JSB CREAT NO , SO CRATE THE FILE DEF *+8 DEF LDCB4+0 DEF IERR4+0 DEF FILE4+0 DEF P150 DEF P3 DEF F4SC+0 DEF F4DSC+0 SSA,RSS ANY ERROR? JMP OPEN4 NO DO AN EXPLICT OPEN F4ERR SSA,RSS ANY ERROR ? JMP F4TST NO , F4ER2 JSB CLOS4 YES , SO CLOSE THE OUTPUT FILE LDA N6 MOVE FILE NAME JSB MOVE DEF FILE4+0 SOURCE DEF LSTNM DESTINATION LDA IERR4 ERROR CODE IN A CMA,INA MAKE POSITIVE JSB CNV99 STA LSTER+4 JMP LIERR * * OPEN4 JSB OPEN OPEN THE LIST FILE DEF *+7 DEF LDCB4+0 DEF IERR4+0 DEF FILE4+0 DEF IPTN2+0 OPEN OPTION DEF F4SC+0 DEF F4DSC+0 * CPA N6 DID WE FIND THE FILE JMP CRAT4 NO , GO CRATE IT JMP F4ERR SEE IF ANY ERROR * F4TST JSB WRITF TEST WRITE THE LIST FILE FOR SEC CODE DEF *+5 DEF LDCB4+0 DEF IERR4+0 DEF SDCB3+0 DEF P1 * SSA,RSS ANY ERROR? JMP F1OPN NO , CONTINUE OPEN THE COMMAND FILE JMP F4ER2 YES , ERROR * * PROCESS AND OPEN COMMAND FILE * F1OPN JSB OPEN OPEN THE COMMAND FILE DEF *+7 DEF CDCB1+0 DATA CONTROL BLOCK DEF IERR1+0 ERROR FLAG DEF FILE1+0 FILE NAMR DEF IPTN2+0 OPEN OPTION DEF F1SC+0 SECURITY CODE DEF F1DSC+0 CARTRIDGE REF # * SSA,RSS ANY ERRORS ? JMP F2OPN NO LDB P1 STB FATAL SET THE FATAL FLAG LDB F1 GET THE FILE NAME ADDRESS JSB FLERR YES * * LTPROCESS AND OPEN THE SYSTEM OUTPUT FILE * F2OPN LDA TYPE2 CHECK OUTPUT FILE NAME ERA,SLA IT IS A FILE OR AN LU ? JMP OPNF2 A FILE, OPEN IT LDA N6 AN LU , IT SHOULD BE A FILE STA IERR2 ECHO FILE NOT THERE JMP F2ER * OPNF2 LDA FILE2 AND HIMSK KEEP ONLY UPPER BYTE CPA ACENT IS IT A ' JMP OPEN2 YES , GO OPEN THE FILE * CRAT2 JSB CREAT NO , SO CRATE THE FILE DEF *+8 DEF ODCB2+0 DEF IERR2+0 DEF FILE2+0 DEF P256 DEF P1 DEF F2SC+0 DEF F2DSC+0 F2ERR SSA,RSS ANY ERROR ? JMP INIT0 NO F2ER JSB CLOS2 YES , SO CLOSE THE OUTPUT FILE LDB F2 GET THE FILE NAME ADDRESS TO B LDA IERR2 ERROR CODE IN A JSB FLERR DO FILE ERROR THING CLA,INA STA FATAL JMP F3OPN * OPEN2 JSB OPEN OPEN THE OUTPUT FILE DEF *+7 DEF ODCB2+0 DEF IERR2+0 DEF FILE2+0 DEF IPTN2+0 OPEN OPTION DEF F2SC+0 DEF F2DSC+0 * CPA N6 DID WE FIND THE FILE JMP CRAT2 NO , GO CRATE IT JMP F2ERR SEE IF ANY ERROR * INIT0 LDB N256 STB CNT1 INITIALIZE THE OUTPUT FILE TO ZERO INIT5 JSB WRITF DEF *+5 DEF ODCB2+0 DEF IERR2+0 DEF SDCB3+0 DEF P128 * SSA,RSS ANY ERROR? JMP INIT8 NO JMP F2ER YES , ECHO ERROR * INIT8 ISZ CNT1 JMP INIT5 * * PROCESS AND OPEN SNAP FILE * F3OPN LDA TYPE3 CHECK SNAP FILE NAME ERA,SLA IT IS A FILE OR AN LU ? JMP OPNF3 A FILE, OPEN IT LDA P1 STA FATAL SET THE FATAL FLAG LDA N6 AN LU , IT SHOULD BE A FILE STA IERR3 ECHO FILE NOT THERE JMP F3ER * OPNF3 LDA FILE3 AND HIMSK KEEP ONLY UPPER BYTE CPA ACENT IS IT A ' JMP OPEN3 YES , GO OPEN THE FILE * CRAT3 JSB CREAT NOM , SO CRATE THE FILE DEF *+8 DEF SDCB3+0 DEF IERR3+0 DEF FILE3+0 DEF P35 DEF P3 DEF F3SC+0 DEF F3DSC+0 F3ERR SSA,RSS ANY ERROR ? JMP F3TST NO , F3ER JSB CLOS3 YES , SO CLOSE THE OUTPUT FILE LDB F3 GET THE FILE NAME ADDRESS TO B LDA IERR3 ERROR CODE IN A JSB FLERR DO FILE ERROR THING CLA,INA STA FATAL JMP EREAD * OPEN3 JSB OPSNP OPEN THE SNAP FILE CPA N6 DID WE FIND THE FILE JMP CRAT3 NO , GO CRATE IT JMP F3ERR SEE IF ANY ERROR * F3TST JSB WRITF TEST WRITE TO SNAP FILE DEF *+5 DEF SDCB3+0 DEF IERR3+0 DEF FILE3+0 DEF P12 * SSA,RSS ANY ERROR? JMP EREAD NO JMP F3ER * EREAD JSB CLOS3 CLOSE THE SNAP FILE FOR NOW LDA FATAL ANY FATAL ERROR ? SLA JMP ABOR YES , GO ABORT * SKP * * ALL FILES OK * JSB RWNDF REWIND LIST FILE AFTER TEST WRITE DEF *+2 DEF LDCB4+0 * JSB FTIME GET SYSTEM TIME DEF *+2 DEF BUFF * LDA SLONG ECHO THE RUN STRING LDB DSTRG JSB DRKEY * JSB SPACE * LDA P34 ECHO THE DATE AND TIME LDB TIMAD JSB DRKEY * JSB SPACE * LDA P8 STA CONSL ECHO TO CONSOL LDB DMES0 JSB DRKEY OUTPUT " RTLGN " * * SKP * * GET LINKING SPECIFICATION * CLA,INA STA CPL.L DEFAULT TO CURRENT PAGE LINKING JSB SPACE LDA P14 LDB MES1 LINKING OPTION? JSB DRKEY JSB READ JMP EXIT END OF FILE LDA OP? CPA LI IS IT LINK? RSS YES JMP LNKER NO , LINK SPECIFICATION ERROR JSB NAMRR GET THE OPTIONS SSA JMP LNKER END OF STRING, NO SPECIFICATION CLA LDB IP@ BUF GET THE INPUT CPB BP IS IT BASE PAGE LINKAGE ? JMP LNK30 YES CPB CP IS IT CP? JMP GTMEM YES JMP LNKER NO , USE CP AND ISSUE WARNING * LNK30 STA CPL.L 0/1 DON'T USE/ USE CURRENT PAGE LINK JMP GTMEM * LNKER LDA P2 DEFAULT TO CURRENT PAGE LINK JSB LDRER JMP GTMEM * MES1 DEF *+1 ASC 7,* CP/BP LINK? * SKP * MES2 DEF *+1 ASC 6,* MEM SIZE? * * GET MEMORY SIZE * GTMEM JSB SPACE LDA P12 LDB MES2 JSB DRKEY JSB READ JMP EXIT LDA OP? CPA MS MEMORY SIZE RSS JMP MS10 JSB NAMRR SSA JMP MS10 LDA IPBUF LDB M3770 CPA P16 JMP MOK LDB M7770 CPA P32 JMP MOK YES MS10 CLA JSB LDRER LDB M7770 DEFAULT TO 32K MEMORY MOK STB CROM SAVE MEMORY SIZE * * GET FREE MEMORY * JSB LIMEM DEF *+4 DEF ANOP DEF FWFM+0 ADDRESS OF PROG'S HIGHEST WD+1 DEF LWFM+0 # OF WORDS AFTER PROG END * LDA LWFM # OF WDS AFTER FREE MEMORY ADA N1 ADA FWFM FIRST WORD OF FREE MEMORY STA TDBP TOP OF DUMMY BASE PAGE STA CSDBP SET CURRENT SYSTEM DUMMY BP ADA N1023 ALLOW 1024 LOCATION FOR DUMMY BP STA LDBP SET LOWER BOUND OF DUMMY BP ADA BPFWA STA CUDBP SET CURRENT USER DUMMY BP LDA LWFM CHECK FOR OVERFLOW ADA N1024 SSA IS IT POSITIVE? JMP GTF10 NO , OVERFLOW ADA FWFM YES , ADD FIRST WD FREE MEMORY STA LWFM SET LAST WORD OF FREE MEMORY * LDA N1024 ZERO OUT DUMMY BASE PAGE STA CNT1 CLA LDB LDBP LOWER BOUNDS OF DUMMY BP LP STA B,I INB ISZ CNT1 ANY MORE? JMP LP YES * JMP LSEG2 GO LOAD SEGMENT 2 GTF10 LDA P1 JSB LDRER PARTITION OVERFLOWED JMP EXIT * * * * LSEG2 JSB EXEC DEF *+3 LOAD SEGMENT 2 DEF P8 DEF SEG2 RTLG2 * SKP SKP * * * LDRER OUTPUTS ERRORS TO THE LIST DEVICE * * CALLING SEQUENCE: * A-REG = +VE ERROR CODE * JSB LDRER * RETURN * * LDRER NOP MPY P3 CALCULATE OFFSET INTO LIST OF ERROR CODE ADA EMESS ADD STARTING ADDRESS OF LIST STA B AND SAVE IN B-REG FOR OUTPUT LDA P6 LENGTH OF MESSAGE IN CHARACTERS JSB DRKEY PRINT IT ISZ ERRCT BUMP UP ERROR COUNT JSB ASTRX PRINT ****** JSB SPACE JMP LDRER,I AND RETURN * * EMESS DEF *+1 ASC 3,MEM SZ MEMORY SIZE SPECIFICATION ERROR ASC 3,OV FIX PARTITION OVERFLOWED ASC 3,LNK ER LINK ERROR , DEFAULT TO CP LINKING * SKP * * CONTANTS * P1 DEC 1 P2 DEC 2 P3 DEC 3 P6 DEC 6 P8 DEC 8 P12 DEC 12 P13 DEC 13 P14 DEC 14 P16 DEC 16 P32 DEC 32 P34 DEC 34 P35 DEC 35 P128 DEC 128 P150 DEC 150 P256 DEC 256 * N1 DEC -1 N6 DEC -6 N256 DEC -256 N1023 DEC -1023 N1024 DEC -1024 * M3770 OCT 37700 M7770 OCT 77700 * BP ASC 1,BP CP ASC 1,CP LI ASC 1,LI MS ASC 1,MS SEG2 ASC 3,RTLG2 * ANOP NOP CNT1 NOP COUNT DEC 13 * ACENT OCT 23400 HIMSK OCT 177400 * LSTER ASC 9, FMGR -15 ON FILE OCT 20040 LSTNM OCT 20040 OCT 20040 OCT 20040 * DMES0 DEF *+1 ASC 4,* RTLGN TIMAD DEF BUFF0 BUFF0 OCT 20040 OCT 20040 BUFF BSS 30 * SKP * * BASE PAGE COMMUNICATION VALUES * A EQU 0 B EQU 1 * SPC 3 END RTLG1 a0.**0  92070-18079 2026 S C0122 &RTLG2              H0101 }ASMB,R,L,C * * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * HED RTE-L GENERATOR SEGMENT 2 NAM RTLG2,5 92070-1X079 REV.2026 800508 * * NAME: RTE L GENERATOR SEGMENT 2 * SOURCE: 92070-18079 * PGMR: B.C. * ENT RTLG2 * * EXT EXEC,.ENTR EXT OPEN,CLOSE,READF,WRITF,POSNT,RWNDF EXT L.BUF,LNKDR,CNUMO,CNUMD * EXT DSTRG,IPBUF,STRNG,ISTRC,DIPBF EXT OP?,IPTN2,ABOR,ASTRX EXT EXIT,#ENPT EXT SDCB3,IERR3,F3 EXT ODCB2 EXT CLOS3,NLIB,CROM,AFWBG,ABGBP * EXT SEGNM,COMFG,LNKDR,BGFLG,SIDCK EXT FWFM,LWFM,BPFWA,COMAD,COMLG EXT TDBP,LDBP,CSDBP,CUDBP * EXT READ,FLERR,NAMRR,DRKEY,SPACE,MOVE EXT DLOCC,LOCC,DBLOC,BPLOC,NUMID,ADDID EXT L.OUT,L.INT,L.LUN,OPSNP EXT L.REL,L.CLS,L.ADD,L.LDF,L.MAT,L.SYE EXT LBS.L,CBP.L,IGN.L,NM1.L,NM2.L,NM3.L,NM4.L EXT TH1.L,TH2.L,NOR.L,PRI.L,PGT.L,FXN.L,PGL.L EXT SRIPX,FXS.L,.CBT EXT ERRCT,CONSL,AINT,IP3,WRDCT,STCR1 EXT BPR.L,CROM,PRERR,MAXAD,LENTF,INL.L * SUP PRESS EXTRANIOUS LISTING * SKP * F5 DEF FILE5 FILE5 BSS 3 FILE NAME TYPE5 NOP F5SC NOP F5DSC NOP * RDCB5 BSS 144 IERR5 NOP DDCB5 DEF RDCB5 * SKP RTLG2 LDA SEGNM CPA P5 SECOND TIME INTO SEGMENT? JMP TIME2 YES * * INITIALIZE LOADER LIBRARY * * DO NOT REMOVE ANY OF THE NEXT 22 WORDS * IDNAM JSB L.INT NO DEF *+9 DEF FWFM+0 1ST WORD OF FREE SPACE DEF LWFM+0 LAST WORD OF FREE SPACE DEF B1777 FIRST WORD OF BASE PAGE ( DECREASING"  ) DEF COMAD+0 ADDR OF SYSTEM COMMON = 0 IF LOCAL DEF COMLG+0 LENGTH OF SYSTEM COMMON OR 0 DEF B2000 LOAD POINT ADDRESS DEF CROM TOP OF MEMORY DEF TABLE TABLE OF ADDRESSES OF SUBR. * CCA STA LNKDR SYSTEM LINK DIRECTION STA COMFG UNLABEL COMMON IN FLAG * LDA B2000 STA LOCC * JSB SPACE LDA P10 STA CONSL ECHO ON CONSOLE LDB DMES4 SYSTEM RELOCATION JSB DRKEY OUTPUT MESSAGE JSB SPACE * SKP TIME2 CCA STA INL.L SET USE INDIRECT LINKS FOR JSB INST. NXTOP JSB READ READ INPUT JMP EXIT END OF FILE LDA OP? GET THE OPCODE LDB OUTID SLB,RSS OUT OF ID SEGMENTS? JMP CMPAR NO , GO ON CPA EN YES , IS THE COMMAND 'END' ? JMP END YES , IT IS AN END JMP RTERR NO , GIVE ' NO ID ' ERROR MESSAGE CMPAR CPA MS IS IT A MULTIPLE SCAN? JMP MSERC YES CPA SE IS IT SEARCH? JMP SERCH YES CPA RE IS IT RELOCATION? JMP RELOC YES CPA DI IS IT DISPLAY? JMP DISP YES CPA LO IS IT SET LOCC? JMP LOSET YES CPA BL IS IT SET BLOCC? JMP BPSET YES CPA EN IS IT END? JMP END YES CPA CO IS IT UNLABEL COMMON? JMP UNCOM YES CPA NE IS IT NEXT RT PROG? JMP END YES , DO IT LIKE AN END CPA ST IS IT START UP PROG? JMP SRTPR YES CPA SC IS IT USE SYSTEM COMMON? JMP SCOM YES CPA DB IS IT DBUG ? JMP DBUG YES CPA LE IS IT LENTRY ( LIST ENTRY PT ) ? JMP LENTY YES WHAT? CLA JSB LDRER WHAT IS IT ?? JMP NXTOP * DMES4 DEF MES4 MES4 ASC 5,* SYS REL * SEG3 ASC 3,RTLG3 * SKP * END LDA LNKDR GET LINK D;IRECTION CPA N1 SYSTEM LINK? JMP EN90 YES * LDA NOR.L CPA N1 ANYTHING RELOCATED? JMP EN75 NO LDA PRENT YES , IS THERE A PRIMARY ENTRY POINT? SZA,RSS JMP TAERR NO , TRANSFER ADDRESS ERROR * LDA APNDB SZA,RSS WANT TO APPEND DBUG? JMP CKUDF NO JSB L.SYE YES DEF *+6 ENTER .DBUG INTO SYM TBL AS UNDEFINED DEF DB1X ADDRESS OF .DBUG DEF P2 DEF ZERO DEF P1 DEF RESLT * CKUDF JSB UNDF? CHECK FOR UNDEF JMP OTUBP NO , UNDEFS EVERYTHING IS FINE * JSB OPSNP YES , OPEN THE SNAP FILE * JSB MRLOK SEARCH SNAP FOR MEM RES ENT. PT. LDA TH2.L STA LOCC UPDATE LOCC * LDA SCOMF GET SYS COM FLAG STA SCBIT SAVE IT FOR ID SEG SC BIT SZA USER SPECIFIED SYS COM? JSB SYLOK YES , GET SYS COM ENTRIES LDA TH2.L STA LOCC UPDATE LOCC SCNAG CLA STA SCOMF STA SUBLD CLEAR ANY SUBROUTINE LOADED IN LIB SCAN JSB LBLOK SEARCH THE SNAP LIBRARY LDA TH2.L STA LOCC UPDATE LOCC * JSB SYLOK SEARCH SNAP FOR SYSTEM ENTRIES LDA TH2.L STA LOCC UPDATE LOCC JSB UNDF? ANY UNDEFINED? JMP OKCL3 NO , UNDEFINED EVERTHING OK LDA SUBLD YES , UNDEFINED SZA ANY SUBROUTINE LOADED DURING THE LIB SCAN? JMP SCNAG YES , TRY LIBRARY SCAN AGAIN JSB DSUND NO , DISPLAY ANY UNDEFINED OKCL3 JSB CLOS3 * * OUTPUT USER BP LINKS * OTUBP LDA STRUP SZA,RSS IS THIS THE START UP PROG? JMP OUTBP NO LDA ADDID ID SEGMENT ADDRESS LDB ABOOT ADDRESS OF $BOOT JSB STCR1 * OUTBP LDB CBP.L GET CURRENT USER LINK CPB BPFWA USED ANY LINKS? JMP EN55 NO ADB N1 STB TCBPL YES , OUTPUT THEM ɯADB LDBP ADD LOWER BOUND OF DUMMY BP EN50 STB TSDBP SAVE DUMMY BP LOCATION LDA B,I GET THE LINK VALUE LDB TCBPL GET THE BP ADDRESS JSB STCR1 OUTPUT THE LINK LDA TCBPL GET THE ADDRESS CPA BPFWA ARE WE FINISH? JMP EN55 YES ADA N1 NO STA TCBPL SAVE THE REAL BP ADDRESS LDB TSDBP GET THE NEXT VALUE ADB N1 JMP EN50 PLAY IT AGAIN SAM * EN55 LDA BGLOD GET FLAG FOR BG LOAD SZA,RSS IS THIS A BG LOAD? JSB SRFI3 NO , CHECK IF THIS A INTERRUPT PROG JSB BUFCL NOP * JSB CKDUP CHECK FOR DUPLICATE PROG NAM JMP DUPGM YES , DUP PROG NAM * CCA STA L.BUF+0 ID 1 LIST LINKAGE LDA STRUP GET STARTUP FLAG SZA,RSS JMP EN70 NOT STARTUP LDA TEMP1 STA L.BUF+1 ID 2 LDA TEMP2 STA L.BUF+2 ID 3 LDA TEMP3 STA L.BUF+3 ID 4 LDA TEMP4 STA L.BUF+4 ID 5 LDA TEMP5 STA L.BUF+5 ID 6 EN70 LDA PRIOR STA L.BUF+6 ID 7 PROIRITY LDA PRENT STA L.BUF+7 ID 8 PRIMARY ENTRY POINT LDA PNAME STA L.BUF+12 ID 13 PROG NAME CHAR 1 & 2 LDA PNAME+1 STA L.BUF+13 ID 14 PROG NAME CHAR 3 & 4 LDA PNAME+2 AND HIMSK STA L.BUF+14 ID 15 PROG NAME CHAR 5 LDA M1000 LDB SCBIT SZB USING SYSTEM COMMOM? IOR B4000 YES , SET SC BIT STA L.BUF+15 ID 16 MR BIT & SC BIT LDA LOMAN STA L.BUF+20 ID 21 LOW MAIN LDA TH2.L STA L.BUF+21 ID 22 HIGH MAIN + 1 STA L.BUF+22 ID 23 SET TO HIGH MAIN + 1 LDA LOBP STA L.BUF+23 ID 24 LOW BP LDA CBP.L STA L.BUF+24 ID 25 HIGH BP + 1 CLA,INA STA L.BUF+28 ID 29 CONSOLE LU = 1 * ISZ #PGM LDB ADDID LDA #PGM CPA P22 # OF PROG EXCEEDS 22 ? JMP EN73 YES , DON'T PUT ID ADDRESS ADA N1 ADA DIDNM BUFFER ADDRESS STB A,I ID NAM ADDRESS EN73 STB A ADB P29 STB ADDID JSB SETCR OUTPUT THE ID SEGMENT ISZ ADDID * LDA NUMID USED UP ONE ID SEGMENT ADA N1 STA NUMID * LDA BGFLG LOADED A BACKGND PROG? SZA,RSS JMP EN75 NO * LDA ADDID YES , FILL CONTENT OF $BGRS ADA N30 WITH ID SEGMENT ADDRESS LDB ABGRS JSB STCR1 * EN75 LDA CBP.L STA BPFWA UPDATE 1ST WORD OF BP EN80 LDA BGFLG LOADING BACKGND? SZA JMP BGPRG YES LDA OP? GET OP CODE CPA EN END FOR RT PROG? JMP ENDRT YES , END RT PROG JMP RT10 NO , NEXT RT PROG * TAERR LDA P19 NO TRANSFER ADDRESS ERROR JSB LDRER JMP EN75 * DUPGM LDA P22 DUPLICATE PROG NAM JSB LDRER PRINT " DU PGM " JMP EN75 * EN90 JSB DSUND DISPLAY ANY UNDEFINED LDA CBP.L REAL CURRENT BASE PAGE INA STA TCBPL TEMPORY CURRENT BASE PAGE LDB CSDBP GET CURRENT SYS. DUM BP CPB TDBP HAVE WE RELOCATED ANYTHING? JMP EXIT NO , BYE BYE LDB A GET CURRENT REAL BP ADB LDBP ADD LOWER DUMMY BP EN100 STB TSDBP DUMMY BP LOCATION LDA B,I GET VALUE LDB TCBPL JSB STCR1 OUTPUT LDA TCBPL INA STA TCBPL LDB TSDBP INB CPB TDBP RSS JMP EN100 * ISZ SEGNM * LDA SEGNM CPA P1 RSS YES , LOAD SEGMENT 3 JMP EN110 NO * JSB EXEC DEF *+3 DEF P8 DEF SEG3 * EN110 CPA P6 CPA P6 LABEL COMMON FLAG? RSS YES JMP EN120 NO LDA D$LCO LDB LOCC JSB FSYMB FIND & PATCH ADDRESS OF LABEL COMMON JSB MSENT MISSING SYSTEM ENTRY POItNT JMP EN300 * EN120 CPA P7 BLANK COMMON FLAG? RSS YES JMP EN300 NO LDA D$BCO LDB LOCC STB CBCOM SAVE ADDRESS OF $BCOM JSB FSYMB FIND & PATCH ADDRESS OF BLANK COMMON JSB MSENT MISSING SYSTEM ENTRY POINT CLA STA INL.L CLEAR USE OF INDIRECT FOR JSB INST. * * EN300 JMP NXTOP GET NEXT OPERATION * * * D$LCO DEF $LCOM $LCOM ASC 3,$LCOM * D$BCO DEF $BCOM $BCOM ASC 3,$BCOM * D$BOT DEF $BOOT $BOOT ASC 3,$BOOT * SKP * * ENDRT CLA,INA STA BGFLG LDA LOCC STA CFWBG SAVE ADDRESS OF FWBG LDB AFWBG JSB STCR1 PATCH $FWBG (1ST WD OF BACKGND) * LDA BPFWA STA CBGBP SAVE ADRESS OF BPFWA LDB ABGBP JSB STCR1 PATCH $BGBP (1ST WD OF BACKGND BP) * LDA P2 STA IPTN2 REOPEN THE SNAP FILE WITH UPDATE MODE JSB OPSNP OPEN THE SNAP FILE * JSB READF READ IN HEADER RECORD DEF *+6 DEF SDCB3+0 DEF IERR3+0 DEF STRNG+0 DEF P12 DEF LEN * LDB DSTRG LDA #ENPT # OF SYS. MODULE & SYS COM ENT. PT. ADA #MREP ADD # OF RP,ABS,MR ENTRY POINT STA B,I INB LDA #MREP # OF RP,ABS & MEM RES ENT. PT. ALF,ALF SHIFT TO UPPER BYTE IOR NLIB # OF LIBRARY IN SNAP STA B,I INB LDA CROM LAST WORD OF MEMORY STA B,I INB LDA LOCC CONTENTS OF $FWBG STA B,I ADB P3 LDA BPFWA CONTENTS OF $BGBP STA B,I ADB P4 LDA SIDCK SYS ID CHECK STA B,I INB STB CNT20 SAVE ADDRESS OF CK SUM * LDA N10 STA CNT10 CHECKSUM FOR HEADER RECORD LDB DSTRG LDA B,I GET FIRST VALUE CKSUM INB ADA B,I ADD NEXT VALUE ISZ CNT10 FINISH ? JMP CKSUM NO , ADD NEXT WORD STNA CNT20,I YES , PUT IT IN WD 12 OF RECORD 1 * JSB RWNDF REWIND TO RECORD 1 DEF *+3 DEF SDCB3+0 DEF IERR3+0 * JSB WRITF WRITE OUT HEADER RECORD DEF *+5 DEF SDCB3+0 DEF IERR3+0 DEF STRNG+0 DEF P12 * JSB CSPER CHECK FOR SNAP FILE WRITE ERROR * * JMP BGPRG GET BACKGND PROG SKP * MSSUB NOP * MSERC CLA IS A MULTIPLE SCAN STA MULT CMA STA LBS.L JMP DOPRS * RELOC CLA NOW SET A FEW FLAGS STA LBS.L NOT A LIBRARY SCAN JMP DOPRS NOW GO DO THE PARSE SERCH CCA NOW SET A FEW FLAGS STA LBS.L IS A LIBRARY SEARCH STA MULT NOT A MULTIPLE SCAN * DOPRS CLA SET A FEW FLAGS STA IGN.L DON'T IGNOR THIS MODULE STA TP7FG CLEAR PROG TYPE 7 FLAG STA SMDNM CLEAR SEARCH MODULE NAME STA MODFD CLEAR MODULE FOUND FLAG CCA STA NM1.L NAM MUST BE FIRST STA NOR.L SUBR LOADED IN THIS SCAN STA FSCOM DON'T ACCEPT SYS. COM. COMMD AFTER THIS STA FDBUG DON'T ACCEPT DBUG COMMD AFTER THIS LDA LOCC STA TH2.L * LDB REL1S SSB,RSS 1ST REL COMMD IN PROG LOAD? JMP SNPCK NO STA LOMAN YES , SAVE LOCC IN LOMAN FOR ID SEG LDA CBP.L GET CURRENT BASE PAGE AND SAVE FOR ID SEG STA LOBP LOW BP FOR ID SEG CLA STA REL1S CLEAR 1ST REL COMMD * * IF PROGRAM STARTS ON SAME PAGE AS THE END OF MEMORY RESIDENT LIBRARY * THEN FORCE JSB EXT DIRECT INSTRUCTIONS TO USE AN INDIRECT LINK. * THIS PREVENTS A SHARED ROUTINE FROM BEING INTERRUPTED ON THE CALL! * CLB LDA CFWRT ADA N1 CALCULATE LAST WORD OF MEM RES. LIB. AND B7600 STA TEMOP LDA TH2.L FIRST INSTRUCTION WORD OF PROGRAM AND B7600 ISOLATE PAGE BITS CPA TEMOP SAME PAGE ASG MEM RES LIB? CCB YES STB INL.L 0/-1, NO/YES FORCE JSB EXT TO INDIRECT * SNPCK LDA SNPLB GET SNAP LIBRARY FLAG SZA SEARCHING SNAP LIBRARY JMP MVIPB YES JSB NAMRR NO PARSE THE INPUT SSA WAS THERE ANYTHING TO PARSE ? JMP WHAT? NO INPUT * MVIPB LDA N6 GET THE WORD COUNT JSB MOVE MOVE THE NAMR TO THE DCB AREA DEF IPBUF+0 SOURCE DEF FILE5 DESTINATION LDA TYPE5 GET THE TYPE WORD AND P3 KEEP ONLY THE LEAST 2 BITS STA TYPE5 * LDA SNPLB GET SNAP LIBRARY FLAG SZA SEARCHING SNAP LIBRARY JMP OPREL YES JSB NAMRR GET POSSIBLE MODULE NAME SSA IS THERE A NAME? JMP OPREL NO NAME , GO OPEN REL FILE * LDA DIPBF CHECK FOR LEGAL FILE NAME ADA P3 LDA A,I AND P3 SZA,RSS IS IT A NULL PARM? JMP OPREL YES , NULL DO SEARCH CPA P3 IS THIS A ASCII NAME? RSS YES , SAVE IT JMP MODNM NO, ERROR ILLGAL MODULE NAME LDA N3 MOVE FILE NAME JSB MOVE MOVE IT TO MDNAM DEF IPBUF+0 DMDNM DEF MDNAM CLA,INA STA SMDNM SET FLAG TO SEARCH FOR IT * * * OPREL JSB OPEN OPEN THE FILE ! DEF *+7 DEF RDCB5 DCB DEF IERR5 ERROR FLAG DEF FILE5 ASCII FILE NAME DEF IPTN1 READ OPTION DEF F5SC SECURITY CODE DEF F5DSC CART REF # SSA,RSS ANY ERROR IN THE READ ? JMP L.MOR NO LDB F5 YES , GET THE FILE NAME JSB FLERR AND REPORT JMP CLSRF * L.MOR JSB L.RED READ A RELOCATABLE RECORD DEF *+2 DEF FLAG * LDA FLAG SSA IS IT EOF? JMP CKMUL YES , CHECK FOR MULTIPLE SCAN * JSB L.CLS GO CLASSIFY THE REL. RECORD DEF *+3 DEF TYPE DEF SBFLD SUBFIELD REC , GEN=0 SSA RTN REC TYPE , 0=OK , -1=CK SUM ERR JMP RELER CHECK SUM ERROR * LDA TYPE CPA P1 JMP REL RELOCATE THE NAM REC TO SET UP PROG TYPE * LDA PGT.L GET PROGRAM TYPE CPA P5 IS IT A SEGMENTED PROGRAM? JMP SEGER ERROR , SEGMENTED PROGRAM NOT ALLOWED DURING GEN CPA P7 IS IT A TYPE 7 SUBROUTINE ? STA TP7FG YES SET THE PROGRAM TYPE 7 FLAG * LDA SMDNM SZA,RSS IS THERE A MODULE NAME? JMP CKMRP NO , MODULE NAME LDA NM2.L YES , SEARCH FOR NAME MODULE INA RAL LDB DMDNM ADDRESS OF MODULE NAME RBL JSB .CBT COMPARE THEM DEF P5 NOP JMP SMDFD NAME MATCHED JMP ENAM NAME NOT MATCHED JMP ENAM NAME NOT MATCHED SMDFD CLA,INA STA MODFD SET MODULE NAM FOUND * CKMRP LDB SEGNM CPB P5 LOADING MEMORY RESIDENT? RSS YES , ALLOW TYPE 6 MODULE ONLY JMP REL NO * LDA PGT.L GET PROGRAM TYPE CPA P6 IS MODULE TYPE 6? JMP REL YES CPA P14 IS IT TYPE 14? JMP REL YES CPA P30 IS IT TYPE 30 , RTE IV SSGA? JMP REL YES LDA LBS.L GET SEARCH FLAG SSA IS THIS A SEARCH ? JMP RELFD YES , FILE FORWARD LDA P17 NO , THIS IS NOT A TYPE 6,14,30 MODULE JSB LDRER GIVE ERROR JMP CLSRF GO CLOSE THE REL. FILE * SEGER LDA P12 ERROR MESSAGE 'SEGMENTED PROG. NOT ALLOWED JSB LDRER JMP CLSRF GO CLOSE THE REL. FILE * RELFD JSB L.RED READ A RELO RECORD DEF *+2 DEF FLAG * LDA FLAG SSA IS IT EOF? JMP CKMUL YES , CHECK FOR MULT. SCAN * JSB L.CLS GO CLASSIFY THE REL RECORD DEF *+3 DEF TYPE DEF SBFLD SUBFIELD RED , GEN = 0 SSA RTN REC TYPE , 0=OK , -1=CK SUM ERR JMP RELER CHECK SUM ERROR * LDA TYPE CPA P5 IS IT AN END RECORD JMP RELED YES JMP RELFD NO , SPACE FORWARD TO NEXT SUBROUTINE SKP * SPC 1 REL JSB L.REL NO, SO GO PROCESS RECORD ! DEF *+2 DEF FLAG * LDA FLAG GET ERROR FLAG SZA ANY ERROR? RSS YES JMP REL2 NO * RELER CMA,INA SET ERROR CODE TO POSITIVE JSB LDRER PRINT ERROR JMP CLSRF CLOSE RELOCATABLE FILE * REL2 LDA TYPE GET REC TYPE CPA P5 IS IT AN END? JMP RELED YES CPA P2 IS IT AN ENT? RSS YES JMP L.MOR NO LDA TP7FG CPA P7 JMP TP7SB YES , TYPE 7 SUBROUTINE LDA SEGNM CPA P6 IS IT SYSTEM COMMON ? JMP SCOMT YES , TAG SYMBOL AS SYSTEM COMMON CPA P5 LOADING MEM. RES. LIBRARY ? JMP TRMRL YES , TAG SYMBOL AS MEM. RES. JMP L.MOR * TRMRL LDA P8 SET TAG TO BIT 3 MEM. RES. STA TAGSM JMP TAGEN * TP7SB LDA B40 STA TAGSM SET TAG TO BIT 5 JMP TAGEN * SCOMT LDA P16 STA TAGSM SET TAG TO BIT 4 SYSTEM COMMON * TAGEN LDB DLBUF GET # OF ENTRIES INB LDA B,I FROM WD 2 OF ENT RECORD AND B17 CMA,INA STA CNT10 NEGATE # OF ENT SYMBOL ADB P2 POINT TO 1ST SYMBOL MRTAG STB SYMAD SAVE THE SYMBOL ADDRESS * JSB L.ADD DEF *+5 SYMAD DEF * DEF VALUA DEF SADDR DEF RESLT LDA RESLT SZA JMP ERSYM LDB SADDR SYMBOL ADDRESS ADB P3 LDA B,I GET WORD 4 OF SYMBOL TABLE AND P3 GET S FIELD CPA P2 IS IT UNDEFINED? JMP ERSYM YES, NEXT SYMBOL LDA B,I NO ,GET WORD 4 OF SYMBOL TABLE AGAIN IOR TAGSM TAG SYM NOT TO BE IN SNAP BIT 5 STA B,I OR TAG AS SYSTEM COMMON ERSYM ISZ CNT10 RSS JMP L.MOR LDB SYMAD ADB P4 JMP MRTAG MATCH NEXT SYMBOL * * * RELED LDA IGN.L ANY THING LOADED? SZA,RSS RSS JMP ENAM NO * ISZ SUBLD YES, A SUBROUTINE IS LOADED LDA PRI.L GET PRIMARY ENTRY POINT ADDRESS SZA,RSS DOES IT HAVE ONE? JMP PMAP NO LDB PRIFG YES CPB N1 IS IT THE FIRST ONE? JMP PREN1 YES JSB DEBUG NO , CHECK IF THE DEBUG MODULE JMP PMAP PREN1 LDB P1 STB PRIFG STA PRENT YES SAVE THE ADDRESS FOR THE RT PROG LDB NM4.L,I GET THE PROGRAM PRIORTY STB PRIOR AND SAVE IT FOR THE ID SEGMENT LDB NM2.L LDA B,I CMA,INA JSB MOVE GET THE PROGRAM NAME DEF NM2.L+2 DEF PNAME AND SAVE IT * SKP * * PRINT MODULE BOUNDS * PMAP JSB BUFCL BLANK OUT L.BUF BLNK2 ASC 1, * LDB NM2.L GET MODULE NAME LDA B,I CMA,INA JSB MOVE DEF NM2.L+2 DEF L.BUF+0 * JSB CNUMO CONVERT LOWER BOUND ADDRESS DEF *+3 DEF TH1.L+0 DEF L.BUF+3 * LDA TH2.L GET HIGH ADDRESS +1 OF THIS LOAD STA LOCC STORE IT IN LOCC LDA TH1.L CCA SUBTRACT -1 LDB PGL.L PROGRAM LENGTH SZB IF ZERO SSB OR NEGATIVE JMP ADTH2 ADDING LWA IS CORRECT (NO LINKS) ADA TH1.L ELSE ADD CURR PROG RELOC ADDR ADA B ADD LENGTH RSS ADTH2 ADA TH2.L ADD LWA PROG STA ADDR STORE IT TEMPORARY JSB CNUMO CONVERT UPPER BOUND ADDRESS DEF *+3 DEF ADDR DEF L.BUF+6 * LDB NM3.L LDA B,I SZA,RSS IS IT ZERO? JMP PM10 YES , NO COMMENTS CMA,INA JSB MOVE @_ DEF NM3.L+2 DEF L.BUF+10 * PM10 JSB SPACE LDA P120 LDB DLBUF JSB DRKEY PRINT BOUNDS * JSB BUFCL BLANK OUT L.BUF ASC 1, * LDA BP STA L.BUF * JSB CNUMO DEF *+3 DEF BPR.L+0 DEF L.BUF+2 * LDA P10 LDB DLBUF JSB DRKEY JSB SPACE * LDA LENTF SZA,RSS LIST ENTRY POINTS ? JMP ENAM NO JSB BUFCL YES , BLANK OUT L.BUF ASC 1, * CLA STA ADDR STA PNTR * PM20 JSB L.LDF DEF *+4 DEF ADDR DEF PNTR DEF N1 JUST GIVE ME THE SYMBOL FOR THIS MODULE LDA ADDR SZA,RSS IS THIS THE END JMP ENAM0 YES * LDA ADDR STA PMSY1 STA PMSY2 JSB L.ADD DEF *+5 PMSY1 DEF ADDR DEF VALUA DEF SADDR DEF RESLT * LDA N3 JSB MOVE PMSY2 DEF ADDR DEF L.BUF+1 LDA L.BUF+3 AND HIMSK IOR B40 ADD BLANK TO 3RD WORD STA L.BUF+3 * JSB CNUMO DEF *+3 DEF VALUA DEF L.BUF+5 * LDA P16 LDB DLBUF JSB DRKEY JMP PM20 ENAM0 JSB SPACE * ENAM CCA EXPECT ANOTHER NAM STA NM1.L CLA STA TP7FG CLEAR TYPE 7 FLAG JMP L.MOR * CKMUL LDA MULT IS IT A MULTIPLE SCAN? ISZ NOR.L SSA YES JMP CLSRF NOT A MULTIPLE SCAN OR NOTHING LOADED JSB RWNDF REWIND THE FILE DEF *+3 DEF RDCB5 DEF IERR5 * CCA STA NOR.L RESET TO NO SUBR LOADED JMP L.MOR * CLSRF JSB CLOSE DEF *+2 DEF RDCB5 CLOSE THE RELOCATION * LDA SMDNM SZA,RSS SEARCHING FOR MODULE NAM? JMP CKSLB NO LDA MODFD YES SZA WAS THE MODULE FOUND? JMP CKSLB YES LDA P27 NO , GIVE ERROR q JSB LDRER CKSLB LDA SNPLB SZA SEARCHING LIBRARY IN SNAP? JMP MSSUB,I YES , RETURN TO LBLOK JMP NXTOP NO * * MODNM LDA P25 ILLEGAL MODULE NAME IN SEARCH COMND JSB LDRER JMP NXTOP * * SKP * * * USE SYSTEM COMMON FOR PROGRAM * SCOM LDA SEGNM SZA,RSS IS IT SYSTEM REL. PHASE? JMP WHAT? YES , NOT ALLOWED LDA FSCOM GET ACCEPT SCOM COMMD FLAG SZA ACCEPT IT? JMP SCERR NO , SEQUENCE ERROR CLA,INA SET USE SYSTEM COMMON FLAG STA SCOMF JSB L.INT INIT LIBRARY DEF *+9 TO USE SYSTEM COMMON DEF FWFM+0 DEF LWFM+0 DEF BPFWA+0 DEF CBCOM+0 ADDRESS OF BLANK COMMON DEF LENBC LENGTH OF BLANK SYSTEM COMMON DEF LOCC+0 DEF CROM+0 DEF TABLE+0 JMP NXTOP * SCERR LDA P18 SCOM MUST BE SPECIFIED BEFORE JSB LDRER ANY RELOCATION JMP NXTOP * * * SKP * * SET FLAG FOR AUTOMATIC APPEND OF DBUG * DBUG LDA SEGNM SZA,RSS IS IT SYSTEM REL. PHASE? JMP WHAT? YES , DBUG NOT ALLOWED LDA FDBUG GET ACCEPT DB FLAG SZA ACCEPT IT ? JMP DBERR NO , OUT OF SEQUENCE CLA,INA YES STA FDBUG SET FLAG STA DBFLG SET USE DBUG FLAG STA APNDB SET APPEND DBUGR JMP NXTOP * DBERR LDA P26 JSB LDRER JMP NXTOP * * * GET LIST ENTRY POINTS LENTRIES,ON * ,OF * LENTY JSB NAMRR GET OPTION ON OR OF SSA END OF INPUT ? JMP WHAT? YES , NO OPTION CLB NO LDA IPBUF CPA ON IS IT ON OPTION? JMP LENON YES CPA OF IS IT OF OPTION? JMP LENOF YES JMP WHAT? OPTION ERROR LENON INB SET ON OPTION LENOF STB LENTF STORE IN LIST ENT FLAG  JMP NXTOP NEXT COMMAND * SKP SPC 1 * * START UP PROGRAM PARAMETERS * SRTPR LDA SEGNM SZA,RSS IS IT SYS. REL. PHASE? JMP WHAT? YES, NOT ALLOWED CLA,INA SET STARTUP FLAG STA STRUP JSB NAMRR GET NEXT INPUT SSA JMP NXTOP END OF STRING LDA IPBUF STA TEMP1 JSB NAMRR GET NEXT INPUT SSA JMP NXTOP END OF STRING LDA IPBUF STA TEMP2 JSB NAMRR GET NEXT INPUT SSA JMP NXTOP END OF STRING LDA IPBUF STA TEMP3 JSB NAMRR GET NEXT INPUT SSA JMP NXTOP END OF STRING LDA IPBUF STA TEMP4 JSB NAMRR GET NEXT INPUT SSA JMP NXTOP END OF STRING LDA IPBUF STA TEMP5 JSB SPACE JMP NXTOP * * SKP * * DISPLAY UNDEF * DISP JSB DSUND JMP NXTOP * * * WHICH LDA FLAG SZA,RSS JMP DSPBP DISPLAY BPLOCC * * DISPLAY LOCC * LDA DLOCC GET ADDRESS OF LOCC STA DSP50 JMP DSP30 GO CONVERT AND PRINT IT * * DISPLAY BPLOCC * DSPBP LDA CBP.L STA BPLOC LDA DBLOC STA DSP50 DSP30 JSB CNUMO CONVERT TO OCTAL # DEF *+3 DSP50 DEF LOCC DEF ADDR LDA P6 LDB DADDR JSB DRKEY PRINT LOCC VALUE JSB SPACE JMP NXTOP * * * SKP * * LOCC,VALUE * LOSET CCA COMPLEMENT A SET LOCC STA FLAG JMP GTVAL * * SET BPLOCC * * BPLOCC,VALUE * BPSET CLA CLEAR A SET BPLOCC STA FLAG GTVAL JSB NAMRR GET LOCC VALUE SSA,RSS END OF STRING ? RSS NO JMP WHICH YES, GO PRINT VALUE CCA STA FSCOM FLAG NOT TO ACCEPT SCOM COMMD LDB DIPBF ADB P3 LDA B,I GET INPUT TYPE CPA P1 IS IT NUMERIC? ERSS JMP ILBND ILLEGAL BOUNDS ADB N3 POINT BACK TO VALUE LDA B,I GET VALUE SSA POSITIVE? JMP ILBND NO , ERROR STA TLOCC SAVE IT TEMPORY LDB FLAG SZB,RSS JMP BPLO STA B LDA P16 CMB,INB ADB LOCC SSB,RSS NEW LOCC BIGGER THAN OLD LOCC? JSB LDRER NO , GIVE WARNING MESSAGE LDA TLOCC STA LOCC JSB SPACE JMP NXTOP * BPLO LDB M2000 GET -2000B ADB A ADD NEW BP SSB,RSS WITHIN BP RANGE? JMP ILBND NO , BOUNCE IT LDA LNKDR GET LINK DIRECTION CPA N1 SYSTEM LINK? JMP BPSY YES LDA CSDBP NO , GET CURRENT SYS DUMMY BP CMA,INA NEGATE ADA TLOCC ADD NEW BP ADA LDBP ADD LOW DUMMY BP BOUND SSA,RSS NEW BP OVERFLOWED INTO SYS DUM BP? JMP L.A20 YES , BP OVERFLOWED LDA TLOCC NO , SET NEW CURRENT USER DUMMY BP ADA LDBP STA CUDBP JMP BPRP BPSY LDA TLOCC GET NEW BP ADA LDBP ADD LOW DUMMY BP BOUND CMA,INA NEGATE ADA CUDBP ADD CURRENT USER DUMMY BP SSA,RSS OVERFLOWED INTO USER BP? JMP L.A20 YES , BASE PAGE OVERFLOWED LDA TLOCC NO ADA LDBP STA CSDBP SET NEW CURRENT SYS DUMMY BP BPRP LDA TLOCC STA BPLOC OK , REPLACE IT AT USER'S RISK STA CBP.L JSB SPACE JMP NXTOP * ILBND LDA P21 ILLEGAL BOUNDS JSB LDRER JMP NXTOP * SKP * * UNLABEL COMMON BLOCK * LEGAL CALL AFTER SEGMENT 5 * UNCOM LDA P7 IS IT CALLED FROM AFTER LABEL COMMON? CPA SEGNM RSS YES JMP WHAT? NO , IT IS A ERROR ISZ COMFG YES , IS IT THE FIRST TIME? JMP WHAT? NO , CALLED MORE THAN ONCE JSB NAMRR GET SIZE OF UNLABEL COMMON SSA JMP BCMER f END OF RECORD NO INPUT SIZE LDB DIPBF ADB P3 LDA B,I GET INPUT TYPE CPA P1 IS IT NUMERIC? RSS YES JMP BCMER NO ERROR LDA IPBUF LOAD THE SIZE SSA POSITIVE? JMP BCMER NO , ERROR STA LENBC ADA LOCC BUMP LOCC FOR THE UNLABEL COMMON SIZE STA LOCC UNC10 LDA D$FWR LDB LOCC STB CFWRT SAVE ADDRESS OF $FWRT JSB FSYMB FIND & PATCH $FWRT (1ST WD RT PROG) JSB MSENT MISSING SYSTEM ENTRY POINT JMP DZPRV * BCMER LDA P24 JSB LDRER JMP UNC10 * D$FWR DEF $FWRT $FWRT ASC 3,$FWRT * D$SYB DEF $SYBP $SYBP ASC 3,$SYBP * D$FWB DEF $FWBG $FWBG ASC 3,$FWBG * D$BGB DEF $BGBP $BGBP ASC 3,$BGBP * D$ROM DEF $ROM $ROM ASC 3,$ROM * D$BGR DEF $BGRS $BGRS ASC 3,$BGRS * $STRT ASC 3,$STRT SKP * * GENERAL CLEANUP AND OUTPUT SYSTEM SNAP * * * FIND ADDRESS OF $LIBX * AND CONSTRUCT JSB $LIBX,I * DZPRV LDA $LIBX JSB LADD FIND SYMBOL STA B SAVE RESULT IN B SZB IS DRIVER ENTRY POINT THERE? JSB MSENT NO , ERROR DISPLAY IT * JSB L.SCN SCAN FOR A BASE PAGE DEF *+3 DEF VALUA DEF BPADR * LDA BPADR SSA,RSS BASE PAGE ALLOCATED JMP CNST5 YES * JSB L.ABP NO ALLOCATE A BP DEF *+3 DEF DUMBP DEF BPADR * LDA VALUA STA DUMBP,I UPDATE DUMMY BP WITH LINK * * POST BASE PAGE LINK TO DISC FILE * LDB BPADR JSB STCR1 * CNST5 LDA BPADR IOR IJSB ADD JSB 0,I CODE STA JBLBX JSB $LIBX,I * * FIND .ZPRV IN SYMBOL TABLE * LDA .ZPRV JSB LADD CPA P2 JMP FNDFX .ZPRV UNDEFINDED JMP DZRNT .ZPRV NOT THERE , GO ON FNDFX LDA SADDR STA SYMCH SYMBOL TO MATCH * * SET UP TEMP1 TO FIND THE FIXUP,g * LDB FXN.L LAST ENTRY OF FIXUP STB TEMP1 NXFIX LDB TEMP1 JSB FDFIX FIND FIXUP JMP DLIBR FINISH DO ZRENT INA FOUND MATCHING ENTRY (A)=ADDRESS OF FIXUP STA ADFEX AND SAVE IT * * JSB RDOUT READ OUTPUT FILE FOR DEF EXIT DEF *+3 DEF ADFEX ADDRESS TO READ ( DEF EXIT ) DEF AEXIT * * LDA N1 ADDRESS OF DEF EXIT LDB ADFEX JSB STCR1 * LDA JBLBX LDB AEXIT JSB STCR1 OUTPUT JSB $LIBX,I * * ISZ AEXIT * JSB RDOUT READ OUTPUT FILE FOR EXIT+1 DEF *+3 DEF AEXIT DEF TEMP2 LDA TEMP2 IOR M1000 MERGE BIT 15 LDB AEXIT PUT IN DEF SUB,I JSB STCR1 * JMP NXFIX * * $LIBR DEF *+1 ASC 3,$LIBR * $LIBX DEF *+1 ASC 3,$LIBX * .ZPRV DEF *+1 .ZPV1 ASC 3,.ZPRV * * .ZRNT DEF *+1 .ZRN1 ASC 3,.ZRNT * D$CKS DEF $CKSM $CKSM ASC 3,$CKSM * SKP DLIBR LDA $LIBR JSB LADD STA B SAVE RESULT IN B SZB IS ENTRY POINT THERE? JSB MSENT NO , ERROR ISZ SADDR ISZ SADDR POINT TO WD 4 OF $LIBR ISZ SADDR LDA SADDR,I LOAD WD 4 STA TYPE SAVE IT IN TYPE LDA VALUA LOAD WD 5 STA VALUR SAVE IT FOR LATER * JSB L.MAT DEF *+5 DEF .ZPV1 DEF TYPE DEF VALUR DEF RESLT * * FIND .ZRNT * DZRNT LDA .ZRNT JSB LADD CPA P2 JMP FNFIX .ZRNT UNDEFINED GO FIND ANY FIXUP JMP RTPRG .ZRNT NOT THERE , JUST GO ON * FNFIX LDA SADDR ADDRESS OF .ZRNT IN SYMBOL TABLE STA SYMCH SYMBOL ADDRESS TO MATCH * * SET UP TEMP1 TO FIND THE FIXUP * RTPRG LDB FXN.L LAST ENTRY OF FIXUP STB TEMP1 NXTFX LDB TEMP1 JSB FDFIX FIND FIXUP JMP XCHN FINISH CHANGE .ZPRV & .ZRENT INA STA AD>FEX ADDRESS OF DEF EXIT * JSB RDOUT DEF *+3 DEF ADFEX ADDRESS OF DEF EXIT DEF AEXIT CONTENT OF DEF EXIT (ADDRESS OF EXIT) * LDA JBLBX LDB AEXIT JSB STCR1 OUTPUT JSB $LIBX,I * ISZ AEXIT JSB RDOUT READ OUTPUT FILE FOR EXIT + 1 DEF *+3 DEF AEXIT ADDRESS OF EXIT+1 DEF TEMP2 CONTENTS OF EXIT+1(DEF TDB) * LDA TEMP2 DEF TDB LDB ADFEX ADDRESS OF DEF EXIT JSB STCR1 OUTPUT DEF TDB * JSB L.MAT DEF *+5 DEF .ZRN1 POINT .ZRNT TO $LIBR DEF TYPE DEF VALUR DEF RESLT * JMP NXTFX DO NEXT FIXUP * * CHANGE .ZPRV AND .ZRNT TO RSS (2001) * XCHN LDA .ZPRV JSB SWRSS * LDA .ZRNT JSB SWRSS * LDA D$SYB LDB CBP.L INB STB CSYBP SAVE ADDRESS OF $SYBP JSB FSYMB JSB MSENT MISSING SYSTEM ENTRY POINT * LDA BPFWA GET 1ST WORD OF BP STA CBP.L SET REAL USER BP FOR RT PROG. CLA,INA STA LNKDR SET USER LINKS = 1 * LDA D$RTB LDB BPFWA STB CRTBP SAVE ADDRESS OF $RTBP JSB FSYMB FIND & PATCH 1ST WD OF RT BP JSB MSENT MISSING SYSTEM ENTRY POINT * LDA D$ROM FIND & PATCH $ROM LDB CROM JSB FSYMB FIND & PATCH $ROM JSB MSENT MISSING SYSTEM ENTRY POINT * LDA D$FWB CLB JSB FSYMB FIND ADDRESS OF $FWBG JSB MSENT MISSING SYSTEM ENTRY POINT LDA VALUA SAVE ADDRESS OF $FWBG STA AFWBG * LDA D$BGB CLB JSB FSYMB FIND ADDRESS OF $BGBP JSB MSENT MISSING SYSTEM ENTRY POINT LDA VALUA STA ABGBP SAVE ADDRESS OF $BGBP * LDA D$BGR CLB JSB FSYMB JSB MSENT MISSING SYSTEM ENTRY POINT LDA VALUA STA ABGRS SAVE ADDRESS OF $BGRS * ~ LDA D$BOT CLB JSB FSYMB FIND & PATCH ADDRESS OF $BOOT JSB MSENT MISSING SYSTEM ENTRY POINT LDA VALUA STA ABOOT SAVE ADDRESS OF $BOOT * JSB L.ADD FIND ADDRESS OF $STRT DEF *+5 DEF $STRT DEF VALUA DEF SADDR DEF RESLT LDA RESLT GET RESULT SZA JSB MSENT MISSING SYSTEM ENTRY POINT LDA VALUA ADDRESS OF $STRT LDB P3 JSB STCR1 PUT ADDRESS OF $STRT IN LOC 3 * LDA JMP3I JMP 3,I LDB P2 JSB STCR1 PUT JMP 3,I IN LOC 2 * * OUTPUT THE SNAP * JSB OPSNP REOPEN THE SNAP FILE * JSB BUFCL NOP LDA CFWRT CONTENTS OF $FWRT STA L.BUF+4 LDA CSYBP CONTENTS OF $SYBP STA L.BUF+5 LDA CRTBP CONTENTS OF $RTBP STA L.BUF+7 LDA CBCOM CONTENTS OF $BCOM STA L.BUF+8 LDA LENBC LENGTH OF BLANK COMMON STA L.BUF+9 * JSB WRITF OUTPUT REC 1 OF SNAP FILE DEF *+5 DEF SDCB3+0 DEF IERR3+0 DEF L.BUF+0 DEF P12 JSB CSPER CHECK SNAP FILE WRITE ERROR * * OUTPUT SYSTEM ENTRY POINTS * CLA,INA 1ST TIME FLAG STA TEMP2 * SNP2 CLA STA PNTR STA CNT10 * LDA P3 STA L.BUF+0 GSYEN JSB L.LDF GET A SYSTEM ENTRY DEF *+4 DEF ADDR DEF PNTR DEF P1 GIVE ME ALL OF THEM LDA ADDR SZA,RSS JMP ESYEN STA ADDRX STA B LDA B,I AND M7777 MASK OUT PRINT IT BIT STA B,I ADB P3 POINT TO WORD 4 OF SYMBOL LDA B,I LOAD WORD 4 AND CHECK AND B40 TO SEE IF SHOULD BE EXCLUDED FROM SNAP SZA JMP GSYEN YES , EXCLUDED FROM SNAP LDA B,I GET WORD 4 AGAIN? AND HIMSK ALF,ALF CPA P4 IS IT AN RP SYMBOL? JMP GRP YES CPA P3 IS IT AN ABSOLUTE RSS YES JMP GCK NO GRP STA B,I REPLACE WD 4 WITH 3=ABS , 4=RP JMP GSUM GCK LDA B,I LOAD WD 4 AGAIN AND P8 SZA,RSS IS IT MEM. RES. SYMBOL? JMP CKSCM NO , CHECK SYS COM SYMBOL CLA YES , MEM RES. SYMBOL STA B,I PUT 0 IN WORD 4 JMP GSUM * CKSCM LDA TEMP2 CPA P1 PASS 1? JMP GSYEN YES , NEXT SYMBOL LDA B,I GET WORD 4 AGAIN AND P16 SZA SYSTEM COMMON ENTIES LDA P2 YES , SET SYMBOL AS SYSTEM COMMON STA B,I RESTORE WORD 4 * GSUM STB TEMP1 SAVE ADDRESS OF SYM TBL WD 4 INB LDA B,I ADA SIDCK ARITHMETIC SUM FOR SYSTEM CHECK WD STA SIDCK AND SAVE IT * LDA N5 JSB MOVE MOVE SYSTEM ENTRY TO OUTPUT BUFFER ADDRX NOP DEF L.BUF+1 LDA L.BUF+3 AND HIMSK IOR B40 ADD BLANK TO 3RD WORD STA L.BUF+3 * LDA B40 STA TEMP1,I EXCLUDE SYMBOL FROM NEXT PASS * JSB WRITF OUTPUT ENTRY TO SNAP FILE DEF *+5 DEF SDCB3+0 DEF IERR3+0 DEF L.BUF+0 DEF P6 JSB CSPER CHECK FOR SNAP FILE WRITE ERROR * ISZ CNT10 JMP GSYEN GET ANOTHER ENTRY POINT * ESYEN LDA CNT10 LDB TEMP2 CPB P1 1ST PASS? RSS YES JMP PASS2 STA #MREP # OF RP,ABS & MEM RES ENT. PT. ISZ TEMP2 SET PASS 2 FLAG JMP SNP2 DO SYS MODULE & SYS COM ENT PT. * PASS2 STA #ENPT SAVE # OF SYSTEM ENTRY POINTS * * FIND & PATCH $CKSM * LDA D$CKS LDB SIDCK JSB FSYMB JSB MSENT MISSING SYSTEM ENTRY POINT * * GET LIBRARY FILE NAME * JSB SPACE LDA P12 LDB DMS65 PRINT " LIB FILES ? " JSB DRKEY * RDLIB JSB READ GET LIBRARY FILE NAME  JMP EXIT LDA OP? CPA EN JMP OTBP CPA LI JMP LIBRY GO GET A LIBRARY NAME LIERR CLA JSB LDRER WHAT IS IT?? JMP OTBP * LIBRY JSB NAMRR PARSE THE INPUT SSA JMP LIERR LDA IPBUF SZA CPA BLNK2 JMP LIERR * LDA N6 JSB MOVE DEF IPBUF+0 DEF LIBFL * JSB WRITF DEF *+5 DEF SDCB3+0 DEF IERR3+0 DEF LIBFL+0 ADDRESS OF LIBRARY FILE DEF P6 JSB CSPER CHECK FOR SNAP FILE WRITE ERROR * ISZ NLIB BUMP UP THE NUMBER OF LIBRARY JMP RDLIB * * OUTPUT SYSTEM BP TO SNAP * OTBP LDA CSYBP CMA,INA ADA B2000 CLB DIV P128 CMA,INA STA CNT20 NEGATIVE COUNT OF THE # OF 128 WD RECORDS STB ZTEM5 # OF WD REMAINING * LDA CSYBP ADA LDBP MBP STA PNTR ADDRESS OF DUMMY BP STA ADDBP * JSB WRITF DEF *+5 DEF SDCB3+0 DEF IERR3+0 ADDBP NOP DEF P128 JSB CSPER CHECK FOR SNAP FILE WRITE ERROE * ISZ CNT20 RSS JMP FINBP LDA PNTR ADA P128 JMP MBP MORE BP * FINBP LDA PNTR ADA P128 STA ADBP JSB WRITF DEF *+5 DEF SDCB3+0 DEF IERR3+0 ADBP NOP DEF ZTEM5 JSB CSPER CHECK FOR SNAP FILE WRITE ERROR JSB CLOS3 * SKP * * RELOCATE REAL TIME PROGRAMS * LDA NUMID STA CNMID * RT10 JSB SPACE LDA P14 STA CONSL ECHO TO CONSOLE LDB MES50 REL RT PROG RT20 JSB DRKEY JSB SPACE CCA STA NOR.L SET NOTHING LOADED FLAG * LDA NUMID SZA OUT OF ID SEGMENT? JMP RT30 NO CLA,INA YES, SET OUT OF ID FLAG STA OUTID JMP NXTOP * RT30 CLA STA SCOMF CLEAR USE SYSTEM FLAG STA FSCOM CLsEAR ALLOW SYS. COM FLAG STA FDBUG CLEAR ALLOW DBUG FLAG STA PRENT CLEAR PRIMARY ENTRY POINT STA STRUP CLEAR START UP FLAG STA DBFLG CLEAR DBUG FLAG STA APNDB CLEAR APPEND DBUGR FLAG STA TEMP1 CLEAR TEMP1 TO TEMP5 STA TEMP2 STA TEMP3 STA TEMP4 STA TEMP5 * CCA 1ST PRIMARY ENTRY PT. STA PRIFG STA REL1S SET 1ST REL COMMD FOR PROG LOAD * JSB L.INT DEF *+9 DEF FWFM+0 DEF LWFM+0 DEF BPFWA+0 DEF ZERO+0 DEF ZERO+0 DEF LOCC+0 DEF CROM+0 DEF TABLE * JMP NXTOP * RTERR LDA P14 JSB LDRER OUT OF ID SEGMENT JMP EXIT1 * * DMS65 DEF MES65 MES65 ASC 6,* LIB FILES * MES50 DEF *+1 ASC 7,* REL RT PROG * D$RTB DEF $RTBP $RTBP ASC 3,$RTBP SKP * BGPRG LDA BGLOD CHECK IF FIRST BG PROG SZA JMP EXIT1 NO , WE ARE FINISH. CLA,INA SET BGLOD TO 1 STA BGLOD * LDA P14 STA CONSL LDB MES70 REL BG PROG JMP RT20 * EXIT1 LDB CFWBG GET START OF BG PROG CMB,INB NEGATE ADB CROM ADD TOP OF MEMORY * LDA CBGBP GET START OF BG BASE PAGE CMA,INA NEGATE ADA CSYBP ADD START OF SYSTEM BASE PAGE * ADA B ADD BOTH CLB DIV P128 DIVIDE BY 128 TO GET # OF BLOCK ADA P2 ROUND UP BY TWO MPY CNMID MULTIPLY BY THE # OF ID SEGMENT STA ZTEM5 * JSB CNUMD CONVERT BLOCK SIZE TO DECIMAL DEF *+3 DEF ZTEM5 DEF ME80 * JSB SPACE LDA P28 LDB MES80 JSB DRKEY PRINT SWAP FILE SIZE FOR THE SYSTEM * LDA CFWRT ADA N1 STA ZTEM5 JSB CNUMO DEF *+3 DEF ZTEM5 DEF ME75 JSB SPACE LDA P14 LDB MES75 JSB DRKEY PRINT SYSTEMP SIZE * LDA CFWRT CMA,INA ADA CFWBG STA ZTEM5 JSB CNUMO DEF *+3 DEF ZTEM5 DEF ME82 JSB SPACE LDA P14 LDB MES82 PRINT REAL TIME SIZE JSB DRKEY * LDA CRTBP CMA,INA ADA CBGBP STA ZTEM5 JSB CNUMO DEF *+3 DEF ZTEM5 DEF ME84 JSB SPACE LDA P16 LDB MES84 JSB DRKEY PRINT REAL TIME BP SIZE * LDA CFWBG CMA,INA ADA CROM STA ZTEM5 JSB CNUMO DEF *+3 DEF ZTEM5 DEF ME86 JSB SPACE LDA P14 LDB MES86 JSB DRKEY PRINT BACKGND SIZE * LDA CBGBP CMA,INA ADA CSYBP STA ZTEM5 JSB CNUMO DEF *+3 DEF ZTEM5 DEF ME88 JSB SPACE LDA P16 LDB MES88 JSB DRKEY PRINT BACKGND BP SIZE * LDA MAXAD ADA N2 LENGTH OF SYSTEM IN WORD 0 CLB JSB STCR1 * LDA P2 LDB P1 1ST ADDRESS TO LOAD JSB STCR1 * LDA P128 STA SEGNM SIGNAL NORMAL TERMINATION * JMP EXIT * MES70 DEF *+1 ASC 7,* REL BG PROG * MES80 DEF *+1 ASC 8,* SWAP FILE SZ ME80 NOP NOP NOP ASC 3, BLOCK * MES75 DEF *+1 ASC 4,* SYS SZ ME75 BSS 3 * MES82 DEF *+1 ASC 4,* RT SZ ME82 BSS 3 * MES84 DEF *+1 ASC 5,* RT BP SZ ME84 BSS 3 * MES86 DEF *+1 ASC 4,* BG SZ ME86 BSS 3 * MES88 DEF *+1 ASC 5,* BG BP SZ ME88 BSS 3 SKP * * THIS SUBR HANDLES THE SPECIAL PROCESING REQUIRED FOR THE * RTE-L DBUGR PACKAGE. DEBUG IS CALLED AFTER THE RECORD IS * PROCESSED ONLY IF THE LAST MODULE WAS LOADED AND HAS A PRIMARY * ENTRY POINT. A CHECK IS MADE TO SEE IF THE LATEST MODULE WAS * 'DBUGR'. IF SO DBURG'S PRIMARY ENTRY POINT IS SAVED IN THE * PROGRAM ID SEGMENT AND TsHE ACTUAL PRIMARY ENTRY POINT IS SAVED * IN '.DBUG'. * DEBUG NOP LDA DBFLG IS DEBUG ALLOWED? SZA,RSS WELL? JMP DEBUG,I NO, SO FORGET IT * LDB NM2.L GET PROG NAME 1,2 INB LDA B,I CPA DB1 CHARS =D,B? RSS YES - CONTINUE JMP DEBUG,I RETURN = PROG IS NOT 'DBUGR' INB LDA B,I CPA DB2 CHARS =U,G? RSS YES - CONTINUE JMP DEBUG,I RETURN - PROG IS NOT 'DBUGR' INB GET PROG NAME 5 LDA B,I CPA DB3 CHAR = R? RSS YES - CONTINUE JMP DEBUG,I RETURN - PROG IS NOT 'DBUGR' * JSB L.ADD FIND ADDRESS OF DBUGR IN LST DEF *+5 DEF DB1X ADDRESS OF SYMBOL NAME DEF VALUX DEF SADDX SYMBOL TABLE ADDRESS DEF RESLX RESULT RETURNED SZA IS 'DBUGR' FOUND? NOP NO , THIS IS AN ERROR CONDITION LDA PRENT GET THE PROGRAM'S PRIMARY ENTRY LDB VALUX AND SET INTO .DBUG ENTRY POINT JSB STCR1 OUTPUT WORD TO DISC LDA PRI.L NOW SET THE PRIMARY ENTRY STA PRENT OF 'DEBUG' INTO THE ID SEGMENT JMP DEBUG,I RETURN * VALUX BSS 1 RESLX BSS 1 SADDX BSS 1 DB1 ASC 1,DB DB2 ASC 1,UG DB3 ASC 1,R DB1X ASC 3,.DBUG * SKP * * CHECK FOR INTERRUPT RT PROGRAM * SRFI3 NOP CLA STA WRDCT LDA DPNAM ADDRESS PROGRAM NAME SRFI4 JSB SRIPX GO SEARCH PROGRAM NAME TABLE RSS FOUND NAME JMP SRFI3,I END OF TABLE LDA IP3,I COMPARES,GET SC AND B77 SZA,RSS JMP SRFI4 ADA AINT ADDRESS OF INTERRUPT TABLE ADA N16 LDB A LDA ADDID CMA,INA JSB STCR1 LDA IP3,I AND M400 ZERO OUT SELECT CODE STA IP3,I JMP SRFI4 * SKP * * CHECK FOR ANY UNDEFS * * JSB UNDF? * N O UNDEFS * YES THERE ARE UNDEFS * UNDF? NOP CLA STA PNTR STA PRTFG CLEAR 1ST TIME PRINT FLAG JSB L.LUN GET UNDEFINED EXTERNAL DEF *+4 DEF ADDR DEF PNTR DEF FLAG SZB UNDEF ? ISZ UNDF? YES , UNDEFS JMP UNDF?,I NO * * * CHECK FOR ANY SNAP FILE ERROR * * A = ERROR CODE FROM WRITF * JSB CSPER * CSPER NOP SSA,RSS ANY ERROR? JMP CSPER,I NO , RETURN LDB F3 ADDRESS OF SNAP FILE NAME JSB FLERR JMP CSPER,I RETURN * * SKP * * CHECK FOR DUPLICATE PROGRAM NAME * * JSB CKDUP * ERROR RTN DUP PROGRAM NAME * NORMAL RTN * CKDUP NOP LDA #PGM SZA,RSS JMP OKRTN OK TO RETURN NOTHING TO CHECK CMA,INA NEGATE # OF PROGRAMS STA ZTEM4 LDA DIDNM ADDRESS OF IDNAMS STA ZPTN LDA PNAME+2 AND HIMSK STA PNAME+2 CKD10 LDA DPNAM STA TLOCC LDA N3 STA ZTEM5 LDA ZPTN,I GET ID SEGMENT ADDRESS ADA P12 STA AEXIT ADDRESS OF ID SEG PROG NAM RDNXT JSB RDOUT DEF *+3 DEF AEXIT ADDRESS OF ID DEF ZTEM3 * LDA ZTEM3 CHAR OF NAM CPA TLOCC,I EQUAL TO CURRENT PROG NAM RSS YES JMP NXNM NO , NO NEED TO CHECK OTHER CHAR ISZ AEXIT GET NEXT CHAR ISZ TLOCC ISZ ZTEM5 ANY MORE CHARACTERS JMP RDNXT YES JMP DURTN NO , DUPLICATE PROG NAM * NXNM ISZ ZPTN ISZ ZTEM4 JMP CKD10 OKRTN ISZ CKDUP DURTN JMP CKDUP,I * SKP * * PLACE RP , ABS & MEM RES ENTRY INTO SYM TABLE * MRLOK NOP JSB POSNT DEF *+5 DEF SDCB3+0 DEF IERR3+0 DEF P2 DEF P2 POSITION TO REC 2 OF SNAP FILE SSA ERROR? JMP MRFMP YES * LDA #MREP GET # OF MEM RES ENTzRY PT. CMA,INA STA CNT10 * NXMR JSB READF READ AN ENTRY DEF *+5 DEF SDCB3+0 DEF IERR3+0 DEF SNAME+0 DEF P10 SSA ERROR? JMP MRFMP YES * LDA SNAME+4 GET WORD 4 OF SNAP ALF,ALF PLACE IN UPPER BYTE FOR SYM. TBL. STA SNAME+4 RESTORE IT * LDA SNAME+1 GET CHARACTER 1 IOR M1000 SET BIT 15 STA SNAME+1 RESTORE IT JSB L.SYE STUFF SYMBOL TABLE DEF *+6 DEF SNAME+1 DEF SNAME+4 DEF SNAME+5 DEF ZERO DEF RESLT LDA RESLT SSA,RSS ANY ERROR? JMP BMPMR NO CMA,INA ERROR , LST OV JSB LDRER JMP EXIT * BMPMR ISZ CNT10 JMP NXMR JMP MRLOK,I * MRFMP LDA P13 JSB LDRER JMP MRLOK,I SKP * * SEARCH THE SNAP FOR SYSTEM ENTRY POINTS * SYLOK NOP * LDA #MREP ADA P2 STA IREC JSB POSNT POSITION TO START OF SYSTEM ENT DEF *+5 DEF SDCB3+0 DEF IERR3+0 DEF IREC DEF P2 SSA ERROR? JMP SNFMP YES * LDA #ENPT GET # OF SYSTEM ENTRIES CMA,INA STA CNT10 * NXENT JSB READF READ AN ENTRY DEF *+5 DEF SDCB3+0 DEF IERR3+0 DEF SNAME+0 DEF P10 SSA ERROR? JMP SNFMP YES * LDB SCOMF GET SYS COMMON FLAG LDA SNAME+4 CHECK IF THIS IS A SYS COM ENTRY CPA P2 IS IT A SYSTEM COMMON ENTRY? RSS YES JMP FIXEN NO * SZB,RSS USER SPECIFED SYS COM? JMP UPCNT NO , NEXT ENTRY CLA YES STA SNAME+4 PLACE IN WORD 4 OF SYM TABLE LDA SNAME+1 GET CHAR 1 IOR M1000 SET BIT 15 STA SNAME+1 RESTORE IT JSB L.SYE STUFF SYM TABLE DEF *+6 DEF SNAME+1 DEF SNAME+4 DEF SNAME+5 D DEF ZERO DEF RESLT LDA RESLT SSA,RSS ANY ERROR? JMP UPCNT NO CMA,INA YES , ERROR LST OV JSB LDRER JMP EXIT * FIXEN SZB SEARCH SYSTEM ENTRY? JMP UPCNT NO JSB L.MAT YES, FIXUP PREVIOUS REFERENCES DEF *+5 DEF SNAME+1 DEF SNAME+4 DEF SNAME+5 DEF RESLT UPCNT ISZ CNT10 JMP NXENT NO , READ NEXT ENTRY JMP SYLOK,I * SNFMP LDA P13 JSB LDRER JMP SYLOK,I * SNAME BSS 10 SKP * * SEARCH THE SNAP LIBRARY FOR UNDEFS * LBLOK NOP JSB RWNDF DEF *+3 DEF SDCB3+0 DEF IERR3+0 * LDA #ENPT GET # OF ENTRY POINT ADA #MREP ADD # OF MR , ABS , RP ENTRY POINTS INA STA IREC LIBRARY RECORD # * JSB POSNT POSITION TO LIBRARY RECORD DEF *+5 DEF SDCB3+0 DEF IERR3+0 DEF IREC DEF IRB * LDA NLIB GET # OF LIBRARY SZA,RSS IS IT NON ZERO? JMP LBL20 NO , IT IS ZERO EXIT CMA,INA YES , THERE IS AN LIBRARY STA CNT30 * RSLIB JSB READF READ SNAP LIBRARY DEF *+6 DEF SDCB3+0 DEF IERR3+0 DEF IPBUF+0 DEF P6 DEF LEN * CLA,INA STA ISTRC SET NAMRR COUNTER STA SNPLB SET FLAG TO RETURN HERE * JSB MSSUB GO SEARCH THE SNAP LIBRARY * ISZ CNT30 ANY MORE LIBRARY? JMP RSLIB YES LBL20 CLA NO STA SNPLB JMP LBLOK,I * IREC NOP IRB NOP * SKP * * LDRER OUTPUTS ERRORS TO THE LIST DEVICE * * CALLING SEQUENCE: * A-REG = +VE ERROR CODE * JSB LDRER * RETURN * * LDRER NOP MPY P3 CALCULATE OFFSET INTO LIST OF ERROR CODE ADA EMESS ADD STARTING ADDRESS OF LIST STA B AND SAVE IN B-REG FOR OUTPUT LDA P6 LENGTH OF MESSAGE IN CHARACTERS JSB DRKEY PRINT IT ISZ ERRCT BUMP UP ERROR COUNT JSB ASTRX PRINT ****** JSB SPACE JMP LDRER,I AND RETURN * * EMESS DEF *+1 ASC 3,?? WHAT IS IT ?? ASC 3,CK SUM CHECK SUM ERROR ASC 3,IL REC ILLEGAL RECORD ASC 3,OV MEM MEMORY OVERFLOW ASC 3,OV FIX FIXUP TABLE OVERFLOW ASC 3,OV SYM SYMBOL TABLE OVERFLOW ASC 3,CM BLK COMMON BLOCK ERROR ASC 3,DU ENT DUPLICATE ENTRY POINTS ASC 3,RE SEQ RECORD OUT OF SEQUENCE ASC 3,IL REL ILLEGAL RELOCATABLE ASC 3,RF EMA ILLEGAL REFERENCE TO EMA ASC 3,RF EMA ILLEGAL REFERENCE TO EMA ASC 3,IL SEG SEGMENTED PROG. NOT ALLOWED ASC 3,SNP ER SNAP FILE ERROR ASC 3,NO ID NO MORE ID SEGMENTS ASC 3,MS ENT MISSING SYSTEM ENTRY POINT ASC 3,LOC WR WARNING LOCC SET BACKWARD ASC 3,IL MRL MEMORY RESIDENT IS NOT TYPE 6,14,30 ASC 3,SCM SQ SYS COM MUST BE BEFORE ANY RELOCATION ASC 3,TR ADD NO TRANSFER ADDRESS ASC 3,UN EXT UNDEFINED EXTERNAL ASC 3,IL BND ILLEGAL BOUND IN LOCC OR BPLOCC ASC 3,DU PGM DUPLICATE PROGRAM NAME ASC 3,OV BSE BASE PAGE LINKAGE OVERFLOW ASC 3,BNK CM BLANK COMMON ERROR ASC 3,MOD NM ILLEGAL MODULE NAME IN SEARCH COMND ASC 3,DB SEQ DBUG COMMD MUST BE SPECIFY BEFORE ANY RELOCATION ASC 3,NO MOD SPECIFIED MODULE NAM NOT FOUND * SKP * * OUTPUT CONSECUTIVE CORE LOCATIONS * * LDA START STARTING ADDRESS * LDB END ENDING ADDRESS * JSB SETCR DATA WILL BE AT STRNG * SETCR NOP STA ZTEM5 STARTING ADDRESS CMA,INA NEGATE STARTING ADDRESS ADA B ADD ENDING ADDRESS INA ADD 1 FOR TOTAL # TO OUTPUT CMA,INA NEGATE FOR COUNT STA CNT10 LDA DLBUF ADDRESS OF DATA STA CNT20 SET10 LDA CNT20,I GET DAP^TA LDB ZTEM5 GET ADDRESS JSB STCR1 OUTPUT ISZ CNT20 NEXT DATA WORD ISZ ZTEM5 NEXT ADDRESS ISZ CNT10 ANY MORE OUTPUT ? JMP SET10 YES JMP SETCR,I NO * SKP SKP * * DISPLAY UNDEF * DSUND NOP CLA STA PNTR STA PRTFG CLEAR 1ST TIME PRINT FLAG DSP10 JSB L.LUN GET A UNDEFINED EXTERNAL DEF *+4 DADDR DEF ADDR ADDRESS OF 3 WORD UNDEF DEF PNTR GET THE ADDRESS DEF FLAG LDA ADDR SZA,RSS IS THERE A UNDEFINED JMP DSUND,I NO , FINISH LDA ADDR RAL LDB .ZPRV RBL JSB .CBT DEF P5 NOP JMP DSP10 NOP NOP LDA ADDR RAL LDB .ZRNT RBL JSB .CBT DEF P5 NOP JMP DSP10 NOP NOP LDA PRTFG WANT TO PRINT HEADER? SZA JMP DSP60 NO JSB SPACE YES LDA P20 STA PRTFG JSB LDRER DSP60 LDA P5 LDB ADDR GET SYMBOL ADDRESS JSB DRKEY GO PRINT IT JMP DSP10 GO GET ANOTHER SYMBOL * PRTFG NOP * * SKP * * * SWITCH .ZPRV AND .ZRNT TO RSS ( 2001B ) * * CALL SEQUENCE * LDA ADDRESS OF SYMBOL * JSB SWRSS * SWRSS NOP JSB LADD LDA SADDR ADDRESS OF SYMBOL IN TABLE ADA P3 LDB P4 BLF,BLF STB A,I PUT SYMBOL AS RP IN WD 4 INA LDB B2001 STB A,I RSS ( 2001B ) IN WD 5 JMP SWRSS,I * * SKP * THE BUFCL SUBROUTINE STUFFS A 60 WORD BUFFER WITH CALL+1 * * * CALLING SEQUENCE: * A = IGNORED * JSB BUFCL * CALL+1 = DATA TO STUFFED * * RETURN: CONTENTS OF A AND B ARE DESTROYED * BUFCL NOP LDB DLBUF LDA N60 STA WDCNT SET BUFFER LENGTH = 60 LDA BUFCL,I GET STUFF DATA STA B,I CLEAR BUFFERw WORD INB ISZ WDCNT ALL WORDS CLEAR? JMP *-3 NO - CONTINUE CLEARING ISZ BUFCL JMP BUFCL,I RETURN * WDCNT NOP TEMPORARY WORD COUNTER * * * * * MISSING SYSTEM SYMBOL -- ERROR MESSAGE * MSENT NOP LDA PRERR SZA PRINT ERROR? JMP MSENT,I NO , PRINTED PREVIOUSLY LDA P15 YES JSB LDRER PRINT " MS ENT " CCA STA PRERR SET ERROR PRINTED FLAG JMP MSENT,I * * SKP * TO ALLOCATE A BASE PAGE LINK * * * JSB TABLE ENTRY #1,I L.ABP * DEF RETRN * DEF DUMY RETURNS DUMMY BP ADDRESS NEG = ERROR * DEF REAL RETURNS REAL BP ADDRESS * DBP NOP RBP NOP L.ABP NOP JSB .ENTR DEF DBP LDA LNKDR GET LINK DIRECTION CPA N1 IS IT A SYSTEM LINK ? JMP L.A10 YES LDA CBP.L GET REAL BP ADA LDBP ADD LOWER BOUND FOR DUMMY BP CPA CSDBP HAS IT REACH SYS BP AREA? JMP L.A20 YES , ERROR STA DBP,I INA STA CUDBP LDA CBP.L GET CURRENT USER REAL BP STA RBP,I INA STA CBP.L UPDATE CURRENT REAL BP JMP L.ABP,I RETURN * * SYSTEM LINK ALLOCATION * L.A10 LDA CBP.L GET REAL BP ADA LDBP ADD LOWER BOUND FOR DUMMY BP CPA CUDBP HAS IT REACH USER BP AREA? JMP L.A20 YES , ERROR STA DBP,I NO , STORE DUMMY BP ADA N1 STA CSDBP UPDATE CURRENT SYS DUM BP LDA CBP.L STA RBP,I STORE REAL BP ADA N1 STA CBP.L UPDATE CURRENT SYS REAL BP JMP L.ABP,I * L.A20 CCA ERROR STA DBP,I LDA P23 JSB LDRER BASE PAGE LINKAGE OVERFLOW JMP EXIT * * * SKP * * TO SCAN DUMMY BASE PAGE ( OR EXISTING BASE PAGE ) * FOR AN EXISTING BASE LINK. * * JSB TABLE ENTRY #2,I L.SCN * DEF RETRN * DEF FVALUE VALUE TO SCAN FOR (REAL BP) * DEF BPADR +/- ADDRESS TO USE / NOT FOUND * VALAD NOP ADDRESS OF VALUE BPADR NOP L.SCN NOP JSB .ENTR DEF VALAD LDA VALAD,I GET VALUE TO SCAN FOR LDB TDBP SCAN SYS DUMMY BP L.S20 CPB CSDBP IS IT EQUAL TO CURRENT SYS DUM BP JMP L.S30 YES , TRY USER BASE PAGE CPA B,I IS IT EQUAL TO SEARCH VALUE JMP FNDSY YES , SYSTEM BP LINK ADB N1 NO, ADD LINK DIRECTION FOR NEXT BP VALUE JMP L.S20 NO CONTINUE SEARCH FNDSY CMB,INB CALCULATE REAL BP ADDRESS ADB TDBP ADD TOP OF DUMMY BP ADDRESS CMB,INB DIFFERENCE BETWEEN CURRENT AND TOP DUM BP ADB B1777 SUBTRACT FROM TOP OF REAL BP STB BPADR,I THIS IS THE REAL LINK JMP L.SCN,I RETURN * L.S30 LDB LDBP LOWER BOUND FOR USER DUMMY BP ADB BPFWA SET USER BP LOCATION L.S60 CPB CUDBP IS IT EQUAL CURRENT USER DUM BP? JMP NOTF YES , RETURN NOT FOUND CPA B,I JMP FNDUS YES , FOUND USER BP INB NO , GET NEXT ADDRESS JMP L.S60 IS IT EQUAL TO CURRENT BP? FNDUS LDA LDBP FOUND USER BP CMA,INA ADB A STB BPADR,I JMP L.SCN,I * NOTF CCB NOT FOUND STB BPADR,I JMP L.SCN,I * SKP * * ROUTINE TO FIND SYSTEM SYMBOL AND PATCH UP ITS VALUE * * CALLING SEQUENCE * * LDA ADDRESS OF SYMBOL * LDB VALUE TO PATCH IN * JSB FSYMB * ERROR RETURN * NORMAL RETURN * FSYMB NOP STB PVAL SAVE PATCH VALUE JSB LADD FIND SYMBOL SZA ANY ERROR JMP ERTN YES , ERROR LDA PVAL PATCH VALUE LDB VALUA JSB STCR1 ISZ FSYMB NORMAL RETURN ERTN JMP FSYMB,I * PVAL NOP SKP * * FIND SYMBOL IN SYMBOL TABLE * * CALLING SEQUENCE * LDA ADDRESS OF SYMBOL IN ASCII * JS'B LADD * NORMAL RETURN * (A)=RESULT * * LADD NOP STA SYBAD JSB L.ADD DEF *+5 SYBAD NOP DEF VALUA DEF SADDR DEF RESLT LDA RESLT JMP LADD,I * VALUA NOP SADDR NOP RESLT NOP * * * * SUBROUTINE TO FIND FIXUP ENTRIES * * (A)=ADDRESS OF .ZPRV/.ZRNT * (B)=CURRENT POINTER TO FIXUP ENTRY * * CALLING SEQUENCE * JSB FDFIX * END OF SEARCH * FOUND MATCHING ENTRIES * FDFIX NOP FD10 CPB FXS.L END OF FIXUP? JMP FDFIX,I INB LDA B,I GET FIXUP ENTRY WORD 2 CPA SYMCH IS IT A MATCHING ENTRY JMP FOND YES ADB P3 JMP FD10 GET NEXT ONE * FOND ADB P3 STB TEMP1 ADB N4 POINT TO WD 1 OF FIXUP LDA B,I ADDRESS OF DEF EXIT ISZ FDFIX JMP FDFIX,I * * * * READ A WORD FROM THE OUTPUT FILE * * JSB RDOUT * DEF *+3 * DEF DADD ADDRESS TO READ * DEF DVAL CONTENTS OF ADDRESS * DADD NOP DVAL NOP RDOUT NOP JSB .ENTR DEF DADD * CLB LDA DADD,I GET ADDRESS ADA P128 REC # =(ADDRESS+128)/128 DIV P128 QUOTIENT IN A = RECORD # STA RECN THIS IS THE RECORD # INB REMAINDER IN B+1 = WORD POSITION STB WORDN THIS THE WORD POSITION IN THE RECORD * JSB READF DEF *+7 DEF ODCB2 DEF IERR5 DEF RDCB5 DEF P128 DEF RTEMP DEF RECN * LDA WORDN ADA N1 ADA DDCB5 LDB A,I STB DVAL,I JMP RDOUT,I * * RECN NOP RTEMP NOP WORDN NOP * SKP * * ROUTINE TO READ IN A RELOCATABLE RECORD . * * JSB L.RED * DEF *+2 * DEF FLAG 0/-1 OK/EOF * * DFLAG NOP L.RED NOP JSB .ENTR DEF DFLAG RREAD JSB READF READ THE NEXT REL RECORD DEF *+6 DEF RDCB5 DEF IERR5 U DEF L.BUF+0 RELOCATABLE RECORD BUFFER ! DEF P60 DEF LEN ACTUAL RECORD LENGTH READ * SSA,RSS ANY ERROR? JMP FNXT2 NO STA DFLAG,I JMP L.RED,I * FNXT2 STA DFLAG,I LDA LEN GET THE RECORD LENGTH READ SZA,RSS ZERO RECORD LENGTH ? JMP RREAD YES, SO TRY AGAIN SSA,RSS NO, WAS IT A NEG LENGTH ( -1 ) JMP L.RED,I NO , RETURN STA DFLAG,I YES , SET EOF JMP L.RED,I * * SKP SKP * TABLE DEF L.ABP+0 DEF L.SCN+0 DEF L.OUT+0 * * SKP * P1 DEC 1 P2 DEC 2 P3 DEC 3 P4 DEC 4 P5 DEC 5 P6 DEC 6 P7 DEC 7 P8 DEC 8 P10 DEC 10 P12 DEC 12 P13 DEC 13 P14 DEC 14 P15 DEC 15 P16 DEC 16 P17 DEC 17 P18 DEC 18 P19 DEC 19 P20 DEC 20 P21 DEC 21 P22 DEC 22 P23 DEC 23 P24 DEC 24 P25 DEC 25 P26 DEC 26 P27 DEC 27 P28 DEC 28 P29 DEC 29 P30 DEC 30 P60 DEC 60 P120 DEC 120 P128 DEC 128 * N1 DEC -1 N2 DEC -2 N3 DEC -3 N4 DEC -4 N5 DEC -5 N6 DEC -6 N10 DEC -10 N16 DEC -16 N30 DEC -30 N60 DEC -60 * B17 EQU P15 B40 OCT 40 B77 OCT 77 B1777 OCT 1777 B2000 OCT 2000 B2001 OCT 2001 B4000 OCT 4000 B7600 OCT 76000 * M400 OCT -400 M2000 OCT -2000 M1000 OCT 100000 * BL ASC 1,BL BP ASC 1,BP CO ASC 1,CO DB ASC 1,DB DI ASC 1,DI EN ASC 1,EN LE ASC 1,LE LI ASC 1,LI LO ASC 1,LO MS ASC 1,MS NE ASC 1,NE OF ASC 1,OF ON ASC 1,ON RE ASC 1,RE SC ASC 1,SC SE ASC 1,SE ST ASC 1,ST * HIMSK OCT 177400 M7777 OCT 77777 * JMP3I JMP 3,I IJSB JSB 0,I * SKP * #PGM NOP # OF PROGRAMS #MREP NOP # OF RP,ABS & MEM RES ENT. PT. ABGRS NOP ABOOT NOP ADDR NOP NOP NOP ADFEX NOP AEXIT NOP APNDB NOP 0/1 NO DBUG/APPEND DBUG BGLOD NOP CBCOM NOP CBGBP NOP CFWBG NO2P CFWRT NOP CNMID NOP CRTBP NOP CSYBP NOP CNT10 NOP CNT20 NOP CNT30 NOP DBFLG NOP DUMBP NOP FDBUG NOP FLAG NOP FSCOM NOP 0=ACCEPT SCOM , -1=NOT ACCEPT SCOM IPTN1 DEC 1 OPEN NON EXECLUSIVE FOR REL & SEARCH JBLBX NOP JSB $LIBX,I LEN NOP LEN OF RELOCATABLE RECORD LENBC NOP LENGTH OF BLANK COMMON LOBP NOP LOW BP FOR RT PROG LOMAN NOP LOW MAIN FOR RT PROG MODFD NOP 0/1 MODULE NOT FOUND/MODULE FOUND MULT NOP 0/-1 YES/NO , NOT A MULTIPLE SCAN OUTID NOP 0/1 NO/YES OUT OF ID SEGMENTS PNTR NOP PRENT NOP PRIMARY ENTRY PT. FOR RT PROG. PRIFG NOP FLAG TO INDICATE FIRST ENTRY POINT PRIOR NOP PRIORTY REL1S NOP 0/-1 NOT 1ST REL COMMD / YES 1ST REL COMMD SBFLD NOP SUBFIELD REC , GEN=0 SCBIT NOP 0/1 DON'T SET SC IN ID/ SET SC IN ID SCOMF NOP 0/1 DO NOT USE / USE SYSTEM COMMON SMDNM NOP 0/1 NO NAME/SEARCH FOR MODULE NAME SNPLB NOP STRUP NOP STARTUP PROG FLAG 1=YES 0=NO SUBLD NOP ANY SUBROUTINE LOADED DURING A SNAP LIB SCAN SYMCH NOP TAGSM NOP TAG BIT 4 = SYS COM , BIT 5 = NOT INCLUDED IN SNAP TCBPL NOP TEMOP NOP TEMP1 NOP TEMP2 NOP TEMP3 NOP TEMP4 NOP TEMP5 NOP TLOCC NOP TSDBP NOP TYPE NOP TYPE OF MODULE TP7FG NOP VALUR NOP ZERO NOP ZPTN NOP ZTEM3 NOP ZTEM4 NOP ZTEM5 NOP * DPNAM DEF PNAME PNAME NOP NOP NOP * MDNAM NOP NOP NOP DLBUF DEF L.BUF+0 * DIDNM DEF IDNAM LIBFL BSS 6 A EQU 0 B EQU 1 * END RTLG2  & 92070-18080 2026 S C0122 &RTLG3              H0101 wASMB,R,L,C * * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * HED RTE-L GENERATOR SEGMENT 3 NAM RTLG3,5 92070-1X080 REV.2026 800410 * * NAME: RTLG3 RTE L GENERATOR SEGMENT 3 * SOURCE: 92070-18080 * PGMR: B.C. * ENT RTLG3 * * EXT EXEC * EXT DSTRG,IPBUF,SLONG,DIPBF EXT OP?,ASTRX EXT EXIT,CNUMO,L.BUF * EXT NAMR,READF,OPEN,CLOSE EXT SDCB3 EXT PPREL,LNKDR,.ENTR,.MBT,.CBT EXT TDBP,LDBP,CSDBP,CUDBP,CSRBP,CURBP,BPFWA * EXT READ,FLERR,NAMRR,DRKEY,SPACE,MOVE EXT LOCC EXT CNV99,L.ADD,LDIPX EXT ERRCT,CONSL,AINT,STCR1 EXT CBP.L,FXN.L,LSY.L,L.CLS,PRERR * SUP PRESS EXTRANIOUS LISTING * SKP * RTLG3 JSB SPACE LDA LOCC STA PPREL LDA P10 STA CONSL LDB DMES8 TABLE GENERATION JSB DRKEY OUTPUT MESSAGE JSB SPACE JMP GTCLS GET THE CLASS # * DMES8 DEF MES8 MES8 ASC 5,* TBL GEN * SKP * * GET CLASS # * GTCLS JSB SPACE LDA P16 LDB DMS10 # OF I/O CLASSES ? JSB DRKEY OUTPUT MESSAGE JSB READ GET # OF CLASSES JMP EXIT END OF FILE LDA OP? CPA CL CLASS ? JMP CL20 YES CL10 CLA,INA JSB LDRER PRINT IT JMP GTRSN AND CONTINUE TO GET RESOURCE # CL20 JSB NAMRR GET SPECIFICED SIZE SSA JMP CL10 END OF STRING LDA DIPBF GET IPBUF ADDRESS ADA P3 LDB A,I GET TYPE CPB P1 IS IT NUMERIC RSS JMP CL10 YLDA DIPBF,I GET THE # OF I/O CLASSES SSA POSITIVE ? JMP CL10 NO STA TSIZE YES , SAVE IT LDB A ADB N256 SSB,RSS LESS THAN 256? JMP CL10 NO , ERROR LDB LOCC YES JSB STCR1 OUTPUT # OF I/O CLASS * LDA D$CLT LDB LOCC JSB FSYMB FIND CLASS POINTER AND PATCH JSB MSENT MISSING SYSTEM ENTRY POINT * LDA TSIZE ALS MUTIPLY BY 2 ADA LOCC INA STA LOCC UPDATE LOCATION COUNTER STA PPREL JMP GTRSN GET THE RESOURCE # * DMS10 DEF MES10 MES10 ASC 8,* # OF I/O CLS? * D$CLT DEF $CLTA $CLTA ASC 3,$CLTA * SKP * * GET # OF RESOURCE NUMBERS * GTRSN JSB SPACE LDA P16 LDB DMS11 # OF RESOURCE # ? JSB DRKEY OUTPUT MESSAGE JSB READ GET # OF RESOURCE # JMP EXIT END OF FILE LDA OP? CPA RE RESOURCE ? JMP RS20 YES RS10 LDA P2 JSB LDRER PRINT IT JMP GTIFT AND CONTINUE TO IFT RS20 JSB NAMRR GET SPECIFICED SIZE SSA JMP RS10 END OF STRING LDA DIPBF GET IPBUF ADDRESS ADA P3 LDB A,I GET TYPE CPB P1 IS IT NUMERIC RSS JMP RS10 LDA DIPBF,I GET THE # OF RESOURCE # SSA POSITIVE ? JMP RS10 NO STA TSIZE YES , SAVE IT LDB A ADB N256 SSB,RSS LESS THAN 256? JMP RS10 NO , ERROR LDB LOCC YES JSB STCR1 OUTPUT # OF RESOURCE NUM * LDA D$RNT LDB LOCC JSB FSYMB JSB MSENT MISSING SYSTEM ENTRY POINT * LDA TSIZE ADA LOCC INA STA LOCC STA PPREL JMP GTIFT GET THE IFT TBL * DMS11 DEF MES11 MES11 ASC 8,* # OF RES NUM? * D$RNT DEF $RNTA $RNTA ASC 3,$RNTA * SKP * * GET THE IFT TABLE * GTIFT NOP LDA D$DVT LDB LOCC JSB FSYMB FIND ADDRESS OF $DVTA AND PATCH JSB MSENT MISSING SYSTEM ENTRY POINT * LDA FXN.L STA FUT1 GET FIXUP ADDRESS AND SAVE ADA N4 STA OPT3 1ST ADDRESS OF FIXUP FOR GENERATOR CLA,INA STA CIFT IFT COUNT STA CDVT DVT COUNT JSB SPACE CLA STA MAXLU SIFT1 LDA P10 LDB DMS12 IFT TBL ? JSB DRKEY OUTPUT MESSAGE JSB SPACE JSB BUFC JSB READ READ INPUT JMP EXIT LDA OP? CPA IF IFT ? JMP SIFT5 YES , IT IS AN IFT CPA EN IS IT AN END? JMP ENIFT YES , END THE IFT ENTRIES JMP IFERR NO , IT IS AN ERROR * SIFT5 CCA STA DFLAG SET DRIVER IN FLAG STA SCFLG SET SELECT CODE IN FLAG CLA STA LDTYP STA SCNM STA EXTWD LDA MSIGN STA QUEUE DEFAULT QUEUE TO FIFO * JSB NAMRR GET FILE NAME SSA JMP IFERR LDA N6 JSB MOVE DEF IPBUF+0 DEF FILE5 LDA TYPE5 AND P3 STA TYPE5 ERA,SLA IS IT A FILE? JMP F5OPN YES JMP IFERR ERROR , NOT A FILE * * F5OPN JSB OPN5 * L.MOR JSB L.RED DEF *+2 DEF FLAG SSA EOF ON THE RELO FILE? JMP IF8 YES , RETURN TO COMMAND FILE INPUT * JSB L.CLS DEF *+3 DEF TYPE DEF SBFLD SUBFIELD , GEN=0 SSA RTN REC TYPE , 0=OK , -1=CK SUM ERR JSB ERROR , -2=ILL REC * LDA TYPE CPA P1 IS IT NAM RECORD? JSB MNAM YES , SAVE NAM AS DEFAULT ENTRY POINT * * LDA TYPE CPA P7 GEN OR LOD REC? RSS YES JMP L.MOR NO , READ ANOTHER RECORD LDA SBFLD GET SUB FIELD SZA GEN RECORD? JMP L.MOR NO *  LDA LEN GET RECORD LENGTH ADA N3 SUBTRACT OFF 3 HEADER WD ALS MULTIPLY BY 2 STA LEN TO GET CHARACTER LENGTH CLA,INA STA ISTRF STA RELFG * LDA LEN LDB LBUF3 ECHO GEN RECORD JSB DRKEY * IF5 JSB NAMRF SSA JMP L.MOR READ NEXT INFO JMP IF15 * IF8 JSB CLOSE CLOSE THE RELO FILE DEF *+2 DEF SDCB3+0 * CLA STA RELFG END OF RELOC FILE * SKP * GET SELECT CODE , QUEUEING , AND TABLE EXTENSION * IF10 JSB NAMRR SSA JMP IF50 END OF STRING IF15 LDB DIPBF ADB P3 LDA B,I ARS,ARS TYPE OF SUBPARAMTER AND P3 INB LDB B,I GET ACTUAL SUBPARAMETER STB SUBP1 AND SAVE IT LDB A LDA DIPBF,I GET FNAME CPA SC IS IT THE SELECT CODE JMP SELCD YES CPA QU IS IT THE QUEUE TYPE? JMP SETQU YES CPA TX IS IT THE # OF IFT EXTENSION? JMP SETTX YES , SET THE # OF EXTENSION CPA IT IS IT THE INTERFACE TYPE? JMP SETIT YES AND HIMSK CPA E IS IT AN ENTRY PT. ? JMP SETPD YES IFERR LDA P3 IFT INPUT ERROR JSB LDRER PRINT IT JMP DVT AND CONTINUE TO GET DVT * * SELECT CODE * SELCD ISZ SCFLG JMP SCERR CPB P1 IS IT NUMERIC? RSS YES JMP SCERR LDA SUBP1 GET THE SELECT CODE ADA N16 SSA SC LT 20B JMP SCERR YES , ERROR LDA SUBP1 GET THE SELECT CODE CMA,INA ADA P63 SSA SC GT 77B? JMP SCERR YES , ERROR LDA SUBP1 GET SELECT CODE JSB CKSC GO CHECK SC FOR DUPLICATION JMP SCERR YES , DUPLICATION LDA SUBP1 GET THE SELECT CODE STA SCNM AND SAVE IT JMP IF20 SCERR LDA P13 JSB LDRER JMP IF20 SKP * * QUEUING TYPE * SETQU CLB LDA SUBP1 CPA PR IS IT PRIORITY JMP QYES YES , SET BIT TO 0 INB NO CPA FI IS IT FIFO? RSS YES JMP QUERR ERROR QYES RBR STB QUEUE JMP IF20 * QUERR LDA P14 JSB LDRER JMP IF20 * * * SET THE EXTENSION WORD * SETTX CPB P1 RSS JMP TBERR LDA SUBP1 SSA POSITIVE? JMP TBERR NO ADA N512 SSA,RSS LESS THAN 512? JMP TBERR NO , ERROR LDA SUBP1 YES , GET # OF EXT WD STA EXTWD SAVE IT JMP IF20 TBERR LDA P15 JSB LDRER * IF20 LDA RELFG SLA INFO FROM WHICH FILE? JMP IF5 IFT INFO FROM RELO FILE JMP IF10 IFT INFO FROM COMMAND FILE * * * ERROR NOP ILL REC OR CK SUM IN RELO REC CLA JSB LDRER JMP ERROR,I * SKP * * ENTRY POINT * SETPD ISZ DFLAG NOP LDA DIPBF RAL INA LDB DASCP RBL JSB .MBT MOVE BYTE DEF P5 NOP JMP IF20 * * * * SET THE INTERFACE TYPE * SETIT CPB P1 NUMERIC? RSS YES JMP TYERR NO , ERROR LDA SUBP1 GET PARAMETER SSA POSITIVE? JMP TYERR NO , ERROR CMA,INA YES , NEGATE ADA P63 SSA LESS THAN 63? JMP TYERR NO LDA SUBP1 GET PARAMETER STA LDTYP YES , SAVE THE INTERFACE TYPE JMP IF20 * TYERR LDA P12 INTERFACE TYPE ERROR JSB LDRER JMP IF20 * * SKP * IF50 LDA SCFLG GET SELECT CODE IN FLAG SSA JMP SCERR LDA DFLAG GET THE DRIVER IN FLAG SSA,RSS IS THE DRIVER ENTRY POINT IN? JMP IF55 YES LDA DMES!8 NO , USE NAM AS DEFAULT RAL LDB DASCP RBL JSB .MBT DEF P5 NOP IF55 JSB FUTP SET UP FOUR POINTER FOR FIXUP LDA LSY.L CHECK FOR FIXUP OVERFLOW CMA ADA FUT4 SSA JMP LER5 YES, OVERFLOW NOP LDA CIFT IFT # ALF,ALF IOR MSIGN FLAG AS IFT FIXUP IOR LDTYP IFT # & DRIVER TYPE STA FUT1,I WORD 1 OF FIXUP CLA STA VALUA JSB DVADD FIND DRIVER ENTRY POINT LDA P9 LDB RESLT GET RESULT SZB ENTRY POINT THERE? JSB LDRER NO , UNDEFINED DRIVER ENTRY POINT LDA VALUA GET ADDRESS OF ENTRY POINT * LDB FUT1 ADB N1 PHYSICAL DRIVER ADDRESS STA B,I WORD 2 OF FIXUP ADB N1 LDA PPREL CURRENT DVT ADDRESS STA B,I WORD 3 OF FIXUP LDA SCNM SELECT CODE ALF,ALF RAL IOR EXTWD # OF TX IOR QUEUE QUEUEING TYPE & S.C. & # OF TX STA FUT4,I WORD 4 OF FIXUP ISZ OPT.3,I BUMP UP # OF FIXUP * LDA CIFT LDB DM#37 JSB STFNM JSB SPACE LDA P8 LDB DMS37 JSB DRKEY PRINT IFT # * ISZ CIFT JMP DVT LET GET A DVT * SKP * * DASCP DEF ASCPD ASCPD NOP NOP NOP * DMS12 DEF MES12 MES12 ASC 5,* IFT TBL? * D$IFT DEF $IFTA $IFTA ASC 3,$IFTA * D$IF# DEF $IFT# $IFT# ASC 3,$IFT# * DMS13 DEF MES13 MES13 ASC 5,* DVT TBL? * D$DVT DEF $DVTA $DVTA ASC 3,$DVTA * D$DV# DEF $DVT# $DVT# ASC 3,$DVT# * DM#35 DEF M#35 DMS35 DEF MES35 MES35 ASC 3,* DVT M#35 NOP ASC 3, * DM#37 DEF M#37 DMS37 DEF MES37 MES37 ASC 3,* IFT M#37 NOP ASC 3, * DM#38 DEF M#38 DEF MES38 MES38 ASC 3,* DP M#38 NOP ASC 3, * F5 DEF FILE5 FILE5 BSS 3 TYPE5 NOP F5SC NOP F5DSC NOP IERR5 NOP * SKP * * k DVT TABLE * DVT JSB SPACE NEW LINE LDA P10 PRINT: LDB DMS13 "DVT TBL" JSB DRKEY JSB SPACE NEW LINE * SDVT1 JSB SPACE NEW LINE JSB BUFC JSB READ PRINT MESSAGE, GET REPLY JMP EXIT LDA OP? CPA EN CHARS= END ? JMP SIFT1 YES, TRY TO END CPA IF ANOTHER IFT ? JMP SIFT5 YES CPA DV IS IT A DVT? RSS YES JMP UNERR NO , IT IS AN ERROR ISZ DVTIN DVT IN FLAG SKP * CLA STA QUEUE STA DVRAD LOGICAL DRIVER ENTRY POINT STA TIMWD CLEAR TIME WORD STA EXTWD CLEAR DVT EXTENSION WORD STA #LU CLEAR THE LU COUNT STA #DP CLEAR THE DRIVER PARMETER COUNT STA MFG CLEAR ACCEPT THE PARAMETER FLAG CCA STA TBUF STA MDLFD SET FLAG MODEL NOT SPECIFIED = -1 STA BFLAG SET BUFFERING-IN FLAG STA DFLAG SET LOGICAL DRIVER IN FLAG STA RFLAG SET # OF DRIVER PARM IN FLAG STA PFLAG SET DRIVER PARMETER IN FLAG STA LUFLG SET THE LU IN FLAG LDA BLIM STA HIBUF SET THE DEFAULT LIMIT LOW=100,HIGH=400 LDA P63 SET DEFAULT DEVICE PRIORITY TO 63 STA DEVPR LDA B70 STA LDTYP SET DEFAULT DEVICE TYPE TO 70B AN INSTRUMENT * LDA FUT4 SET UP DP IN FREE MEMORY ADA N1 STA CFUT4 STA DPA DRIVER PARAMETER ADDRESS ADA N1 STA PFUT4 CLA STA CFUT4,I ZERO OUT DP COUNT * JSB NAMRR GET FILE NAME SSA JMP UNERR LDA N6 JSB MOVE DEF IPBUF+0 DEF FILE5 * JSB NAMRR GET MODEL # SSA JMP UNERR LDB DIPBF ADB P3 LDA B,I GET TYPE AND P3 SZA,RSS IS IT NULL JMP FOPEN YES CLA STA MDLFD SET FLAG MODEL SPECIFIED = 0 R LDA N10 NO JSB MOVE DEF IPBUF+0 DEF TBUF * FOPEN LDA TYPE5 GET FILE TYPE AND P3 STA TYPE5 SZA,RSS IS IT A NULL? JMP IF90 YES CPA P3 IS IT A FILE NAME? RSS YES JMP UNERR NO * JSB SPACE JSB OPN5 * * L.MR JSB L.RED DEF *+2 DEF FLAG SSA EOF ON THE RELO FILE? JMP IF80 YES , RETURN TO COMMAND FILE INPUT * JSB L.CLS DEF *+3 DEF TYPE DEF SBFLD SUBFIELD SSA RTN REC TYPE , 0=OK , -1=CK SUM ERR JSB ERROR * * LDA TYPE CPA P1 IS IT THE NAM RECORD? JSB MNAM YES , USE NAM AS THE DEFAULT ENTRY POINT * * LDA TYPE CPA P7 GEN OR LOD RECORD? RSS JMP L.MR NO , READ ANOTHER RECORD LDA SBFLD GET GEN RECORD SZA GEN RECORD? JMP L.MR NO * LDA LEN GET RECORD LENGTH ADA N3 SUBTRACT OFF 3 HEADER WD ALS MULTIPLY BY 2 STA LEN TO GET CHARACTER LENGTH CLA,INA STA ISTRF STA RELFG STA PNFLG SET FIRST TIME PRINT FLAG * IF60 JSB NAMRF SSA JMP L.MR READ NEXT INFO LDA DIPBF,I GET FIRST INPUT AND HIMSK CPA M IS IT THE MODEL #? JMP IF65 YES LDA MFG CPA P1 ACCEPT THE PARAMETERS? JMP L.MR NO , GET ANOTHER MODEL? LDA PNFLG GET PRINT IT FLAG CPA P1 RSS YES , 1ST TIME FLAG JMP IFN10 NO , NOT 1ST TIME FLAG INA STA PNFLG LDA LEN LDB LBUF3 ECHO THE GEN RECORD JSB DRKEY JMP IFN10 GET NEXT PARAMETER * IF65 CLA,INA STA MFG SET IN THE MODEL SECTION LDA MDLFD CPA P1 HAS THE MODEL # BEEN FOUND? JMP IF80 YES , CLOSE RELO FILE AND CONTIN_UE CLB NO LDA DIPBF ADA P3 STB A,I CLEAR OUT PARM TYPE WD STB TBUF+3 CLEAR OUT PARM TYPE WD LDA DIPBF COMPARE MODEL # ? RAL LDB ATBUF RBL JSB .CBT COMPARE THEM DEF P20 NOP JMP IF70 YES , MODEL # MATCHED JMP L.MR JMP L.MR IF70 CLA STA MFG ACCEPT THE PARARMETER IN MODEL # INA STA MDLFD YES , MODEL FOUND JMP IF60 * IF80 JSB CLOSE CLOSE THE RELO FILE DEF *+2 DEF SDCB3+0 * LDA MDLFD SZA DID WE FIND THE MODLE #? JMP IF90 YES , MODEL FOUND LDA P24 NO , GIVE ERROR MESSAGE JSB LDRER * IF90 CLA STA RELFG END OF RELOC FILE CCA STA PFLAG JSB SPACE * * SKP IFN JSB NAMRR SSA JMP LISCN END OF STRING IFN10 LDB DIPBF ADB P3 LDA B,I STA OFST2 SUB PARAMETER TYPE ARS,ARS AND P3 INB STB OFST1 SUB PARAMETER ADDRESS LDB B,I GET ACTUAL SUBPARAMETER STB SUBP1 AND SAVE IT LDB A LDA DIPBF,I CPA BL IS IT BUFFER LENGTH ? JMP SETBL YES CPA DP IS IT DRIVER PARAMETER ? JMP SETDP YES CPA DT IS IT DRIVER TYPE ? JMP SETDT YES CPA LU IS IT LOGICAL UNIT ? JMP SETLU YES CPA PR IS IT PRIORITY ? JMP SETPR YES CPA TO IS IT TIME OUT ? JMP SETTO YES CPA TX IS IT # OF TABLE EXTENSION ? JMP SETBX YES CPA DX IS IT # OF DRIVER PARAMETER JMP SETDX YES CPA QU IS IT QUEUING TYPE? JMP STQU YES , SET QUEUEING TYPE CPA DASH IS IT A CONTINUATION? JMP MORIN YES AND HIMSK CPA E IS IT THE DRIVER ENTRY POINT? JMP SETLD YEa{S LDA P11 WHAT IS IT ?????? JSB LDRER JMP SDVT1 * MORIN JSB READ JMP EXIT JMP IFN10 * * IFN20 LDA RELFG SLA JMP IF60 JMP IFN * SKP * * SET TIME OUT * SETTO CPB P1 NUMERIC? RSS JMP TOERR NO , ERROR LDA SUBP1 GET TIME OUT VALUE SZA CMA ONE'S COMPLEMENT FOR THAT TIME STA TIMWD SAVE FOR OUTPUT JMP IFN20 * TOERR LDA P16 JSB LDRER JMP IFN20 * * TABLE EXTENSION * SETBX CPB P1 RSS JMP TXERR LDA SUBP1 GET # OF TABLE EXTENSION ADA N512 SSA,RSS LESS THAN 512? JMP TXERR NO , ERROR LDA SUBP1 YES , GET # OF TABLE EXTENSION STA EXTWD SAVE # OF EXTENSIONS JMP IFN20 * TXERR LDA P15 JSB LDRER JMP IFN20 * * DEVICE PRIORITY * SETPR CPB P1 IS IT NUMERIC? RSS JMP PRERS LDA SUBP1 GET DEVICE PRIORITY ADA N64 SSA,RSS LESS THAN 64? JMP PRERS NO , DEVICE PR ERROR LDA SUBP1 YES STA DEVPR JMP IFN20 * PRERS LDA P20 JSB LDRER JMP IFN20 * SKP SKP * * DRIVER PARAMETER SIZE * SETDX CPB P1 IS IT NUMERIC? RSS YES JMP DXERR NO , ERROR LDA SUBP1 GET DX SIZE SSA POSITIVE? JMP DXERR NO ADA N128 SSA,RSS LESS THAN 128? JMP DXERR NO , ERROR LDA SUBP1 GET SIZE CMA,INA NEGATE ADA PFUT4 FIXUP ADDRESS STA DPBND SAVE IN DP LOWER BOUND CMA,INA NEGATE ADA LSY.L ADD SYMBOL TABLE UPPER BOUND SSA,RSS OVERFLOW? JMP LER5 YES , SYSTEM OVERFLOWED STB RFLAG SET DX IN * LDA SUBP1 GET NEW SIZE CMA,INA ADA #DP ADD OLD SIZE SSA,RSS IS NEW DX (BIGGER? JMP SDX20 NO STA ZTEM5 YES , SAVE DIFFERENCE CLB CLEAR THE BIGGER AREA LDA SUBP1 CMA,INA ADA PFUT4 STDX5 STB A,I CLEAR NEW DP AREA INA ISZ ZTEM5 JMP STDX5 SDX20 LDB SUBP1 STB #DP STB CFUT4,I NEW DP COUNT JMP IFN20 * DXERR LDA P21 JSB LDRER JMP IFN20 * SKP * * DEVICE TYPE * SETDT CPB P1 RSS JMP DTERR LDA SUBP1 SSA POSITIVE? JMP DTERR NO ADA N64 SSA,RSS LESS THAN 64? JMP DTERR NO LDA SUBP1 YES ALF,ALF STA LDTYP AND SAVE IT JMP IFN20 * DTERR LDA P18 JSB LDRER JMP IFN20 * SKP * * SET BUFFER LIMITS * SETBL CLA LDB SUBP1 CPB BU IS 1ST PARM BUFFERING? JMP SBL5 YES ,SET FLAG CPB UN NO , IS IT UNBUFFERING? JMP SBL10 YES SZB IS IT A NULL? JMP BLERR NO , ERROR RSS YES SBL5 STB BFLAG SET BUFFER FLAG SBL10 LDB DIPBF YES , GET LOWER LIMIT ADB P3 LDA B,I ARS,ARS ARS,ARS AND P3 CPA P1 IS IT NUMERIC? RSS YES JMP BLERR NO , ERROR ADB P2 LDA B,I GET LOWER LIMIT SSA POSITIVE? JMP BLERR NO STA LOBUF AND STORE IT LDB DIPBF GET UPPER LIMIT ADB P3 LDA B,I ALF,ALF RAL,RAL AND P3 CPA P1 IS IT NUMERIC? RSS YES JMP BLERR ADB P3 LDA B,I GOT IT STA HIBUF LDB LOBUF GET LOWER LIMIT CMB,INB NEGATE ADB HIBUF SSB HI LIMIT > LOW LIMIT JMP BLERR NO , ERROR ASR 4 DIVIDE BY 16 BLF,BLF SHIFT UP TO UPPER 8 BITS STB HIBUF LDB LOBUF * ASR 4 STB A IOR HIBUF MERGE IN THE HIBUF LIMIT STA HIBUF SAVE IT JMP IFN20 * BLERR LDA P17 JSB LDRER JMP IFN20 SKP * * SET DRIVER PARAMETER * SETDP SZB,RSS NULL? JMP SDP30 YES , EXIT LDA B60 STA MASK SAVE IT AS A MASK LDA N5 STA CNT1 LDB SUBP1 GET PARAMETER POSITION POINTER CMB,INB ADB #DP ADD DP COUNT SSB IS PARAMETER WITHIN RANGE? JMP DPERR NO , ERROR * LDB SUBP1 GET POINTER AGAIN CMB,INB ADB PFUT4 INB ADDRESS TO STORE DP SDP10 LDA OFST2 GET PARMATER TYPE AND MASK SZA,RSS JMP IF NOT NULL JMP SDP30 NULL , FINISH LDA MASK RAL,RAL STA MASK * ISZ OFST1 SUB PARM ADDRESS LDA OFST1,I GET SUB PARM CPB DPBND ADDRESS EXCEEDED DP BOUND? JMP DPERR YES STA B,I ADB N1 ISZ CNT1 ANY MORE SUB PARM? JMP SDP10 YES SDP30 JMP IFN20 NO * DPERR LDA P19 JSB LDRER JMP IFN20 * SKP * * SET LU'S * SETLU ISZ LUFLG GET THE LU'S JMP LUERR CPB P1 IS IT NUMERIC? RSS JMP LUERR LDA SUBP1 GET SUB PARM 1 STA LU1 LDA OFST2 GET PARM TYPE AND B60 GET 2ND SUB PARM TYPE SZA,RSS JMP IFN IT IS THE END ARS 4 CPA P1 IS IT NUMERIC? JMP LUERR NO , ERROR ISZ OFST1 YES LDA OFST1,I GET IT STA LU2 STORE 2ND LU LDA OFST2 3RD SUB PARM TYPE AND B300 SZA,RSS JMP IFN IT IS THE END CPA P64 IS IT NUMERIC? RSS YES JMP LUERR ISZ OFST1 LDA OFST1,I GET 3RD LU STA LU3 AND STORE IT JMP IFN20 * LUERR LDA P22 JSB LDRER JMP IFN20 * jESKP * * * ENTRY POINT * SETLD ISZ DFLAG NOP LDA DIPBF RAL INA LDB DASCP RBL JSB .MBT MOVE BYTE DEF P5 NOP * CLA STA VALUA JSB DVADD FIND DRIVER ENTRY POINT LDA P9 LDB RESLT SZB ERROR JSB LDRER YES , UNDEFINED DRIVER ENTRY POINT LDA VALUA STA DVRAD SAVE IN DRIVER ADDRESS JMP IFN20 * * * UNERR LDA P4 JSB LDRER JMP SDVT1 * * SET DVT QUEUEING * STQU CLB LDA SUBP1 GET THE PARAMETER CPA PR IS IT PRIORITY? JMP QOK YES INB NO CPA FI IS IT FIFO? RSS YES JMP QERR QOK RBR STB QUEUE JMP IFN20 * QERR LDA P14 JSB LDRER JMP IFN20 * SKP * LISCN JSB CNUMO CONVERT DVT ADDRESS TO OCTAL DEF *+3 DEF PPREL+0 DEF MES35+4 LDA CDVT LDB DM#35 JSB STFNM JSB SPACE LDA P14 LDB DMS35 JSB DRKEY PRINT DVT ADDRESS JSB SPACE * JSB BUFC LDB DSTRG ADDRESS OF STRING CCA STA B,I DVT 1 LINK WORD INB LDA QUEUE STA B,I DVT 2 QUEUE BIT 15 INB LDA PPREL ADA P2 STA B,I DVT 3 CIRCULAR NODE POINT TO DVT 3 INB LDA PPREL STA B,I DVT 4 CIRCULAR DVT POINT TO DVT 1 ADB P2 LDA LDTYP STA B,I DVT 6 DEVICE TYPE ADB P2 CLA ISZ BFLAG IS BUFFERING REQUESTED ? IOR MSIGN YES , SET BIT 15 STA B,I DVT 8 B & CLEAR BUFFER ACC. INB LDA HIBUF STA B,I DVT 9 BUFFER LIMIT & 1ST TIME BIT ADB P2 CCA STA B,I DVT 11 TIME OUT LIST LINKAGE ADB P2 LDA TIMWD STA B,I DVT 13 TIME OUT VALUE INB LDA DVRA-D STA B,I DVT 14 LOGICAL DRIVER ADDRESS ADB P6 LDA DEVPR IOR MSIGN STA B,I DVT 20 DVR COMMON & DEV PRIORTY LDA #DP GET # OF DVR PARM ALF,ALF SHIFT TO UPPER BYTE RAL AND HIMSK ADA EXTWD LDB DSTRG ADB P20 STA B,I DVTP & DVTX LDA PPREL GET CURRENT DVT ADDRESS STA ADVT AND SAVE IT IN ADVT LDB A ADB P21 STB PPREL JSB SETCR OUTPUT IN ABS ISZ PPREL JSB BUFC CLEAR THE OUTPUT BUFFER LDA #DP DRIVER PARAMETER? SZA,RSS JMP CH250 NO CMA,INA YES NEGATE # OF DRIVER PARAMETER STA #DP AND STORE IT BACK CLA,INA STA TCNT DP COUNT CH0 LDA DSTRG ADDRESS OF OUTPUT BUFFER STA ZTEMP LDA N40 OUTPUT BUFFER SIZE STA CNT1 CLA STA CNT2 # OF DRIVER PARAMETER IN OUTPUT BUFFER CH050 LDA PFUT4,I GET DRIVER PARAMETER STA ZTEMP,I STORE IT IN THE OUTPUT BUFFER * ISZ ZTEMP BUMP UP OUTPUT ADDRESS LDA PFUT4 ADA N1 STA PFUT4 DECREASE ADDRESS ISZ CNT2 BUMP UP # OF DRIVER PARM IN OUTPUT BUFFER ISZ #DP END OF DRIVER PARAMETER ? RSS JMP CH150 YES ISZ CNT1 END OF OUTPUT BUFFER ? JMP CH050 NO , GET MORE DRIVER PARM CH150 LDB CNT2 # OF DRIVER PARAMETER LDA PPREL ADB PPREL ADB N1 STB PPREL JSB SETCR OUTPUT ABS ISZ PPREL JSB BUFC LDA #DP SZA ANY MORE DRIVER PARAMETER? JMP CH0 YES * * * SKP CH250 JSB SPACE CLA STA OFST1 STA OFST2 LDA LU1 GET LU 1 SZA JSB CKDLU PREVIOUSLY DEFINE ? JSB LUER YES , ERROR STA OFST1 NO LDA LU2 GET 2ND LU SZA,RSS JMP CH020 JSB CKDLU  PREVIOUSLY DEFINE ? JSB LUER YES , ERROR ALF,ALF NO , EVERYTHING OK STA OFST2 LDA LU3 GET 3RD LU SZA,RSS JMP CH020 JSB CKDLU PREVIOUSLY DEFINE ? JSB LUER YES , ERROR IOR OFST2 NO STA OFST2 CH020 JSB FUTP SET UP FOUR POINTER FOR FIXUP NOP LDA CIFT GET IFT # ADA N1 ALF,ALF MOVE TO UPPER BYTE IOR EXTWD IFT # & # OF TX STA FUT1,I WORD 1 OF FIXUP LDA ADVT CURRENT DVT ADDRESS LDB FUT1 ADB N1 STA 1,I WORD 2 OF FIXUP ADB N1 LDA OFST1 1ST LU STA 1,I WORD 3 OF FIXUP ADB N1 LDA OFST2 2ND & 3RD LU STA B,I WORD 4 OF FIXUP ISZ OPT.3,I BUMP UP # OF FIXUP LDA LSY.L CMA ADA FUT4 SSA CHECK FOR MEMORY OVERFLOW JMP LER5 * * ISZ CDVT CLA STA FTIME JSB SPACE JMP SDVT1 * SKP * LUER NOP LDA P22 LU ALREADY DEFINED JSB LDRER CLA JMP LUER,I * * LER5 LDA P8 SYSTEM OVERFLOW JSB LDRER JMP EXIT START OVER * * ENIFT LDA PPREL STA LOCC * LDB CIFT ADB N1 LDA D$IF# JSB FSYMB PATCH # OF IFT'S JSB MSENT MISSING SYSTEM ENTRY POINT * LDB CDVT ADB N1 LDA D$DV# JSB FSYMB PATCH # OF DVT'S JSB MSENT MISSING SYSTEM ENTRY POINT * * SKP * * NODE INPUT * JSB SPACE NEW LINE CLA,INA STA CNODE SET NODE COUNT=1 LDA P15 LDB ME27A "* NODE INPUT" JSB DRKEY JSB SPACE * ND0 NOP LDA CNODE LDB M27CA JSB STFNM JSB SPACE LDA P18 LDB ME27B "* NODE XX = LU #'S " JSB DRKEY JSB READ JMP EXIT LDA CNODE ALF,ALF ST8A CNODE LDA OP? CPA EN IS IT THE END JMP ENODE YES CPA NO IS IT A NODE? RSS YES JMP NDERR ??? WHAT IS IT ? LDA FUT4 PREPARE THE FIXUP ADA N1 STA CFUT4 SAVE COUNTER ADDRESS ADA N1 STA PFUT4 SAVE POINTER ADDRESS CLA STA CFUT4,I ZERO OUT # OF LU'S * ND5 JSB NAMRR SSA JMP NDFIN LDB DIPBF ADB P3 LDA B,I GET TYPE CPA P1 IS IT NUMERIC? RSS YES JMP NDERR NO , ERROR LDA DIPBF,I STA #LU NO , LET SAVE IT LDA OPT.3,I # OF FIXUP CMA,INA STA OFST1 AND SAVE IT LDB OPT3 ADDRESS OF FIXUP ND010 STB CNT1 CURRENT ADDRESS OF FIXUP LDA B,I GET WORD 1 OF FIXUP SSA IS IT A DVT FIXUP ENTRY JMP ND060 NO ADB N2 YES,MOVE TO LU LDA B,I GET LU STB OFST2 ADDRESS OF NODE AND LOMSK CPA #LU DOES THIS EQUAL FIXUP LU ? JMP ND050 YES ADB N1 NO GET NEXT WORD LDA B,I AND HIMSK UPPER BYTE ALF,ALF CPA #LU DOES THIS EQUAL FIXUP JMP ND050 YES LDA B,I NO , GET WORD AGAIN AND LOMSK CPA #LU DOES THIS EQUAL FIXUP ? JMP ND050 YES JMP ND060 NO ND050 LDA OFST2,I HAS THIS LU BEEN DEFINE IN A NODE ? AND HIMSK SZA NO , SET NODE JMP NDERR YES , ERROR LDA OFST2 LU MATCHED , GET FIX ADDRESS STA PFUT4,I SAVE THE NODE ADDRESS ISZ CFUT4,I BUMP UP THE COUNT LDA PFUT4 ADA N1 STA PFUT4 JMP ND5 GET ANOTHER LU * ND060 ISZ OFST1 NEXT FIXUP RSS JMP NDERR UNABLE TO FIND THE LU LDB CNT1 ADB N4 GET NEXT FIXUP ADDRESS JMP ND010 * NDFIN LDA CFUT4,I GET # OF FIXUP  CMA,INA STA CFUT4,I LDA CFUT4 ADA N1 STA PFUT4 NODE ADDRESS ND100 LDB PFUT4,I GET NODE ADDRESS LDA B,I GET NODE IN FIXUP IOR CNODE INSERT NODE # STA B,I SAVE IT BACK LDA PFUT4 GET NEXT VALUE ADA N1 STA PFUT4 ISZ CFUT4,I ARE WE FINISH? JMP ND100 NO ND105 LDA CNODE ALF,ALF INA STA CNODE JMP ND0 * NDERR LDA P6 NODE ERROR JSB LDRER JMP ND105 * ME27A DEF *+1 ASC 8,* DVT NODE LIST ME27B DEF *+1 ASC 3,* NODE ME27C NOP ASC 5,= LU #'S? M27CA DEF ME27C * * CNODE NOP LOMSK OCT 377 SKP SKP * * NODE * ENODE LDA N2 STA OFST1 NODE INFO OFFSET LDA N2 STA OFST2 DVT ADDRESS OFFSET CCA STA BFLAG NODE FLAG LDA OPT.3,I # OF FIXED UP ENTRIES LDB CNODE # OF NODE BLF,BLF ADB N1 STB CNODE SZB ANY NODE? JSB FIXTB YES ,FIXUP THE NODE LINKS IN THE DVT CLA NO STA OFST1 IFT INFO OFFSET LDA N3 STA OFST2 DVT ADDRESS OFFSET CLA STA BFLAG IFT FLAG LDA OPT.3,I # OF FIXUP ENTRIES LDB CIFT ADB N1 SZB,RSS ANY FIXUP ENTRIES? JMP F05 NO JSB FIXTB YES * * FIX DVT EXT WORD FOR DVT ENTRIES NOT IN * A NODE CONFIGURATION * LDA OPT.3,I GET & NEGATE # OF FIXUPS CMA,INA STA CNT1 LDB OPT3 FIXUP ADDRESS FX5 STB PFUT4 LDA B,I GET FIRST FIXUP SSA IS THIS A DVT FIXUP? JMP FX15 NO , GET NEXT DVT AND LOMSK SZA,RSS IS EXT WD ZERO? JMP FX15 YES , GET NEXT DVT STA EXTWD NO , SAVE # OF EXT WD ADB N2 POINT TO NODE WORD LDA B,I GET NODE IN DVT FIXUP AND HIMSK SZA IS NODE ZERO?  JMP FX15 NO , GET NEXT DVT ADB P1 YES , POINT TO DVT FIXUP WD 2 LDB B,I GET REAL DVT ADDRESS ADB P21 POINT TO DVT 22 LDA PPREL JSB STCR1 PATCH UP DVT 22 * LDA PPREL ADA EXTWD STA PPREL UPDATE LOCC * FX15 ISZ CNT1 ANY MORE FIXUP? RSS YES JMP F05 NO LDB PFUT4 ADB N4 JMP FX5 * SKP * * FIXUP TABLE * FIXTB NOP CMA,INA STA CNT1 # OF FIXUP ENTRIES STA Z1TMP SAVE # OF FIXUP ENTRIES CMB,INB STB CNT2 # OF NODE OR IFT ENTRIES CLA STA CFUT4 FI05 ISZ CFUT4 THE NODE # OR IFT # TO MATCH LDA OPT3 STA PFUT4 CCA STA ZTEMP FIRST TIME FLAG LDA Z1TMP RESTORE # OF FIXUPS STA CNT1 FI10 LDA PFUT4,I GET FIRST FIXUP SSA IS THIS A DVT ? JMP FI15 NO GET NEXT FIXUP AND LOMSK STA EXTWD # OF TX LDB PFUT4 ADB OFST1 LDA B,I GET NODE # OR IFT # AND HIMSK ALF,ALF CPA CFUT4 DOES IT MATCH CURRENT # ? JMP FI20 YES FI15 ISZ CNT1 END OF FIXUP? RSS NO JMP FI40 YES LDA PFUT4 ADA N4 STA PFUT4 JMP FI10 * FI20 ISZ ZTEMP IS IT THE 1ST MATCH? JMP FI30 NO LDA PFUT4 YES ADA N1 LDA A,I GET DVT ADDRESS STA ADDR1 SAVE IT AS THE 1ST ADDRESS STA ADDR2 SAVE IT AS THE 2ND ADDRESS LDA EXTWD STA MAXRD JMP FI15 * FI30 LDA PFUT4 ADA N1 LDA A,I GET THE MATCHING DVT'S ADDRESS STA ADDR3 ADDRESS OF LINKING DVT LDB BFLAG IF NODE FIXUP ADD 2 POINT TO DVT 3 SZB ADA P2 LDB OFST2 LOCATION WITHIN THE DVT CMB,INB ADB ADDR2 DVT ADDRESS JSB STCR1 ABS OUTPUT LDA BFLAG ΰ SZA IS THIS A NODE SEARCH ? RSS YES JMP FI35 NO LDA EXTWD SZA,RSS ANY TABLE EXTENSION ? JMP FI35 NO LDA PPREL LDB ADDR2 ADB P21 JSB STCR1 OUTPUT THE DVTX ADDRESS LDA EXTWD # OF TX CMA,INA NEGATE ADA MAXRD ADD CURRENT MAX SSA IS IT POSITIVE ? RSS NO JMP FI35 YES LDA EXTWD REPLACE CURRENT MAX STA MAXRD FI35 LDA ADDR3 SET LAST ADDRESS AS CURRENT LINKING ADDRESS STA ADDR2 CURRENT LINKING ADDRESS JMP FI15 * * COMPLETED ONE PASS,FIXUP LAST WITH 1ST TO CLOSE LOOP * FI40 LDB ADDR2 SECOND DVT ADDRESS LDA OFST2 GET DVT OFFSET CMA,INA ADB A DVT 2 + OFFSET FOR PATCH LDA BFLAG SZA IF NODE FIXUP ADD 2 POINT TO DVT 3 LDA P2 ADA ADDR1 PLACE ADDRESS 1 INTO DVT 2 JSB STCR1 LDA BFLAG SZA IS THIS A NODE ? RSS YES JMP FI50 NO LDA MAXRD SZA,RSS ANY TABLE EXTENSION FOR THIS NODE ? JMP FI50 NO LDA PPREL OUTPUT DVTX ADDRESS LDB ADDR2 ADB P21 JSB STCR1 LDA PPREL ADA MAXRD RESERVE MAX EXT TABLE FOR THE NODE STA PPREL * FI50 ISZ CNT2 FINISH WITH # OF NODE OR # OF IFT JMP FI05 NO JMP FIXTB,I YES * SKP * F05 LDB PPREL STB LOCC LDA D$IFT JSB FSYMB FIND AND PATCH IFT ADDRESS JSB MSENT MISSING SYSTEM ENTRY POINT * LDA OPT.3,I GET # OF FIXUP SZA,RSS ANY FIXUP? JMP PWRFL NO , DO POWER FAIL CMA,INA NEGATE STA CNT1 AND SAVE LDA OPT3 STA ADDR1 IFT ADDRESS CLA STA CDVT * F10 JSB BUFC LDB DSTRG STB PFUT4 CCA STA PFUT4,I IFT 1 TIME OUT LIST L&INKAGE ISZ PFUT4 ISZ PFUT4 LDA PFUT4 SAVE IFT 3 ADDRESS STA ZTEMP IN ZTEMP ISZ PFUT4 LDA ADDR1,I GET 1ST WORD OF FIXUP SSA,RSS IS THIS A IFT ENTRY? JMP F80 NO AND B7740 YES STA IFTNM IFT NUMBER LDA ADDR1,I GET 1ST WORD AGAIN AND LOMSK ALF,ALF STA DTYPE LDB ADDR1 ADB N1 POINT TO FIXUP 2ND WORD LDA B,I STA PFUT4,I IFT 4 PHYSICAL DRIVER ADDRESS ISZ PFUT4 LDA PPREL CURRENT IFT ADDRESS STA DPA AND SAVE IT STA B,I PLACE IT IN FIXUP WORD 2 ADB N1 POINT TO FIXUP 3RD WORD LDA B,I DVT ADDRESS STA PFUT4,I IFT 5 DVT REFERENCE ISZ PFUT4 ADB N1 POINT TO FIXUP 4TH WORD CLA STA QUEUE LDA B,I GET 4TH FIXUP WORD SSA IS Q SET ? ISZ QUEUE YES AND B7700 NO RAR ALF,ALF SHIFT TO LOW BYTE STA SCNM SELECT CODE LDA B,I GET WORD 4 AGAIN AND B777 EXTENSION WORD STA EXTWD LDA QUEUE RAR MOVE TO BIT 15 STA ZTEMP,I IFT 3 QUEUE LDA DTYPE IOR SCNM STA PFUT4,I IFT 6 INTERFACE TYPE & SC ISZ PFUT4 ADB N1 STB ADDR1 LDA EXTWD IOR B2000 STA PFUT4,I IFT 7 IFT EXTENSION LENGTH ISZ PFUT4 * JSB CNUMO DEF *+3 DEF PPREL+0 DEF MES37+4 ISZ CDVT LDA CDVT LDB DM#37 JSB STFNM JSB SPACE LDA P14 LDB DMS37 JSB DRKEY PRINT IFT ADDRESS * LDA PPREL LDB A ADB P6 STB PPREL JSB SETCR OUTPUT IFT TABLE ISZ PPREL LDA PPREL ADA EXTWD RESERVE SPECIFIED # OF EXT WDS STA PPREL * * PATCH IFT ADDRESS INTO DVT * LDA OPT.3,I CMA,INA STA CNT2 # OF FIXUP LDB OPT3 F50 STB ADDR2 IFT ADDRESS LDA ADDR2,I SSA IS THIS A DVT ENTRY ? JMP F55 NO AND B7740 YES CPA IFTNM EQUAL TO CURRENT ? RSS YES JMP F55 ADB N1 LDB B,I GET DVT FIXUP WORD 2 DVT'S ADDRESS ADB P4 DVT WORD 5 IFT REFERENCE LDA DPA IFT ADDRESS JSB STCR1 F55 ISZ CNT2 ANY MORE DVT'S ? RSS JMP F100 NO LDB ADDR2 GET NEXT DVT ADB N4 JMP F50 F80 LDA ADDR1 ADA N4 STA ADDR1 F100 ISZ CNT1 ANY MORE IFT'S ? RSS YES JMP PWRFL NO , CHECK POWER FAIL JMP F10 NEXT IFT * * B2000 OCT 2000 B7740 OCT 77400 B7700 OCT 77000 B777 OCT 777 * ADDR1 NOP ADDR2 NOP ADDR3 NOP * SKP * * CHECK FOR THE POWER FAIL DRIVER * PWRFL JSB L.ADD FIND ID.43 DEF *+5 DID43 DEF ID.43 DEF VALUA DEF SADDR DEF RESLT LDA RESLT SZA IS ID.43 ( POWERFAIL DRIVER ) THERE ? JMP FIXLU NO , DO NOTHING LDA VALUA YES , BUILD A DUMMY IFT STA Z1TMP SAVE ADDRESS OF ID.43 LDB PPREL LDA D$PIF JSB FSYMB FIND & PATCH $PIFT WITH ADDR OF DUMMY IFT JSB MSENT MISSING SYSTEM ENTRY POINT * LDB PPREL CCA PATCH DUMMY IFT 1 WITH -1 JSB STCR1 LDB PPREL PATCH DUMMY IFT 4 WITH ADB P3 ADDRESS OF ID.43 STB PPREL LDA Z1TMP ADDRESS OF ID.43 JSB STCR1 * ISZ PPREL LDB PPREL CLA,INA PLACE 1 IN DUMMY IFT 5 JSB STCR1 * LDB PPREL ADB P2 STB PPREL LDA B1001 SET BIT 9 OF DUMMY IFT 7 & 1 WD OF EXT JSB STCR1 ISZ PPREL ISZ PPREL JMP FIXLU * D$PIF DEF $PIFT $PIFT ASC 3,$PIFT * ID.43 ASC 3,ID.43 * SKP * * BUIvLD THE LU TABLE * FIXLU LDB PPREL STB LOCC LDA D$LUT JSB FSYMB FIND AND PATCH LU TABLE ADDRESS JSB MSENT MISSING SYSTEM ENTRY POINT * LDA D$LU# LDB MAXLU JSB FSYMB FIND AND PATCH # OF LU JSB MSENT MISSING SYSTEM ENTRY POINT * JSB BUFC LDB DIPBF CLEAR 24 ADDITIONAL WORDS LDA N24 FOR A TOTAL OF 64 WORDS STA WDCNT EQUAL TO MAX # OF LU CLA LP1 STA B,I INB ISZ WDCNT JMP LP1 LDA OPT.3,I # OF FIXUP ENTRIES SZA,RSS ANY FIXUP? JMP SINTT NO , DO INTERRUPT CMA,INA STA CNT1 LDB OPT3 LU10 STB PFUT4 POINTER FOR FIXUP ENTRY LDA PFUT4,I GET 1ST WORD OF FIXUP SSA IS THIS A DVT ENTRY JMP LU20 NO , NEXT FIXUP ADB N1 LDA B,I GET DVT ADDRESS STA ADVT AND SAVE IT ADB N1 STB ZTEMP LDA B,I AND LOMSK 1ST LU SZA,RSS ZERO ? JMP LU20 YES , NEXT DVT ADA N1 ADA DSTRG LDB ADVT DVT ADDRESS STB A,I SAVE IT IN THE LU TABLE LDA ZTEMP ADA N1 STA ZTEMP LDA ZTEMP,I AND HIMSK SZA,RSS ANY MORE LU ? JMP LU20 NO ALF,ALF ADA DSTRG ADA N1 STB A,I STORE DVT IN 2ND LU LOCATION LDA ZTEMP,I AND LOMSK SZA,RSS ANY MORE LU ? JMP LU20 NO ADA DSTRG ADA N1 STB A,I STORE DVT IN 3ND LU LOCATION LU20 ISZ CNT1 END OF FIXUP RSS JMP LU40 LDB PFUT4 ADB N4 JMP LU10 LU40 LDA PPREL OUTPUT LU TABLE LDB PPREL ADB MAXLU ADB N1 STB PPREL JSB SETCR ISZ PPREL JMP SINTT * D$LUT DEF $LUTA $LUTA ASC 3,$LUTA * D$LU# DEF $LUT# $LUT# ASC 3,$LUT# * SKP * * INTERRUPT TABLE PROCESSOR * SIINTT LDB PPREL STB LOCC ADB N16 SUBTRACT -20B TO $INTA LDA D$INT FIND & PATCH $INTA JSB FSYMB JSB MSENT MISSING SYSTEM ENTRY POINT * LDA N3 JSB MOVE DEF $CIC+0 DEF ASCPD+0 * JSB DVADD FIND ADDRESS OF $CIC LDB RESLT GET RESULT SZB IS ENTRY THERE? JSB MSENT NO , MISSING SYSTEM ENTRY SYMBOL * JSB L.SCN SCAN FOR A BASE PAGE DEF *+3 DEF VALUA DEF BPADR * LDA BPADR SSA,RSS BASE PAGE ALLOCATED? JMP SET15 YES * JSB L.ABP NO , ALLOCATE A BP DEF *+3 DEF DUMBP DEF BPADR * LDA VALUA STA DUMBP,I UPDATE DUMMY BP WITH LINK SET15 LDA BPADR LOAD $CIC ADDRESS IOR IJSB ADD JSB 0,I CODE STA JSCIC SET JSB CIC,I CODE JSB BUFCL JSCIC OCT 0 STUFF DATA LDA P5 LDB P40 JSB SETCR OUTPUT JSB $CIC,I LDA P40 LDB P63 JSB SETCR OUTPUT JSB $CIC,I * LDA N7 FILL LOC 11B TO 17B STA CNT1 WITH " CLC SC,C " LDA P9 STA CNT2 SET30 LDA CLCF0 GET CLC 00,C LDB CNT2 ADDRESS TO FILL IOR B DATA CLC SC,C JSB STCR1 OUTPUT ISZ CNT2 ISZ CNT1 ANY MORE ? JMP SET30 YES * JSB SPACE NEW LINE LDA PPREL GET CURRENT RELOCATION ADDR STA AINT SAVE INTERRUPT TABLE ADDRESS LDA P9 LDB MES29 MES29 = ADDR. * INT TABLE JSB DRKEY PRINT: INT TBL * JSB SPACE NEW LINE * SETIN JSB BUFC JSB READ PRINT MESSAGE, GET REPLY JMP EXIT LDA OP? CPA EN CHARS = EN? JMP ENDIO YES - I/O TABLES COMPLETE CPA IN CHECK FOR INTERRUPT RSS YES JMP ITERR NO , ERROR JSB NAMRR GET SELECT CODE SSA JMP ITERR END OF L INE ERROR LDB DIPBF ADB P3 LDA B,I GET TYPE CPA P1 IS IT NUMERIC ? RSS YES JMP ITERR NO , ERROR LDA DIPBF,I GET INTERRUPT CHANNEL STA INTCH ADA N16 CHAN L.T. 20B ? SSA JMP ITERR YES, CHANNEL ERROR LDA INTCH GET SELECT CODE CMA,INA ADA P63 S.C. GT 77B? SSA NO JMP ITERR YES , ERROR * CLB LDA INTCH GET SELECT CODE DIV P4 DIVIDE BY 4 STA PIMKB THIS $PIMK BIT * * JSB NAMRR GET TYPE OF INTERRUPT ENTRY SSA END OF LINE JMP ITERR LDA DIPBF,I GET THE ASCII CPA PR CHARS = PR? JMP INTPR YES - PROCESS INT PRG RECORD CPA EN CHARS = EN? JMP INTEN YES - PROCESS INT ENT RECORD JMP ITERR INPUT ERROR * * PRG ENTRY * INTPR JSB NAMRR SSA IS IT THE END? JMP ITERR YES , ERROR LDA DIPBF ADA P3 LDA A,I AND P3 CPA P3 RSS YES , ASCII JMP ITERR NO , ERROR LDA N3 JSB MOVE DEF IPBUF+0 DEF TBUF LDA TBUF+2 NAME: 5 AND HIMSK MASK OUT LOWER HALF IOR INTCH PUT IN CHN(SELECT CODE) STA TBUF+2 SAVE IN TABLE LDA ATBUF ADDRESS OF NAME JSB LDIPX PUT IN TABLE JMP ITERR CLA LDB JSCIC TRAP CELL IS JSB $CIC,I JSB COMIN JSB REMOV REMOVE THE IFT FOR THIS SEL.CODE JMP SETIN * * ENT ENTRY * INTEN JSB NAMRR SSA IS IT THE END ? JMP ITERR YES LDA N3 NO , MOVE THE ENTRY NAME JSB MOVE DEF IPBUF+0 DEF ASCPD+0 * JSB DVADD GET THE ADDRESS OF ENTRY POINT LDA RESLT CHECK RESULT FOR ERROR SZA,RSS JMP SETE1 EVERYTHING OK * LDA P9 JS[2B LDRER ERROR JMP SETIN * SETE1 LDA PIMKW GET PIMK WORD LDB BIT GET BIT ADDRESS ADB PIMKB ADD PIMK BIT INB LDB B,I GET THE MASK BIT IOR B IOR IT WITH THE PIMK WORD STA PIMKW SAVE THE NEW PIMK WORD * JSB L.SCN SCAN FOR A BP DEF *+3 DEF VALUA DEF BPADR * LDA BPADR SSA,RSS DOES ENTRY HAVE LINK? JMP SETE5 YES * JSB L.ABP NO , ALLOCATE A BP LINK DEF *+3 DEF DUMBP DEF BPADR REAL BP * LDA VALUA STA DUMBP,I PUT LINK IN DUMMY BP SETE5 LDA BPADR IOR IJSB CONSTRUCT JSB LINK,I STA B CLA JSB COMIN JSB REMOV JMP SETIN * * ITERR LDA P7 JSB LDRER JMP SETIN REPEAT INPUT * * ITER2 NOP LDA P10 JSB LDRER PRIVILEDGE INTERRUPT ERROR - FATAL JMP ITER2,I * ENDIO LDA OPT.3,I GET THE FIXUP TABLE SZA,RSS ANY FIXUP? JMP TST30 NO CMA,INA STA CNT1 LDB OPT3 TST10 STB PFUT4 POINT TO FIXUP ENTRY LDA PFUT4,I SSA,RSS JMP TST20 ADB N3 LDA B,I GET SELECT CODE AND MSK1 ARS ALF,ALF STA INTCH * CLB DIV P4 DIVIDE SELECT CODE BY 4 STA PIMKB THIS IS THE $PIMK BIT LDA PIMKW GET $PIMK WORD LDB BIT GET BIT ADDRESS ADB PIMKB ADD BIT POSITION INB AND B,I SZA HAS PRIVILEDGE INTERRUPT BEEN SET? JSB ITER2 LDB PFUT4 ADB N1 BACK UP TO IFT ADDRESS LDA B,I GET IFT ADDRESS LDB JSCIC JSB COMIN OUTPUT THE TRAP CELL AND INT TBL TST20 ISZ CNT1 RSS JMP TST50 LDB PFUT4 ADB N4 JMP TST10 * TST30 LDB MAXSC SZB MAXSC ZERO? JMP TST50 NO LDB B30 YES , SET MAXSYqC TO 30B STB MAXSC AND SAVE IT * TST50 LDB MAXSC GET LARGEST SELECT CODE ADB N16 SUBTRACT -20B INB LDA D$IN# FIND & PATCH # OF INTERRUPT ENTRIES JSB FSYMB JSB MSENT MISSING SYSTEM ENTRY POINT * LDB PIMKW GET THE $PIMK WORD CMB NEGATE IT THE REAL MASK LDA D$PMK JSB FSYMB FIND & PATCH $PIMK PRIV. INT. MASK JSB MSENT MISSING SYSTEM ENTRY POINT LDA MAXSC ADA N16 ADA AINT INA STA LOCC LDA MAXSC FWA FOR USER BP INA STA BPFWA ADA LDBP LOWER BOUND FOR DUMMY BP STA CUDBP CURRENT USER DUMMY BP JSB SPACE NEW LINE JSB SPACE NEW LINE * JSB EXEC DEF *+3 LOAD SEGMENT 4 DEF P8 DEF SEG4 JMP EXIT SKP * IJSB JSB 0,I I-JSB CODE FOR INTERRUPT LOCS * INTCH NOP INT RECORD CHANNEL NO. * MES29 DEF *+1 ASC 5,* INT TBL * D$INT DEF $INTA $INTA ASC 3,$INTA * D$IN# DEF $INT# $INT# ASC 3,$INT# * D$PMK DEF $PIMK $PIMK ASC 3,$PIMK * $CIC ASC 3,$CIC SEG4 ASC 3,RTLG4 SKP * * * OUTPUT TRAP LOC AND INT TABLE * * CALLING SEQUENCE: * LDA INT TABLE CODE * LDB TRAP CELL INSTRUCTION * JSB COMIN * COMIN NOP STA TBUF SAVE INT TABLE CODE STB TBUF+1 SAVE TRAP CELL INST. * LDA INTCH STA B CMB,INB ADB MAXSC SSB,RSS RSS STA MAXSC * LDA TBUF+1 GET INT LOC CODE LDB INTCH INT SELECT CODE JSB STCR1 * LDA TBUF INT TABLE CODE LDB N16 ADB INTCH ADB AINT JSB STCR1 * JMP COMIN,I * * SKP * * REMOVE THE IFT FIXUP ENTRY FOR * EITHER A ENTRY POINT INTERRUPT OR PROGRAM INTERRUPT * REMOV NOP LDA OPT.3,I GET THE FIXUP TABLE CMXA,INA STA CNT1 LDB OPT3 SST10 STB PFUT4 POINT TO FIXUP ENTRY LDA PFUT4,I SSA,RSS JMP SST20 ADB N3 LDA B,I GET SELECT CODE AND MSK1 ARS ALF,ALF CPA INTCH MATCHING SELECT CODE? RSS YES JMP SST20 NO , GET NEXT ONE LDA PFUT4,I GET WORD 1 AND MSK77 MASK OUT BIT FOR IFT ENTRY STA PFUT4,I JMP REMOV,I EXIT * SST20 ISZ CNT1 RSS JMP REMOV,I LDB PFUT4 ADB N4 JMP SST10 * * * * SKP * * * ROUTINE TO MOVE DRIVER NAM INTO DMES8 FOR * DEFAULT DRIVER ENTRY POINT * MNAM NOP LDA LBUF3 RAL LDB DMES8 RBL JSB .MBT MOVE 5 BYTE DEF P5 NOP JMP MNAM,I * * * * * * ROUTINE TO CONVERT THE OCTAL NUMBER IN A TO * ASCII AND STUFF THE 2 LOW ORDER DIGITS INTO A BUFFER * ADDRESSED BY B. LEADING ZEROS ARE SUPPRESED * * CALLING SEQUENCE: * * A = OCTAL NUMBER * B = BUFFER ADDRESS * * RETURN: A AND B ARE DESTROYED * STFNM NOP STB STFAD SAVE FINAL ADDRESS JSB CNV99 STA STFAD,I STORE IN BUFFER JMP STFNM,I * STFAD NOP * * * SKP SKP SKP * TO ALLOCATE A BASE PAGE LINK * * * JSB TABLE ENTRY #1,I L.ABP * DEF RETRN * DEF DUMY RETURNS DUMMY BP ADDRESS NEG = ERROR * DEF REAL RETURNS REAL BP ADDRESS * DBP NOP RBP NOP L.ABP NOP JSB .ENTR DEF DBP LDA LNKDR GET LINK DIRECTION CPA N1 IS IT A SYSTEM LINK ? JMP L.A10 YES LDA CBP.L GET CURRENT REAL BP ADA LDBP ADD LOWER BOUND FOR DUMMY BP CPA CSDBP HAS IT REACH SYS BP AREA? JMP L.A20 YES , ERROR STA DBP,I INA STA CUDBP LDA CBP.L GET CURRENT USER REAL BP STA RBP,I INA STA CBP.L UPDA:TE CURRENT REAL BP JMP L.ABP,I RETURN * * SYSTEM LINK ALLOCATION * L.A10 LDA CBP.L GET CURRENT REAL BP ADA LDBP ADD LOWER BOUND FOR DUMMY BP CPA CUDBP HAS IT REACH USER BP AREA? JMP L.A20 YES , ERROR STA DBP,I NO , STORE DUMMY BP ADA N1 STA CSDBP UPDATE CURRENT SYS DUM BP LDA CBP.L STA RBP,I STORE REAL BP ADA N1 STA CBP.L UPDATE CURRENT SYS REAL BP JMP L.ABP,I * L.A20 CCA ERROR STA DBP,I LDA P23 JSB LDRER BASE PAGE LINKAGE OVERFLOW JMP EXIT * * * SKP * * * TO SCAN DUMMY BASE PAGE ( OR EXISTING BASE PAGE ) * FOR AN EXISTING BASE LINK. * * JSB TABLE ENTRY #2,I L.SCN * DEF RETRN * DEF VALUE VALUE TO SCAN FOR * DEF BPADR +/- ADDRESS TO USE / NOT FOUND * VALAD NOP ADDRESS OF VALUE BPADR NOP L.SCN NOP JSB .ENTR DEF VALAD LDA VALAD,I GET VALUE TO SCAN FOR LDB TDBP SCAN SYS DUMMY BP L.S20 CPB CSDBP IS IT EQUAL TO CURRENT SYS DUM BP JMP L.S30 YES , TRY USER BASE PAGE CPA B,I IS IT EQUAL TO SEARCH VALUE JMP FNDSY YES , SYSTEM BP LINK ADB N1 NO, ADD LINK DIRECTION FOR NEXT BP VALUE JMP L.S20 NO CONTINUE SEARCH FNDSY CMB,INB CALCULATE REAL BP ADDRESS ADB TDBP ADD TOP OF DUMMY BP ADDRESS CMB,INB DIFFERENCE BETWEEN CURRENT AND TOP DUM BP ADB B1777 SUBTRACT FROM TOP OF REAL BP STB BPADR,I THIS IS THE REAL LINK JMP L.SCN,I RETURN * L.S30 LDB LDBP LOWER BOUND FOR USER DUMMY BP ADB BPFWA SET USER BP LOCATION L.S60 CPB CUDBP IS IT EQUAL CURRENT USER DUM BP? JMP NOTF YES , RETURN NOT FOUND CPA B,I JMP FNDUS YES , FOUND USER BP INB NO , GET NEXT ADDRESS JMP L.S60 IS IT EQUAL TO CURRENT BP? FNDUS LDA LDBP FOUNX#D USER BP CMA,INA ADB A STB BPADR,I JMP L.SCN,I * NOTF CCB NOT FOUND STB BPADR,I JMP L.SCN,I * SKP * * * LDRER OUTPUTS ERRORS TO THE LIST DEVICE * * CALLING SEQUENCE: * A-REG = +VE ERROR CODE * JSB LDRER * RETURN * * LDRER NOP MPY P3 CALCULATE OFFSET INTO LIST OF ERROR CODE ADA EMESS ADD STARTING ADDRESS OF LIST STA B AND SAVE IN B-REG FOR OUTPUT LDA P6 LENGTH OF MESSAGE IN CHARACTERS JSB DRKEY PRINT IT ISZ ERRCT BUMP UP ERROR COUNT JSB ASTRX PRINT ****** JSB SPACE JMP LDRER,I AND RETURN * * EMESS DEF *+1 ASC 3,IL REC ILL REC OR CK SUM IN RELO REC ASC 3,CLS ER # OF CLASS ERROR ASC 3,RSN ER # OF RESOURCE NUM ERROR ASC 3,IFT ER IFT INPUT ERROR ASC 3,DVT ER DVT INPUT ERROR ASC 3,MS ENT MISSING SYSTEM ENTRY POINT ASC 3,NOD ER NODE INPUT ERROR ASC 3,INT ER INTERRUPT TABLE INPUT ERROR ASC 3,OV MEM SYSTEM OVERFLOW ,NEEDS LAGER PARTITION ASC 3,UND DV UNDEFINED DRIVER ENTRY POINT ASC 3,PR INT PRIVILEDGE INTERRUPT ERROR - FATAL ERROR ASC 3,?? ILLEGAL INPUT ASC 3,IT ERR INTERFACE TYPE ERROR ASC 3,SC ERR SELECT CODE ERROR ASC 3,QU ERR QUEUING ERROR ASC 3,TX ERR TABLE EXTENSION ERROR ASC 3,TO ERR TIME OUT ERROR ASC 3,BL ERR BUFFER LIMIT ERROR ASC 3,DT ERR DEVICE TYPE ERRORR ASC 3,DP ERR DRIVER PARAMETER ERROR ASC 3,PR ERR DEVICE PRIORITY ERRORR ASC 3,DX ERR DRIVER PARAMETER ERROR ASC 3,LU ERR LU SPECIFICATION ERROR ASC 3,OV BSE BASE PAGE LINKAGE OVERFLOW ASC 3,MDL NF SPECIFIED MODLE # NOT FOUND IN FILE * SKP SKP * * * THE BUFCL SUBROUTINE STUFFS A 40 WORD BUFFER WITH CALL+1 * * * CALLING SEQUENCE: * A = IGNORED * B = ADDRESS OF BUFFER * JSB BUFCL * CALL+1 = DATA TO STUFFED * * RETURN: CONTENTS OF A AND B ARE DESTROYED * BUFCL NOP LDB DSTRG LDA N40 STA WDCNT SET BUFFER LENGTH = 40 LDA BUFCL,I GET STUFF DATA STA B,I CLEAR BUFFER WORD INB ISZ WDCNT ALL WORDS CLEAR? JMP *-3 NO - CONTINUE CLEARING ISZ BUFCL JMP BUFCL,I RETURN * WDCNT NOP TEMPORARY WORD COUNTER * * * SUBROUTINE TO CLEAR OUTPUT BUFFER * BUFC NOP JSB BUFCL OCT 0 JMP BUFC,I * SKP * * * THE CKDLU SUBROUTINE DETERMINES IF THE LU # HAVE BEEN DEFINED * OR LU LARGER THAN 77B * * CALLING SEQUENCE * * LDA LU # * JSB CKDLU * JMP ERROR ERROR LU HAVE PREVIOUSLY DEFINE * NORMAL RETURN (A) = LU # * * CKDLU NOP STA LUFLG ADA N64 SSA,RSS LESS THAN 64? JMP CKDLU,I NO , ERROR LDA LUFLG YES CLB DIV P16 (A)=QUOTIENT (B)=REMAINDER STA KTEMP SAVE IT FOR CHECK SZB RSS ADA N1 ADA NUMFL ADDRESS OF NUMFL STA ZTEMP SAVE IT LDA ZTEMP,I YES , LOAD THE FLAG ADB BIT ADDRESS OF BIT LDB B,I AND B SZA HAS THIS LU BEEN ENTERED ? JMP CKDLU,I YES , ERROR LDA ZTEMP,I NO , RELOAD THE FLAG IOR B TAG THE FLAG STA ZTEMP,I AND STORE IT BACK LDA LUFLG LDB LUFLG CMB,INB ADB MAXLU SSB,RSS RSS STA MAXLU ISZ CKDLU JMP CKDLU,I * NUMFL DEF *+1 NOP NOP NOP NOP BIT DEF *+1 OCT 100000 OCT 1 OCT 2 OCT 4 OCT 10 OCT 20 OCT 40 OCT 100 OCT 200 OCT 400 OCT 1000 OCT 2000 OCT 4000 OCT 10000 OCT 20000 OCT 40000  OCT 100000 * KTEMP NOP * SKP * * CKSC SUBROUTINE CHECKS FOR PREVIOUSLY DEFINED * SELECT CODE. * * CALL SEQUENCE * * LDA SELECT CODE * JSB CKSC * JMP ERROR ERROR RETURN * NORMAL RETURN * CKSC NOP CLB DIV P16 (A)=QUOTIENT (B)=REMAINDER STA KTEMP SAVE IT FOR CHECK SZB RSS ADA N1 ADA SCFL SELECT CODE FLAG ARRAY ADDRESS STA ZTEMP LDA ZTEMP,I LOAD THE FLAG ADB BIT LDB B,I AND B SZA HAS THIS SELECT CODE BEEN ENTERED? JMP CKSC,I YES , ERROR RETURN LDA ZTEMP,I NO , RELOAD FLAG IOR B TAG THE FLAG STA ZTEMP,I AND STORE IT BACK ISZ CKSC JMP CKSC,I NORMAL RETURN * SCFL DEF *+1 NOP NOP NOP NOP * SKP SKP SKP SKP * * * OUTPUT CONSECUTIVE CORE LOCATIONS * * LDA START STARTING ADDRESS * LDB END ENDING ADDRESS * JSB SETCR DATA WILL BE AT STRNG * SETCR NOP STA ZTEM5 STARTING ADDRESS CMA,INA NEGATE STARTING ADDRESS ADA B ADD ENDING ADDRESS INA ADD 1 FOR TOTAL # TO OUTPUT CMA,INA NEGATE FOR COUNT STA CNT10 LDA DSTRG ADDRESS OF DATA STA CNT20 SET10 LDA CNT20,I GET DATA LDB ZTEM5 GET ADDRESS JSB STCR1 OUTPUT ISZ CNT20 NEXT DATA WORD ISZ ZTEM5 NEXT ADDRESS ISZ CNT10 ANY MORE OUTPUT ? JMP SET10 YES JMP SETCR,I NO * SKP * * ROUTINE TO FIND SYSTEM SYMBOL AND PATCH UP ITS VALUE * * CALLING SEQUENCE * * LDA ADDRESS OF SYMBOL * LDB VALUE TO PATCH IN * JSB FSYMB * ERROR RETURN * NORMAL RETURN * FSYMB NOP STA SYBAD PUT SYMBOL ADDRESS INTO CALLING SEQUENCE STB PVAL SAVE PATCH VALUE JSB L.ADD SFIND SYMBOL DEF *+5 SYBAD DEF * DEF VALUA DEF SADDR DEF RESLT LDA RESLT GET RESULT SZA ANY ERROR JMP ERTN YES , ERROR LDA PVAL PATCH VALUE LDB VALUA JSB STCR1 ISZ FSYMB NORMAL RETURN ERTN JMP FSYMB,I * VALUA NOP SADDR NOP RESLT NOP PVAL NOP * * * * ROUTINE TO PRINT MISSING SYSTEM ENTRY POINT * MSENT NOP LDA PRERR SZA PRINT ERROR? JMP MSENT,I NO , PRINTED PREVIOUSLY LDA P5 JSB LDRER PRINT " MS ENT " CCA STA PRERR SET ERROR PRINTED FLAG JMP MSENT,I * * SKP SKP * * FIND PHYSICAL OR LOGICAL DRIVER ENTRY POINT * * CALLIN SEQUENCE * * ASCII OF DRIVER ENTRY POINT IN ASCPD * JSB DVADD * ENTRY POINT IN VALUA * OR ERROR MESSAGE * DVADD NOP JSB L.ADD FIND DRIVER ENTRY POINT DEF *+5 DEF ASCPD DEF VALUA DEF SADDR DEF RESLT JMP DVADD,I SKP * * ROUTINE TO READ IN A RELOCATABLE RECORD . * * JSB L.RED * DEF *+2 * DEF FLAG 0/-1 OK/EOF * * FFLAG NOP L.RED NOP JSB .ENTR DEF FFLAG RREAD JSB READF READ THE NEXT REL RECORD DEF *+6 DEF SDCB3 DEF IERR5 DEF L.BUF+0 RELOCATABLE RECORD BUFFER ! DEF P60 DEF LEN ACTUAL RECORD LENGTH READ * SSA,RSS ANY ERROR? JMP FNXT2 NO STA FFLAG,I JMP L.RED,I * FNXT2 STA FFLAG,I LDA LEN GET THE RECORD LENGTH READ SZA,RSS ZERO RECORD LENGTH ? JMP RREAD YES, SO TRY AGAIN SSA,RSS NO, WAS IT A NEG LENGTH ( -1 ) JMP L.RED,I NO , RETURN STA FFLAG,I YES , SET EOF JMP L.RED,I * SKP * * * THE NAMRF SUBROUTINE USES THE RELOCATABLE LIBRARY * PARSING ROUTINE NAMR. THE INPUT TO NAMR IS A STRING * OF ASCaII CHARACTERS. * THE OUTPUT IS A 10 WORD BUFFER PARSED AS : * PRAM1,PRAM2,PRAM3,TYPE,S1,S2,S3,S4,S5,S6 * PARAMETERS BETWEEN COMMAS ARE PARSED. SUBPARAMETERS ARE * DELINEATED BY COLONS. THE TYPE WORD DESCRIBES ALL * PARAMETERS AS ASCII, NUMERIC, OR NULL. * THE TYPE WORD IS BROKEN UP INTO 2 BIT FIELDS TO DESCRIBE * THE INPUT. *15,14 13,12 11,10 9,8 7,6 5,4 3,2 1,0 *----------------------------------------------- * S6 ! S5 ! S4 ! S3 ! S2 ! S1 ! PRAM ! *----------------------------------------------- * * PRAM = 0 ...NULL PRAM1 = PRAM2 = PRAM3 = 0 * PRAM = 1....NUMERIC (ONLY PRAM1 USED) PRAM1 = # * PRAM = 2 ...NOT USED * PRAM = 3 ... ASCII (USES PRAM1,PRAM2,PRAM3 ) * * S1 - S6 ARE DEFINED THE SAME EXCEPT THEY ARE ONE WORD ONLY * NAMRF NOP JSB NAMR THIS IS THE RELO LIBR PARSING ROUTINE DEF *+5 RETURN ADDR DEF IPBUF+0 ADDRESS OF 10 WORD PARSED BUFFER DEF L.BUF+3 ADDRESS OF BUFFER TO BE PARSED DEF LEN CHARACTER LENGTH DEF ISTRF CHAR OFFSET IN STRNG FOR NEXT PRAM JMP NAMRF,I RETURN TO CALLER * * SKP * * OPEN THE RELOCATABLE FILE * OPN5 NOP JSB OPEN OPEN THE FILE ! DEF *+7 DEF SDCB3+0 DCB DEF IERR5 ERROR FLAG DEF FILE5 ASCII FILE NAME DEF IPTN1 READ OPTION DEF F5SC SECURITY CODE DEF F5DSC CART REF # SSA,RSS ANY ERROR IN THE READ ? JMP OPN5,I NO LDB F5 YES , GET THE FILE NAME JSB FLERR AND REPORT JMP OPN5,I * * * * * * SET FIXUP TABLE POINTERS * FUTP NOP LDA FUT1 ADA N4 STA FUT1 ADA N3 STA FUT4 JMP FUTP,I * * NOP OPT.3 DEF *-1 FUT1 NOP FUT4 NOP * SKP SKP * #DP NOP #LU NOP ADVT NOP BFLAG NOP CDVT NOP CFUT4 NOP CIFT NOP CNT1 NOP CNT2 NOP CNT10 NOP CNT20 NOP DPA NOP DEVPR NOP DFLAG NOP g DPBND NOP DTYPE NOP DUMBP NOP DVRAD NOP DVTIN NOP EXTWD NOP FLAG NOP FTIME NOP HIBUF NOP IFTNM NOP IPTN1 NOP ISTRF NOP LDTYP NOP LEN NOP LOBUF NOP LU1 NOP LU2 NOP LU3 NOP LUFLG NOP MASK NOP MAXLU NOP MAXSC NOP MAXRD NOP MDLFD NOP -1/0/1 MODEL NOT SPEC./NOT FOUND/FOUND MFG NOP OFST1 NOP OFST2 NOP OPT3 NOP 1ST ADDRESS OF FIXUP IN GENERATOR QUEUE NOP PFLAG NOP PFUT4 NOP PIMKB OCT 4 $PIMK BIT PIMKW OCT 2 $PIMK WORD PNFLG NOP RELFG NOP RFLAG NOP SBFLD NOP SUBFIELD , GEN=0 SCFLG NOP SCNM NOP SUBP1 NOP TCNT NOP TIMWD NOP TSIZE NOP TYPE NOP ZTEMP NOP ZTEM5 NOP Z1TMP NOP * ATBUF DEF TBUF TBUF BSS 10 SKP SKP * * CONSTANTS * P1 EQU BIT+2 P2 EQU BIT+3 P3 DEC 3 P4 EQU BIT+4 P5 DEC 5 P6 DEC 6 P7 DEC 7 P8 EQU BIT+5 P9 DEC 9 P10 DEC 10 P11 DEC 11 P12 DEC 12 P13 DEC 13 P14 DEC 14 P15 DEC 15 P16 EQU BIT+6 P17 DEC 17 P18 DEC 18 P19 DEC 19 P20 DEC 20 P21 DEC 21 P22 DEC 22 P23 DEC 23 P24 DEC 24 P32 EQU BIT+7 P40 DEC 40 P60 DEC 60 P63 DEC 63 P64 EQU BIT+8 * N1 DEC -1 N2 DEC -2 N3 DEC -3 N4 DEC -4 N5 DEC -5 N6 DEC -6 N7 DEC -7 N8 DEC -8 N10 DEC -10 N16 DEC -16 N24 DEC -24 N40 DEC -40 N64 DEC -64 N128 DEC -128 N256 DEC -256 N512 DEC -512 * B30 OCT 30 B60 OCT 60 B70 OCT 70 B300 OCT 300 B1001 OCT 1001 B1777 OCT 1777 * BL ASC 1,BL BU ASC 1,BU CL ASC 1,CL DP ASC 1,DP DT ASC 1,DT DV ASC 1,DV DX ASC 1,DX EN ASC 1,EN FI ASC 1,FI IF ASC 1,IF IN ASC 1,IN IT ASC 1,IT LU ASC 1,LU NO ASC 1,NO PR ASC 1,PR QU ASC 1,QU SC ASC 1,SC TO ASC 1,TO RE ASC 1,RE TX ASC 1,TX UN ASC 1,UN * BLIM OCT 11060 DASH OCT 26440 E OCT 42400 M OCT 46400 HIMSK OCT 177400 MSIGN EQU BIT+1 MSK1 OCT 77000 MSK77 OCT 77777 CLCF0 CLC 0,C * LBUF3 DEF L.BUF+3 * BLANK EQU P32 * A EQU 0 B EQU 1 END RTLG3  ' 92070-18081 1941 S C0122 &RTLG4              H0101 yASMB,L,Z,C *RTLGN USE 'ASMB,Z ' ALWAYS !! * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * HED RTE L GENERATOR SEGMENT 4 NAM RTLG4,5 92070-1X081 REV.1941 790906 * * * NAME: RTE L GENERATOR SEGMENT 4 * SOURCE: 92070-18081 * PGMR: B.C. * ENT RTLG4 * * EXT EXEC * EXT DSTRG,IPBUF,DIPBF EXT OP?,ASTRX EXT EXIT * EXT SEGNM EXT TDBP,LDBP,CSDBP,CUDBP EXT L.ADD,LNKDR,.ENTR,CBP.L EXT NUMID,ADDID,BPFWA * EXT READ,NAMRR,DRKEY,SPACE,FCLOS,MOVE EXT LOCC EXT ERRCT,CONSL,L.SYE,STCR1,PRERR * SUP PRESS EXTRANIOUS LISTING * SKP SKP * * RTLG4 JSB SPACE LDA P12 STA CONSL ECHO TO CONSOLE LDB MES41 JSB DRKEY PRINT " * MEM ALLOC " * LDA D$PRT FIND AND PATCH $PRTY (PARITY) LDB P5 JSB FSYBP JSB MSENT * LDA D$TBG FIND & PATCH $TBG LDB P6 JSB FSYBP JSB MSENT * LDA D$MP FIND & PATCH $MP (MEM PROTECT) LDB P7 JSB FSYBP JSB MSENT * LDA D$UIT FIND & PATCH $UIT ( UNIMPLEMENTED INST. ) LDB P8 JSB FSYBP JSB MSENT * JMP GTID GET # OF ID SEGMENT * D$PRT DEF $PRTY $PRTY ASC 3,$PRTY * D$TBG DEF $TBG $TBG ASC 3,$TBG * D$MP DEF $MP $MP ASC 3,$MP * D$UIT DEF $UIT $UIT ASC 3,$UIT * MES41 DEF *+1 ASC 6,* MEM ALLOC * SKP * MES42 DEF *+1 ASC 6,* # ID SEG? * * * GET # ID SEGMENT * GTID JSB SPACE LDA P12 LDB MES42 JSB DRxKEY JSB BUFC JSB READ JMP EXIT LDA OP? CPA ID ID SEGMENT? JMP GTID# YES IDERR LDA P2 JSB LDRER CLB,INB FATAL ERROR JMP STID GTID# JSB NAMRR SSA JMP IDERR LDA DIPBF GET IPBUF ADDRESS ADA P3 LDA A,I GET TYPE CPA P1 IS IT NUMERIC? RSS YES JMP IDERR NO , ERROR LDB IPBUF SSB POSITIVE ID JMP IDERR NO , ERROR SZB,RSS NON ZERO ID? JMP IDERR NO , ERROR LDA B ADA N255 SSA,RSS IS LESS THAN 255? JMP IDERR NO , ERROR STID STB NUMID POSITIVE AND NON ZERO * LDA D$ID# JSB FSYMB FIND & PATCH # OF ID'S JSB MSENT MISSING SYSTEM ENT POINT * LDA D$IDA LDB LOCC STB ADDID SAVE ADDRESS OF ID SEGMENT JSB FSYMB FIND & PATCH ADDRESS OF 1ST ID SEG JSB MSENT MISSING SYSTEM ENT POINT * LDA NUMID SAVE # ID MPY P30 EACH ID SEGMENT IS 30 WORDS ADA LOCC STA LOCC * * MAKE SWAP TABLE SIZE EQUAL TO # OF ID SEGMENTS * LDA D$SWT LDB LOCC JSB FSYMB FIND SWAP TABLE POINTER AND PATCH ADDRESS JSB MSENT MISSING SYSTEM ENT POINT LDA NUMID ADA LOCC STA LOCC * JMP GTSAM * D$IDA DEF $IDA $IDA ASC 3,$IDA * D$ID# DEF $ID# $ID# ASC 3,$ID# * D$SWT DEF $SWTA $SWTA ASC 3,$SWTA * SKP * MES43 DEF *+1 ASC 6,* # OF SAM? * D$SAM DEF $SAM $SAM ASC 3,$SAM * MES44 DEF *+1 ASC 12,* MEM RES LIBR & SY COM * D$RLI DEF $RLIB $RLIB ASC 3,$RLIB * * GET # OF WORD FOR SAM * GTSAM JSB SPACE LDA P12 LDB MES43 JSB DRKEY JSB BUFC JSB READ JMP EXIT LDA OP? CPA SA # OF WORD FOR SAM JMP GSAM# SAMER CLA JSB LDRER JMP ADSAM PUT IN ZERO FOR # OF SAM GSAM# JSB NAMRR SSA JMP SAMER LDA DIPBF GET IPBUF ADDRESS ADA P3 LDA A,I GET TYPE CPA P1 IS IT NUMERIC? RSS YES JMP SAMER NO , ERROR LDA IPBUF SSA POSITVE? JMP SAMER NO , ERROR STA NMSAM SAVE # OF SAM * ADSAM LDA D$SAM LDB LOCC JSB FSYMB FIND & PATCH ADDRESS OF $SAM JSB MSENT MISSING SYSTEM ENT POINT LDA NMSAM GET # OF SAM ADA LOCC STA LOCC * LDA D$RLI FIND & PATCH ADDRESS OF RES. LIB. LDB LOCC JSB FSYMB JSB MSENT MISSING SYSTEM ENT POINT * SKP * JSB SPACE LDA P24 LDB MES44 MEM RES LIBR JSB DRKEY JSB SPACE * LDA P5 STA SEGNM UPDATE SEGMENT FLAG FOR 2ND TIME INTO SEG 2 * * ENTER .ZPRV INTO SYM TBL AS UNDEFINED * JSB L.SYE DEF *+6 DEF .ZPRV DEF P2 DEF VALUE DEF P1 DEF RESLT * * ENTER .ZRNT INTO SYM TBL AS UNDEFINED * JSB L.SYE DEF *+6 DEF .ZRNT DEF P2 DEF VALUE DEF P1 DEF RESLT * SKP * * GET # OF DISC LU * JSB SPACE LDA P16 LDB MES46 * # OF DISC LU? JSB DRKEY JSB BUFC JSB READ JMP EXIT LDA OP? CPA CD JMP GETD# GET # OF DISC CDERR LDA P4 ERROR JSB LDRER JMP MCLU GETD# JSB NAMRR SSA JMP CDERR LDA DIPBF GET IPBUF ADDRESS ADA P3 LDA A,I GET TYPE CPA P1 IS IT NUMERIC? RSS JMP CDERR NO , ERROR LDA IPBUF SSA POSITIVE? JMP CDERR NO STA #DLU YES * * * SKP * * GET THE LU TO MOUNT ON BOOTUP * MCLU JSB SPACE LDA P14 LDB MES48 LU TO MOUNT? JSB DRKEY JSB BUFC  JSB READ JMP EXIT LDA OP? CPA MC JMP GLMC MCERR LDA P5 JSB LDRER JMP SSCD GLMC JSB NAMRR SSA JMP MCERR LDA DIPBF GET IPBUF ADDRESS ADA P3 LDA A,I GET TYPE CPA P1 IS IT NUMERIC? RSS YES JMP MCERR NO , ERROR LDA IPBUF STA LBOOT * * SKP * * GET THE SYSTEM SECURITY CODE * SSCD JSB SPACE LDA P16 LDB MES50 SYS SEC CODE? JSB DRKEY JSB BUFC JSB READ JMP EXIT LDA OP? CPA SS JMP GSS SSERR LDA P6 JSB LDRER JMP DNXT GSS JSB NAMRR SSA JMP SSERR LDA IPBUF STA MSC JSB SPACE * * ENTER $XECM INTO SYMBOL TABLE * DNXT JSB L.SYE DEF *+6 DEF $XECM DEF P1 DEF LOCC+0 DEF P1 DEF RESLT * * PLACE MASTER SECURITY CODE INTO $XECM * LDA MSC LDB LOCC JSB STCR1 * ISZ LOCC * * ENTER $CDIR INTO SYMBOL TABLE * JSB L.SYE DEF *+6 DEF $CDIR DEF P1 DEF LOCC+0 DEF P1 DEF RESLT * * PLACE BOOT LU INTO $CDIR * LDA LBOOT SSA,RSS CMA,INA NEGATE THE BOOT UP LU LDB LOCC JSB STCR1 * LDA #DLU ALS,ALS ADA LOCC STA LOCC * ISZ LOCC * * ENTER $MDSP INTO SYMBOL TABLE * JSB L.SYE DEF *+6 DEF $MDSP DEF P1 DEF LOCC+0 DEF P1 DEF RESLT * * PLACE VALUE OF $MDSP ( END OF DISC TABLE ADDRESS ) * LDA LOCC ADA N1 LDB LOCC+0 JSB STCR1 * ISZ LOCC * * ENTER $CPU INTO SYMBOL TABLE * JSB L.SYE DEF *+6 DEF $CPU DEF P1 DEF LOCC+0 DEF P1 DEF RESLT * LDA P1 LDB LOCC JSB STCR1 * ISZ LOCC * * NXSEG JSB EXECs DEF *+3 DEF P8 DEF SEG2 * JMP EXIT * .ZPRV ASC 3,.ZPRV * .ZRNT ASC 3,.ZRNT * $XECM ASC 3,$XECM * $CDIR ASC 3,$CDIR * $MDSP ASC 3,$MDSP * $CPU ASC 3,$CPU * MES46 DEF *+1 ASC 8,* # OF DISC LU? * MES48 DEF *+1 ASC 8,* LU TO MOUNT? * MES50 DEF *+1 ASC 8,* SYS SEC CODE? SKP * * * ROUTINE TO PRINT MISSING SYSTEM ENTRY POINT * MSENT NOP LDA PRERR SZA PRINT ERROR? JMP MSENT,I NO , PRINTED PREVIOUSLY LDA P1 JSB LDRER PRINT " MS ENT " CCA STA PRERR SET ERROR PRINTED FLAG JMP MSENT,I * * SKP * * * THE BUFCL SUBROUTINE STUFFS A 40 WORD BUFFER WITH CALL+1 * * * CALLING SEQUENCE: * A = IGNORED * B = ADDRESS OF BUFFER * JSB BUFCL * CALL+1 = DATA TO STUFFED * * RETURN: CONTENTS OF A AND B ARE DESTROYED * BUFCL NOP LDB DSTRG LDA N40 STA WDCNT SET BUFFER LENGTH = 40 LDA BUFCL,I GET STUFF DATA STA B,I CLEAR BUFFER WORD INB ISZ WDCNT ALL WORDS CLEAR? JMP *-3 NO - CONTINUE CLEARING ISZ BUFCL JMP BUFCL,I RETURN * WDCNT NOP TEMPORARY WORD COUNTER * * * SUBROUTINE TO CLEAR OUTPUT BUFFER * BUFC NOP JSB BUFCL OCT 0 JMP BUFC,I * * SKP * * * LDRER OUTPUTS ERRORS TO THE LIST DEVICE * * CALLING SEQUENCE: * A-REG = +VE ERROR CODE * JSB LDRER * RETURN * * LDRER NOP MPY P3 CALCULATE OFFSET INTO LIST OF ERROR CODE ADA EMESS ADD STARTING ADDRESS OF LIST STA B AND SAVE IN B-REG FOR OUTPUT LDA P6 LENGTH OF MESSAGE IN CHARACTERS JSB DRKEY PRINT IT ISZ ERRCT BUMP UP ERROR COUNTER JSB ASTRX PRINT ****** JSB SPACE JMP LDRER,I AND RETURN * * EMESS DEF *+1 ASC 3,SAM ER SAM SPECIFICATION ERROR ASC 3,MS ENT MISSING SYSTEM ENTRY POINT ASC 3,ID ERR # OF ID SEG NOT GIVEN ASC 3,OV BSE BASE PAGE LINKAGE OVERFLOW ASC 3,CD ERR DISC CARTRIDGE DIRECTORY ERROR ASC 3,MC ERR MOUNT CARTRIDGE ERROR ASC 3,SS ERR SYSTEM SECURITY CODE ERROR * SKP SKP * TO ALLOCATE A BASE PAGE LINK * * * JSB TABLE ENTRY #1,I L.ABP * DEF RETRN * DEF DUMY RETURNS DUMMY BP ADDRESS NEG = ERROR * DEF REAL RETURNS REAL BP ADDRESS * DBP NOP RBP NOP L.ABP NOP JSB .ENTR DEF DBP LDA LNKDR GET LINK DIRECTION CPA N1 IS IT A SYSTEM LINK ? JMP L.A10 YES LDA CBP.L GET CURRENT REAL BP ADA LDBP ADD LOWER BOUND FOR DUMMY BP CPA CSDBP HAS IT REACH SYS BP AREA? JMP L.A20 YES , ERROR STA DBP,I INA STA CUDBP LDA CBP.L GET CURRENT USER REAL BP STA RBP,I INA STA CBP.L UPDATE CURRENT REAL BP JMP L.ABP,I RETURN * * SYSTEM LINK ALLOCATION * L.A10 LDA CBP.L GET CURRENT REAL BP ADA LDBP ADD LOWER BOUND FOR DUMMY BP CPA CUDBP HAS IT REACH USER BP AREA? JMP L.A20 YES , ERROR STA DBP,I NO , STORE DUMMY BP ADA N1 STA CSDBP UPDATE CURRENT SYS DUM BP LDA CBP.L STA RBP,I STORE REAL BP ADA N1 STA CBP.L UPDATE CURRENT SYS REAL BP JMP L.ABP,I * L.A20 CCA ERROR STA DBP,I LDA P3 JSB LDRER BASE PAGE LINKAGE OVERFLOW JMP EXIT * * * SKP SKP * * * TO SCAN DUMMY BASE PAGE ( OR EXISTING BASE PAGE ) * FOR AN EXISTING BASE LINK. * * JSB TABLE ENTRY #2,I L.SCN * DEF RETRN * DEF VALUE VALUE TO SCAN FOR * DEF BPADR +/- ADDRESS TO USE / NOT FOUND * VALAD NOP ADDR2ESS OF VALUE BPADR NOP L.SCN NOP JSB .ENTR DEF VALAD LDA VALAD,I GET VALUE TO SCAN FOR LDB TDBP SCAN SYS DUMMY BP L.S20 CPB CSDBP IS IT EQUAL TO CURRENT SYS DUM BP JMP L.S30 YES , TRY USER BASE PAGE CPA B,I IS IT EQUAL TO SEARCH VALUE JMP FNDSY YES , SYSTEM BP LINK ADB N1 NO, ADD LINK DIRECTION FOR NEXT BP VALUE JMP L.S20 NO CONTINUE SEARCH FNDSY CMB,INB CALCULATE REAL BP ADDRESS ADB TDBP ADD TOP OF DUMMY BP ADDRESS CMB,INB DIFFERENCE BETWEEN CURRENT AND TOP DUM BP ADB B1777 SUBTRACT FROM TOP OF REAL BP STB BPADR,I THIS IS THE REAL LINK JMP L.SCN,I RETURN * L.S30 LDB LDBP LOWER BOUND FOR USER DUMMY BP ADB BPFWA SET USER BP LOCATION L.S60 CPB CUDBP IS IT EQUAL CURRENT USER DUM BP? JMP NOTF YES , RETURN NOT FOUND CPA B,I JMP FNDUS YES , FOUND USER BP INB NO , GET NEXT ADDRESS JMP L.S60 IS IT EQUAL TO CURRENT BP? FNDUS LDA LDBP FOUND USER BP CMA,INA ADB A STB BPADR,I JMP L.SCN,I * NOTF CCB NOT FOUND STB BPADR,I JMP L.SCN,I * SKP * * * ROUTINE TO FIND SYSTEM SYMBOL AND PATCH UP ITS VALUE * * CALLING SEQUENCE * * LDA ADDRESS OF SYMBOL * LDB VALUE TO PATCH IN * JSB FSYMB * ERROR RETURN * NORMAL RETURN * FSYMB NOP STA SYBAD PUT SYMBOL ADDRESS INTO CALLING SEQUENCE STB PVAL SAVE PATCH VALUE JSB L.ADD FIND SYMBOL DEF *+5 SYBAD DEF * DEF VALUA DEF SADDR DEF RESLT LDA RESLT GET RESULT SZA ANY ERROR JMP ERTN YES , ERROR LDA PVAL PATCH VALUE LDB VALUA JSB STCR1 ISZ FSYMB NORMAL RETURN ERTN JMP FSYMB,I * VALUA NOP SADDR NOP RESLT NOP PVAL NOP SKP * * ROUTINE xe0.*TO FIND SYMBOL,SCAN,ALLOCATE BP AND PATCH * TRAP CELL LOCATION * * CALLING SEQUENCE * LDA ADDRESS OF SYMBOL * LDB ADDRESS OF TRAP LOCATION * JSB FSYBP * RETURN TO (P+1) = ERROR * RETURN TO (P+2) = OK * FSYBP NOP STA SYMA SAVE SYMBOL ADDRESS STB TRPLO SAVE TRAP LOCATION * JSB L.ADD FIND ENTRY POINT ADDRESS DEF *+5 SYMA DEF * DEF VALUA DEF SADDR DEF RESLT LDA RESLT SYMBOL DEFINED? SZA JMP RTERR NO , RETURN ERROR * JSB L.SCN SCAN FOR A BP DEF *+3 DEF VALUA DEF BPADR LDA BPADR SSA,RSS DOES ENTRY HAVE BP LINK? JMP SETRP YES , SET TRAP LOC * JSB L.ABP NO , ALLOCATE A BP LINK DEF *+3 DEF DUMBP DEF BPADR * LDA VALUA STA DUMBP,I PUT LINK IN DUMMY BP SETRP LDA BPADR IOR IJSB CONSTRUCT JSB LINK,I FOR TRAP LOC LDB TRPLO JSB STCR1 OUTPUT ISZ FSYBP JMP FSYBP,I * RTERR CLA STA VALUA JMP FSYBP,I * DUMBP NOP TRPLO NOP IJSB JSB 0,I SKP * * #DLU NOP LBOOT NOP MSC NOP NMSAM NOP VALUE NOP SPC 1 * * CONTANTS * P1 DEC 1 P2 DEC 2 P3 DEC 3 P4 DEC 4 P5 DEC 5 P6 DEC 6 P7 DEC 7 P8 DEC 8 P12 DEC 12 P14 DEC 14 P16 DEC 16 P24 DEC 24 P30 DEC 30 * N1 DEC -1 N40 DEC -40 N255 DEC -255 * B1777 OCT 1777 * * CD ASC 1,CD ID ASC 1,ID MC ASC 1,MC SA ASC 1,SA SS ASC 1,SS SEG2 ASC 3,RTLG2 SKP * BASE PAGE COMMUNICATION VALUES * A EQU 0 B EQU 1 * * BSS 0 SIZE OF GENERATOR SPC 3 END RTLG4 ]0  92070-18082 1941 S C0122 &ID.00              H0101 SYASMB,R,L,C * * NAME: ID.00 * SOURCE: 92070-18082 * RELOC: 92070-16082 * PGMR: T.A.L. * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * NAM ID.00,0 92070-16082 REV.1941 800228 * ENT ID.00 EXT $IFTX,$DV15,$DV16,$DV17,$DV18,$DV19 EXT $IF5,$IF6,$DIOC,$LUTA,$DMPR * GEN 6,EID.00,TX:17 * A EQU 0 B EQU 1 * ID.00 NOP LDB $IFTX GET INTERFACE DRIVER STORAGE ADDR STB DMAAD SAVE IT ADB D13 COMPUTE BREAK FLAG ADDR STB BRKFL SAVE IT INB COMPUTE PARITY CHECK FLAG ADDR STB PCHKB SAVE IT INB COMPUTE IGNORE INPUT FLAG ADDR STB IGNOR SAVE IT INB COMPUTE BIT BUCKET ADDR STB BITBK SAVE IT AND B7 LDB ABRTE DON'T DOWN/DO FLUSH, NO MESSAGE SZA,RSS ABORT? JMP ABORT YES * CPA B1 INITIATE? JMP INIT YES STA DIREC SAVE DIRECTIVE CLA,INA LDB $IF5,I GET DVT ADDRESS JSB $DIOC SET UP DVT POINTERS LDA DIREC RESTORE DIRECTIVE CPA B2 CONTINUATION? JMP CONT YES CPA B3 TIMEOUT? JMP TIMOT YES * * POWERFAIL * * JMP PWRFL POWERFAIL * ABRTE OCT 140077 ABORT ERROR CODE B1 OCT 1 B2 OCT 2 B7 OCT 7 B3000 OCT 3000 D13 DEC 13 DIREC NOP DIRECTIVE * * * INITIATION * * INIT CLA STA IGNOR,I ZERO IGNORE INPUT FLAG LDA $DV15,I GET RQ AND B3 CPA B3 CONTROL REQUEST? JMP CNTRL YES &'* * BUILD DEFAULT CONTROL WORD * * LDA $DV18,I GET USER CONTROL WORD AND =B174377 ZERO XMIT,RCV & CHLN BITS LDB $DV15,I GET SUBFUNCTION & RQ IOR B1000 SET XMIT, BIT 9 SLB,RBL WRITE REQUEST? XOR B3000 NO, SET RCV, BIT 10 BLF,BLF SHIFT BINARY-ASCII BIT SSB BINARY? IOR BIT8 YES, SET FOR 8 DATA BITS SSB,RSS ASCII? XOR PCHKB,I YES, ADD ERROR CHECKING * STA $DV18,I SAVE CARD CONTROL WORD LDA $DV15,I GET RQ LDB $DV17,I GET TRANSMISSION LOG SLA READ REQUEST? JMP READ YES * * * WRITE REQUEST * * LDA $DV15,I CHECK FOR BINARY/ASCII AND BIT6 SZA,RSS ASCII? JMP ASCII YES * BINRY SZB,RSS BINARY ZERO XLOG? JMP ZLOG YES, INTERFACE COMPLETE JSB QUAD BUILD DATA QUAD, NO 'CRLF' OCT 71400 DMA CONTROL WORD DEF $DV18,I CARD CONTROL WORD DEF $DV16,I BUFFER ADDRESS DEF $DV17,I BUFFER LENGTH JMP ID.IO SEND DATA * ASCII LDA $DV15,I GET SUBFUNCTION AND BIT11 GET ESC BACKARROW BIT SZA PERFORM ESC BACKARROW? JMP ASBLK YES * * CHARACTER MODE * * LDA $DV15,I CHECK FOR 'CRLF' AND BIT7 SZA ADD CRLF? JMP BINRY NO SZB,RSS ASCII ZERO XLOG? JMP CRLF1 YES JSB QUAD BUILD DATA QUAD OCT 171400 DMA CONTROL WORD DEF $DV18,I ASIC CONTROL WORD DEF $DV16,I BUFFER ADDRESS DEF $DV17,I BUFFER LENGTH * CRLF1 JSB QUAD BUILD 'CRLF' QUAD OCT 71400 DMA CONTROL WORD DEF $DV18,I ASIC CONTROL WORD DEF CRLFA CRLF ADDRESS DEF M2 BUFFER LENGTH JMP ID.IO SEND DATA * * BLOCK MODE * * ASBLK SZB,RSS ASCII ZERO XLOG? JMP CRLFQ YES, OUTPUT CRLF JSB QUAD BUILD DATA QUAD W OCT 171400 DMA CONTROL WORD DEF $DV18,I ASIC CONTROL WORD DEF $DV16,I BUFFER ADDRESS DEF $DV17,I BUFFER LENGTH * CRLFQ LDA $DV15,I CHECK FOR 'CRLF' AND BIT7 SZA ADD CRLF? JMP NOCR NO * JSB QUAD BUILD 'CRLF ESC_ DC1' QUAD OCT 71400 DMA CONTROL WORD DEF $DV18,I ASIC CONTROL WORD DEF CRLFA CRLF ADDRESS DEF M5 BUFFER LENGTH JMP ID.IO SEND DATA * NOCR JSB QUAD BUILD 'ESC_ DC1' QUAD OCT 71400 DMA CONTROL WORD DEF $DV18,I ASIC CONTROL WORD DEF ESCA ESC_ ADDRESS DEF M3 BUFFER LENGTH * * * START DMA * * ID.IO CLA,INA ALLOW TIMEOUT ISZ ID.00 SETUP FOR INTERFACE CONTINUE WDOUT CLC 21B,C SUSPEND AND CLC 23B,C TERMINATE DMA OPERATION CLB OTB 24B CLEAR BREAK FLAG OTB 31B CLEAR XMIT & RCV STC 30B,C ENABLE BREAK * LDB $IFTX GET QUAD INB STARTING ADDRESS OTB 20B STC 20B,C START DMA JMP ID.00,I INTERFACE COMPLETE/CONTINUE * WAIT STC 30B,C CLA,INA ALLOW TIMEOUT STA BRKFL,I SET BREAK FLAG ISZ ID.00 JMP ID.00,I INTERFACE CONTINUE * * * READ REQUEST * * READ SZB,RSS ZERO XLOG? JMP ZLOG YES, INTERFACE COMPLETE LDA $DV19,I GET OPTIONAL PARAMETER AND LBYTE REMOVE LOWER BYTE SZA,RSS HIBYTE > 0? JMP READB NO, CHECK LOW BYTE LDA $DV18,I GET ASIC CONTROL WORD AND M1011 REMOVE RCV & ECHO BITS IOR B1000 SET XMIT BIT STA TEMP SAVE ASIC CONTROL WORD JSB QUAD BUILD WRITE QUAD OCT 171400 DMA CONTROL WORD DEF TEMP CARD CONTROL WORD DEF $DV19 OPTIONAL PARAMETER ADDR DEF M1 BUFFER LENGTH * READB LDA $DV19,I GET OPTIONAL PARAMETER AND HBYTE REMOVE HIGH BYTE o SZA,RSS LOW BYTE ZERO? JMP READQ YES, BUILD READ QUAD SSA,RSS POSITIVE NUMBER? CMA,INA YES, MAKE NEGATIVE INA SUBTRACT ONE STA IGNOR,I SAVE IN EXTENSION JSB QUAD BUILD READ QUAD OCT 171600 DMA CONTROL WORD DEF $DV18,I CARD CONTROL WORD DEF $DV16,I BUFFER ADDRESS DEF $DV17,I BUFFER LENGTH * LDA IGNOR,I GET NUMBER OF INTERRUPTS TO IGNORE SZA,RSS ZERO? JMP READ1 YES, READ ONE BYTE INTO BIT BUCKET * JSB QUAD BUILD BIT BUCKET QUAD OCT 71000 DMA CONTROL WORD DEF $DV18,I CARD CONTROL WORD DEF $DV16,I BUFFER ADDRESS DEF IGNOR,I BUFFER LENGTH JMP ID.IO SEND DATA * READ1 JSB QUAD BUILD READ BYTE QUAD OCT 71600 DMA CONTROL WORD DEF B2000 ASIC CONTROL WORD DEF BITBK BIT BUCKET ADDRESS DEF M1 JMP ID.IO READ BYTE * READQ JSB QUAD BUILD READ QUAD OCT 71600 DMA CONTROL WORD DEF $DV18,I CARD CONTROL WORD DEF $DV16,I BUFFER ADDRESS DEF $DV17,I BUFFER LENGTH JMP ID.IO SEND DATA * * M1 OCT -1 M2 OCT -2 M3 OCT -3 M5 OCT -5 BIT6 OCT 100 BIT 6, "BINARY-ASCII" BIT BIT7 OCT 200 BIT 7, "CRLF" BIT BIT8 OCT 400 BIT 8, "CHLN" BIT B1000 OCT 1000 BIT 9, "XMIT" BIT BIT11 OCT 4000 BIT 11, "ESC_" BIT M1011 OCT 171777 MASK RCV & ECHO, BITS (10 & 11) LBYTE OCT 177400 LOWER BYTE MASK HBYTE OCT 377 HIGH BYTE MASK * * * CONTROL REQUEST * * CNTRL LDA $DV15,I GET LSR 6 SUBFUNCTION AND B77 CPA B6 DYNAMIC STATUS? JMP DYNAM YES CPA B43 ENABLE/DISABLE ERROR CHECKING JMP PCHK YES CPA B23 CONTROL ASYNCHRONOUS INT.? JMP CASYN YES DONE CLA IGNOR REQUEST STA $DV16,I CLEAR ERROR CODE JMP ID.00,I INTERFACE COMPLETION * B6 OCT 6 B23 OCT 23 B43 OCT 43 B77 OCT 77 * * * DYNAMIC STATUS (FUNCTION CODE =6) * * DYNAM JSB STAT READ ASIC STATUS & OUTPUT CNTRL WRD JMP DONE INTERFACE COMPLETE * * * ENABLE/DISABLE ERROR (FUNCTION CODE = 43) * * PCHK LDA $DV16,I GET PARAMETER AND PMASK MASK PARITY & FRAMING ERROR STA PCHKB,I SAVE IN PARITY CHECK FLAG JMP IDCOM INTERFACE COMPLETE * PMASK OCT 30000 MASK PARITY & FRAMING ERROR BITS * * * ENABLE ASYNCHRONOUS INTERRUPT (FUNCTION CODE = 23) * * CASYN LDA $DV16,I GET PARAMETER SZA ENABLE ASYNC INT. JMP DASYN NO LDA $IF5,I SAVE DVT RESUME ADDR. LU1 STA $IFTX,I IN DVT EXTENSION. * EASYN JSB QUAD BUILD READ QUAD OCT 61600 DMA CNTRL WRD DONOT WRITE RESIDUE!!! DEF B2000 ASIC CONTROL WORD DEF BITBK BIT BUCKET ADDRESS DEF M1 1 BYTE CLA DISABLE TIMEOUT STA BITBK,I INITIALIZE BIT BUCKET JMP WDOUT SEND DATA * B2000 OCT 2000 BIT 10, RCV DC2 OCT 22 DC2 IN LOWER BYTE * * * DISABLE ASYNCHRONOUS INTERRUPT (FUNCTION CODE = 23) * * DASYN CLA ZERO DVT RESUME ADDR. STA $IFTX,I IN DVT EXTENSION. STA $DV16,I ZERO ERROR CODE JMP LUCHK CHECK FOR LU=1 SKP * * * CONTINUATION * * CONT LIA 24B SZA,RSS FRONT PANEL INTERRUPT? JMP CONT1 NO, CONTINUE CLA YES, ZERO OTA 24B SELECT CODE 24 * PWRFL LDB $IF6,I GET AVAILABILITY SSB,RSS BUSY? JMP BRK NO, CHECK FOR ASYNC CONDITION LDA BREAK DON'T DOWN/DON'T FLUSH, RESTART NO MESS STA $DV16,I ERROR CODE CLC 21B,C SUSPEND AND CLC 23B,C TERMINATE DMA OPERATION JSB STAT READ ASIC STATUS & OUTPUT CNTRL WRD JMP IDCOM INTERFACE COMPLETE * CONT1 SFC 22B DMA COMPLEzTION? JSB $DMPR NO, MEMORY ERROR LDA $IF6,I GET AVAILABILITY SSA BUSY? JMP TICST YES ISZ ID.00 NO, SETUP FOR CONTINUE LDA $IFTX,I GET DVT RESUME ADDR. SZA ASYNCHRONOUS INT. ENABLED? JMP CONT4 YES CLC 30B,C CLEAR INTERRUPT FLAG CLC 21B,C SUSPEND AND CLC 23B,C TERMINATE DMA OPERATION LDA B4 REPORT AN ILLEGAL INTERRUPT JMP ID.00,I INTERFACE CONTINUE * CONT4 STA $IF5,I SAVE DVT RESUME ADDR. LDB BITBK,I CHECK IF BLOCK MODE ENABLED LSR 8 SHIFT TO LOWER BYTE CPB DC2 BLOCK MODE? JMP HOLD YES ISZ ID.00 DEVICE RESUME JMP EASYN ENABLE ASYNCHRONOUS INT. * HOLD JSB QUAD BUILD DC1 QUAD OCT 171400 DMA CONTROL WORD DEF B1000 ASIC CONTROL WORD DEF DC1A DC1 ADDRESS DEF M1 1 BYTE JSB QUAD BUILD READ QUAD OCT 171600 DMA CONTROL WORD DEF B2000 ASIC CONTROL WORD DEF BITBK BIT BUCKET ADDRESS DEF M1 1 BYTE JSB QUAD BUILD 'DC1' QUAD OCT 71400 DMA CONTROL WORD DEF B1000 ASIC CONTROL WORD DEF DC1A BUFFER ADDRESS DEF M1 BUFFER LENGTH * LDA B3 ASSERT HOLD & TIMEOUT STA BITBK,I JMP WDOUT SEND DATA * * * READ ASIC STATUS * * STAT NOP READ ASIC STATUS & OUTPUT CNTRL WRD LIA 31B READ OUTPUT CONTROL WORD STA $DV19,I SAVE IT LIA 32B READ ASIC STATUS WORD IOR BRKFL,I MERGE BREAK FLAG INTO STATUS STA $DV18,I SAVE IT JMP STAT,I RETURN * TICST JSB STAT READ ASIC STATUS & OUTPUT CNTRL WRD SSA VAL DATA BIT SET? JMP TLOG YES, IGNOR ERROR BITS RAL SSA BREAK BIT SET? JMP WAIT YES, WAIT FOR DMA COMPLETION AND EMASK CHECK FRAMING,׌ PARITY & OVERRUN SZA,RSS ZERO? JMP TLOG YES, NO ERROR LDB B5 NO, TRANSMISSION ERROR JMP TDMA TERMINATE DMA OPERATION * TLOG CLF 23B CLEAR FLAGS 20, 21 & 22 LIA 23B READ REMAINING CHARACTERS (NEG) LDB $DV17,I GET BUFFER LENGTH SSB ARE THEY CHARACTERS? CMB,INB,RSS YES BLS MULTIPLY WORDS BY 2 ADA B FIND ACTUAL CHARACTER COUNT (POS) LDB $DV17,I GET BUFFER LENGTH SSB,RSS ARE THEY CHARACTERS? ARS NO, DIVIDE CHARS. BY 2 CLB STA $DV17,I SAVE AS + CHARS OR + WORDS STB $DV16,I SETUP ERROR CODE JMP ASYNC ENABLE ASYNCHRONOUS INTERRUPT * BRK ISZ ID.00 EXIT WAIT FOR VALID REQUEST * ASYNC LDB $IFTX,I GET DVT RESUME ADDR SZB WAS ASYNCHRONOUS INT. ENABLED? JMP EASYN YES, RE-ENABLE INTERRUPT LUCHK LDA $IF5,I CPA $LUTA,I LU=1? JMP LU1 YES, RE-ENABLE INTERRUPT CLA OTA 31B DISABLE PE & OE INT'S CLC 30B,C DISABLE BREAK IDCOM CLA JMP ID.00,I INTERFACE COMPLETION * B3 OCT 3 B4 OCT 4 B5 OCT 5 * * * ZERO TRANSMISSION LOG * * ZLOG STB $DV16,I ERROR CODE JSB STAT READ ASIC STATUS & OUTPUT CNTRL WRD JMP ASYNC ENABLE ASYNCHRONOUS INTERRUPT * * * TIMEOUT * * TIMOT LDB B3 TIMEOUT ERROR. ABORT JSB STAT READ ASIC STATUS & OUTPUT CNTRL WRD TDMA STB $DV16,I CREATE ERROR CODE CLB STB $DV17,I ZERO TRANSMISSION LOG CLC 21B,C SUSPEND AND CLC 23B,C TERMINATE DMA OPERATION OTB 32B RESET ASIC CARD JMP ASYNC ENABLE ASYNCHRONOUS INTERRUPT * * EMASK OCT 70000 MASK FRAMING, PARITY & OVERRUN BREAK OCT 100077 DON'T DOWN/DON'T FLUSH, RESTART NO MESS TEMP NOP TEMPORARY STORAGE CRLF OCT 6412 'CRLF' ESC OCT 15537 'ESC_' DC1 OCT 1040 |0.*0 'DC1' CRLFA DEF CRLF ESCA DEF ESC DC1A DEF DC1 * * * BUILD DATA QUAD * * QUAD NOP LDB QUAD,I ISZ DMAAD STB DMAAD,I DMA CONTROL WORD JSB NEXT ASIC CONTROL WORD JSB NEXT BUFFER ADDRESS JSB NEXT BUFFER LENGTH ISZ QUAD FIX RETURN ADDRESS SSB CHARACTERS? JMP QUAD,I YES, QUAD COMPLETE BLS NO, SAVE CMB,INB BUFFER LENGTH STB DMAAD,I IN CHARACTERS JMP QUAD,I QUAD COMPLETE * * NEXT NOP ISZ DMAAD ISZ QUAD LDB QUAD LDB B,I RBL,CLE,SLB,ERB JMP *-2 LDB B,I STB DMAAD,I JMP NEXT,I * * DMAAD NOP DVT RESUME ADDR PTR BRKFL NOP BREAK FLAG PCHKB NOP PARITY CHECK FLAG IGNOR NOP IGNORE INPUT FLAG BITBK NOP BIT BUCKET * * INTERFACE STORAGE * * * WORD 1: DVT RESUME ADDRESS * WORD 2: DMA CONTROL WORD \ * WORD 3: CARD CONTROL WORD \ 1ST QUAD * WORD 4: BUFFER ADDRESS / * WORD 5: - BUFFER LENGTH (CHAR) / * WORD 6: DMA CW \ * WORD 7: CARD CW \ 2ND QUAD * WORD 8: BUF ADDR / * WORD 9: BUF LENGTH / * WORD 10: DMA CW \ * WORD 11: CARD CW \ 3RD QUAD * WORD 12: BUF ADDR / * WORD 13: BUF LENGTH / * WORD 14: BREAKFLAG * WORD 15: ERROR CHECKING FLAG * WORD 16: IGNORE INPUT FLAG * WORD 17: BIT BUCKET * * DRIVER PARAMETER STORAGE * * * NONE * * END <0  92070-18083 1941 S C0122 &DD.00              H0101 TTASMB,R,L,C * * NAME: DD.00 * SOURCE: 92070-18083 * RELOC: 92070-16083 * PGMR: T.A.L. * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * * NAM DD.00,0 92070-16083 REV.1941 791102 * * ENT DD.00 EXT $DV1,$DV6,$DV12,$DV15,$DV16,$DV17,$DV18 EXT $DV19,$DV22,$IFTX EXT $XQSB,$ATTN,$DVLU,$LUTA,$DVTP,.MVW * GEN 14,EDD.00,TX:15,TO:32000,QU:FI * GEN 19,M2621,DT:0,DX:12,DP:1:1:0:10400B:0:FM GEN 11,DP:6:GR:20040B:0:CO:MN GEN 5,DP:11:D:0 * GEN 17,M2631,DT:12B,DX:3,DP:1:3:0:10400B * GEN 20,M2635:0,DT:0,DX:12,DP:1:3:0:10400B:0:FM GEN 11,DP:6:GR:20040B:0:CO:MN GEN 5,DP:11:D:0 * GEN 18,M2635:1,DT:12B,DX:3,DP:1:3:0:10400B * GEN 19,M2645,DT:5,DX:12,DP:1:1:0:10400B:0:FM GEN 11,DP:6:GR:20040B:0:CO:MN GEN 5,DP:11:D:0 * GEN 20,M2675:0,DT:5,DX:12,DP:1:3:0:10400B:0:FM GEN 11,DP:6:GR:20040B:0:CO:MN GEN 5,DP:11:D:0 * GEN 18,M2675:1,DT:12B,DX:3,DP:1:3:0:10400B * A EQU 0 B EQU 1 SKP * DD.00 NOP STA DIREC SAVE DIRECTIVE JSB SETAD SETUP EXTENSION ADDR PTR'S CLA ZERO STA $DV12,I DEVICE TIMEOUT VALUE LDA DIREC GET DIRECTIVE AND B7 SZA ABORT? JMP GO NO * * ABORT * * STA DVX8,I ZERO CHARACTER ACCUMULATOR LDA B4 CALL INTERFACE DRIVER JSB CEXIT WITH ABORT CODE JMP LDCOM DEVICE COMPLETE * * GO CPA B1 INITIATE? JMP INIT YES CPA B2 CONTINUATION? JMP CONT YES CPA B3 TIMEOUT? JMP TIMOT YES CPA B4 POWER FAIL? JMP LDCOM YES, DEVICE COMPLETE * * * RESUME * * ISZ DD.00 WAIT FOR RESUME ISZ DD.00 ENTRY FROM INTERFACE RESUM LDB $DV1 GET DVT ADDRESS CPB $IFTX,I CURRENT DVT ENABLED? RSS YES JMP LDCM2 NO, DEVICE COMPLETE JSB DT GET DEVICE TYPE JMP LDCM2 PRINTER, DEVICE COMPLETE JSB $DVLU GET CONSOLE LU SZA,RSS ZERO? JMP LDCM2 YES, DEVICE COMPLETE STA LU1 NO, SAVE LU PRIMARY PROG STA LU2 SAVE LU FOR SECONDARY PROG STA BUFF SAVE LU IN FIRST WORD OF BUFR CLA LDB $IFTX GET INTERFACE DRIVER STORAGE ADDR ADB D13 COMPUTE BREAK FLAG ADDR STA B,I ZERO BREAK FLAG LDB DVP5,I GET PRIMARY SCHEDULED PROG SZB,RSS DISABLED? JMP SECPR YES, CHECK SECONDARY PROGRAM LDA DVP8,I GET PRIMARY OPTIONAL PARAMETER ADDR STA BUFF+1 SAVE IT IN SECOND WORD OF BUFR JSB $XQSB SCHEDULE PRIMARY PROGRAM DEF DVP5,I SCHEDULED PROG NAME DEF BUFF LU PARAMETER ADDRESS LU1 NOP CONSOLE LU SZA,RSS A=0? SUCCESSFUL SCHEDULE? JMP LDCM2 YES, DEVICE COMPLETE SECPR LDB DVP9,I GET SECONDARY SCHEDULED PROG SZB,RSS DISABLED? JMP CHKLU YES, CHECK FOR LU=1 LDA DVP12,I GET SECONDARY OPTIONAL PARAMETER ADDR STA BUFF+1 SAVE IT IN SECOND WORD OF BUFR JSB $XQSB SCHEDULE SECONDARY PROGRAM DEF DVP9,I SCHEDULED PROGRAM NAME DEF BUFF LU PARAMETER ADDRESS LU2 NOP CONSOLE LU SZA,RSS SUCCESSFUL SCHEDULE? JMP LDCM2 YES, DEVICE COMPLETE CHKLU LDA LU1 GET CONSOLE LU LDB $DV1 GET DVT ADDR CPB $LUTA,I LU=1? CLA,INA +{ NO, SET TO 1 STA $ATTN SET SYSTEM ATTENSION FLAG JMP LDCM2 DEVICE COMPLETE * B1 OCT 1 B2 OCT 2 B3 OCT 3 B7 OCT 7 B12 OCT 12 PRINTER DEVICE TYPE D13 DEC 13 BUFF REP 5 NOP * * * INITIATION * * INIT LDA $DV6,I GET DEVICE STATUS AND LBYTE REMOVE STATUS STA $DV6,I SAVE IT CLA STA DVX10,I ZERO FORM CONTROL CHAR STA DVX8,I ZERO CHARACTER ACCUMULATOR LDA $DV15,I GET RQ STA DVX15,I SAVE INITIAL SUBFUNCTION AND B3 CPA B3 CONTROL REQUEST? JMP CNTRL YES LDB $DV16,I GET BUFFER ADDR STB DVX2,I SAVE BUFF ADDR OF CURRENT REQ. STB DVX6,I SAVE INITIAL BUFF ADDR. STB DVX12,I SAVE INITIAL BUFF ADDR. LDB $DV17,I GET XLOG STB DVX7,I SAVE INITIAL XLOG STB DVX13,I SAVE INITIAL XLOG SZB,RSS ZERO? JMP ZLOG YES, CHECK FOR WRITE CPA B1 READ REQUEST? JMP READ YES * * * WRITE REQUEST * * LDA $DV15,I GET Z BIT (BIT12) ALF,SLA Z BIT SET? JMP WRITF YES, WRITE SECOND BUFFER FIRST WRITE JSB DT GET DEVICE TYPE JMP FCNTL PRINTER, CHECK FORM CONTROL CWRIT LDA DVX13,I GET INITIAL XLOG OF OUTPUT SSA CHARACTERS? JMP *+3 YES, SAVE THEM CMA,INA CONVERT ALS TO -CHAR'S STA DVX3,I SAVE -CHAR LENGTH LDA $DV15,I GET SUBFUNCTION AND BCRLF CLEAR CRLF BIT7 & ESC_ BIT11 STA DVX5,I SAVE MODIFIED SUBFUNCTION LSR 6 BIT 6 SLA ASCII? JMP SCHAR NO, SEND CHARACTERS LSR 4 YES, CHECK FOR TRANSPARENT SLA TRANSPARENT? JMP SBIN YES, SET BINARY BIT LDA DVX3,I GET -CHAR'S CMA,INA MAKE CHAR'S POSITIVE LDB DVX12,I GET INITIAL ADDR OF OUTPUT JSB LSCHR GET LAST CHARACTER CPA B137 UNDERSCORE? RSS YES, DO NOT OUTPUT JMP SCHAR NO, SEND CHAR'S ISZ DVX3,I INCREMENT BUFFER LENGTH NOP LDA DVX5,I GET SUBFUNCTION IOR BIT7 INHIBIT CRLF BIT SSUB STA DVX5,I SAVE IT SCHAR LDA $DVTP,I GET TERMINAL CONFIGURATION SLA,RSS ENQ/ACK ENABLED? JMP NOENQ NO, SKIP ENQ/ACK HANDSHAKE LDA DVX5,I GET INITIAL SUBFUNCTION AND RQASC CLEAR BITS 6,7,11 & RQ IOR B201 MAKE SURE ITS A STA $DV15,I ASCII READ (NO CRLF) LDA ENQ GET 'ENQ' IN UPPER BYTE STA $DV19,I SAVE IT LDA DVX9 GET 1 BYTE READ ADDR. JSB EXIT1 SEND 'ENQ', READ 'ACK' * NOENQ LDA DVX2,I GET ADDR. OF CURRENT REQ. STA $DV16,I SAVE IT ADA D39 INCREMENT ADDR BY 78 CHAR'S STA DVX2,I SAVE NEW CURRENT REQ. ADDR. * * LIMIT CHARACTER OUTPUT TO 78 * * LDB DVX3,I GET BUFFER LENGTH (-CHAR'S) STB $DV17,I SAVE LENGTH ADB D78 ADD +78 CHAR'S STB DVX3,I SAVE REMAINING CHAR'S LDA DVX5,I GET WRITE SUBFUNCTION STA $DV15,I SAVE IT SSB,RSS BUFFER LENGTH < 78 CHARS? JMP SSFLG YES, CHECK FOR SUPRESS SPACE IOR BIT7 NO, INHIBIT 'CRLF' BIT STA $DV15,I SAVE NEW SUBFUNCTION LDB M78 SET -78 CHAR MAX STB $DV17,I SAVE LENGTH JMP OUTPT SEND 78 CHAR'S SSFLG LDB DVP2,I GET SUPRESS SPACE FLAG SZB,RSS SUPRESS SPACE? JMP ESCBA NO, ALLOW 'CRLF' IOR BIT7 YES, INHIBIT 'CRLF' STA $DV15,I SAVE SUBFUNCTION JMP OUTPT SEND CHAR'S ESCBA IOR BIT11 ENABLE ESCAPE BACKARROW (BIT11) LDB $DVTP,I GET TERMINAL CONFIGURATION SSB 264X TERMINAL? STA $DV15,I YES, SAVE ESC_ BIT IN SUBFUN * OUTPT CLA STA $DV18,I W ZERO ASIC CONTROL WORD INA ALLOW TIMEOUT JSB CEXIT INITIATE WRITE * LDB DVX3,I GET BUFF LNGTH REMAINING CHAR'S SSB POSITIVE? JMP SCHAR NO, OUTPUT REMAINING CHARS. * LDB DVP2,I GET SUPRESS SPACE FLAG SZB,RSS SUPRESS SPACE? JMP WRITC NO, COMPLETE WRITE REQUEST CLA YES STA DVP2,I ZERO SUPRESS SPACE FLAG LDA CRA GET 'CR' ADDRESS JSB EXIT1 INITIATE 'CR' * WRITC LDA DVX8,I GET TOTAL XLOG (+CHARS) INA ROUNDOFF ARS CONVERT TO WORDS LDB DVX7,I GET ORIGIONAL XLOG SSB WORDS? LDA DVX8,I NO, SAVE CHAR'S STA $DV17,I YES, SAVE WORDS JSB BUFIX RESTORE FORM CONTROL CHAR LDA DVX15,I GET SUBFUNCTION AND ZBIT GET Z BIT SZA,RSS Z-BIT SET? JMP INITD NO, DONE WITH INITIAL REQUEST XOR DVX15,I YES, CLEAR Z-BIT STA DVX15,I SAVE SUBFUNCTION JMP INITR DO INITIAL REQUEST * INITD LDA $DV18,I GET ASIC STATUS SLA NEW DATA RECEIVED? JMP RESUM YES, ACKNOWLEDGE IT JMP LDCM2 NO, DEVICE COMPLETE * SBIN LDA DVX5,I GET WRITE SUBFUNCTION IOR BIT6 SET BINARY BIT JMP SSUB SAVE SUBFUNCTION * CRA DEF B6400 B6400 OCT 6400 'CR' IN UPPER BYTE * BIT6 OCT 100 BINARY BIT 6 BIT7 OCT 200 INHIBIT CRLF BIT B201 OCT 201 ENQ OCT 2400 'ENQ' D39 DEC 39 D78 DEC 78 M78 DEC -78 BCRLF OCT 173577 CLEAR CRLF BIT7 & ESC_ BIT11 ZBIT OCT 10000 Z-BIT * * * ZERO TRANSMISSION LOG * * ZLOG CPA B1 READ REQUEST? JMP LDCM3 YES, DEVICE COMPLETE JMP TICST INITIATE ZERO LENGTH WRITE * * ASCII WRITE SUBROUTINE * * ASCWT NOP LDA $DV15,I GET RQ AND RQASC MAKE SURE IOR B2 ITS A A(SCII WRITE LDB $DVTP,I GET TERMINAL CONFG WORD SSB 264X TERMINAL? IOR BIT11 YES, ENABLE ESC_ BIT IN SUBFUNC STA $DV15,I SAVE IT JMP ASCWT,I RETURN * RQASC OCT 173474 ZERO BITS 6,7,11 & RQ * * RESTORE FORM CONTROL CHARACTER * * BUFIX NOP LDB DVX12,I RESTORE FORM CONTROL LDA B,I CHARACTER BACK IOR DVX10,I INTO OUTPUT STA B,I BUFFER JMP BUFIX,I * * GET DEVICE TYPE * * DT NOP LDA $DV6,I GET ALF,ALF DEVICE AND B77 TYPE CPA B12 PRINTER? JMP DT,I YES, RETURN P+1 ISZ DT JMP DT,I NO, RETURN P+2 SKP * * * READ REQUEST * * READ LDA $DV15,I GET Z BIT (BIT12) ALF,SLA Z BIT SET? JMP WRITF YES, WRITE FIRST LDA $DV17,I GET BUFFER LENGTH CREAD SSA CHARACTERS? JMP *+3 YES, SAVE THEM CMA,INA CONVERT ALS TO -CHAR'S STA DVX3,I SAVE -CHAR LENGTH STA $DV17,I READM LDA BIT14 TYP 1 SPEC CHAR LDB $DV15,I GET SUBFUNCTION BLF,BLF SLB,RBR ECHO SET? IOR BIT11 YES, SET ECHO IN CONTROL WORD RBR,SLB TRANSPARENT BIT SET? IOR BIT15 YES, SET SPEC CHAR 'CR' BLF,SLB BINARY BIT SET? IOR BIT15 YES, SET SPEC CHAR 'CR' STA $DV18,I SAVE CONTROL WORD JMP DC1 SET UP DC1 * * * BLOCK TRANSFER * * BKXFR LDA DVX6,I GET INITIAL CHAR ADDR PTR LDA A,I GET FIRST CHAR IN BUFFER AND LBYTE REMOVE LOWER BYTE CPA DC2H BLOCK MODE? JMP BKCON YES, CONTINUE CLA,INA NO, DC2 NOT FIRST CHAR ADA DVX8,I ADD DC2 BACK INTO STA DVX8,I ACCUMULATED COUNT JMP NOBLK CONTINUE READ * BKCON LDA BIT15 SET SPEC CHAR 'RS' STA $DV18,I SAVE ASIC CONTROL WORD  LDA DVX3,I GET READ LENGTH (-CHARS) STA $DV17,I SAVE IT LDA DVX2,I GET BUFFER ADDR STA $DV16,I SAVE IT DC1 LDA DVP3,I SET UP FOR STA $DV19,I DC1 CODE IN UPPER BYTE CLA,INA ALLOW TIMEOUT JSB CEXIT SEND DC1, READ DVT17 BYTES * JMP LDCOM DEVICE COMPLETE * DC2H OCT 11000 DC2 CODE IN UPPER BYTE * * * WRITE FIRST * * WRITF LDA $DV19,I SETUP OUTPUT LENGTH LDB $DV18,I MOVE OUTPUT ADDR STB DVX2,I SAVE ADDR OF CURRENT REQ. STB DVX12,I SAVE INITIAL ADDR OF OUTPUT STA DVX13,I SAVE INITIAL XLOG OF OUTPUT LDA $DV15,I GET RQ AND RQASC MAKE SURE IOR B2 ITS A ASCII WRITE STA $DV15,I RAL,SLA SSA SYSTEM REQUEST TYPE? JMP WRITE NO, LEAVE TIMEOUT ALONE LDA DVP4,I GET DEVICE TIMEOUT DVR PARAM STA $DV12,I SAVE IT JMP WRITE * * * COMPLETE INITIAL REQUEST * * INITR CLA STA DVX8,I ZERO CHARACTER ACCUMULATOR LDB DVX6,I GET INITIAL REQUEST BUFFER ADDR STB $DV16,I SAVE IT STB DVX2,I SAVE IT LDA DVX15,I GET INITIAL REQUEST STA $DV15,I SAVE IT AND B3 CPA B2 WRITE REQUEST? JMP WRT YES, SET UP FOR WRITE LDA DVX7,I NO, GET INITIAL XLOG OF READ JMP CREAD NOW DO READ WRT STB DVX12,I SAVE INITIAL ADDR OF OUTPUT LDA DVX7,I GET INITIAL XLOG OF OUTPUT STA DVX13,I SAVE IT JMP WRITE DO WRITE * * * BACKSPACE * * BKSPC LDB DVX2,I GET ADDR OF CURRENT REQ. CCA DECREMENT TOTAL ADA DVX8,I CHARACTER COUNT SSA COUNT POSITIVE? JMP RESRT+1 NO, AT BEGINNING OF USER'S BUFF STA DVX8,I YES, SAVE IT JSB LSCHR FIND LAST CHAR NOBLK SEZ EVEN? JMP RESRT YES, RESTART DMA LDA B,I GET LAST WORD AND LBYTE REMOVE LOWER BYTE IOR B40 PAD WITH A BLANK STA B,I RESTORE WORD LDA BIT14 SET TYP 1 SPEC CHAR JSB RDCHR NO, INITIATE JSB CEXIT ONE BYTE READ * CLA,INA ONE BYTE LENGTH LDB DVX9 BYTE ADDR JSB LSCHR GET BYTE JUST READ STA TEMP SAVE IN LOW BYTE LDA DVX8,I GET TOTAL BYTES READ LDB DVX2,I GET STARTING BUFFER ADDR JSB LSCHR FIND LAST GOOD CHAR IN USER BUFF XOR B,I MOVE TO HIGH BYTE IOR TEMP MERGE IN SINGLE BYTE READ STA B,I SAVE IN USER'S BUFFER RESRT INB INCREMENT STB $DV16,I USER'S BUFFER ADDR LDB DVX8,I GET TOTAL CHAR'S READ ADB DVX3,I ADD -CHAR'S LENGTH STB $DV17,I SAVE -CHAR'S TO READ JMP READM READ N CHAR'S MORE * * * RUBOUT REQUEST * * RBOUT JSB ASCWT MAKE SURE ITS A ASCII WRITE LDA ROUTA GET RUBOUT ADDRESS STA $DV16,I SAVE IT CCA BUFFER LENGTH STA $DV17,I SAVE IT CLA STA $DV18,I ZERO ASIC CONTROL WORD INA ALLOW TIMEOUT JSB CEXIT INITIATE RUBOUT * JMP INITR RESTART REQUEST * BKSL OCT 56000 "\" IN UPPER BYTE ROUTA DEF BKSL BACKSLASH PTR * * * CONTROL D REQUEST * * CNTRD LDA $DV6,I GET DEVICE STATUS IOR BIT57 SET 'EOF' & 'EOM' BITS STA $DV6,I SAVE IT CLA ZERO STA $DV16,I ERROR CODE AND STA $DV17,I TRANSMISSION LOG JSB BUFIX RESTORE FORM CONTROL CHAR JMP LDCM2 DEVICE COMPLETION * BIT57 OCT 240 SET EOF & EOM BITS * * * CONTROL REQUEST * * CNTRL LDA DVX10 CREATE DUMMY BUFF ADDR FOR STA DVX12,I BUFIX ROUTINE LDA $DV15,I GET LSR 6 SUBFUNCTION AND B77 SZA,RSS RESET TERMINAL? JMP RESET Y.ES CPA B6 DYNAMIC STATUS? JMP TICST YES CPA B11 LINE SPACING/FORMFEED? JMP SPACE YES CPA B15 CONDITIONAL FORMFEED? JMP SPACE YES CPA B20 ENABLE PRIMARY PROG SCHED? JMP EPPRG YES CPA B21 DISABLE PRIMARY PROG? JMP DPPRG YES CPA B22 SET TIMEOUT? JMP SETTO YES CPA B23 DISABLE ASYNCHRONOUS INTERRUPTS? JMP DPROG YES CPA B40 ENABLE SECONDARY PROG SCHED? JMP ESPRG YES CPA B41 DISABLE SECONDARY PROG? JMP DSPRG YES CPA B42 GET CHARACTER? JMP GTCHR YES, READ 1 ASCII BYTE LDB $DV16,I GET NEW CONFIGURATION WORD CPA B44 MODIFY CONFIGURATION WORD? STB $DVTP,I YES, SAVE NEW WORD JMP LDCM3 DEVICE COMPLETION * B6 OCT 6 B11 OCT 11 B15 OCT 15 B20 OCT 20 B21 OCT 21 B23 OCT 23 B40 OCT 40 B41 OCT 41 B42 OCT 42 B44 OCT 44 B77 OCT 77 D55 DEC 55 M2 DEC -2 M55 DEC -55 * * RESET TERMINAL (FUNCTION CODE = 00) * * RESET JSB ASCWT MAKE SURE ITS A ASCII WRITE LDA ESCEA GET ESCAPE SEQ ADDR FOR RESET STA $DV16,I SAVE IT LDA M2 BUFFER LENGTH STA $DV17,I SAVE IT CLA STA $DV18,I ZERO ASIC CONTROL WORD INA ALLOW TIMEOUT JSB CEXIT INITIATE TERMINAL RESET * JMP LDCM2 DEVICE COMPLETE * ESCEA DEF ESCE ESCE OCT 15505 * * DYNAMIC STATUS (FUNCTION CODE = 6) * * TICST CLA JSB CEXIT INITIATE DYNAMIC STATUS * JMP LDCM2 DEVICE COMPLETE * * LINE SPACING (FUNCTION CODE = 11) * * SPACE JSB ASCWT MAKE SURE ITS A ASCII WRITE LDB $DV16,I GET # OF LINES SPACED SSB NEGATIVE? JMP SNDFF YES, SEND FORMFEED CMB,INB,SZB ZERO? JMP LINE NO, SKIP LINES JSB DT  YES, GET DEVICE TYPE JMP SUP PRINTER, SET SUPRESS FLAG CCB CRT, SKIP ONE LINE LINE LDA B ADA D55 SSA DECIMAL PARM > 55? LDB M55 YES, SET TO 55 LINES STB DVX11,I SAVE LINE FEED COUNT LNSPC JSB LNSP SETUP FOR LINE SPACE JSB CEXIT INITIATE ZERO LENGTH RECORD * ISZ DVX11,I DONE WITH LINEFEED'S? JMP LNSPC NO JMP LDCM2 YES, DEVICE COMPLETE * * SUPRESS SPACE (FUNCTION CODE = 11) * * SUP CLA,INA STA DVP2,I SET SUPRESS FLAG JMP LDCM2 DEVICE COMPLETE * * SEND FORMFEED (FUNCTION CODE = 11) * * SNDFF JSB DT GET DEVICE TYPE JMP FORM PRINTER, PERFORM FORMFEED JMP LINE CRT, SPACE LINES FORM LDA FFA GET FORMFEED ADDRESS JSB EXIT1 INITIATE FORMFEED * JMP LDCM2 DEVICE COMPLETE * FFA DEF FF FF OCT 6000 FORMFEED IN UPPER BYTE * * SETUP LINESPACE * * LNSP NOP CLA STA $DV17,I ZERO BUFFER LENGTH STA $DV18,I ZERO ASIC CONTROL WORD INA ALLOW TIMEOUT JMP LNSP,I RETURN * * FORM CONTROL * * FCNTL LDA $DV15,I GET SUBFUNCTION STA DVX5,I SAVE IT AND BIT10 GET HONESTY MODE (X FIELD) SZA BIT 10 SET? JMP CWRIT YES, IGNORE FORM CONTROL LDA $DV15,I AND BIT7 GET CARRIAGE CONTROL (V FIELD) SZA BIT 7 SET? JMP CWRIT YES, OUTPUT ENTIRE BUFFER LDB DVX12,I NO, GET ADDRESS OF FIRST CHARACTER LDA B,I GET FIRST TWO CHARACTERS AND LBYTE GET FORM CONTROL CHARACTER STA DVX10,I SAVE IN EXTENSION XOR B,I REPLACE FORM CONTROL CHARACTER STA B,I IN OUTPUT BUFFER WITH NUL JSB ASCWT MAKE SURE ITS A ASCII WRITE LDA DVX10,I GET FORM CONTROL CHARACTER CPA A0 DOUBLE SPACE? JMP DBLSP w YES CPA A1 EJECT PAGE? JMP EJPG YES CPA ASS SUPRESS SPACE? JMP SUPSP YES JMP CWRT SINGLE SPACE * A0 OCT 30000 ASCII ZERO IN UPPER BYTE A1 OCT 30400 ASCII ONE IN UPPER BYTE ASS OCT 25000 ASCII * IN UPPER BYTE BIT10 OCT 2000 HONESTY MODE (X FIELD) * * * BOUBLE SPACE * * DBLSP LDB M1 LINE FEED COUNT STB DVX11,I SAVE IT DSPC JSB LNSP SETUP FOR LINESPACE JSB CEXIT INITIATE ZERO LENGTH RECORD * ISZ DVX11,I DONE WITH LINEFEED'S? JMP DSPC NO, DO MORE JMP CWRIT YES, CONTINUE WRITE CWRT LDA DVX5,I GET WRITE SUBFUNCTION STA $DV15,I SAVE IT JMP CWRIT CONTINUE WRITE * * SUPRESS SPACE * * SUPSP CLA,INA STA DVP2,I SET SUPRESS FLAG JMP CWRT RESTORE SUBFUNCTION * * EJECT PAGE * * EJPG LDA FFA GET FORMFEED ADDRESS JSB EXIT1 INITIATE FORMFEED JMP CWRT RESTORE SUBFUNCTION * * * ENABLE PRIMARY/SECONDARY PROGRAM SCHED (FUNCTION CODE = 20/40) * * EPPRG LDB DVP5 SAVE PRIMARY PROG NAME IN DVP5-DVP7 RSS OPTIONAL PARAMETER IN DVP8 ESPRG LDB DVP9 SAVE SECONDARY PROG NAME IN DVP9-DVP11 LDA $DV16 GET SCHED PROG NAME POINTER JSB .MVW SAVE SCHEDULED NAME DEF B4 PLUS OPTIONAL PARAMETER NOP LDA $DV15,I SEND CONTROL REQUEST IOR B2300 WITH SUBFUN = 23 STA $DV15,I CLA ZERO PARAMETER TO STA $DV16,I ENABLE ASYNC INT. JSB CEXIT INITIATE PRIMARY/SECONDARY PROG REQUEST * JMP LDCM2 DEVICE COMPLETE * B2300 OCT 2300 * * * DISABLE PRIMARY/SECONDARY PROGRAM SCHED (FUNCTION CODE = 21/41) * * DPPRG CCA STA DVP5,I SETUP ILLEGAL NAME JMP LDCM2 DEVICE COMPLETE * DSPRG CCA STA DVP9,I SETUP ILLEGAL NAME JMP LDCM2 DEVICE COMPLETE * * b * DISABLE ASYNCHRONOUS INTERRUPTS (FUNCTION CODE = 23) * * DPROG CLA,INA SET PARAMETER TO STA $DV16,I DISABLE ASYNC INT. CLA JSB CEXIT INITIATE DISABLE PROG REQUEST * JMP LDCM2 DEVICE COMPLETE * * * SET TIMEOUT (FUNCTION CODE = 22) * * SETTO JSB DT GET DEVICE TYPE JMP LDCM2 PRINTER, DEVICE COMPLETE LDA $DV16,I GET TEN'S OF MILLISEC CMA,INA MAKE NEG. STA DVP4,I UPDATE DEVICE TIMEOUT DVR PARAM LDCM3 CLA ZERO STA $DV16,I ERROR CODE JMP LDCM2 DEVICE COMPLETE * * READ 1 ASCII CHARACTER INTO EXTENSION (FUNCTION CODE = 42) * * GTCHR LDA $DV15,I MAKE SURE AND RQASC ITS A IOR B1 ASCII READ STA $DV15,I SAVE IT CLB LDA $DV16,I GET OPTIONAL PARAMETER SZA,RSS ZERO? LDB BIT11 YES, SET ECHO BIT STB $DV18,I SAVE ASIC CONTROL WORD LDA DVX9 GET1 BYTE READ ADDR. STA $DV16,I SAVE IT CCA ONE BYTE BUFFER LENGTH STA $DV17,I SAVE IT CLA STA $DV19,I ZERO OPTIONAL PARAMETER STA DVX3,I REQUIRED FOR READ CONTINUATION INA ALLOW TIMEOUT JSB CEXIT READ ONE ASCII CHARACTER * LDA DVX9,I GET CHARACTER READ (UPPER BYTE) LDB $DV17,I GET XLOG (+1) LSL 8 SHIFT XLOG INTO HIGH BYTE AND STB $DV17,I CHAR INTO LOW BYTE OF B REG. JMP LDCM2 DEVICE COMPLETE * * * CONTINUATION EXIT * * CEXIT NOP LDB CEXIT STORE RETURN ADDR STB DVX1,I AT DVX1 LDB $DV16,I GET BUFFER ADDR STB DVX4,I SAVE ADDR OF CURRENT READ ISZ DD.00 JMP DD.00,I INTERFACE INITIATE * EXIT1 NOP CCB BUFFER LENGTH = 1 CHAR DST $DV16,I SAVE BUFFER ADDR, BUFFER LENGTH ADB DVX8,I REMOVE LAST CHARACTER STB DVX8,I FROM ACCUMULATED XLOG CLA STA $DV18,I ZERO ASIC CONTROL WORD INA ALLOW TIMEOUT LDB EXIT1 SAVE RETURN ADDR JMP CEXIT+2 INITIATE REQUEST SKP * * * CONTINUATION * * CONT LDA $DV17,I GET XLOG (+CHAR'S) ADA DVX8,I ADD PREVIOUS ACCUMULATED CHAR'S STA DVX8,I SAVE ACCUMULATED XLOG (+CHAR'S) LDA $DV16,I GET ERROR CODE AND B77 CPA B3 TIMEOUT? JMP TIMOT YES SZA ERROR? JMP LDCOM YES, DEVICE COMPLETE LDA $DV15,I GET RQ LDB DVX1,I RAR,SLA WRITE REQ? JMP B,I YES, CONTINUE WRITE LDA $DV18,I GET ASIC STATUS ALF,ALF GET SPECIAL CHAR BIT SSA SPECIAL CHAR? JMP DMAIN NO, DMA INT. CCA YES ADA DVX8,I REMOVE LAST CHAR FROM COUNT STA DVX8,I SAVE COUNT LDA $DV17,I GET XLOG (+CHAR'S) LDB DVX4,I GET CHAR ADDR PTR JSB LSCHR GET SPECIAL CHARACTER CPA DC2L DC2? JMP BKXFR YES, BLOCK TRANSFER CPA CR CR? JMP WZERO YES CPA BSL BACKSPACE? JMP BKSPC YES CPA RO RUBOUT? JMP RBOUT YES CPA RS RECORD SEPERATOR? JMP WZERO YES, WRITE ZERO LENGTH RECORD CPA CN.D CONTROL D? JMP CNTRD YES JMP RBOUT * WZERO SEZ,RSS LAST CHAR EVEN? JMP WRTZ NO, SETUP FOR ZERO LENGTH ASCII WRITE LDA B,I YES, GET LAST WORD AND LBYTE REMOVE LOWER BYTE IOR B40 PAD WITH A BLANK STA B,I RESTORE WORD WRTZ LDA DVX15,I GET INITIAL SUBFUNCTION LSR 6 BIT 6 SLA BINARY? JMP LDCOM YES, NO CRLF JSB ASCWT MAKE SURE ITS A ASCII WRITE CLA ZERO STA $DV17,I XLOG AND STA $DV18,I ASIC CONTROL WORD INA  ALLOW TIMEOUT JSB CEXIT INITIATE ZERO LENGTH RECORD * LDCOM LDA DVX8,I GET TOTAL XLOG (+CHARS) INA ROUNDOFF ARS CONVERT TO WORDS LDB DVX7,I GET ORIGIONAL XLOG SSB WORDS? LDA DVX8,I NO, SAVE CHAR'S STA $DV17,I YES, SAVE WORDS JSB BUFIX RESTORE FORM CONTROL CHAR LDCM2 CLA JMP DD.00,I DEVICE COMPLETE * DMAIN LDA DVX8,I GET ACCUMULATED XLOG (+CHAR'S) ADA DVX3,I GET BUFFER LENGTH (-CHAR'S) SZA XLOG=ORIGIONAL BUFFER LENGTH? JMP B,I NO, FINISH REQUEST LDA $DV17,I YES, GET XLOG (+CHAR'S) LDB DVX4,I GET CHAR ADDR PTR JSB LSCHR GET LAST CHARACTER LDA $DV15,I GET SUBFUNCTION AND B2100 TRANSPARENT & BINARY BITS SET? CME,SZA NO, COMPLEMENT CHARACTER FLAG JMP LDCOM YES, DO NOT APPEND 'CRLF' JMP WZERO FINISH READ * B2100 OCT 2100 TRANSPARANT & BINARY BITS * * * READ ONE CHARACTER SUBROUTINE * * RDCHR NOP LDB $DV15,I GET SUBFUNCTION BLF,BLF SLB ECHO SET? IOR BIT11 YES, SET ECHO IN CONTROL WORD STA $DV18,I FORM ASIC CONTROL WORD LDA DVX9 GET BUFFER ADDR OF 1 BYTE READ STA $DV16,I SAVE IT CCA BUFFER LENGTH STA $DV17,I OF 1 BYTE CLA STA $DV19,I ZERO OPTIONAL PARAMETER INA ALLOW TIMEOUT JMP RDCHR,I RETURN * BIT11 OCT 4000 ECHO BIT/ESCAPE BACKARROW BIT * * * GET LAST CHARACTER SUBROUTINE * * LSCHR NOP A=XLOG(+CHARS), B=CHAR ADDR PTR ADA M1 CREATE RBL LAST ADB A BYTE ADDRESS CLE,ERB E=0/1, ODD/EVEN LDA B,I GET LAST CHAR SEZ,RSS CHAR EVEN? ALF,ALF NO, ROTATE TO LOW BYTE AND HBYTE REMOVE HIGH BYTE JMP LSCHR,I A=CHAR IN LOW/ BYTE, E=ODD/EVEN * M1 OCT -1 * * * TIMEOUT * * TIMOT LDA $DV15,I GET RQ CLB SLA READ REQUEST? STB $DV16,I YES, ZERO ERROR CODE JSB BUFIX RESTORE FORM CONTROL CHAR JMP LDCM2 DEVICE COMPLETE * * * * TEMP NOP TEMPORARY STORAGE DIREC NOP DIRECTIVE LBYTE OCT 177400 LOWER BYTE MASK HBYTE OCT 377 HIGH BYTE MASK BIT14 OCT 40000 SPEC CHAR (TYP 1) BIT15 OCT 100000 SPEC CHAR (TYP 2) B137 OCT 137 UNDERSCORE CHARACTER B22 EQU * DC2L OCT 22 DC2 CODE IN LOWER BYTE CR OCT 15 CARRIAGE RETURN B4 EQU * CN.D OCT 4 CONTROL D RS OCT 36 RECORD SEPERATOR BSL OCT 10 BACKSPACE IN LOWER BYTE RO OCT 177 RUBOUT IN LOWER BYTE * * * ROUTINE FOR DEFINING STORAGE IN DEVICE DVR EXT. * * SETAD NOP LDA $DV22,I GET ADDR POINTING TO ADDR OF DVT EXT CPA DVX1 EXTENSION SETUP? JMP SETAD,I YES, RETURN LDB D.26 SET FOR 15 EXTENSION AND 11 PARAMETER ADDR. STB TEMP LDB DVX SETUP DVX1-DVX15 POINTERS LOOP STA B,I INB CPB DVXT DRIVER PARAMETER ADDRESS? LDA $DVTP YES, SETUP DVP2-DVP12 POINTERS INA ISZ TEMP JMP LOOP JMP SETAD,I * D.26 DEC -26 * * EXTENSION FOR MISC. STORAGE * * DVX DEF DVX1 DVXT DEF DVP2 DVX1 NOP CONTINUATION ADDR DVX2 NOP BUFF ADDR OF CURRENT REQUEST DVX3 NOP BUFF LENGTH (-CHAR'S) DVX4 NOP ADDRESS OF CURRENT READ DVX5 NOP MODIFIED SUBFUNCTION DVX6 NOP INITIAL ADDRESS OF REQUEST DVX7 NOP INITIAL XLOG OF REQUEST DVX8 NOP CHARACTER ACCUMULATOR DVX9 NOP BUFFER FOR 1 BYTE READ DVX10 NOP FORM CONTROL CHARACTER DVX11 NOP LINE FEED COUNTER DVX12 NOP INITIAL ADDR OF OUTPUT DVX13 NOP INITIAL XLOG OF OUTPUT DVX14 NOP }`^Z FREE DVX15 NOP INITIAL SUBFUNCTION * * DRIVER PARAMETER STORAGE * * * $DVTP NOP TERMINAL CONFIGURATION DVP2 NOP SUPRESS SPACE FLAG DVP3 NOP TRIGGER CHARACTER BEFORE READ DVP4 NOP TIMEOUT FOR SYSTEM REQUEST * DVP5 NOP SCHEDULED PRIMARY PROGRAM DVP6 NOP SCHEDULED PRIMARY PROGRAM DVP7 NOP SCHEDULED PRIMARY PROGRAM DVP8 NOP OPTIONAL PARAMETER, PRIMARY PROG * DVP9 NOP SCHEDULED SECONDARY PROGRAM DVP10 NOP SCHEDULED SECONDARY PROGRAM DVP11 NOP SCHEDULED SECONDARY PROGRAM DVP12 NOP OPTIONAL PARAMETER, SECONDARY PROG * * END `  92070-18084 1941 S C0122 &DD.20              H0101 WTASMB,R,L,C * * NAME: DD.20 * SOURCE: 92070-18084 * RELOC: 92070-16084 * PGMR: T.A.L. * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * * NAM DD.20,0 92070-16084 REV.1941 791024 * * ENT DD.20 EXT $DV6,$DV15,$DV16,$DV17,$DV18,$DV19,$DV22 EXT $DVTP,$CVT3,$CVT * GEN 21,EDD.20,TX:20,TO:3000,DT:20B,QU:FI GEN 2,DX:1 * GEN 7,M2645:1,DP:1:1 GEN 7,M2645:2,DP:1:2 * A EQU 0 B EQU 1 SKP * DD.20 NOP STA DIREC SAVE DIRECTIVE JSB SETAD SETUP EXTENSION ADDR PTR'S LDA DIREC GET DIRECTIVE AND B7 SZA ABORT? JMP GO NO * * ABORT * * STA DVX14,I ZERO CHARACTER ACCUMULATOR LDA B4 CALL INTERFACE DRIVER JSB CEXIT WITH ABORT CODE JMP DDCM2 DEVICE COMPLETE * * GO CPA B1 INITIATE? JMP INIT YES CPA B2 CONTINUATION? JMP CONT YES CPA B3 TIMEOUT? JMP DDCM2 YES, DEVICE COMPLETE JMP DDCOM DEVICE COMPLETE * * B1 OCT 1 B2 OCT 2 B3 OCT 3 B7 OCT 7 M9 DEC -9 DIREC NOP DIRECTIVE * * * INITIATION * * INIT LDA ESC& GET STA DVX4,I SAVE IT LDA $DVTP,I GET CTU (1 OR 2) IOR PLU MERGE STA DVX5,I SAVE LDA $DV15,I GET SUB(FUNCTION STA DVX15,I SAVE IT AND RQASC CLEAR BITS 6,7,8 & RQ IOR B202 MAKE SURE ITS A ASCII WRITE STA $DV15,I INHIBIT 'CRLF' CLA STA $DV18,I ZERO ASIC CONTROL WORD LDA DVX15,I GET RQ AND B3 CPA B3 CONTROL REQUEST? JMP CNTRL YES LDA $DV6,I GET DEVICE STATUS AND LBYTE REMOVE OLD STATUS STA $DV6,I LDA DVX15,I GET SUBFUNCTION AND ECHO REMOVE ECHO BIT 8 STA DVX15,I SAVE INITIAL SUBFUNCTION MINUS ECHO BIT AND B3 GET RQ LDB $DV16,I GET BUFFER ADDR STB DVX2,I SAVE INITIAL ADDR. LDB DVX4 GET ESC SEQUENCE ADDR. STB $DV16,I SAVE IT LDB $DV17,I GET XLOG STB DVX10,I SAVE INITIAL XLOG (-CHARS OR +WORDS) SSB CHARACTERS? JMP *+3 YES, SAVE THEM CMB,INB NO, CONVERT TO BLS - CHARACTERS STB DVX3,I SAVE -CHAR LENGTH CPA B1 READ REQUEST? JMP READ YES * * * WRITE REQUEST * * WRITE LDA DVX3,I GET -CHAR LENGTH CMA,INA MAKE CHARACTERS POSITIVE LDB DVX15,I GET SUBFUNCTION BLF,BLF RBL SSB ASCII? RSS NO, CHARACTER LENGTH OK ADA B2 YES, ADD TWO TO LENGTH FOR 'CRLF' LDB M257 ADB A SSB LENGTH > 256? SZA,RSS ZERO XLOG? JMP ERROR YES, ILLEGAL REQUEST ERROR CCE E=1 FOR DECIMAL JSB $CVT3 CONVERT +CHAR'S TO ASCII LDA DN IOR $CVT+1 STA DVX6,I SAVE LDA $CVT+2 STA DVX7,I SAVE TO WRITE LDA W GET STA DVX8,I SAVE LDA M9 STA $DV17,I BUFFER LENGTH CLA,INA ALLOW TIMEOUT JSB CEXIT INITIATE WRITE ESCAPE SEQUENCE * LDB ENQ GET ENQUIRY RACK STB $DV19,I SAVE 'ENQ' OR ZERO LDA DVX15,I GET RQ XOR B3 MAKE SURE ITS A ASCII READ STA $DV15,I SAVE IT LDA DVX16 GET 1 BYTE READ ADDRESS STA $DV16,I SAVE IT CCA BUFFER LENGTH STA $DV17,I SAVE IT CLA STA $DV18,I ZERO ASIC CONTROL WORD INA ALLOW TIMEOUT JSB CEXIT SEND 'ENQ', READ 'ACK' * CLB CLEAR 'ENQ' LDA DVX16,I GET BYTE READ AND LBYTE REMOVE LOW BYTE CPA ACK 'ACK' RECEIVED? RSS YES, CONTINUE JMP RACK NO, RETRY FOR ACK ONLY * LDA DVX15,I GET SUBFUNCTION AND CBIT7 ADD 'CRLF' STA $DV15,I LDA DVX2,I GET INITIAL BUFFER ADDRESS STA $DV16,I SAVE IT LDA DVX3,I GET INITIAL BUFFER LENGTH STA $DV17,I SAVE IT CLA STA $DV18,I ZERO ASIC CONTROL WORD INA ALLOW TIMEOUT JSB CEXIT INITIATE WRITE * LDA $DV17,I GET XLOG (+CHAR'S) STA DVX14,I SAVE IN EXTENSION JSB STAT SETUP FOR 2 CHAR READ JSB CEXIT SEND DC1, READ 'S' OR 'F' CLB ZERO ERROR CODE LDA DVX12,I GET COMPLETION STATUS AND LBYTE REMOVE LOW BYTE CPA S SUCCESSFUL? JMP DONE YES STB DVX14,I NO, ZERO XLOG JSB DYST GET DYNAMIC STATUS * DONE STB $DV16,I SETUP ERROR CODE JMP DDCOM DEVICE COMPLETE * STAT NOP SETUP FOR 2 CHAR READ LDA DVX12 GET READ ADDRESS STA $DV16,I SAVE IT LDA M2 BUFFER LENGTH STA $DV17,I SAVE IT LDA DVX15,I GET RQ AND RQASC MAKE SURE ITS A ASCII READ INA RQ=1 STA $DV15,I SAVE IT CLA STA $DV18,I ZERO ASIC CONTROL WORD LDA DC1 SETUP DC1 STA $DV19,I IN OPTIONAL PARAMETER CLA,INA ALLOW TIMEOUT JMP STAT,I RETURN * * BIT6 OCT 100 BINARY BIT 6 CBIT7 OCT 177577 ADD 'CRLF' RQASC OCT 177074 ZERO BITS 6,7,8 & RQ ECHO OCT 177377 ZERO ECHO BIT 8 PLU OCT 70060 B202 OCT 202 M2 DEC -2 S OCT 51400 ILREQ OCT 140001 ILLEGAL REQUEST RS.CR OCT 17015 RECORD SEPERATOR CARRIDGE RETURN ACK OCT 3000 'ACKNOWLEDGE' * * * READ REQUEST * * READ LDA B3 SZB,RSS ZERO XLOG? JMP FBRF YES, FORWARD SPACE ONE RECORD LDA S2 GET STA DVX6,I SAVE IT LDA R GET STA DVX7,I SAVE IT LDA M7 BUFFER LENGTH STA $DV17,I SAVE IT CLA,INA ALLOW TIMEOUT JSB CEXIT SEND READ ESCAPE SEUQENCE * LDA DVX15,I GET INITIAL SUBFUNCTION IOR BIT6 SET BINARY BIT STA $DV15,I SAVE IT LDA DVX16 GET DRIVER EXTENSION ADDR STA $DV16,I SAVE IT LDA M5 BUFFER LENGTH STA $DV17,I SAVE IT LDA B1415 SETUP FOR SPECIAL CHAR (CR) STA $DV18,I IN ASIC CONTROL WORD LDB DC1 SETUP FOR STB $DV19,I DC1 CODE IN UPPER BYTE CLA,INA ALLOW TIMEOUT JSB CEXIT SEND DC1, READ 5 BYTES * CLA ZERO ASIC CONTROL WORD LDB DVX15,I GET INITIAL SUBFUNCTION STB $DV15,I SAVE IT LDB DVX16,I GET LAST CHARACTERS READ CPB RS.CR RSCR? JMP ZEROL YES, END OF READ STA $DV18,I SAVE ASIC CONTROL WORD LDA DVX2,I GET INITIAL BUFFER ADDR STA $DV16,I SAVE IT LDA DVX16,I GET FIRST AND SECOND BYTES LDB DVX17,I GET THIRD AND FOURTH BYTES BLF MERGE THE FOUR RRL 4 BYTES IN ORDER BLF TO FIND RRL 4 BUFFER LENGTH ALF RRR 4 CMA,INA,SZA,RSS BUFFER LENGTH ZERO? JMP ZEROL YES, READ STATUS STA B SAVE LENGTH CMB,INB MAKE LENGTH POSITIVE (+CHAR'S) STB DVX13,I SAVE REQUEST LENGTH (> +CHARS) ADB DVX3,I ADD ORIGIONAL LENGTH (-CHAR'S) SSB,RSS REQUEST LENGTH >= BUFFER LENGTH? LDA DVX3,I YES, USE BUFFER LENGTH STA $DV17,I SAVE LENGTH (-CHARS) SSB REMAINING LENGTH POSITIVE? CLB NO, ZERO INTERRUPTS TO BIT BUCKET LDA DC1 DC1 IN UPPER BYTE IOR B MERGE REMAINING INTERRUPTS TO BIT BUCKET STA $DV19,I SAVE DC1 + INTERRUPTS TO BIT BUCKET CLA,INA ALLOW TIMEOUT JSB CEXIT SEND DC1, READ DVT17 BYTES * LDA $DV15,I GET SUBFUNCTION LSR 6 LDB $DV17,I GET XLOG (+CHARS) SLA ASCII? JMP XLOG NO, DO NOT ADJUST XLOG LDA DVX13,I YES, GET REQUEST LENGTH (+CHARS) ADA M1 SUBTRACT ONE ADA DVX3,I ADD BUFFER LENGTH (-CHARS) SZA,RSS (RL-1) = BL? ADB M1 YES, XLOG = XLOG -1 SSA (RL-1) < BL? ADB M2 YES, XLOG = XLOG - 2 XLOG SSB XLOG NEGATIVE? CLB YES, ZERO XLOG STB DVX14,I SAVE XLOG (+CHAR'S) CLE,ERB E=0/1, ODD/EVEN ADB DVX11,I FIND LAST CHAR ADDR. SEZ,RSS LAST CHAR EVEN? JMP DDCOM NO, DEVICE COMPLETE LDA B,I YES, GET LAST WORD AND LBYTE REMOVE LOWER BYTE (SPEC CHAR) STB TEMP SAVE CHAR ADDR PTR LDB $DV15,I GET SUBFUNCTION BLF,BLF RBL SSB,RSS BINARY? IOR B40 NO, PAD WITH A BLANK STA TEMP,I RESTORE WORD JMP DDCOM DEVICE COMPLETE * M1 DEC -1 B40 OCT 40 DC1 OCT 10400 DC1 CODE IN UPPER BYTE B1415 OCT 140000 SPECIAL CHAR (CR) LBYTE OCT 177400 LOWER BYTE MASK * * * ZERO LENGTH READ/DYNAMIC STATUS SETUP * TICST LDA S GET RSS ZEROL STA DVX14,I ZERO XLOG STA DVX12,I SAVE OR NON JSB DYST GET DYNAMIC STATUS JMvP DONE SETUP ERROR CODE * * * CONTROL REQUEST * * CNTRL LDA DVX15,I GET LSR 6 SUBFUNCTION AND B77 SZA,RSS RESET CTU? JMP RW YES, DO REWIND CPA B1 WRITE EOF? JMP RW YES CPA B2 BACKSPACE 1 RECORD? JMP FBRF YES CPA B3 FORWARD SPACE 1 RECORD? JMP FBRF YES CPA B4 REWIND? JMP RW YES CPA B5 REWIND? JMP RW YES CPA B6 DYNAMIC STATUS? JMP TICST YES CPA B10 WRITE EOF IF NOT PREV. WRITTEN JMP EOF YES CPA B13 FORWARD SPACE 1 FILE? JMP FBRF YES CPA B14 BACKSPACE 1 FILE? JMP FBRF YES CPA B26 WRITE END OF DATA (EOD)? JMP RW YES CPA B27 LOCATE ABSOLUTE FILE IPRAM1? JMP ABSF YES ZERR CLA,RSS ZERO ERROR CODE ERROR LDA ILREQ ILL. REQ. DON'T DOWN/DO FLUSH STA $DV16,I SAVE ERROR CODE JMP DDCM2 DEVICE COMPLETION * B4 OCT 4 B5 OCT 5 B6 OCT 6 B10 OCT 10 B13 OCT 13 B14 OCT 14 B26 OCT 26 B27 OCT 27 B77 OCT 77 B320 OCT 320 * * END OF FILE (FUNCTION CODE = 10) * * EOF LDA S GET IN UPPER BYTE STA DVX12,I SET TO SUCCESSFUL JSB DYST GET DYNAMIC STATUS LDA $DV6,I GET DEVICE STATUS AND B320 SZA AT EOF, LP, OR REWINDING? JMP ZERR YES, DO NOT WRITE EOF CLA,INA WRITE EOF * * REWIND/WRITE EOF/WRITE EOD (FUNCTION CODE = 1,4,5 OR 26) * * RW LDB U0 REWIND CPA B1 WRITE EOF? LDB U5 YES CPA B26 WRITE EOD? LDB U6 YES STB DVX6,I SAVE LDB C STB DVX7,I SAVE "C" LDB M7 STB $DV17,I BUFFER LENGTH SEND LDB DVX4 GET ESCAPE SEQUENCE ADDR. gj STB $DV16,I SAVE IT CLA,INA ALLOW TIMEOUT JSB CEXIT INITIATE REQUEST * JSB STAT SETUP FOR 2 CHAR READ JSB CEXIT SEND DC1, READ 'S' OR 'F' JSB DYST GET DYNAMIC STATUS JMP DONE SETUP ERROR CODE * * FORWARD/BACKWARD SPACE 1 RECORD/FILE (FUNCTION CODE = 2,3,13 OR 14) * * FBRF LDB UFRWD CPA B2 FORWARD SPACE? LDB UBKWD NO, BACKSPACE CPA B14 LDB UBKWD BACKSPACE STB DVX6,I SAVE LDB ONEC CPA B13 RECORD? LDB TWOC NO, FILE CPA B14 LDB TWOC FILE STB DVX8,I SAVE <1C OR 2C> LDB ONEP SPACE ONE RECORD/FILE STB DVX7,I SAVE <1 SMALL"P"> LDB M10 STB $DV17,I BUFFER LENGTH JMP SEND * M5 DEC -5 M7 DEC -7 M8 DEC -8 M10 DEC -10 * * DYNAMIC STATUS (FUNCTION CODE = 6) * * DYST NOP LDA DYST STORE RETURN ADDRESS STA DVX20,I AT DVX20 LDA DVX15,I GET SUBFUNCTION AND RQASC CLEAR BITS 6,7,8 & RQ IOR B202 MAKE SURE ITS A ASCII WRITE STA $DV15,I INHIBIT 'CRLF' CLA STA $DV18,I ZERO ASIC CONTROL WORD LDA UP STA DVX6,I SAVE <^> LDA M5 BUFFER LENGTH STA $DV17,I SAVE IT LDA DVX4 GET ESCAPE SEQUENCE ADDR. STA $DV16,I SAVE IT CLA,INA ALLOW TIMEOUT JSB CEXIT SEND STATUS ESCAPE SEQUENCE * LDA $DV15,I MAKE SURE XOR B3 ITS A STA $DV15,I ASCII READ LDA DVX16 GET READ ADDR. STA $DV16,I SAVE IT LDA M8 BUFFER LENGTH STA $DV17,I SAVE IT LDA DC1 SETUP DC1 CODE STA $DV19,I IN OPTIONAL PARAMETER CLA STA $DV18,I ZERO ASIC CONTROL WORD INA ALLOW TIMEOUT JSB CEXIT SEND DC1, READ 8 BYTES STATUS * LDA $DV6,I/' GET DEVICE STATUS AND LBYTE REMOVE OLD STATUS STA $DV6,I * LDA DVX18,I GET STATUS BYTES 0 & 1 LDB DVX19,I GET STATUS BYTE 2 BLF MERGE THE RRL 8 THREE BYTES ALF TO FORM RRR 8 STATUS WORD AND B7777 REMOVE UPPER FOUR BITS STA $DV18,I SAVE STATUS WORD * * EXAMINE STATUS * * LDB B10 SET BIT 3 AND B10 GET SOFT ERROR BIT SZA SOFT ERROR? JSB DV6ER YES, SET 'RE' IN DV6 LDB BIT6 SET BIT 6 LDA $DV18,I GET STATUS WORD AND BIT4 GET TAPE BUSY BIT SZA TAPE BUSY? JSB DV6ER YES, SET 'DB' IN DV6 LDA $DV18,I GET STATUS WORD AND B5002 GET EOF,EOT & EOV BITS LDB BIT7 SET BIT 7 SZA EOF, EOT, OR EOV? JSB DV6ER YES, SET 'EOF' IN DV6 LDA $DV18,I GET STATUS WORD AND B2000 GET LOAD POINT BIT LDB BIT4 SET BIT 4 SZA LOAD POINT? JSB DV6ER YES, SET 'BOM' IN DV6 LDA $DV18,I GET STATUS WORD AND B1002 GET EOT & EOV BITS LDB B40 SET BIT 5 SZA EOT OR EOV? JSB DV6ER YES, SET 'EOM' IN DV6 LDB B2 NR ERROR MESSAGE LDA $DV18,I GET STATUS WORD SLA,RSS TAPE INSERTED? JMP ERR NO, SET 'NR' DV16=2 LDB B6 WP ERROR MESSAGE IOR =B177277 INA,SZA,RSS WRITE PROT & WRITE ERR SET? JMP ERR YES, SET 'WP' DV16=6 LDB B5 PE ERROR MESSAGE LDA $DV18,I GET STATUS WORD AND B444 SZA WRITE ERR, RD ERR OR HARD ERR? JMP ERR YES, SET 'PE' DV16=5 CLB SET DV16=0 ERR LDA DVX12,I GET 'S','U' OR 'F' SZA,RSS ZERO LENGTH READ? JMP ZLNRD YES, CHECK STATUS BITS AND LBYTE REMOVE LOW BYTE OA CPA S SUCCESSFUL? JMP SUCCS YES CPA U USER INTERRUPT? LDB RTRY YES, RESTART ZLNRD LDA $DV18,I GET STATUS AND B7467 MASK SFT ERR,WRT PROT,CMND EXECUTION CPA B4001 EOF, TAPE INSERTED SET? CLB YES, ZERO ERROR CODE CPA B3 EOV, TAPE INSERTED SET? SUCCS CLB YES, ZERO ERROR CODE LDA DVX20,I GET RETURN ADDRESS JMP A,I RETURN * DV6ER NOP LDA $DV6,I GET DEVICE STATUS IOR B ADD STATUS BIT STA $DV6,I SAVE NEW STATUS JMP DV6ER,I RETURN * BIT4 OCT 20 'BOM' BIT BIT7 OCT 200 'EOF' BIT B444 OCT 444 'WRITE ERR','RD ERR','HARD ERR' BITS B2000 OCT 2000 'LOAD POINT' BIT B5002 OCT 5002 'EOF','EOT','EOV' BITS B1002 OCT 1002 'EOT','EOV' BITS B7467 OCT 7467 B4001 OCT 4001 B7777 OCT 7777 RTRY OCT 100077 DON'T DOWN/DON'T FLUSH, RESTART U OCT 52400 'U', USER INTERRUPT * * * LOCATE ABSOLUTE FILE IPRM1 (FUNCTION CODE = 27) * * ABSF LDA $DV16,I GET ABSOLUTE FILE SSA NEGATIVE FILE #? JMP DDCM2 YES, DEVICE COMPLETE LDB M257 ADB A SSB,RSS FILE > 256 JMP DDCM2 YES, DEVICE COMPLETE CCE E=1 FOR DECIMAL FILE # JSB $CVT3 CONVERT FILE # TO ASCII LDA UN IOR $CVT+1 STA DVX6,I SAVE LDA $CVT+2 STA DVX7,I SAVE FILE NUMBER LDA P2 STA DVX8,I SAVE LDA C STA DVX9,I SAVE LDA M11 STA $DV17,I BUFFER LENGTH JMP SEND * M11 DEC -11 M257 DEC -257 * * DDCOM LDA DVX14,I GET TOTAL XLOG (+CHARS) INA ROUNDOFF ARS CONVERT TO WORDS LDB DVX10,I GET ORIGIONAL XLOG SSB WORDS? LDA DVX14,I NO, SAVE CHAR'S STA $DV17,I YES, SAVEv WORDS DDCM2 CLA JMP DD.20,I DEVICE COMPLETE * * * CONTINUATION EXIT * * CEXIT NOP LDB CEXIT STORE RETURN ADDR STB DVX1,I AT DVX1 LDB $DV16,I GET BUFFER ADDR STB DVX11,I SAVE ADDR OF CURRENT READ ISZ DD.20 JMP DD.20,I INTERFACE INITIATE SKP * * * CONTINUATION * * CONT LDA $DV16,I GET ERROR CODE AND B77 SZA ANY ERRORS? JMP DDCM2 YES, DEVICE COMPLETE LDB DVX1,I JMP B,I CONTINUE REQUEST * * * ROUTINE FOR DEFINING STORAGE IN DEVICE DVR EXT. * * SETAD NOP LDA $DV22,I GET ADDR POINTING TO ADDR OF DVT EXT CPA DVX1 EXTENSION SETUP? JMP SETAD,I YES, RETURN LDB D.20 SET FOR 20 MISC. STORAGE STB TEMP LDB DVX SETUP STA B,I DVX1-DVX20 INA ADDRESS INB POINTERS ISZ TEMP JMP *-4 JMP SETAD,I RETURN * D.20 DEC -20 TEMP NOP TEMPORARY STORAGE * * * REWIND/WRITE EOF/WRITE EOD * ESC& ************************** * P1(P2) * U0(U5)(U6) * C * ESC& OCT 15446 P1 OCT 70061 U0 OCT 72460 C OCT 41400 * P2 OCT 70062 U5 OCT 72465 U6 OCT 72466 * * FORWARD/BACKWARD SPACE 1 RECORD/FILE * ESC& ************************************ * P1(P2) * UFRWD(UBKWD) * ONEP * ONEC(TWOC) * UFRWD OCT 72453 ONEP OCT 30560 <1SMALL"P"> ONEC OCT 30503 <1C> * UBKWD OCT 72455 TWOC OCT 31103 <2C> * * FIND THE NTH FILE ON CTU (1 OR 2) * ESC& ********************************* * P1(P2) * UN * P2 * C * UN OCT 72400 * * WRITE N BYTES TO CTU (1 OR 2) * ESC& ***************************** * P1(P2) * DN * W * DN OCT 62000 W OCT 53400 *B@< ENQ OCT 2400 * * READ FROM CTU (1 OR 2) TO COMPUTER * ESC& ********************************** * P1(P2) * S2 * R * S2 OCT 71462 R OCT 51000 * * FETCH STATUS OF CTU (1 OR 2) * ESC& **************************** * P1(P2) * UP * UP OCT 57000 <^> * * EXTENSION FOR MISC. STORAGE * * DVX DEF DVX1 DVX1 NOP CONTINUATION ADDR DVX2 NOP BUFF ADDR OF CURRENT REQUEST DVX3 NOP BUFF LENGTH (-CHAR'S) DVX4 NOP ESC& DVX5 NOP P1(P2) DVX6 NOP REMAINING DVX7 NOP CONTROL DVX8 NOP ESCAPE DVX9 NOP SEQUENCE DVX10 NOP INITIAL LENGTH DVX11 NOP ADDR OF CURRENT READ DVX12 NOP ADDRESS OF 'S' OR 'F' DVX13 NOP REQUEST LENGTH (+CHARS) DVX14 NOP CHARACTER ACCUMULATOR DVX15 NOP INITIAL SUBFUNCTION DVX16 NOP BUFFER ADDR DVX17 NOP FOR DVX18 NOP 1-8 DVX19 NOP BYTE READ DVX20 NOP CONTINUATION ADDR FOR DYNAMIC STATUS * * DRIVER PARAMETER STORAGE * * * $DVTP CTU LEFT OR RIGHT * * END B  92070-18085 1941 S C0122 &DD.30              H0101 YTASMB,R * * NAME: DD.30 * SOURCE: 92070-18085 * RELOC: 92070-16085 * PGMR: B.L.L.,C.H.W. * * **************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT * * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * **************************************************************** * * NAM DD.30,0 92070-16085 REV.1941 791228 * * SKP * DEFINE DEVICE TABLE DEFAULTS FOR DISCS GEN 10,EDD.30,TX:25,DX:8 * 7902 DEFAULTS (2 LU'S) GEN 11,M7902:0,TO:750,DT:30B GEN 13,DP:2:0:0:0:3:134,DP:7:30:2 * GEN 11,M7902:1,TO:750,DT:30B GEN 13,DP:2:1:0:0:3:134,DP:7:30:2 * * 7906 DEFAULTS (4 LU'S) GEN 11,M7906:0,DT:32B,TO:100 GEN 14,DP:2:0:0:0:5:406,DP:7:48:1 * GEN 11,M7906:1,DT:32B,TO:100 GEN 14,DP:2:0:1:0:5:406,DP:7:48:1 * GEN 11,M7906:2,DT:32B,TO:100 GEN 14,DP:2:0:2:0:5:406,DP:7:48:1 * GEN 11,M7906:3,DT:32B,TO:100 GEN 14,DP:2:0:3:0:5:406,DP:7:48:1 * * 7910 DEFAULTS (4 LU'S) GEN 11,M7910:0,DT:31B,TO:1000 GEN 13,DP:2:0:0:0:4:370,DP:7:32:2 * GEN 11,M7910:1,DT:31B,TO:1000 GEN 14,DP:2:0:0:187:4:370,DP:7:32:2 * GEN 11,M7910:2,DT:31B,TO:1000 GEN 14,DP:2:0:0:373:4:370,DP:7:32:2 * GEN 11,M7910:3,DT:31B,TO:1000 GEN 14,DP:2:0:0:559:4:370,DP:7:32:2 * * 7920 DEFAULTS (10 LU'S) GEN 11,M7920:0,DT:32B,TO:100 GEN 13,DP:2:0:0:0:9:406,DP:7:48:5 * GEN 11,M7920:1,DT:32B,TO:100 GEN 14,DP:2:0:0:83:9:406,DP:7:48:5 * GEN 11,M7920:2,DT:32B,TO:100 GEN 14,DP:2:0:0:166:9:406,DP:7:48:5 * GEN 11,M7920:3,DT:32B,TO:100 GEN 14,DP:2:0:0:249:9:406,DP:7:48:5 * GEN 11,M7920:4,DT:32B,TO:100 GEN 14,DP:2:0:0:332:9:ߔ406,DP:7:48:5 * GEN 11,M7920:5,DT:32B,TO:100 GEN 14,DP:2:0:0:415:9:406,DP:7:48:5 * GEN 11,M7920:6,DT:32B,TO:100 GEN 14,DP:2:0:0:498:9:406,DP:7:48:5 * GEN 11,M7920:7,DT:32B,TO:100 GEN 14,DP:2:0:0:581:9:406,DP:7:48:5 * GEN 11,M7920:8,DT:32B,TO:100 GEN 14,DP:2:0:0:664:9:406,DP:7:48:5 * GEN 11,M7920:9,DT:32B,TO:100 GEN 15,DP:2:0:0:747:10:370,DP:7:48:5 * * 7925 DEFAULTS (9 LU'S) GEN 11,M7925:0,DT:32B,TO:100 GEN 13,DP:2:0:0:0:9:549,DP:7:64:9 * GEN 11,M7925:1,DT:32B,TO:100 GEN 14,DP:2:0:0:62:9:549,DP:7:64:9 * GEN 11,M7925:2,DT:32B,TO:100 GEN 14,DP:2:0:0:124:9:549,DP:7:64:9 * GEN 11,M7925:3,DT:32B,TO:100 GEN 14,DP:2:0:0:186:9:549,DP:7:64:9 * GEN 11,M7925:4,DT:32B,TO:100 GEN 15,DP:2:0:0:248:11:1024,DP:7:64:9 * GEN 11,M7925:5,DT:32B,TO:100 GEN 15,DP:2:0:0:363:11:1024,DP:7:64:9 * GEN 11,M7925:6,DT:32B,TO:100 GEN 15,DP:2:0:0:478:11:1024,DP:7:64:9 * GEN 11,M7925:7,DT:32B,TO:100 GEN 15,DP:2:0:0:593:11:1024,DP:7:64:9 * GEN 11,M7925:8,DT:32B,TO:100 GEN 15,DP:2:0:0:708:11:1024,DP:7:64:9 * * * ENT DD.30 * EXT $DVTP,$DV1,$DV6,$DV12,$DV15,$DV16 EXT $DV17,$DV18,$DV19,$DV20,$DV22 EXT .MVW,$CVT1,$SYMG,$DVLU * SKP DD.30 NOP LDB $DVTP ARE WE CPB DVP1 SET UP? JMP START YES. STA TEMP LDA N19 STA TEMP2 LDA DVAD DXSET STB 0,I INA INB CPA DXAD DVT EXTENSION YET? LDB $DV22,I YES. PICK UP DVT EXT. ADDRESS. ISZ TEMP2 JMP DXSET LDA TEMP GET ENTRY CODE * START AND B7 ADA JPTBA JUMP TABLE ADDR JMP 0,I VECTOR BASED ON ENTRY TYPE * JPTBA DEF JUMPA,I N19 DEC -19 DXAD DEF EXT1 DVAD DEF *+1 DVP1 BSS 1 DEVICE ADDRESS DVP2 BSS 1 UNIT DVP3 BSS 1 STARTING HEAD DVP4 BSS 1 STARTING CYLINDER DVP5 BSS 1 SPARES (NOT USED BY DD.30) DVP6 BSS 1 # OF TRACKS DVP7 BSS 1 SECTORS/TRACK DVP8 BSS 1 EXT1 BSS 1 ORIGINAL REQ BUFFER ADDR EXT2 BSS 1 ORIGINAL REQ LENGTH EXT3 BSS 1 COROUTINE ADDR ON CONTINUE EXT4 BSS 1 DEVICE CMDS EXT5 BSS 1 CYLINDER IN SEEK CMD / RCVD STATUS-1 EXT6 BSS 1 HEAD(15-8)/SECTOR(7-0) / RCVD STATUS-2 EXT7 BSS 1 DSJ RECEIVED EXT8 BSS 1 BUF'D(B15=0)/UNBUF'D(B15=1) FLAG + RQ CODE EXT9 BSS 1 ABORT FG(B15=1), T.O.FLAG(14-0 NOT 0) EXT10 BSS 1 ERROR COUNT FOR RETRIES QUIN1 BSS 1 ADDR OF 1ST QUINTUPLET SKP ************************************************************* * INITIATION ENTRY ************************************************************* INIT LDA $DV15,I SAVE CONWORD LDB 0 AND N4 CHANGE REQUEST TYPE TO MULTI-BUFFERED. STA $DV15,I XOR 1 SZA RQ CODE=0? CPA B3 OR 3? JMP REJ1 YES, REQ ERROR STA EXT8,I SAVE CONWORD BITS 1&0 DLD $DV16,I SAVE USER'S BUFFER ADDRESS. DST EXT1,I & REQUEST LENGTH LDA $DV20,I TEST "FIRST TIME" FLAG IOR EXT9,I AND ABORT FLAG (FOR ENTIRE NODE) SSA,RSS TO SEE IF DSJ & FILE MASK REQUIRED JMP INIT2 NO ************************************************************* * 1ST TIME THROUGH FOR THIS LU -INITIALIZE, OR * LAST REQUEST ON THIS NODE ABORTED ************************************************************* JSB BDSJQ BUILD DSJ QUINT. LDA DVP8,I GET # OF SURFACES CPA B1 SINGLE SURFACE? INA,RSS YES, GO SURFACE MODE CLA ELSE GO CYLINDER MODE XOR FMOP USE AUTO TRACK SWITCHING JSB BDCMD BUILD FILE MASK COMMAND (QUINT #2) LDA N2 2 QUINTS * JSB EXIT *** READ DSJO & SET FILE MASK *** * JSB CKDSJ VERIFY DSJ * NOTE: WE RETURN HERE ONLY IF DSJ WAS GOOD (0) STA EXT9,I CLEAR ABORT FLAG (A=0) LDA $DV20,I ELA,CLE,ERA CLEAR 1ST TIME BIT STA $DV20,I * END OF 1ST TIME INITIALIZATION CODE * INIT2 LDA DVP6,I NO. OF TRACKS CMA,INA LDB $DV18,I REQUESTED TRACK SSB NEGATIVE? JMP REJ1 YES ADA 1 SSA,RSS TRACK NO. TOO HIGH? JMP EOM YES, TAKE EOM RETURN. LDB $DV19,I SECTOR CLE,SLB,ERB NEGATIVE OR ODD? JMP REJ1 YES. STB TEMP2 SAVE PHYSICAL SECTOR CMB ADB DVP7,I SECTORS/TRACK CCE,SSB SECTOR NO. TOO LARGE? JMP REJ1 YES. * * CHECK FOR ENOUGH ROOM FOR REQUEST * LDB EXT2,I SZB,RSS JMP DONE1+1 ZERO LENGTH CMB,SSB,INB CMB,INB,RSS POSITIVE WORDS BRS -BYTES TO POS WORDS CLA RRR 7 DIVIDE BY 128 CLE,SZA INB ROUND UP LDA $DV6,I AND B234C DEVICE TYPE CPB B1 IF FLOPPY AND SZA SINGLE SECTOR, E=0 CLA,CCE ELSE E=1 (UNBUFFERED) SWP ADA TEMP2 DIV DVP7,I DIVIDE BY SECTORS/TRACK SZB INA ROUND UP TRACK LDB EXT8,I RBL,ERB BIT 15= 0 IF BUFFERED STB EXT8,I ADA $DV18,I STARTING TRACK. CMA,INA ADA DVP6,I NO. OF GOOD TRACKS. SSA,RSS ENUF ROOM FOR REQUEST? JMP OK YES, CONTINUE * EOM LDA $DV6,I NO. END OF MEDIA RETURN. IOR B20 SET END OF MEDIA BIT. STA $DV6,I * ILLEGAL REQUEST REJECT REJ1 LDA NDDF DON'T DOWN, DO FLUSH, ILL REQ JMP LDONE SKP ************************************************************* * BUILD SEEK CMD: TRACK TO CYLINDER, HEAD, SECTOR ADDRESS ************************************************************* OK LDA $DV18,I GET TRACK NO. CLB SET TO DIVIDE. DIV DVP8,I A = CYL OFFSET, B = HEAD OFFSET. ADA DVP4,I ADD STARTING CYL STA EXT5,I AND SAVE IT. ADB DVP3,I NOW HAVE ACTUAL HEAD. BLF,BLF POSITION IT IN UPPER BYTE. ADB TEMP2 COMBINE HEAD & SECTOR STB EXT6,I AND SAVE IT. SPC 3 ************************************************************* * BUILD SEEK QUINTUPLET IN DVT EXTENSION & DO SEEK ************************************************************* LDA DVP2,I UNIT IOR SEKOP INCLUDE SEEK OP CODE LDB QUIN1 ADB B5 POINT TO 2ND QUINT STB $DV16,I * JSB BDCMD ** BUILD SEEK QUINT ** ADB N3 LDA N6 FIX-UP LENGTH TO STA 1,I 6 BYTES * CCA * JSB EXIT *** SEND SEEK CMD *** STA EXT5,I CLEAR STATUS FIELD SKP ************************************************************* * SEEK DONE - READS AND WRITES ************************************************************* LDA EXT8,I GET REQUEST FLAG ERA,RAL 0 = WRITE SEZ,SSA 1 = READ JMP UNBUF UNBUFFERED READ ************************************************************* * BUFFERED READ - BUILD DSJ, READ CMD QUINTS. * WRITE - BUILD DSJ, WRITE CMD, WRITE DATA QUINTS. ************************************************************* JSB BDSJQ ** BUILD DSJ QUINT ** * LDA DVP2,I UNIT SEZ,RSS JMP WRIT DO WRITE SPC 3 ************************************************************* * BUFFERED READ PROCESSING ************************************************************* IOR RDOP ADD READ OPCODE TO UNIT * JSB BDCMD ** BUILD READ CMD QUINT ** ADB N2 STB TEMP POINT TO W ORDS 4,5 DLD BUFRD CACON,SECONDARY FOR BUFRD RD DST * MODIFY QUINT TEMP EQU *-1 * LDA N2 TWO QUINTUPLETS FOR READ JSB EXIT *** SEND READ CMD *** * LDB RESUM SENT, NOW DO LOGICAL WAIT LDA NEGTO STA $DV12,I SET TIMEOUT VALUE CLA,INA LWAIT ISZ DD.30 JMP EXIT1 NEGTO DEC -200 2 SECONDS * RESUM DEF *+1 ************************************************************* * PARALLEL POLL RECEIVED, GET THE DATA NOW ************************************************************* JSB CKDSJ VALIDATE DSJ JSB RDDSJ ** BUILD READ DATA & DSJ QUINTS ** LDA N2 JMP DATIN GO DO XFER SKP ************************************************************* * BUILD WRITE CMD AND WRITE DATA QUINTS ************************************************************* WRIT IOR WROP INCLUDE WRITE OPCODE WITH UNIT * JSB BDCMD ** BUILD WRITE CMD QUINT ** * LDA EXT1,I USER BUFR ADDR STA WBUF LDA EXT2,I GET REQ LENGTH STA WLEN * JSB QUINT ** BUILD WRITE DATA QUINT ** OCT 120102 WBUF NOP WLEN NOP DEC 2 OCT 140 * LDA N3 JSB EXIT *** DO WRITE *** SPC 3 * DATA SENT, CHECK XLOG & DSJ JSB LENCK VERIFY XLOG * JSB BDSJQ ** BUILD A POST-WRITE DSJ QUINT ** * CCA JSB EXIT *** DO A DSJ *** * JSB CKDSJ CHECK DSJ JMP DONE GO WRAP IT UP SKP ************************************************************* * UNBUFFERED READ - BUILD READ CMD, READ DATA, DSJ QUINT. ************************************************************* UNBUF JSB RDDSJ ** BUILD READ DATA & READ DSJ QUINTS ** LDB QUIN1 STB $DV16,I BEGINNING OF MULTI-BUF REQ LDA DVP2,I GET UNIT IOR RDOP ADD READ OPCODE * JSB BDCMD ** BUILD READ CMD QUINT ** * LDA N3 * DATIN JSB EXIT *** DO A DATA READ *** * JSB LENCK VERIFY XLOG * SKP ************************************************************* * SEND AN END COMMAND ************************************************************* DONE LDB QUIN1 STB $DV16,I LDA ENDOP * JSB BDCMD ** BUILD END QUINT ** CCA ONE QUINTUPLET. JSB EXIT *** SEND END COMMAND *** SPC 3 * LDA EXT2,I LENGTH DONE1 STA $DV17,I XLOG. CLA STA $DV18,I STA $DV19,I * * HERE TO CLEAN-UP & TAKE DONE EXIT LDONE CLB SZA ANY ERROR? STB $DV17,I YES, WIPE XLOG STA $DV16,I SAVE ERROR CODE CPA RSTRT IS THIS A RESTART? JMP LDON2 YES, DON'T PROCESS RETRY BIT YET LDA $DV6,I AND UMSK CLEAR-OUT DV6 STATUS CPB EXT10,I ERR COUNT=0? RSS IOR B10 NO, SET "RETRY" STA $DV6,I UPDATE DV6 STB EXT10,I CLEAR ERROR COUNT * LDON2 STB EXT3,I CLEAR COROUTINE ADDR LDA EXT9,I AND BIT15 MAINTAIN "ABORTED" BIT STA EXT9,I BUT CLEAR T.O. FLAG CLAI CLA JMP DD.30,I DONE * UMSK OCT 177400 B234C OCT 23400 SPC 3 LENCK NOP JSB CKDSJ LDB EXT2,I SSB CMB,INB CPB $DV17,I XLOG MATCH REQ LENGTH? JMP LENCK,I YES JMP RETRY NO, ERROR SKP ************************************************************* * CONTINUE AND RESUME COME HERE ************************************************************* CONT LDA $DV16,I CPA RSTRT RESTART FROM INTERFACE DVR JMP LDONE YES, OBEY IT AND B77 TEST ERROR CODE CPA B3 TIME OUT AT INTERFACE LEVEL? JMP TIMOT YES SZA NO ERROR? JMP LDONE ERROR, GO OUT DONE LDB EXT3,I COROUTINE ADDR SZB JMP 1,I ** GO TO COROUTINE (A=0) ** " * LDA B4 ILLEGAL INTERRUPT JMP LWAIT GET OUT SKP ************************************************************* * ENTERED ON ABORT ************************************************************* ABORT LDA B24 TELL PHY DVR TO ABORT WITH LOCK LDB ABAD WHERE TO GO TO ON RETURN. JMP EXIT1 * AB1 LDA $DV15,I AND NDDF SAVE "TY" FIELD IN CONTROL WORD IOR B4103 BUILD A PPOLL DISABLE CONTROL REQ STA $DV15,I CLA JSB EXIT *** DO CONTROL(42) TO DISABLE POLL *** * * BELOW CODE DOES A "HARD CLEAR" IN TWO STEPS. THIS CONSISTS * OF SENDING A SECONDARY OF "160" FOLLOWED BY A SINGLE BYTE * WITH EOI. THE ADDRESSED DEVICE THEN IS SENT A "SELECTED * DEVICE CLEAR". * LDA $DV15,I AND .14 CONWD=MUBUF REQ STA $DV15,I LDB QUIN1 STB $DV16,I DVT16 POINTS TO QUINT JSB QUINT MOVE QUINT TO EXT OCT 120102 WRITE DEF *+2 A ZERO WITH DEC -1 EOI AS THE DEC 0 1ST PART OF "AMIGO OCT 160 CLEAR" SEQUENCE * CCA JSB EXIT DROP SINGLE QUINT ON TO PHY DVR * LDA $DV15,I AND .14 IOR B3 FORM A CONTROL CLEAR REQ STA $DV15,I JSB EXIT DO A CTL (0) TO PHY DVR TO SEND "SDC" * LDB BIT15 SET ABORT FLAG: NEXT REQUEST FOR STB EXT9,I ANY LU ON THIS NODE WILL 1ST DO JMP DONE1 A DSJ AND RESEND FILE MASK * ABAD DEF AB1 B1 OCT 1 B4 OCT 4 B20 OCT 20 B24 OCT 24 B77 OCT 77 B4103 OCT 4103 B377 OCT 377 N6 DEC -6 .14 OCT 140000 NDDF OCT 140001 BIT15 OCT 100000 SKP ************************************************************* * SUBROUTINE TO BUILD THE DSJ QUINTUPLET ************************************************************* BDSJQ NOP BUILD DSJ QUINT SUB. LDB QUIN1 STB $DV16,I * BDSJ2 LDA EXjCT7 STA BDSJ4 ADDR OF EXT WD #11 * JSB QUINT ** BUILD DSJ QUINT ** OCT 120101 BDSJ4 NOP DEC -1 DEC 0 OCT 160 JMP BDSJQ,I SPC 3 ************************************************************* * BUILD READ DATA, DSJ QUINTS. ************************************************************* RDDSJ NOP DLD EXT1,I GET USER BUFFER/LENGTH DST DBUF SET FOR MOVE TO QUINT LDB QUIN1 ADB B5 STB $DV16,I * JSB QUINT ** BUILD READ DATA QUINT ** OCT 120101 DBUF NOP NOP B2 DEC 2 OCT 140 * LDA RDDSJ STA BDSJQ STORE RTN ADDR JMP BDSJ2 BUILD DSJ QUINT SKP ************************************************************* * CHECK DSJ & RETURN IF OK. OTHERWISE DO A STATUS READ * AND DETERMINE RECOVERY PROCEDURE. * CKDSJ ALWAYS RETURNS A=0 ************************************************************* CKDSJ NOP LDA EXT7,I GET DSJ BYTE AND B377 ISOLATE ONE BYTE CCE,SZA,RSS ZERO? JMP CKDSJ,I YES,O.K. ADA N4 SSA,RSS GREATER THAN 3? JMP XMSER YES. CONTROLLER IS FUBAR. * * STATUS ROUTINE, ENTERED ON BAD DSJ * LDB QUIN1 STB $DV16,I LDA DVP2,I UNIT IOR STOP INCLUDE STATUS OPCODE * JSB BDCMD ** BUILD STATUS CMD QUINT ** * LDA EXT5 RCVD STATUS GOES STA TEMP2 INTO EXT5 & EXT6 JSB QUINT ** BUILD READ STATUS QUINT ** OCT 120101 TEMP2 NOP N4 DEC -4 B10 OCT 10 OCT 150 * LDA CKDSJ STA EXT7,I SAVE SUBR RETURN ADDR LDA N2 TWO QUINTUPLETS JSB EXIT *** READ THE STATUS *** * LDA EXT5,I STATUS-1 WORD ALF,ALF AND B37 CPA B37 DRIVE ATTENTION? JMP DVATN YES CPA B14 END OF CYLINDER? JMP POWUZP YES, RESEND FILE MASK CPA B21 DEFECTIVE TRACK? JMP PARER YES. NOT ALLOWED. CPA B23 STATUS-2 ERROR? JMP NR? YES. CHECK FOR NOT READY. * RETRY LDA EXT10,I STEP ERROR COUNT. INA CPA B3 THREE TIMES? JMP PARER YES. XMISSION ERROR RETURN. STA EXT10,I PUT IT BACK. LDA RSTRT 100077B = RETRY CODE. NO MSG PRINTED. JMP LDONE ** GO OUT LOGICAL COMPLETION ** * * HERE TO CHECK STATUS-2 * NR? LDA EXT6,I STATUS-2 WORD. RAR,SLA DRIVE CONNECTED? JMP NRDY NO. SET DOWN. RAR,SLA,RAR SEEK CHECK? JMP RETRY YES. RAR,SLA DRIVE FAULT? JMP FAULT YES. LDB EXT8,I RAR,RAR SLA WRITE PROTECTED? SLB YES, IS THIS A WRITE? JMP RETRY NO. TRY AGAIN. LDA B6 YES. DOWN, DON'T FLUSH. JMP LDONE * FAULT LDA B12 FAULT ERROR CODE = 10 JMP LDONE * POWUP LDA $DV20,I RAL,ERA SET "FIRST TIME" FLAG STA $DV20,I TO REISSUE DSJ & SET FILE MASK JMP RETRY RETRY ENTIRE REQUEST SPC 2 NRDY LDA B2 ERROR CODE=2, NOT READY JMP LDONE SPC 3 * DVATN AND EXT6,I EXAMINE STAT-2 BITS 4-0 SZA ANY ERRORS? JMP RETRY YES LDB EXT7,I NO, OK TO PROCEED JMP 1,I RETURN TO "CKDSJ" CALLER SKP * HERE ON HARD FAILURE. DOWN DISC & DONT GIVE TRK/SECTOR * IF WE COULDN'T GET STATUS BACK (TIMEOUT OR BAD XLOG). * OTHERWISE PRINT TRACK/SECTOR/STATUS & DONT DOWN THE DISC PARER LDA EXT5,I STATUS ALF,ALF AND B37 ISOLATE STAT-1 TYPE CLE,SZA,RSS DID WE GET A STATUS? JMP XMSER NO, DOWN THE LU JSB $CVT1 CONVERT STAT TO ASCII/OCTAL STA MSF3 LDA $DV18,I GET TRACK CLB DIV .100 CCE,SZA >100? z IOR B20 YES IOR SPACE STA MSF1 STORE TRACK # LDA 1 GET 2 LOW-ORDER DIGITS JSB $CVT1 CONVERT TO ASCII-DECIMAL IOR BIT12 FORCE NUMERIC IN LHW STA MSF1+1 LDB $DV1 DVT ADDR JSB $DVLU GET LU JSB $CVT1 CONVERT TO ASCII-DECIMAL STA MSF2 JSB $SYMG PRINT MSG TO CONSOLE DEF DSMSG DLD EXT5,I GET STAT-1 & STAT-2 DST $DV18,I STORE IN DV18 & DV19 LDA MEDER DON'T DOWN & FLUSH JMP LDONE EXIT BY LOGICAL DONE * XMSER LDA B5 XMISSION ERROR JMP LDONE SKP ************************************************************* * HERE ON A TIMEOUT, IF 1ST, DO A READ DSJ * AND TRY TO RECOVER. ************************************************************* TIMOT LDB EXT9,I LDA B3 RBR,SLB THIRD TIME? JMP LDONE YES ISZ EXT9,I BUMP T.O. FLAG * JSB BDSJQ ** BUILD DSJ QUINT ** * CCA ONE QUINT. JSB EXIT *** GET DSJ *** * STA EXT5,I CLEAR STATUS WORD JMP RETRY DIDN'T TIMEOUT, SO RETRY * * * SEKOP OCT 1000 SEEK OPCODE ( 2) RDOP EQU CLAI READ OPCODE ( 5) WROP OCT 4000 WRITE OPCODE(10) STOP OCT 1400 STATUS OPCODE( 3) FMOP OCT 7407 FILE MASK OPCODE(17) ENDOP OCT 12400 END OPCODE (25) * B3 OCT 3 B5 DEC 5 B6 DEC 6 B7 OCT 7 B12 OCT 12 B14 OCT 14 B21 OCT 21 B23 OCT 23 B37 OCT 37 BIT12 OCT 10000 SPACE OCT 20040 RSTRT OCT 100077 MEDER OCT 140077 FLUSH,DON'T DOWN .100 DEC 100 N3 DEC -3 BUFRD OCT 20000,152 BUFRD RD CACON & SECONDARY SKP * * SUBROUTINE TO BUILD A SEND CMD QUINT * BDCMD NOP STA EXT4,I STORE CMD LDA EXT4 STA BDCM2 ADDR OF CMD INTO QUINT * JSB QUINT MOVE CMD QUINT TO EXTENSION OCT 120102 BDCM2 NOP N2 DEC -2 DEC 0 OCTHFB 150 * JMP BDCMD,I RETURN SPC 3 * * SUBROUTINE TO BUILD A QUINTUPLET * QUINT NOP LDA QUINT JSB .MVW DEF B5 NOP JMP 0,I RETURN * * ENTER HERE TO SAVE COROUTINE ADDR FOR RETURNING ON CONTINUE EXIT NOP STA $DV17,I SAVE NEG # OF QUINTS CLA LDB EXIT EXIT1 STB EXT3,I STORE NEXT ENTRY. ISZ DD.30 JMP DD.30,I RETURN. SPC 2 DSMSG OCT 40001 CONSOLE TRACK ERROR MSG DEC -22 ASC 02,*TRK MSF1 DEC 0,0 ASC 02, LU MSF2 NOP ASC 03, STAT= MSF3 NOP SPC 3 JUMPA DEF ABORT DEF INIT DEF CONT DEF TIMOT DEF RETRY DEF CONT END eH  92070-18086 2001 S C0122 &DD.12              H0101 UMASMB,R,L,C * NAME: DD.12 * SOURCE: 92070-18086 * RELOC: 92070-16086 * PGRM: D.L.M. * * ***************************************************************** * * COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED * * * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED INTO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * ***************************************************************** HED DD.12 HP-IB LINE PRINTER DRIVER NAM DD.12 92070-16086 REV.2001 800109 ENT DD.12 EXT $DV1,$DV6,$DV12,$DV15,$DV16,$DV17,$DV18 EXT $DV19,$DV20,$DV22,.MVW GEN 25,EDD.12,DX:1,TX:26,TO:1000,DT:12B GEN 3,M2631 * * A EQU 0 B EQU 1 * DD.12 NOP LDB $DV1 ARE WE CPB DX15,I SET UP? JMP START YES. STA TEMP NO, DO IT. LDA M.26 STA CNTR LDA $DV22,I DVT EXTENSION ADDRESS LDB DXAD DXSET STA B,I INA INB ISZ CNTR JMP DXSET LDA $DV1 WE ARE SET UP NOW STA DX15,I * LDA TEMP GET ENTRY DIRECTIVE START AND B7 GET LOWER 3 BITS ADA JTBLA ADD TO JUMP TABLE ADDR. JMP A,I GO TO IT! JTBLA DEF *+1,I ADDRESS OF TABLE DEF ABORT ZERO = ABORT DEF INIT ONE = INITIATE DEF CONT TWO = CONTINUE DEF TIMOT THREE = TIME OUT DEF PFAIL FOUR = POWER FAIL DEF CONT FIVE = RESUME ON INTERRUPT DEF REJ1 SIX AND SEVEN ARE ILLEGAL DEF REJ1 * PFAIL JSB RSET DO A RESET. LDA RSTRT THEN RESTART THE REQUEST. CLB JMP NR * * M.26 DEC -26 NDDF OCT 140000 CNTR NOP TEMP NOP DXAD DEF DX1 DX1 BSS 1 Q DX2 BSS 1 U DX3 BSS 1 I DX4 BSS 1  N DX5 BSS 1 T DX6 BSS 1 DX7 BSS 1 A DX8 BSS 1 R DX9 BSS 1 E DX10 BSS 1 A DX11 BSS 1 TEMPORARY LOCATION/STATUS DX12 BSS 1 TEMPORARY LOCATION/DSJ DX13 BSS 1 REQUEST AND FUNCTION CODE DX14 BSS 1 USER'S BUFFER ADDRESS/PRAM 1 DX15 BSS 1 DVT ADDRESS DX16 BSS 1 CONTINUE/RESUME ENTRY POINT DX17 BSS 1 LENGTH OF BUFFER DX18 BSS 1 END OF LINE MODIFIER DX19 BSS 1 SPACE SUPPRESS FLAG DX20 BSS 1 CARRIAGE CONTROL FLAG DX21 BSS 1 SUBROUTINE RETURN ADDRESS DX22 BSS 1 FIRST WORD OF USER'S BUFFER DX23 BSS 1 PAPER OUT FLAG DX24 BSS 1 STATUS WORD DX25 BSS 1 COUNT DX26 BSS 1 PAPER FLAG SKP * INITIATE THE REQUEST * INIT LDA $DV15,I SAVE REQUEST CODE & FUNCTION CODE AND B7703 STA DX13,I TEMPORARILY. LDA $DV15,I AND MSK CHANGE REQUEST TO STA $DV15,I MULTI-BUFFERED. LDA $DV16,I SAVE USER'S BUFFER (OR PRAM1) STA DX14,I LDA $DV17,I SAVE LENGTH STA DX17,I STA DX25,I INIT1 JSB DSJ0 FIRST CHECK DSJ JSB EXITC DO IT * JSB BDDSJ CHECK STATUS LDB $DV20,I GET PAPER RETURN ADDRESS LDA DX18,I AND FINAL TERMINATOR SSB WAS IT OUT? SSA AND WAS THE TERMINATOR TO BE DONE? JMP INIT2 NO - CONTINUE JSB SLEW YES - DO TERMINATOR * JSB EXITC DO IT! * JSB EXITR WAIT FOR PARALLEL POLL * INIT2 LDA $DV20,I GET FIRST TIME BIT AGAIN ELA,CLE,ERA CLEAR STA $DV20,I AND RESTORE CLA CLEAR: STA DX22,I FIRST WORD FLAG STA DX26,I AND PAPER FLAG LDA DX13,I REQUEST CODE CPA B3 CONTROL REQUEST CLEAR? +K JMP CLEAR YES CPA B1103 CONTROL REQUEST FORMS? JMP FORMS YES * AND B3 LOWER BITS ONLY CPA B2 IS IT A WRITE?? JMP WRITE YES DO IT CPA B3 IS IT ANOTHER CONTROL REQUEST JMP CNTRL REJ1 LDA NDDF DON'T DOWN, DO FLUSH. INA ILLEGAL REQUEST CLB JMP NR1 * CNTRL CLA NOT RECOGNIZED CONTROL REQUESTS JMP EXITD NORMAL COMPLETION EXIT * SKP * ALL NOT READY CODES COME HERE EXCEPT PAPER OUT * NR CLB STB DX16,I STA DX23,I SAVE FAILURE CODE JSB RSTR RESTORE FIRST WORD LDB B4103 DISABLE PROGRAM SCHEDULING JSB SDV15 PUT IN DV15 JSB EXITC DO IT * CLB CLEAR DX23 AND LDA DX23,I FETCH ERROR CODE STB DX23,I JMP NR1 NREDY LDA B2 NOT READY CODE NR1 STA $DV16,I LDA DX24,I GET STATUS STA $DV18,I AND POST CLA STA $DV17,I XLOG JMP DD.12,I RETURN. * * TIME OUT ROUTINE * TIMOT LDA DX23,I GET PAPER FLAG SZA WAS PAPER OUT? JMP PPR1 YES - GO CHECK STATUS TMOT1 LDA B3 TIME OUT CODE JMP NR * * CONTINUES ALL COME HERE * CONT LDA DX16,I GET RETURN LDB $DV16,I GET IFD STATUS CPB B3 CHECK STATUS JMP TMOT1 TIME OUT CT1 SZA SPURIOUS INT.? JMP A,I O.K. LDA B4 ILL. INT. CLB ISZ DD.12 P+3 JMP EXIT2 * * ABORT HANDLES ABORT REQUESTS * ABORT LDA ABADD GET RETURN ADDRESS STA EXITC STORE IN CONTINUE EXIT LDA B4 JMP EXTC1 ABADD DEF AB1 * AB1 JSB RSTR RESTORE FIRST WORD IF ANY LDB B4103 DISABLE DRIVER SCHEDULING JSB SDV15 PUT IN DVT CLA CLEAR DVT16 STA $DV16,I JSB EXITC DO IT A * AB2 CLA STA DX21,I CLEAR RE-ENTRANT POINTS LDB DX25,I GET TRANSMISSION LOG JMP EXTD1 ALL DONE * * SKP * * WRITE CAUSES THE CHARACTERS IN THE USERS BUFFER TO BE PRINTED * BASED ON THE CONTROL WORD PASSED TO IT. * WRITE CLA,INA CARRIAGE CONTROL SET STA DX18,I TO DO CR,LF. LDA DX19,I CHECK IF SUPPRESS SPACE CLB SLA IS IT SET?? STB DX18,I YES - CR MODIFIER ONLY STB DX19,I CLEAR SPACE SUPPRESS BIT. SLLEN LDA DX17,I REQUEST LENGTH. ALS CHANGE WORD COUNT TO CHARS. CMA,INA NEGATE. SSA * * PROCESS INITIAL CARRIAGE CONTROL REQ. * STCHR STA DX17,I RUNNING COUNT HERE. LDA DX13,I FETCH CONWORD AND BIT10 SZA HONESTY MODE ? JMP HNSTY YEP. GO DO IT'S THING. LDA DX13,I AND BIT7 GET CONTROL BIT 7. SZA SS = 1 JMP NOCC MEANS NO CARRIAGE CONTROL. STA DX20,I NO CC FLAG. LDA DX17,I GET LENGTH SZA,RSS IF ITS ZERO DO CR-LF JMP TRM DO TERMINATOR LDB DX14,I BUFFER ADDRESS LDA B,I GET THE FIRST CHAR. IN BUFFER ALF,ALF AND B377 LDB PEJEC CPA EJECT PAGE EJECT ? JMP PEJCT YES. CLB,INB GET DOUBLE SPACE MODIFIER IN CASE. CPA DOUBL DOUBLE SPACE ? JMP PEJCT YES. CLB PUT A 0 MODIFIER CPA STAR SPACE SUPPRESS ? STB DX18,I YES - RESET MODIFIER FOR CARRIAGE RETURN ONLY JMP LOUT GO OUTPUT THE LINE SKP * * NOCC SUPRESSES CARRIAGE CONTROL AT BEGINNING * NOCC CLB,INB SET NO CC FLAG TO 1. STB DX20,I JMP LOUT GO OUTPUT A LINE. * PEJCT LDA B MODIFIER JSB SLEW SET UP TO DO BEGINNING LINE MODIFIER JSB EXITC * JSB EXITR WAIT FOR PARALLEL POLL * JSB DSJ0 BUILD DSJ QUINT JSB EXITC GO DO IT * JSB CKDSJ CHECK DSJ JSB BDDSJ DSJ BAD - CHECK STATUS * * LOUT CHECKS THE LAST WORD TO BE OUT FOR AN UNDERSCORE "_" * IF FOUND IT DECREASES THE BUFFER LENGTH BY ONE TO BE TRANSMITTED * AND DOESN'T DO END-OF-LINE MODIFIER * LOUT LDB DX17,I GET LENGTH OF BUFFER CMB,INB TWO'S COMPLEMENT CLE,ERB DIVIDE BY 2 AND SAVE REM. SEZ,RSS ADD -1 IF REM. IS ZERO ADB M1 ADD MINUS ONE ADB DX14,I ADD START ADDR. FOR LAST WORD ADDR. LDA B,I GET LAST WORD LDB DX17,I AND LENGTH AGAIN SLB ODD MEANS BYTE IN UPPER HALF ALF,ALF MAKE SURE IN LOWER HALF AND B377 IS IT UNDERSCORE? CPA B137 RSS YES JMP LT1 NO - PRINT ENTIRE BUFFER ISZ DX17,I DECREASE CHAR. COUNT BY ONE CCB SET B STB DX18,I FORGET ABOUT MODIFIER SKP * * NOW PRINT THE BUFFER * LT1 LDA DX17,I GET LENGTH SZA,RSS IS IT ZERO? JMP TRM YES - DO TERMINATOR ONLY LDA DX20,I GET NOCC FLAG CLE,SLA,RSS SKIP IF SET CCE SET E SETUP LDB DX14,I GET ADDRESS OF FIRST WORD LDA B,I GET FIRST WORD STA DX22,I AND SAVE IN EXT. AND B377 PUT A NULL IN UPPER BYTE SEZ IF E=1 UPDATE THE FIRST WORD STA B,I RESTORE TO BUFFER JSB PRNBF GO SET UP QUINTS JSB EXITC PRINT THEM! CONTINUE P+2 * JSB EXITR WAIT FOR PARALLEL POLL * JSB RSTR RESTORE FIRST WORD JSB DSJ0 BUILD DSJ QUINT JSB EXITC GO DO IT * JSB CKDSJ CHECK DSJ JSB BDDSJ BAD DSJ - ANALYZE TRM LDA DX18,I CHECK FOR TERMINATION. SSA IS MODIFIER CORRECT? JMP NOTRM g(DON'T DO TERMINATOR CCB SET STB DX26,I PAPER FLAG JSB SLEW JSB EXITC P+2 * JSB EXITR WAIT FOR PARALLEL POLL * * NOTRM DOES COMPLETION DSJ * NOTRM JSB DSJ0 BUILD DSJ QUINT JSB EXITC GO DO IT * JSB CKDSJ CHECK DSJ JSB BDDSJ ERROR ! LDB DX25,I SKP * * EXITD IS DRIVER DONE EXIT POINT * EXITD LDA $DV6,I GET STATUS IOR BIT5 OR IN BIT TO XOR BIT5 CLEAR EOM BIT STA $DV6,I AND RESTORE EXTD1 STB $DV17,I STORE XLOG. CLA STA $DV16,I ERROR CODE STA DX16,I CLEAR NEXT ENTRY LDB DX24,I PUT CURRENT STATUS STB $DV18,I AND STATUS. JMP DD.12,I COMPLETION RETURN. * * PRNBF SETS UP THE QUINT TO TRANSMIT THE USER'S BUFFER FOR * THE PHYSICAL DRIVER. * PRNBF NOP LDA DX14,I GET BUFFER ADDRESS STA BUFR AND STORE IN BUFFER LDA DX17,I GET CHAR. COUNT STA LEN AND STORE IN LENGTH LDA M1 PUT -1 IN A STA $DV17,I NUMBER OF QUINTS IN $DV17 LDA PRTQA GET QUINT ADDRESS JSB MOVE GO MOVE QUINTS INTO EXT. DEF DX1 STARTING HERE JMP PRNBF,I RETURN * * HNSTY JUST PRINTS THE USERS BUFFER (NO CARRIAGE CONTROL PERIOD!) * HNSTY LDB DX17,I GET LENGTH SZB,RSS IF ZERO, DON'T DO ANYTHING JMP EXITD ALL DONE IF ZERO JSB PRNBF GO PRINT THE BUFFER JSB EXITC EXIT P+1 TO PRINT * JSB EXITR WAIT FOR PARALLEL POLL * JMP NOTRM ALL DONE - COMPLETE SKP * * * FORMS CONTROL REQUESTS COME HERE. * FORMS LDB DX14,I GET PRAM1 SZB,RSS IS IT ZERO? JMP SSPC YES - SUPPRESS SPACE LDA PEJEC SSB TOP OF FORM? JMP FRM1 YES - DO IT ADB M64 ADD -64 TO PRAM1 SSB,RSS IS IT STILL POSITIVE? `  JMP CNTRL YES - ILLEGAL PRAM1, COMPLETE REQUEST LDA DX14,I GET PRAM1 AGAIN FRM1 JSB SLEW GO SET UP QUINTS JSB EXITC GO DO IT! P+2 * JSB EXITR WAIT FOR PARALLEL POLL * CLA CLEAR STA DX25,I DX25 JMP NOTRM GO DO FINAL DSJ * * * * SSPC CLA,INA SET SPACE SUPPRESS BIT STA DX19,I PUT IT IN EXTENSION CLB JMP EXITD ALL DONE * * * SLEW SETS UP THE QUINT FOR FORMS CONTROL * SLEW NOP ALF,ALF MOVE TO UPPER BYTE STA DX11,I LDA DX11 STA SLDX LDA M1 ONE QUINT STA $DV17,I LDA SLUQA SLEW QUINT ADDRESS JSB MOVE PUT IT IN EXT. DEF DX1 STARTING LOCATION JMP SLEW,I SKP * * CONTROL REQUEST CLEAR. CAUSES 1. RESET TO PRINTER * 2. PUT PRINTER ON-LINE * CLEAR JSB CLR CLEAR PRINTER JSB RSET DO A TERMINAL RESET JSB STAT READ STATUS (DON'T CARE ABOUT DSJ) CLB JMP EXITD ALL DONE * * CLR READS 10 BYTES OF LONG STATUS. ALSO FREES CONTROLLER * AFTER PAPER OUT * CLR NOP LDA CLR SAVE RETURN ADDRESS STA DX21,I IN DX21 LDA M1 ONE QUINT STA $DV17,I LDA DX11 STA FLDX POINTER TO MODIFIER LDA B6 LONG STATUS MODIFIER ALF,ALF MOVE TO PROPER POSITION STA DX11,I LDA FLQA QUINT ADDRESS JSB MOVE PUT THEM IN EXTENSION DEF DX1 STARTING HERE JSB EXITC GO DO IT! * JSB EXITR WAIT FOR PARALLEL POLL * LDA SCRCH DATA READY, SO READ LONG STATUS STA RLDX LDA LSQA READ LONG STATUS QUINT ADDRESS JSB MOVE DEF DX1 STARTING HERE LDA M2 ONE QUINT STA $DV17,I PUT INTO DVT JSB EXITC GO TO IT. * LDA DX21,I GET RETURN JMP A,I RETURN SKP * * RESET THE CONTROLLER * RSET NOP LDA RSET SAVE RETURN STA DX21,I LDA B5 RESET MODIFIER ALF,ALF PUT IN PROPER POSTION STA DX11,I PUT IN EXTENSION LDA DX11 GET ADDRESS STA FLDX STORE IN FLUSH QUINT LDA FLQA GET QUINT ADDRESS JSB MOVE MOVE INTO EXT. DEF DX1 STARTING HERE JSB EXITC GO DO IT * JSB EXITR WAIT FOR POLL * JSB DSJ0 BUILD DSJ QUINT JSB EXITC CONTINUE EXIT * RS2 LDA B7 ON-LINE ALF,ALF PUT IN PROPER POSITION STA DX11,I LDA DX11 GET ADDRESS OF BUFFER STA RSDX STORE IN QUINT LDA B200 ALF,ALF PUT IN PROPER POSITION STA DX12,I LDA DX12 STA FLDX LDA RSQA GET QUINT ADDRESS JSB MOVE MOVE INTO EXT. DEF DX1 JSB MOVE MOVE NEXT QUINT DEF DX6 LDA M2 TWO QUINTS STA $DV17,I JSB EXITC CONTINUE EXIT * JSB EXITR WAIT FOR PARALLEL POLL * LDA DX21,I FETCH RETURN JMP A,I SKP * * STATUS SUBROUTINE * STAT NOP LDA STAT GET RETURN ADDRESS STA DX21,I SAVE RE-ENTRANT POINT LDA M2 TWO QUINTS STA $DV17,I LDA DX11 STA STATQ+1 LDA STAQA STATUS QUINT ADDRESS JSB MOVE MOVE IT INTO EXT. DEF DX1 STARTING ADDRESS LDA DX12 STA DSJQ+1 LDA DSJQA MOVE DSJ QUINT JSB MOVE DEF DX6 JSB EXITC P+2 * LDA DX11,I GET STATUS JSB LBYTI PUT IN PROPER LOCATION STA DX24,I AND SAVE TEMPORARILY AND B300 LDB DX21,I GET RETURN ADDRESS CPA B300 ON-LINE? READY FOR DATA? JMP B,I P+1 IS NOT READY RETURN * * * IF STATUS BAD, THEN ANALYBZE * LDB DX24,I GET STATUS LDA B2 AND ERROR CODE RBR,SLB IS PRINTER OUT OF PAPER? JMP PPRO DO PAPER OUT EXIT RBR,RBR MOVE TO NEXT POSITION SLB PRINTER RECEIVE PARITY ERROR? LDA B5 YES JMP NR * * ALL BAD DSJ'S COME HERE * BDDSJ NOP LDA BDDSJ SAVE RETURN ADDRESS STA DX23,I JSB STAT CHECK STATUS CLA CLEAR STA DX23,I RETURN POINT JMP BDDSJ,I STATUS OK - CONTINUE SKP * * PAPER IS OUT. CONTINUE TO READ STATUS AND DSJ EVERY 5 SECONDS * UNTIL THE DEVICE INDICATES ITS READY * PPRO LDA $DV6,I GET DEVICE STATUS IOR BIT5 INDICATE EOM STA $DV6,I LDA =D-500 SET A LOGICAL TIMEOUT STA $DV12,I IN CLOCK LDA $DV20,I SET IOR BIT15 FIRST TIME BIT IN STA $DV20,I CASE OF ABORT CLA,INA START TIMEOUT ISZ DD.12 EXIT ISZ DD.12 LOGICAL JMP DD.12,I WAIT * PPR1 JSB STAT CHECK STATUS JSB CLR CLEAR DEVICE * LDA $DV20,I RESET FIRST TIME ELA,CLE,ERA BIT STA $DV20,I RESTORE CLB LDA DX23,I RETURN ADDRESS INTO THE DRIVER STB DX23,I CLEAR THAT LOCATION LDB DX26,I GET PAPER FLAG CMB,SZB IF SET DO TERMINATOR AGAIN JMP A,I RETURN TO PROGRAM AT POINT OF EXIT JMP TRM DO TERMINATOR AGAIN * SKP * * "MOVE" MOVES THE QUINTS INTO THE EXTENTION. * MOVE NOP LDB MOVE,I GET ADDRESS OF ADDRESS IN EXT. LDB B,I GET FINAL ADDRESS CPB DX1 IF DX1 SET DVT STB $DV16,I SET UP EXT ADDRESS WHERE QUINTS ARE. MO5 JSB .MVW MOVE QUINT INTO EXTENSION DEF B5 FIVE WORDS IN EXT. NOP ISZ MOVE BUMP RETURN JMP MOVE,I RETURN P+2 * * LBYTI NOP ALF,ALF MOVE TO LOWEmR BYTE AND B377 MASK OUT UPPER BYTE JMP LBYTI,I RETURN * * * CHECK DSJ SUB * CKDSJ NOP LDA DX12,I GET DSJ RESPONSE JSB LBYTI MOVE TO PROPER POSITION SZA,RSS ISZ CKDSJ O.K. RETURN P+2 JMP CKDSJ,I ZERO IS COOL. * DSJ0 NOP LDA DX12 STA DSJQ+1 LDA DSJQA DSJ QUINT ADDRESS JSB MOVE PUT IN EXT. DEF DX1 STARTING HERE LDA M1 ONE QUINT STA $DV17,I PUT IN DVT. JMP DSJ0,I RETURN SKP * *SDV15 MODIFIES DV15 WITHOUT DESTROYING BITS 14 AND 15 * SDV15 NOP LDA $DV15,I GET DV15 AND NDDF SAVE 14 AND 15 IOR B OR IN DESIRED PATTERN STA $DV15,I RESTORE TO DV15 JMP SDV15,I BACK TO MAIN PROGRAM * * RSTR: RESTORE FIRST WORD TO BUFFER * RSTR NOP LDA DX22,I GET FIRST WORD AGAIN LDB DX14,I GET ADDRESS OF FIRST WORD SZA IF ITS ZERO DON'T RESTORE!! STA B,I RESTORE TO BUFFER LOCATION CLA CLEAR A STA DX22,I AND STORE IN DX22 JMP RSTR,I ALL DONE!! * * EXITC IS THE CONTINUE EXIT WHICH SAVES THE NEXT ENTRY POINT * EXITC NOP CLA CLEAR A EXTC1 LDB EXITC STB DX16,I SAVE NEXT ENTRY. EXIT2 ISZ DD.12 JMP DD.12,I RETURN. * * EXITR IS THE LOGICAL WAIT EXIT WHICH SETS THE RESUME ENTRY POINT * EXITR NOP CLA,INA A=1 (SET TIMEOUT BIT) LDB EXITR GET ENTRY POINT STB DX16,I AND SAVE IT LDB M3000 GET LOGICAL TIMEOUT STB $DV12,I AND STORE IN CLOCK ISZ DD.12 INCREMENT RETURN ISZ DD.12 TWICE JMP DD.12,I RETURN SKP * CONSTANTS, QUINTS, ETC. * * RSQA DEF RSETQ STAQA DEF STATQ SLUQA DEF SLEWQ DSJQA DEF DSJQ PRTQA DEF PRNTQ FLQA DEF FLSHQ LSQA DEF RLSQ * PRNTQ OCT 120102 PRINT DATA BUFR OCT 0 LEN OCT 0 pB@ <-UNIT-> <------SC------> * SYSAD ABS SYS-O HPIBA OCT 0 UNIT# OCT 0 FHED OCT 0 FCYL OCT 0 #SPAR OCT 0 #TRKS OCT 206 #SECT OCT 36 #HEDS OCT 2 (IF = 1 THEN SURFACE MODE) SYS ASC 3,SYSTEM OCT 0 IF SET TO 51523 WILL SUSPEND (102077) REV. DEC 1 A EQU 0 B EQU 1 * SKP HERE CLC 4 TURN OFF POWER FAIL INTERRUPTS SZA IS IT POWER FAIL RESTART? ABS JMP+HERE0-O NO THEN CONTINUE STA 4 YES THEN REBOOT ABS JMP+REBOT-O HERE0 SSA HLT 1 STOP IF A<0 MANUAL BOOT ABS STA+TEMP-O CLA STA 4 FORCE REBOOT IF AUTO RESTART SZB,RSS ABS LDB+SYSAD-O IF B=0 USE DEFAULT NAME FOR SYSTEM ABS STB+FILAD-O ABS LDA+SYSAD-O LDB B,I SZB,RSS IF LOAD & GO CHECK FOR DEFAULT ABS STA+FILAD-O ABS LDA+TEMP-O ABS AND+B77-O OTA 2,C ENABLE GLOBAL REGISTER ABS LDA+TEMP-O jALF,ALF RAR ABS STA+TEMP-O ABS AND+B7-O ABS STA+DISKA-O ABS IOR+LSTNA-O ADD LISTEN ADDRESS ABS STA+L0-O ABS STA+L1-O DISK LISTEN ABS STA+L2-O ABS LDA+DISKA-O ABS IOR+TLKA-O ADD TALK ADDRESS ABS STA+T1-O DISK TALK ABS STA+T2-O ABS LDA+TEMP-O RAL,RAL GET TO UNIT RAL ABS AND+B7-O ABS STA+UNIT-O ABS IOR+EOI-O ADD EOI ABS STA+U1-O UNIT+EOI SKP * BLANK FILL FILE NAME * ABS LDA+M3-O ABS STA+CNT-O ABS LDA+NAMAD-O ABS STA+TEMP-O CLE LOOP ABS LDB+M256-O ABS LDA+FILAD-O+I+I SEZ ABS LDB+B377-O AND B SZA,RSS ABS JMP+FZERO-O SEZ ABS IOR+TEMP-O+I+I ABS STA+TEMP-O+I+I CME SEZ ABS JMP+LOOP-O ABS ISZ+FILAD-O ABS ISZ+TEMP-O ABS ISZ+CNT-O ABS JMP+LOOP-O ABS LDB+FILAD-O+I+I CHECK TO HALT AT END OF BOOT ABS LDA+HLT77-O GET HALT INSTRUCTION ABS CPB+ASS-O DID HE SET STOP SIGNAL ABS STA+HLT-O YES SET HALT INSTRUCTION ABS JMP+CONT-O FZERO SEZ,RSS ABS JMP+LBYT-O F0 ABS LDA+BLNK-O ABS IOR+TEMP-O+I+I ABS STA+TEMP-O+I+I ABS ISZ+TEMP-O ABS ISZ+CNT-O RSS ABS JMP+CONT-O LBYT ABS LDA+UBLNK-O ABS STA+TEMP-O+I+I ABS JMP+F0-O SKP * SUBROUTINE TO CONVERT TRACK TO CYL & HEAD * TCONV NOP CLB SET FOR DIVIDE ABS DIV+I+I A-REG = CYL, B-REG = HEAD OFFSET ABS #HEDS-O ABS ADA+FCYL-O ADD FIRST CYL ABS STA+CYL-O ABS AND+B377-O ABS STA+CYL+1-O LOWER BYTE OF CYL ADDRESS ABS LDA+CYL-O FETCH CYL WORD AGAIN ALF,ALF ABS AND+B377-O ABS STA+CYL-O UPPER BYTE OF CYL ADDRESS ABS ADB+FHED-O ADD FIRST HEAD TO HEAD OFFSET ABS STB+HED-O AND STORE IT ABS LDA+#HEDS-O CHECK IF CYLINDER OR SURFACE MODE ABS LDB+B1005-O CLE,ERA SZA ABS ADB+B2-O ABS STB+FLMSK-O SET FILE MASK ABS JMP+TCONV-O+I+I RETURN * * SEARCH THE DIRECTORY * DIREC ABS LDA+BUF+8-O ABS STA+#DTRK-O ABS LDB+DEFL-O * NEXT LDA B,I ABS CPA+NAME-O ABS JMP+MATCH-O FIRST WORD MATCHES NENT ABS ADB+.16-O NO MATCH, SO FETCH NEXT ENTRY ABS CPB+EOB-O END OF BUFFER? ABS JMP+DREAD-O YES, SEE IF THERE ARE MORE TRACKS ABS JMP+NEXT-O NO, GET NEXT ENTRY * DREAD ABS ISZ+#DTRK-O HAVE WE READ ALL DIR. TRACKS? RSS NO HLT 2 YES, COULDN'T FIND IT ABS LDA+TEMP-O GO READ NEXT DIR. TRACK ABS JMP+CONT+1-O MATCH INB LDA B,I ABS CPA+NAME+1-O ABS JMP+MCH1-O ABS ADB+M1-O ABS JMP+NENT-O MCH1 INB LDA B,I ABS CPA+NAME+2-O ABS JMP+FOUND-O ABS ADB+M2-O ABS JMP+NENT-O SKP FOUND ABS ADB+B2-O LDA B,I ABS STA+TRACK-O INB LDA B,I ABS AND+B377-O RAR DIVIDE BY 2 TO GET PHYSICAL SECT. ABS IOR+EOI-O TAG LAST BYTE WITH EOI ABS STA+SECTR-O AND STORE IT INB LDA B,I FETCH FILE SIZE ASL 6 MULT. BY 64 = NO. OF WORDS ABS STA+TEMP2-O ABS LDB+DST16-O SET UP DESTINATION FOR 16K CLA ABS STA+DST32-O+I+I SEE HOW BIG MEMORY IS ABS LDA+DST32-O+I+I SZA,RSS IF STILL 0 THEN 32K ABS LDB+DST32-O ABS STB+TEMP-O ABS STB+LOCAD-O ABS LDA+TEMP2-O CMB,INB ADB A USE FILE SIZE OR MEMORY SIZE? SSB,RSS ABS LDA+TEMP-O USE MEMORY SIZE RAL X 2 = NO. OF C;HARS. CMA,INA MAKE IT NEG. ABS STA+LEN-O STORE IT IN THE QUAD ABS LDA+TRACK-O FETCH TRACK AND ABS JSB+TCONV-O CONVERT TO CYL & HEAD SKP * FIX-UPS FOR THE BIG MOVE * ABS LDA+TEMP-O DESTINATION ADDRESS ABS LDB+LDAD-O WHERE WE START CMB,INB SUBTRACT ADA B ABS LDB+DEF1-O ADB A ABS STB+DEF1-O ABS LDB+DEF2-O ADB A ABS STB+DEF2-O ABS LDB+DEF3-O ADB A ABS STB+DEF3-O ABS LDB+QUADA-O ADB A ABS STB+QUADA-O ABS LDB+DSJA-O ADB A ABS STB+DSJA-O CLA ABS STA+DEFL-O START WITH LOCATION 0 ABS STA+JMP..-O SET TO START PROGRAM * * CODE TO MOVE BOOT TO TOP OF MEMORY * ABS LDA+LSIZE-O LOAD SIZE ABS STA+CNT-O ABS LDB+LDAD-O WHERE WE START LOOP2 LDA B,I ABS STA+TEMP-O+I+I ABS ISZ+TEMP-O INB ABS ISZ+CNT-O ABS JMP+LOOP2-O ABS JMP+LOCAD-O+I+I JMP TO IT SKP .16 DEC 16 B2 OCT 2 B3 OCT 3 B7 OCT 7 B77 OCT 77 B1005 OCT 1005 DST16 OCT 36500 DST32 OCT 76500 BLNK OCT 40 UBLNK OCT 20000 #DTRK OCT 0 TRACK OCT 0 CNT OCT 0 DISKA OCT 0 FILAD OCT 0 TEMP2 OCT 0 LOCAD OCT 0 HLT77 HLT 77B ASS ASC 1,SS NAMAD ABS NAME-O NAME BSS 3 LDAD ABS READ-O LSIZE ABS READ-BUF * * CONT ABS LDA+#TRKS-O DIREC. STARTS IN LAST TRACK ABS ADA+M1-O LAST TR = #TRKS - 1 ABS STA+TEMP-O ABS JSB+TCONV-O CONVERT TO CYL & HEAD ABS LDA+EOI-O FETCH EOI BIT ABS STA+SECTR-O START WITH SECTOR 0 ABS LDA+#SECT-O FETCH SECTORS/TRACK ASL 7 MULT. BY 128 STA B ABS ADA+DEFL-O BEGINNING OF BUFFER ABS STA+EOB-O END OF BUFFER BLS X 2 = NO. OF CHARS. CMB,INB ABS STB+LEN-O LENGTH = 1 TRACKS} WORTH ABS JMP+READ-O LAST EQU * BSS EQU LAST-BOOTX BSS 500B-BSS SKP * THIS CODE GETS MOVED TO HIGH MEMORY * READ ABS LDA+M3-O SET FOR 3 RETRIES ABS STA+FAIL-O READ2 CLC DMACT,C ABS LDA+ONL-O PUT IT OTA DREG ON-LINE STC DREG,C ABS LDA+AIFC-O ASSERT OTA DREG IFC STC DREG,C FOR ABS LDA+M256-O > 100 MICROSECS. RD1 INA,SZA ABS JMP+RD1-O ABS LDA+CMDRS-O CLEAR IFC OTA DREG STC DREG,C ABS LDA+QUADA-O QUADS ADDRESS ABS JSB+SCDMA-O GO DO IT ABS JMP+RTRY-O DMA PARITY RETURN ABS LDA+CMDRS-O OTA DREG STC DREG,C ABS LDA+UNTLK-O UNTALK OTA DREG THE DISK STC DREG,C ABS LDA+BIT15-O THIS IS THE OTA CREG WAY YOU ABS LDA+M8-O CLEAR THE RD2 STC DREG,C INBOUND INA,SZA FIFO ABS JMP+RD2-O ABS LDA+LEN-O CHECK RESIDUE SZA ZERO IS GOOD. ABS JMP+RTRY-O OTHERWISE, TRY AGAIN. * * NOW GET THE DSJ * ABS LDA+DSJA-O ADDRESS OF DSJ QUADS ABS JSB+SCDMA-O ABS JMP+RTRY-O DMA PARITY ABS LDA+DSJ-O FETCH DSJ SZA,RSS DSJ = 0 ? ABS JMP+JMP..-O YES, CONTINUE RTRY ABS ISZ+FAIL-O NO. RETRY? ABS JMP+READ2-O YEP. HLT 3 NOPE. T.S. ABS JMP+READ-O OK TRY AGAIN JMP.. ABS JMP+DIREC-O CONTINUE * CCA INDICATE MANUAL UP OTA 3 INSURE NO SEQUENTIAL LOADING CLB AND NO FILE STC 4 ENABLE WORLD HLT NOP JMP 2 INCASE OF %R SKP * SELF-CONFIG. DMA OUTPUT ROUTINE * SCDMA NOP OTA DMAPT PASS DMA THE STARTING ADDRESS STC DMAPT,C START AUTO CONFIGsURATION SFS RRR 16 GET OFF THE BACKPLANE SFS DMACT NOW JUST WAIT FOR IT ABS JMP+POW?-O POWER DOWN? DONE SFS DMADR CHECK FOR DMA PARITY ABS ISZ+SCDMA-O NO PARITY CLC DMACN,C ABS JMP+SCDMA-O+I+I * * POW? RRR 16 GET OFF THE BACKPLANE SFC 4 NO POWER DOWN? ABS JMP+SFS-O CLA STA 4 INSURE REBOOT ON POWER UP SFS 4 LET IT GO ALL THE WAY ABS JMP+*-1-O REBOT OTA 1 DIDN'T GO ALL THE WAY CLC 2 FORCE REBOOT JMP 2 SKP ********************************************************************** * * QUADS * ********************************************************************** * * SEEK + READ COMMAND * QUADA ABS QUAD0-O QUAD0 OCT 141000 CONT+DEV. CMD.+WORD+FOUR+OUT OCT 0 DEF1 ABS CMD2-O ABS CMD2-CMD3 * * READ DATA * OCT 71200 OCT 103000 DEFL ABS BUF-O LEN OCT 0 * * READ DSJ * DSJA ABS DSJQ-O DSJQ OCT 141000 CONT+DEV.CMD.+WORD+FOUR+OUT OCT 0 WRITE DEF2 ABS CMD3-O DEC -8 * OCT 61200 DEV.CMD.+BYTE+FOUR+IN OCT 102000 READ+PACK DEF3 ABS DSJ-O DEC -1 SKP * SEEK BUFFER * CMD2 OCT 60042 ABS UNL ABS MTA L0 OCT 0 OCT 550 OCT 17 SET FILE MASK FLMSK OCT 1001 SURFACE MODE ABS UNL ABS MTA L1 OCT 0 LISTEN+DISK ADDRESS OCT 550 SECONDARY OCT 2 SEEK OPCODE UNIT OCT 0 CYL OCT 0 OCT 0 HED OCT 0 SECTR OCT 0 SECTOR+EOI ABS UNL UNLISTEN * * READ COMMAND BUFFER * OCT 60042 L2 OCT 0 LISTEN+DISK ADDRESS OCT 550 SECONDARY OCT 5 READ OPCODE U1 OCT 0 UNIT`*($+EOI ABS UNL UNLISTEN ABS MLA MY LISTEN ADDRESS T1 OCT 0 TALK+DISK ADDRESS OCT 540 SECONDARY OCT 1400 UNCOUNTED XFER OCT 60040 INPUT MODE * * READ DSJ BUFFER * CMD3 OCT 60042 ABS MLA MY LISTEN ADDRESS T2 OCT 0 TALK+DISK ADDRESS OCT 560 SECONDARY OCT 1001 COUNTED XFER OF 1 BYTE UNTLK ABS UNT UNTALK ABS UNL UNLISTEN OCT 60040 INPUT MODE SKP * HP-IB ADDRESSES * UNT EQU 537B UNL EQU 477B MTA EQU 536B MLA EQU 476B * * PHI STUFF * DREG EQU 30B CREG EQU 31B SREG EQU 32B * * DMA REGISTERS * DMAPT EQU 20B DMACN EQU 21B DMADR EQU 22B DMACT EQU 23B * * CONSTANTS, ETC. * CMDRS OCT 60043 TEMP OCT 0 B377 OCT 377 EOB OCT 0 BIT15 OCT 100000 M8 DEC -8 M1 DEC -1 M2 DEC -2 M3 DEC -3 ONL OCT 70200 AIFC OCT 60021 EOI OCT 1000 M256 DEC -256 DSJ OCT 0 FAIL OCT 0 * LSTNA OCT 440 TLKA OCT 500 * BUF OCT 0 * LDA EQU 062000B LDB EQU 066000B STA EQU 072000B STB EQU 076000B ADA EQU 042000B ADB EQU 046000B I EQU 040000B INDIRECT BIT (CODE AS I+I) CPA EQU 052000B CPB EQU 056000B JSB EQU 016000B JMP EQU 026000B ISZ EQU 036000B AND EQU 012000B IOR EQU 032000B DIV EQU 000400B LESS BIT 15 END **  92070-18089 1941 S C0122 &DKLIB              H0101 zFTN4,L C********************************************************************* C C DISC LIBRARY C C********************************************************************* C NAME: DKLIB C SOURCE: 92070-18089 C RELOC: 92070-16089 C PGMR: WWL C C C **************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * C * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT * C * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C **************************************************************** C C C SUBROUTINE XDSJ (LU,DVID,DSJ), 92070-16089 REV.1941 790920 IMPLICIT INTEGER (A-Z) INTEGER IARY(5) DATA DSJ2/160B/ CALL EXEC (1,120100B+LU,DSJ,-1,DSJ2,0) RETURN END C SUBROUTINE XFMSK (LU,DVID,MSK,IER) IMPLICIT INTEGER (A-Z) INTEGER IARY(5) DATA SGC/150B/,FMOP/7400B/ CMD=IOR(FMOP,MSK) CALL EXEC (2,120100B+LU,CMD,-2,SGC,0) CALL RMPAR (IARY) IER=0 IF (IAND(IARY(1),77B) .NE. 0) IER=1 IF (IAND(IARY(1),77B) .EQ. 3) IER=4 RETURN END C SUBROUTINE XSTAT (LU,DVID,S1,S2,IER) IMPLICIT INTEGER (A-Z) INTEGER IARY(5),BUF(2) DATA STOP/1400B/,STAT2/150B/ BUF(1)=IOR(STOP,IAND(DVID,177400B)/256) CALL EXEC (2,120100B+LU,BUF,-2,STAT2,0) CALL EXEC (1,120100B+LU,BUF,-4,STAT2,0) CALL RMPAR (IARY) IER=0 ERCODE=IAND(IARY(1),77B) IF (ERCODE .EQ. 3) IER=4 S1=BUF(1) S2=BUF(2) RETURN END C SUBROUTINE XSEEK (LU,DVID,CYL,HEAD,SECTR,S1,S2,IER) IMPLICIT INTEGER (A-Z) INTEGER BUF(3),IARY(5) DATA SEKOP/1000B/,SGC/150B/,DSJ2/160B/ BUF(1)=IOR(SEKOP,IAND(DVID,177400B)/256) BUF(2)=CYL BUF(3)=IOR(HEAD*256,SECTR) CALL EXEC (2,120100B+LU,BUF,-6,SGC,0) CALL EXEC (1,120100B+LU,DSJ,-1,DSJ2,0) CALL RMPAR (IARY) ERCODE=IAND(IARY(1),77B) IER=4 IF (ERCODE .EQ. 3) RETURN IF (DSJ .NE. 0) GO TO 20 S1=0 S2=0 GO TO 50 20 CALL XSTAT (LU,DVID,S1,S2,IR) 50 IER=IAND(DSJ,177400B)/256 RETURN END C SUBROUTINE XDRED (LU,DVID,BUF,LEN,S1,S2,IER) IMPLICIT INTEGER (A-Z) INTEGER IARY(5),BUF(144) DATA SGC/150B/,SRD/140B/,DSJ2/160B/,RDOP/2400B/ CMD=IOR(RDOP,IAND(DVID,177400B)/256) CALL EXEC (2,120100B+LU,CMD,-2,SGC,0) CALL EXEC (1,120100B+LU,BUF(17),LEN,SRD,0) CNT=10 10 CALL EXEC (1,120100B+LU,DSJ,-1,DSJ2,0) CALL RMPAR (IARY) ERCODE=IAND(IARY(1),77B) IF (ERCODE .NE. 3) GO TO 50 CNT=CNT-1 IF (CNT .GT. 0) GO TO 10 IER=4 S1=0 S2=0 RETURN 50 CALL XSTAT (LU,DVID,S1,S2,IR) IER=IAND(DSJ,177400B)/256 RETURN END C SUBROUTINE XRDFS (LU,DVID,BUF,LEN,S1,S2,IER) IMPLICIT INTEGER (A-Z) INTEGER BUF(154),IARY(5) DATA SGC/150B/,SRD/140B/,RFSOP/3000B/,DSJ2/160B/ CMD=IOR(RFSOP,IAND(DVID,177400B)/256) CALL EXEC (2,120100B+LU,CMD,-2,SGC,0) CALL EXEC (1,120100B+LU,BUF(17),LEN,SRD,0) CNT=10 10 CALL EXEC (1,120100B+LU,DSJ,-1,DSJ2,0) CALL RMPAR (IARY) ERCODE=IAND(IARY(1),77B) IF (ERCODE .NE. 3) GO TO 50 CNT=CNT-1 IF (CNT .GT. 0) GO TO 10 IER=4 S1=0 S2=0 RETURN 50 CALL XSTAT (LU,DVID,S1,S2,IR) IER=IAND(DSJ,177400B)/256 RETURN END C SUBROUTINE XRDOF (LU,DVID,BUF,LEN,OFSET,S1,S2,IER) IMPLICIT INTEGER (A-Z) INTEGER CMD(2),IARY(5),BUF(144) DATA SGC/150B/,SRD/140B/,RDOP/7000B/,DSJ2/160B/ CMD(1)=RDOP CMD(2)=OFSET CALL EXEC (2,120100B+LU,CMD,-4,SGC,0) CALL EXEC (1,120100B+LU,BUF(17),LEN,SRD,0) CNT=10 10 CALL EXEC (1a,120100B+LU,DSJ,-1,DSJ2,0) CALL RMPAR (IARY) ERCODE=IAND(IARY(1),77B) IF (ERCODE .NE. 3) GO TO 50 CNT=CNT-1 IF (CNT .GT. 0) GO TO 10 IER=4 S1=0 S2=0 RETURN 50 CALL XSTAT (LU,DVID,S1,S2,IR) IER=IAND(DSJ,177400B)/256 RETURN END C SUBROUTINE XRDNV (LU,DVID,BUF,LEN,S1,S2,IER) IMPLICIT INTEGER (A-Z) INTEGER IARY(5),BUF(128) DATA SGC/150B/,SRD/140B/,DSJ2/160B/,RNVOP/11000B/ CMD=IOR(RNVOP,IAND(DVID,177400B)/256) CALL EXEC (2,120100B+LU,CMD,-2,SGC,0) CALL EXEC (1,120100B+LU,BUF(17),LEN,SRD,0) CNT=10 10 CALL EXEC (1,120100B+LU,DSJ,-1,DSJ2,0) CALL RMPAR (IARY) ERCODE=IAND(IARY(1),77B) IF (ERCODE .NE. 3) GO TO 50 CNT=CNT-1 IF (CNT .GT. 0) GO TO 10 IER=4 S1=0 S2=0 RETURN 50 CALL XSTAT (LU,DVID,S1,S2,IR) IER=IAND(DSJ,177400B)/256 RETURN END C SUBROUTINE XVRFY (LU,DVID,SCNT,S1,S2,IER) IMPLICIT INTEGER (A-Z) INTEGER BUF(2),IARY(5) DATA VFYOP/3400B/,SGC/150B/,DSJ2/160B/ BUF(1)=IOR(VFYOP,IAND(DVID,177400B)/256) BUF(2)=SCNT CALL EXEC (2,120100B+LU,BUF,-4,SGC,0) CALL EXEC (1,120100B+LU,DSJ,-1,DSJ2,0) CALL RMPAR (IARY) ERCODE=IAND(IARY(1),77B) IF (ERCODE .NE. 3) GO TO 50 IER=4 S1=0 S2=0 RETURN 50 CALL XSTAT (LU,DVID,S1,S2,IR) IER=IAND(DSJ,177400B)/256 RETURN END C SUBROUTINE XRCAL (LU,DVID,IER) IMPLICIT INTEGER (A-Z) INTEGER IARY(5) DATA SGC/150B/,RCLOP/400B/ CALL EXEC (2,120100B+LU,RCLOP,-2,SGC,0) CALL RMPAR (IARY) IER=0 IF (IAND(IARY(1),77B) .NE. 0) IER=1 IF (IAND(IARY(1),77B) .EQ. 3) IER=4 RETURN END C SUBROUTINE XDWRT (LU,DVID,BUF,LEN,S1,S2,IER) IMPLICIT INTEGER (A-Z) INTEGER IARY(5),BUF(144) DATA SGC/150B/,SWD/140B/,WRO[P/4000B/,DSJ2/160B/ CMD=IOR(WROP,IAND(DVID,177400B)/256) CALL EXEC (2,120100B+LU,CMD,-2,SGC,0) CALL EXEC (2,120100B+LU,BUF(17),LEN,SWD,0) CNT=10 10 CALL EXEC (1,120100B+LU,DSJ,-1,DSJ2,0) CALL RMPAR (IARY) ERCODE=IAND(IARY(1),77B) IF (ERCODE .NE. 3) GO TO 50 CNT=CNT-1 IF (CNT .GT. 0) GO TO 10 IER=4 S1=0 S2=0 RETURN 50 CALL XSTAT (LU,DVID,S1,S2,IR) IER=IAND(DSJ,177400B)/256 RETURN END C SUBROUTINE XFRMT (LU,DVID,PATRN,TYPE,STAGR,IER) IMPLICIT INTEGER (A-Z) INTEGER IARY(5),BUF(3) DATA FMTOP/14000B/,FMT2/154B/,DSJ2/160B/ BUF(1)=IOR(FMTOP,IAND(DVID,177400B)/256) BUF(2)=(TYPE*256)+STAGR BUF(3)=PATRN CALL EXEC (2,120100B+LU,BUF,-5,FMT2,0) CALL EXEC (1,120100B+LU,DSJ,-1,DSJ2,0) CALL RMPAR (IARY) IF (IAND(IARY(1),77B) .NE. 3) GO TO 50 IER=4 RETURN 50 IER=IAND(DSJ,177400B)/256 RETURN END C SUBROUTINE XINIT (LU,DVID,BUF,LEN,SPD,S1,S2,IER) IMPLICIT INTEGER (A-Z) INTEGER IARY(5),BUF(144) DATA INTOP/5400B/,SGC/150B/,SWD/140B/,DSJ2/160B/ DMY=IOR(INTOP,IAND(DVID,177400B)/256) DMY=IOR(SPD*8192,DMY) CALL EXEC (2,120100B+LU,DMY,-2,SGC,0) CALL EXEC (2,120100B+LU,BUF(17),LEN,SWD,0) CALL EXEC (1,120100B+LU,DSJ,-1,DSJ2,0) CALL RMPAR (IARY) ERCODE=IAND(IARY(1),77B) IF (ERCODE .NE. 3) GO TO 50 IER=4 S1=0 S2=0 RETURN 50 CALL XSTAT (LU,DVID,S1,S2,IR) IER=IAND(DSJ,177400B)/256 RETURN END C SUBROUTINE XWRFS (LU,DVID,BUF,LEN,S1,S2,IER) IMPLICIT INTEGER (A-Z) INTEGER BUF(154),IARY(5) DATA SGC/150B/,SWD/140B/,WFSOP/4400B/,DSJ2/160B/ CMD=IOR(WFSOP,IAND(DVID,177400B)/256) CALL EXEC (2,120100B+LU,CMD,-2,SGC,0) CALL EXEC (2,120100B+LU,BUF(17),LEN,SWD,0) CNT=10 10 CALL EXEC (1,120100B+LU,DSJ,-1 l,DSJ2,0) CALL RMPAR (IARY) ERCODE=IAND(IARY(1),77B) IF (ERCODE .NE. 3) GO TO 50 CNT=CNT-1 IF (CNT .GT. 0) GO TO 10 IER=4 S1=0 S2=0 RETURN 50 CALL XSTAT (LU,DVID,S1,S2,IR) IER=IAND(DSJ,177400B)/256 RETURN END C SUBROUTINE XPHAD (LU,DVID,CYL,HEAD,SECTR,IER) IMPLICIT INTEGER (A-Z) INTEGER BUF(2),IARY(5) DATA PADOP/12000B/,CMD2/150B/,RD2/150B/ BUF(1)=PADOP BUF(2)=0 CALL EXEC (2,120100B+LU,BUF,-2,CMD2,0) CALL EXEC (1,120100B+LU,BUF,-4,RD2,0) CALL RMPAR (IARY) ERCODE=IAND(IARY(1),77B) IER=4 IF (ERCODE .EQ. 3) RETURN CYL=BUF(1) HEAD=BUF(2)/256 SECTR=IAND(BUF(2),377B) IER=0 RETURN END C SUBROUTINE XADRC (LU,DVID,CYL,HEAD,SECTR,IER) IMPLICIT INTEGER (A-Z) INTEGER IARY(5),BUF(3) DATA ADRC2/150B/,ADROP/6000B/ BUF(1)=ADROP BUF(2)=CYL BUF(3)=IOR(HEAD*256,SECTR) CALL EXEC (2,120100B+LU,BUF,-6,ADRC2,0) CALL RMPAR (IARY) ERCODE=IAND(IARY(1),77B) IER=0 IF (ERCODE .EQ. 3) IER=4 RETURN END C SUBROUTINE XLGAD (LU,DVID,CYL,HEAD,SECTR,IER) IMPLICIT INTEGER (A-Z) INTEGER IARY(5),BUF(3) DATA GTAD2/150B/,LADOP/12000B/ BUF(1)=LADOP CALL EXEC (2,120100B+LU,BUF,-2,GTAD2,0) CALL EXEC (1,120100B+LU,BUF,-4,GTAD2,0) CALL RMPAR (IARY) IF (IAND(IARY(1),77B) .EQ. 3) GO TO 10 IER=0 CYL=BUF(1) HEAD=IAND(BUF(2),17400B)/256 SECTR=IAND(BUF(2),377B) RETURN 10 IER=4 RETURN END C SUBROUTINE XIDEN (LU,DVID,ID) IMPLICIT INTEGER (A-Z) RETURN END C SUBROUTINE XEND (LU,DVID) IMPLICIT INTEGER (A-Z) DATA SGC/150B/,ENDOP/12400B/ CALL EXEC (2,120100B+LU,ENDOP,-2,SGC,0) RETURN END C SUBROUTINE XSPAR (LU,STRAK,IER) }$" IMPLICIT INTEGER (A-Z) INTEGER DP(8),BUF(17) CALL EXEC (13,10000B+LU,P1,P2,DP,8) NSPARS=DP(5) IF (NSPARS .EQ. 0) GO TO 50 CNT=0 STRAK=DP(6) 10 CALL XGTAD (LU,DVID,STRAK,SECT,CYL,HEAD,SECT) CALL XSEEK (LU,DVID,CYL,HEAD,SECT,S1,S2,IER) IF (IER .EQ. 4) RETURN CALL XDRED (LU,DVID,BUF(1),1,S1,S2,IER) IF (IER .EQ. 4) RETURN IDCST=IAND(S1,17400B)/256 IF (IDCST .EQ. 20B) GO TO 30 IDCST=IAND(S1,120000B) IF (IDCST .EQ. 0) RETURN 30 CNT=CNT+1 STRAK=STRAK+1 IF (CNT .LT. NSPARS) GO TO 10 50 IER=1 RETURN END C SUBROUTINE XGTAD (LU,DVID,TRACK,SECT1,CYL,HEAD,SECT2) IMPLICIT INTEGER (A-Z) INTEGER DP(8) EQUIVALENCE (DVAD,DP(1)),(UNIT,DP(2)),(SHED,DP(3)),(SCYL,DP(4)) EQUIVALENCE (NHEDS,DP(8)) CALL XTTBL (LU,DP) HEAD=SHED+MOD(TRACK,NHEDS) CYL=(TRACK/NHEDS)+SCYL DVID=(UNIT*256)+DVAD SECT2=SECT1/2 RETURN END C SUBROUTINE XTTBL (LU,DP) IMPLICIT INTEGER (A-Z) INTEGER DP(8) C C THIS SUBROUTINE RETURNS DISC DRIVER PARAMETERS AS FOLLOWS: C C DP(1) = HP-IB ADDRESS C DP(2) = UNIT NUMBER C DP(3) = STARTING HEAD C DP(4) = STARTING CYLINDER C DP(5) = NUMBER OF SPARES THIS LU C DP(6) = NUMBER OF TRACKS THIS LU C DP(7) = NUMBER OF SECTORS/TRACK C DP(8) = NUMBER OF SURFACES (OR HEADS) C CALL EXEC (13,10000B+LU,P1,P2,DP,8) RETURN END END$ $  92070-18090 1941 S C0122 &INSTL              H0101 FTN4,L PROGRAM INSTL() $, 92070-16090 REV. 1941 790911 C NAME: INSTL C SOURCE: 92070-18090 C RELOC: 92070-16090 C PGMR: WWL C C C **************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * C * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT * C * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C **************************************************************** C C IMPLICIT INTEGER (A-Z) INTEGER OBUF(512) COMMON /BOOTX/OBUF INTEGER DCB(144),BUF(128) INTEGER DVP(8),SNAM(10),SYNAM(10),BOTNAM(10),TEMP(10) DATA A/40400B/,BOTNAM/2HBO,2HOT,2HEX/ C C C CALL GETST (BUF,-80,IB) LOG=LOGLU(ISES) IF (IB .GT. 0) GO TO 40 20 WRITE(LOG,30) 30 FORMAT(" ENTER SNAP FILE, SYSTEM FILE, BOOT FILE, AND LU.") CALL REIO (1,LOG+400B,BUF,-80) CALL ABREG (IA,IB) IF (IB .EQ. 0) GO TO 20 C 40 IV=1 CALL NAMR (SNAM,BUF,IB,IV) CALL NAMR (SYNAM,BUF,IB,IV) CALL NAMR (TEMP,BUF,IB,IV) IF (TEMP(1) .EQ. 0) GO TO 55 DO 50 I=1,10 BOTNAM(I)=TEMP(I) 50 CONTINUE C 55 CALL NAMR (TEMP,BUF,IB,IV) IF (TEMP(1) .EQ. 0) GO TO 20 LU=TEMP(1) C C FIRST OPEN SNAP FILE & FIND LU TABLE C CALL OPEN (DCB,IER,SNAM,0,SNAM(5),SNAM(6)) IF (IER .GE. 0) GO TO 100 60 WRITE(LOG,70)IER,(SNAM(I),I=1,3) 70 FORMAT(" FMGR",I6," ON ",3A2) GO TO 900 100 CALL READF (DCB,IER,BUF,128,LEN) IF (IER .NE. 0) GO TO 60 IF (LEN .LT. 0) GO TO 60 IF (BUF(2) .NE. 2H$L) GO TO 100 IF (BUF(3) .NE. 2HUT) GO TO 100 IF (IAND(BUF(4),177400B) .NE. A) GO TO 100 C C FOUND THE LU TABLE SYMBOL C SLUT=BUF(6) REC=(SLUT/128)+1 OFSET=MOD(SLUT,128)+1 C C NOW CLOSE THE SNAP FIL~E, OPEN THE SYSTEM FILE, AND C FIND THE DVT FOR THIS LU C CALL CLOSE (DCB) CALL OPEN (DCB,IER,SYNAM,0,SYNAM(5),SYNAM(6)) IF (IER .GE. 0) GO TO 150 120 WRITE(LOG,70)IER,(SYNAM(I),I=1,3) GO TO 900 C 150 CALL READF (DCB,IER,BUF,128,LEN,REC) IF (IER .NE. 0) GO TO 120 DVTA=BUF(OFSET)+LU REC=DVTA/128+1 OFSET=MOD(DVTA,128) C CALL READF (DCB,IER,BUF,128,LEN,REC) IF (IER .NE. 0) GO TO 120 CALL FDVT (BUF,OFSET,REC1,OFST1,6) CALL FDVT (BUF,OFSET,REC2,OFST2,23) CALL READF (DCB,IER,BUF,128,LEN,REC1) IF (IER .NE. 0) GO TO 120 TYPE=IAND(BUF(OFST1),37400B)/256 IF ((TYPE .GE. 30B) .AND. (TYPE .LE. 37B)) GO TO 200 WRITE(LOG,190)LU 190 FORMAT(" LU",I4," IS NOT A DISC LU.") GO TO 900 C 200 N=1 300 CALL READF (DCB,IER,BUF,128,LEN,REC2) IF (IER .NE. 0) GO TO 120 DO 320 I=N,8 IF (OFST2 .GT. 128) GO TO 330 DVP(I)=BUF(OFST2) OFST2=OFST2+1 320 CONTINUE GO TO 350 C C GO HERE IF SOME OF THE PARMS ARE IN NEXT RECORD C 330 N=I REC2=REC2+1 OFST2=1 GO TO 300 C C GOT'EM ALL. NOW CLOSE SYSTEM FILE. C 350 CALL CLOSE (DCB) C OBUF(7)=DVP(1) OBUF(8)=DVP(2) OBUF(9)=DVP(3) OBUF(10)=DVP(4) OBUF(11)=DVP(5) OBUF(12)=DVP(6) OBUF(13)=DVP(7) OBUF(14)=DVP(8) C C NOW OPEN BOOT FILE. IF NOT THERE, CREATE IT. C CALL OPEN (DCB,IER,BOTNAM,0,BOTNAM(5),BOTNAM(6)) IF (IER .EQ. -6) GO TO 450 IF (IER .GE. 0) GO TO 500 400 WRITE(LOG,70)IER,(BOTNAM(I),I=1,3) GO TO 900 C 450 CALL CREAT (DCB,IER,BOTNAM,4,1,BOTNAM(5),BOTNAM(6)) IF (IER .LT. 0) GO TO 400 GO TO 550 C 500 IF (IER .EQ. 1) GO TO 520 WRITE(LOG,510) 510 FORMAT(" BOOT FILE NOT TYPE 1.") GO TO 900 C 520 CALL LOCF (DCB,IER,REC1,IRB,I,SIZE) IF (SIZE .GE. 8) GO TO 550 WRITE(LOG,53 0) 530 FORMAT(" FILE NOT >= 4 BLOCKS.") GO TO 900 C 550 CALL WRITF (DCB,IER,OBUF,512) IF (IER .NE. 0) GO TO 400 WRITE(LOG,590)(BOTNAM(I),I=1,3) 590 FORMAT(" INSTL END. ",3A2," IS YOUR BOOT EXTENSION FILE."/ $" WARNING: BOOT FILE MUST BE AT CYL 0, SECTOR 0.") C 900 CALL CLOSE (DCB) C END C SUBROUTINE FDVT (BUF,OFSET,REC,OFST1,NTRY) INTEGER BUF(128),REC,OFSET,OFST1,DVTA C DVTA=BUF(OFSET) REC=DVTA/128+1 OFST1=MOD(DVTA,128)+NTRY 10 IF (OFST1 .LE. 128) RETURN REC=REC+1 OFST1=OFST1-128 GO TO 10 END END$ &  92070-18091 1941 S C0122 &IDDUP              H0101 wASMB,R,L,C * SOURCE: 92070-18091 * RELOC: 92070-16091 * PGMR: M.L.K. * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * NAM IDDUP,7 92070-1X091 REV.1941 790709 * SKP * ENT IDDUP,IDRPD EXT .ENTR SUP * * IDDUP NOP LDA DUMMY SET UP FOR DEFAULT STA IER PARAMETERS LDA IDDUP GET RETURN ADDRESS STA DDUP AND SAVE JMP DDUP+1 GO TO .ENTR * IDNAM NOP GENERIC ID NAME NWNAM NOP NEW NAME FOR PROGRAM IER NOP ERROR PARAMETER * DDUP NOP DUMMY ENTRY JSB .ENTR DEF IDNAM CCE SET FAILURE FOR SPL LDA .14 GET NOT FOUND ERROR CODE STA IER,I PASS TO USER JMP DDUP,I RETURN * * DUMMY DEF DUMY DUMY NOP .14 DEC 14 SKP * DUMMY IDRPD ROUTINE * IDRPD NOP DUMMY ENTRY POINT LDA DUMMY SET UP FOR DEFAULT STA IERR PARAMETER LDA IDRPD GET RETURN ADDRESS STA DRPD AND MOVE IT JMP DRPD+1 GO TO .ENTR * NAME NOP IERR NOP * DRPD NOP JSB .ENTR DEF NAME CLA,CLE SET UP SUCCESS RETURN STA IERR,I PASS TO CALLER JMP DRPD,I END   92070-18092 1941 S C0122 &RTIOL              H0101 ASMB,R * * NAME: RTIOL * SOURCE: 92070-18092 * RELOC: 92070-16092 * PGMR: C.H.W. * * **************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT * * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * **************************************************************** * * NAM RTIOL,0 92070-16092 REV.1941 800324 * * * * ENT $ABRQ,$BLIM,$CIC,$DIOC,$DMPR,$DVLU ENT $DV1,$DV2,$DV3,$DV4,$DV5,$DV6 ENT $DV7,$DV8,$DV9,$DV10,$DV11,$DV12 ENT $DV13,$DV14,$DV15,$DV16,$DV17,$DV18 ENT $DV19,$DV20,$DV21,$DV22,$DVTP ENT $IF1,$IF2,$IF3,$IF4,$IF5,$IF6 ENT $IF7,$IFTX ENT $INIO,$IOCL,$IOCX,$IODN,$IOFL,$IORQ,$IOTI ENT $IOTO,$IOUP,$IRT,$MPTF,$PBZY,$PDON ENT $POWF,$PRTY,$Q.PV,$Q.TO,$RTSM,$RUN# ENT $TBG,$TBG#,$UNLK,$UPIO,$XSIO * EXT $CVT1,$SYMG,$ERAB,$IDSQ,$IDNO EXT $ERMG,$TYPE,$PIMK EXT $RQRT,$RQCT,$RQP1,$RQP2,$RQP3 EXT $RQP4,$RQP5,$RQP6,$RQP7,$RQP8,$RQP9 EXT $ROM,$TMP1,$TMP2,$TMP3,$TMP4,$TMP5 EXT $PRIO,$XQT,$SUSP,$IDSZ,$IDA EXT $A,$B,$EO EXT $XEQ,$LIST,$ALC,.MVW EXT $CLCK,$RTN,$SCHD EXT $C.CL,$I.CL,$F.CL EXT $LUTA START OF LU TABLE EXT $LUT# # OF DEFINED LU'S EXT $DVTA START OF DVT'S EXT $DVT# # OF DVT'S EXT $IFTA START OF IFT'S EXT $IFT# # OF IFT'S EXT $INTA START OF INTERRUPT TABLE EXT $INT# # OF ENTRIES SKP * <$CIC> PERFORMS THE FOLLOWING: * * 1. DISABLES THE INTERRUPT SYSTEM. * * 2. SAVES ALL REGISTERS PLUS THE INTERRUPT * RETURN POINT IN THE EXECUTING * ID SEGMENT. * * 3. TRANSFERS DIRECTLY TO THE INTERRUPT * PROCESSOR "$CLC^K" ON TBG INTERRUPT. * * FOR OTHER SOURCES, THE INTERRUPT SOURCE * CODE IS USED TO INDEX THE INTERRUPT TABLE. * THE CONTENTS OF THE INTBL ENTRY DETERMINES * THE MANNER IN INITIATING THE PROCESSOR: * * A. +, THE CONTENTS OF THE ENTRY IS * ASSUMED TO BE THE FWA OF AN IFT ENTRY. * THE ADDRESSES OF THE ENTRY * ARE SET IN <$IF1 - $IFN> AND CONTROL * IS TRANSFERRED DIRECTLY TO THE * PHYSICAL DRIVER (PHYSICAL RESUME). * * B. -, THE VALUE IS SET POSITIVE AND IS * SET IN A CALL TO <$LIST> IN THE * SCHEDULING MODULE- THE CALL IS MADE IF * THE USER PROGRAM IS DORMANT- CONTROL IS * TRANSFERRED TO $XEQ. IF THE PROGRAM IS * NOT DORMANT, IT IS NOT SCHEDULED AND THE * DIAGNOSTIC "SC03 INT XXXXX" IS OUTPUT * TO THE SYSTEM TTY- XXXXX IS THE PROGRAM * NAME. CONTROL IS RETURNED TO THE INTER- * RUPTED SEQUENCE. * * C. 0, ILLEGAL OR UNDEFINED INTERRUPTS ARE * NOT PROCESSED BUT THE DIAGNOSTIC * "ILL INT XX" IS OUTPUT TO THE SYSTEM * TTY. XX IS THE INTERRUPT CODE. * * 4. RESTORING INTERRUPT CONDITIONS AND RETURN * TO POINT OF INTERRUPTION. AN ENTRY POINT * CALLED '$IRT' IS PROVIDED FOR USE BY * OTHER MODULES OF THE R/T EXEC TO RESET * FLAGS, RESTORE REGISTERS, & RETURN TO THE * USER PROGRAM. * * THE CALLING SEQUENCE IS JUST: * * - JMP $IRT - * * $IRT PERFORMS THE FOLLOWING: * 1 - DISABLES THE INTERRUPT SYSTEM * 2 - IF PRIVILEGED DONE QUEUE HAS A REQUEST, REENABLES * INTERRUPTS & REENTERS PHY DRIVER OR DOES PHY DONE. * 3 - IF ANY TBG TICKS OCCURRED WHILE IN SYSTEM, RESTORES * INTERRUPTS & JUMPS TO $CLCK. * 4 - ELSE RESTORES THE REGISTERS AND * 5 u- EXECUTES THE CURRENT PROGRAM AT $SUSP. * * SKP $CIC NOP * CLC 4 DISABLE INTERRUPT SYSTEM * * PRESERVE CURRENT STATUS OF MACHINE * DST $A,I SAVE A&B * LIB 4 GET INTERRUPT CODE ISZ $MPTF LDA $PIMK OTA 0 SET INTERRUPT MASK STC 4 ALLOW PRIVILEGED INTERRUPTS NOW! * ERA,ALS SOC INA STA $EO,I SAVE E&O LDA $CIC SAVE P-REGISTER A POSSIBLE STA $SUSP,I POINT OF SUSPENSION. CPB .6 IF TIME BASE GENERATOR, JMP $CLCK GO TO TIME PROCESSOR * STB CHAN SAVE INTERRUPT CODE ADB $INTA INDEX TO PROPER ENTRY * * GET PROCESSOR IDENT FROM INTERRUPT TABLE * LDB 1,I CODE. GET CONTENTS OF ENTRY SZB,RSS INTERRUPT ALLOWED? JMP CIC.4 NO, UNDEFINED INTERRUPT * SSB,RSS DO "PHYSICAL RESUME" IF JMP PR.00 VALUE IS POSITIVE. * ** INTERRUPT PROCESSOR IS USER ROUTINE TO BE ** SCHEDULED FOR PRIORITY EXECUTION * JSB DOCLF CLEAR FLAG CMB,INB SET POSITIVE TO GET ID SEG ADDR STB 0 LEAVE ID SEG ADDR IN B REG FOR <$LIST> * ADA .15 CHECK STATUS OF PROGRAM. LDA 0,I IF STATUS IS ZERO (DORMANT), AND B77 SZA SCHEDULE PROGRAM, OTHERWISE JMP $PBZY ISSUE DIAGNOSTIC. * JSB $LIST CALL SCHEDULER TO LINK PROGRAM OCT 60 INTO SCHEDULE LIST. JMP $XEQ * .15 DEC 15 SPC 2 * * TBG INTERRUPT PROCESSOR - TBG RUNS PRIVILEGED $TBG NOP CLC 4 TURN OFF ALL INTERRUPTS STA SAVA **BELOW MAY BE MODIFIED BY ROUTINES WISHING PRIVILEGED SERVICE **EVERY 10 MILLISECS $TBG# CLF 6 CLEAR TBG FLAG LDA $MPTF GET STATE OF MEMORY PROTECT SZA,RSS IS IT ENABLED? JMP $TBG2 YES, WE CAN ENTER $CIC DIRECTLY ISZ TICK NO, DON'T ENTER SYSTEM, BUT * POSSIBLE "N!OP" HERE IF ROLL-OVER IS POSSIBLE LDA SAVA INCREMENT TICK COUNTER & GET OUT STC 4 JMP $TBG,I RETURN TO POINT OF INTERRUPTION * $TBG2 LDA $TBG PASS INTERRUPT RETURN POINT STA $CIC TO $CIC LDA SAVA JMP $CIC+2 ENTER $CIC NOW! SAVA NOP SPC 2 * PARITY INTERRUPT HAS OCCURRED $PRTY NOP LIB 5 GET VIOLATION ADDR HLT 5 & HALT JMP *-1 * HERE FROM DRIVER ON A DMA PARITY $DMPR NOP LIA 2 IOR HLT0 STA HLTDP STORE CONFIG'D HALT LIA 20B SELF-CONFIG ADDR LIB 22B DMA ADDR ADA M1 ADB M1 HLTDP NOP HALT JMP *-1 HLT0 HLT 0 * * DOCLF NOP LDA CHAN SELECT CODE OTA 2,C SET ENABLE GLOBAL REG CLC 21B SUSPEND DMA CLC 23B,C TURNOFF DMA CLC 30B,C CLEAR CARD JMP DOCLF,I SKP SPC 3 * * * ILLEGAL OR UNDEFINED INTERRUPT * CIC.4 JSB DOCLF CLEAR THE FLAG LDB ASCSC ="SC" LDA CHAN GET THE INTERRUPT CODE. CLE JSB ILLIN GIVE ILLEGAL INTERRUPT MSG JMP IOCX * * ISSUE DIAGNOSTIC FOR BEING UNABLE TO * SCHEDULE USER PROGRAM ON INTERRUPT. * * B REG HAS ID SEG ADDR ON ENTRY $PBZY ADB .12 SET (B) TO ADDRESS OF NAME IN LDA 1,I PROGRAM ID SEGMENT. STA CICM2+4 STORE INB PROGRAM DLD 1,I NAME IN DST CICM2+5 DIAGNOSTIC AND PRINT JSB $SYMG "INT-XXXXX BUSY" DEF CICM2 JMP IOCX SKP * * RESET INTERRUPT CONDITIONS - RETURN TO SEQUENCE * * * ROUTINE: '$IRT' * * THIS ROUTINE RETURNS TO THE CURRENT USER PROGRAM. * IT RESTORES THE PROGRAMS REGISTERS AND THE INTERRUPT * AND MEMORY PROTECT SYSTEM. * * CALLING SEQUENCE: * * SET UP $XQT AREA ON THE BASE PAGE FOR THE PROGRAM * * JMP $IRT * $IRT EQU * CLC 4 PROTECT KAGAINST A TICK HERE LDB $Q.PV HEAD OF COMPLETED PRIV IFTS SZB ANYTHING QUEUED? JMP PVSET YES, DO A PHYSICAL DONE LDA TICK COUNT OF TICKS WHILE M.P. WAS OFF SZA ANY? JMP TICKD YES, TICKED WHILE IN SYSTEM LDB $SUSP,I (A) = 0 AT THIS POINT STB CHAN (B) = RETURN ADDR. SAVE IT SPC 1 LDB $EO,I RESTORE E & O CLO SLB,ELB STO STA $MPTF CLEAR MEMORY PROTECT FLAG OTA 0 ENABLE EVERYBODY * DLD $A,I RESTORE THE A AND B REGS STC 4 TURN ON THE INTERRUPT SYSTEM STC 7 AND MEMORY PROTECT JMP CHAN,I RETURN * TICKD ADA M1 DECREMENT TICK COUNT STA TICK STC 4 JMP $CLCK TICK NOP * * UNLINK FROM COMPLETED PRIVILEGED QUEUE PVSET LDA 1,I GET LINK TO NEXT OR ZERO STA $Q.PV UPDATE HEAD PTR ADB M7 POINT TO 1ST WD OF IFT * * PRIVILEGED DRIVERS CAN ENTER HERE DIRECTLY IF $MPTF WAS ZERO * B REG MUST HAVE ADDR OF IFT EXTENSION WORD 1 (IFTX) * NOTE THAT "T" BIT IN IFT IS NOT CHECKED HENCE PRIVILEGED * DRIVERS CAN NOT LEAVE THEMSELVES IN THE TIME LIST AT PHY.DONE. $PDON STC 4 INTERRUPT SYSTEM ON JSB OFTO REMOVE IFT FROM T.O. LIST JSB @IFT SET-UP IFT POINTERS LDA $IF7,I GET SYS.FLAGS SSA,RSS REQUEST TO REENTER PHY. DVR.? JMP PD.00 NO, DO PHY. DONE NOW LDB .2 YES, GO TO PHY DVR, USING JMP PR.04 IF6 TO SET GLOBAL REG $Q.PV NOP PRIVILEGED DONE QUEUE M7 DEC -7 $MPTF DEC 1 * IMSG OCT 40001 XSIO QUEUE DEC -14 ASC 7,**ILL INT-XXXX * CICM2 OCT 1 DEC -14 ASC 7,INT-XXXXX BUSY * ASCSC ASC 1,SC * * THIS ROUTINE PRINTS THE ILLEGAL INTERRUPT MESSAGE ILLIN NOP STB IMSG+7 "SC" OR "LU" JSB $CVT1 CONVERT TO ASCII STA IMSG+8 STORE IN MSG " JSB $SYMG PRINT MSG DEF IMSG JMP ILLIN,I SKP * * THIS IS THE I/O REQUEST INITIATION SECTION OF RTIOL. * IT IS ENTERED ON AN EXEC 1,2,3,17,18,19,& 20. IF REQUEST * IS BUFFERED OR CLASS, THE I/O CONTROL BLOCK RESIDES IN * SYSTEM AVAILABLE MEMORY. THE ID SEGMENT IS THE I/O CONTROL * BLOCK ON NORMAL REQUESTS. THE I/O CONTROL BLOCK IS ADDED * TO THE DVT INITIATION QUEUE (DVT2) IN EITHER A PRIORITY OR * FIFO SEQUENCE AS SPECIFIED IN THE DVT. * * * I/O REQUEST INITIATION $IORQ EQU * CLA CLEAR: STA DISCF DISC I/O OP.FLAG STA B1LNG I/O BUFR LNG STA B2LNG OP.BUFR LNG CPA $RQCT INSURE >0 PARMS JMP $ER01 -NO, ERR: "IO01" * * LU VALIDITY CHECK * LDA $RQP2,I *VALIDATE LU AND B77 EXTRACT LU STA $B,I SAVE LU IN PGM'S B REG CMA,INA,SZA,RSS LU=0? JMP L.BKT YES, USE BIT BUCKET ADA $LUT# CMA,SSA,RSS LU <= LUMAX? JMP $ER02 -NO, ERR: "IO02" ADA $LUT# RECOVER LU-1 ADA $LUTA & LDB 0,I GET DVT ASGNMNT SZB,RSS IF 0 THEN USE L.BKT LDB $D$DV BIT BUCKET JSB @DVT SET DVT ADDRS * * REQUEST CODE ANALYSIS * LDA $RQP1 GET REQUEST CODE AND B17 & KEEP LOW PART STA RQPX CPA .13 IF STATUS REQ, JMP L.15 GO PROCESS * LDA $DV6,I *CHECK DEVICE AVAILABILITY RAL LDB B54 DOWN DEVICE LIST STATE SSA IF DEVICE DOWN, (AV=1)? JMP L.SUS SUSPEND PROG SKP * * REQUEST CHECK FOR REQUIRED PARMS * LDB RQPX AND B70K CHECK DEVICE TYPE CPA B30K FOR DISC (30-37) & JMP L.018 DO SPECIAL HANDLING CPB .3 CONTROL? JMP L.01A YES LDA $RQP2,I GET CONWD IOR DSKCK INA,SZA,RSS SUPPOSED TO BE A DISC REQ? /' JMP $ER01 YES, ERROR * L.011 ADB RQPTB *GET REQUIRED PARMS LDA 1,I (INDEXED BY REQ.CODE) L.012 LDB $RQP2,I GET 4-BIT QUANT. @ TAB.ENT BLF,SLB,ERB IF Z=1, (BIT 12 OF CONWD) ALF POSITION WITHIN HI/LO BYTE LDB RQPX CPB $RQP1 IF NORMAL REQ. ALF,ALF POSITION TO LO BYTE AND B17 EXTRACT REQUIREMENT CMA,SEZ,INA JMP L.016 IF Z=1, SET OPT.BUFR.LNG L.013 ADA $RQCT SSA REQUIRED # PARMS PROVIDED? JMP $ER01 -NO, ERR: "IO01" * CPB .3 *INPUT BUFR VALIDITY CHK JMP L.02 IF CNTRL REQ, SKIP BUFR CHK LDA $RQP4,I GET BUFR LNG & CLE,SSA,RSS INSURE WE HAVE JMP L.014 WORD COUNT ARS TRANSLATE -CHARS CMA,INA TO +WORDS L.014 STA B1LNG POST FOR LATER USE CPB $RQP1 IF CLASS REQ, CPB .2 OR WRITE REQ, JMP L.02 SKIP BUFR CHK ADA $RQP3 INSURE AREA RESIDES CMA,CLE,SSA,INA,RSS JMP $ER04 WITHIN ADA $ROM AVAILABLE SEZ MEMORY JMP L.02 OK * $ER04 LDB .4 IO04 JMP EREX * L.016 LDB $RQP6,I *IF 2-BUFR REQ SSB,RSS CHECK 2ND BUFR LNG JMP L.017 BRS TRANSLATE -CHARS CMB,INB TO +WORDS & L.017 STB B2LNG POST FOR LATER LDB RQPX JMP L.013 * L.018 ISZ DISCF *FLAG DISC OPS. CPB .3 CONTROL? JMP L.019 YES LDA $RQP2,I SSA BYPASS DEVICE DRIVER? JMP L.019 YES, IGNORE BELOW CHECK IOR DSKCK INA,SZA CON BITS SET FOR DISC? JMP $ER01 NO, ERROR L.019 CPB $RQP1 CLASS REQUESTS LOSE! RSS JMP $ER02 -ERR: "IO02" CPB .3 CONTROL REQ? CCA,RSS YES, REQUIRE 2 PARMS LDA M5 NO, REQUIRE 6 PARMS JMP L.013 * L.01A CPB $RQP1 jpCLASS CONTROL? JMP L.011 NO LDA $RQP4 YES, RE-ALIGN LDB $RQP5 OPTIONAL STB $RQP4 PARAMETERS LDB $RQP6 FOR EASE STB $RQP5 OF FUTURE LDB $RQP7 PROCESSING STB $RQP6 STA $RQP7 LDA RQPCN JMP L.012 .13 DEC 13 B17 OCT 17 B30K OCT 30000 DSKCK OCT 170077 B70K OCT 70000 SKP * * * THE FOLLOWING TABLE DEFINES THE REQUIRED * NUMBER OF PARAMETERS-1 FOR EACH I/O REQUEST * AVAILABLE. THE TABLE IS INDEXED BY REQUEST * CODE TO OBTAIN AN ENTRY. FORMAT OF THIS * ENTRY IS AS FOLLOWS: * *********************************** * * 15-12 * 11-8 * 7-4 * 3-0 * * *********************************** * * CLASS * NORMAL * NORMAL * CLASS * * * Z=1 * Z=0 * Z=1 * Z=0 * * *********************************** * RQPTB DEF * DO NOT REARRANGED! OCT 61526 READ : 6,3,5,6 OCT 61526 WRITE: 6,3,5,6 RQPCN OCT 60523 CNTRL: 6,1,5,3 OCT 60006 W/R : 6,-,-,6 SKP * * CHECK LU LOCK CONDITION * L.02 LDA $DV7,I EXTRACT LU LOCK FLAG AND B3770 LDB $PRIO,I ID SEG PRIORITY STB T1 SET LINKING PRIORITY SZA,RSS LOCKED? JMP L.03 NO, SKIP LOCK CHK * STA T3 SAVE RN FOR LOCK PASSING TEST LDB C100K SET 77777 AS LINK PRIORITY STB T1 (TO INSURE PRIOR REQUESTS FINISH) LDB $XQT JSB $IDNO GET ID SEG NO BLF,RBR CPB T3 JMP L.025 LOCKED TO CALLING PGM LDA T3 RRR 3 ADA M1 MPY $IDSZ ADA $IDA A= ID SEG ADDR OF LOCKER ADA .28 LDA 0,I AND .1700 ISOLATE SEQ NO IOR T3 SWP CPB $RQP9,I JMP L.025 KEYWORD MATCHES LDB B50 LOCKED DEVICE SUSPEND LIST JMP L.SUS SUSPEND CALLER * B3770 OCT 3770 .1700 OCT 170000 * L.025 CLB,INB BUFFERING PRIORITY= 1 SKP * BUILD I/O CONTROL WORD, LESS TY FIELD * * FORMAT: * ************************************** * * 15-14 * 13 * 12 * 11-6 * 5-3 * 2 * 1-0 * * ****************************************** * * TY * E * Z * SF * 0 * D * RQ * * ****************************************** * * WHERE: * TY=REQ.TYPE: 0=NORMAL,1=BUFR'D,2=SYSTEM,3=CLASS * E =FLAG IF CALLER WANTS TO HANDLE ALL ERRORS (ALWAYS FLUSH) * Z =OPTIONAL BUFR INDICATOR * 0=PARM3/4=INTG.VARIABLES * 1=PARM3/4=BUFR ADDR/LNG * SF=SUB-FUNCTION, (6-BIT FIELD) * D =DON'T CALL LOGICAL DRIVER * RQ=REQUEST CODE: 1=READ,2=WRITE,3=CONTROL * L.03 STB T2 SET BUFFERING PRIORITY LDB RQPX *CONSTRUCT I/O CNTRL WORD: CPB .4 -BIT(1-0)=I/O REQ CODE CLB,INB CHANGE CLASS W/R TO READ LDA $RQP2,I SSA DON'T CALL LOGICAL DRIVER? ADB .4 YES, MOVE TO CONWD BIT 2 AND B377C -BIT(12)=Z-BIT & BIT(13)=E-BIT IOR 1 -BITS(11-6)=SUB-FUN. STA T3 =(WORD2 OF I/O CONTROL BLOCK) * * CLASS ALLOCATION/INITATION * LDB RQPX CPB $RQP1 CLASS I/O JMP L.05 NO, SKIP THIS CONCERN LDB T2 PRIORITY JSB $I.CL INITIATE CLASS JMP L.054 -PENDING COUNT AT MAX JMP L.134 -BUFFER RETHREAD, SET TO GO STB T5 OK, (B)=CLASS TAB.ENTRY PTR CLB,INB JMP L.052 * CKTYP NOP LDA RQPX CPA $RQP1 IS THIS CLASS I/O? JMP CKTYP,I NO, OK TO SUSPEND LDA $RQP7,I GET CLASS WORD SSA,RSS NO WAIT? JMP CKTYP,I NO, SUSPEND OK LDA M2 ($A)=-2:SAM FULL/BUFR LIM'D STA $A,I L.RTN LDA $RQRT SET RETURN ADDR STA $SUSP,I @ ID SEG JMP $XEQ & RETURN TO DISPATCHER SKP * * AUTOMATIC BUFFERING SECTION k * FOUR THINGS PREVENT A NORMAL REQUEST FROM BEING BUFFERED * 1. THE DVT BUFFERING FLAG IS NOT SET * 2. THE "NO BUFFER" BIT ON THE USER'S REQUEST IS SET * 3. THE DEVICE IS A DISC (TYPE=30-37) * 4. THE REQUEST IS FOR DYNAMIC STATUS * L.05 LDA $RQP2,I *CHECK BUFFERING REQUIREMENT RAL,ELA E=1 IIF OVERRIDE BUFFERING SET LDA $DV8,I GET DVT BUFFERING FLAG CMA,SEZ,SSA,RSS DV8(15)=1 & NO OVERRIDE? CPB .1 YES, CHECK IF INPUT JMP L.10 -NO BUFFERING! LDA T3 AND B7703 LDB DISCF DISC REQUESTS SZB,RSS & CPA B603 DYNAMIC STATUS REQ JMP L.10 ARE NEVER BUFFERED! * L.052 ADB .9 *COMPUTE BUFR SIZE REQUIREMENT STB T4 =9 FOR I/O BLOCK, (+1 FOR CLASS) ADB B1LNG +PRIMARY BUFR LNG ADB B2LNG +OPTIONAL BUFR LNG STB L.LNG POST FOR ALLOCATION STB $TMP1,I SAVE BUFR LEN IN CASE OF MEM SUSP * CLB SET TO TEST JSB $BLIM UPPER BUFFER LIMIT JMP L.06 HERE IF NOT ABOVE B.L. LDB $PRIO,I ABOVE LIMIT, SO ADB M41 CHECK PRIORITY AND SSB IF < 41 JMP L.06 THEN IGNORE B.L. * L.054 JSB CKTYP MAKE SURE NOT NO-WAIT CLASS I/O LDB B55 & SUSPEND REQUEST SKP * * GENERAL WAIT LIST SUSPENSIONS, AS FOLLOWS: * DOWN DEVICE - STATE= 54 * LOCKED LU - STATE= 50 * BUFR LIMITED - STATE= 55 * MEM SUSPEND - STATE= 61 * L.SUS STB DISCF SAVE NEW STATE LDA $DV1 A=DVT ADDRESS LDB $XQT B=ID SEG ADDRESS JSB $LIST SUSPEND PGM ON DESIGNATED LIST DISCF NOP JMP $XEQ & RETURN TO DISPATCHER * * ALLOCATE MEMORY FOR BUFR'D/CLASS REQUESTS * L.06A LDA RQPX *NO SAM IN SYSTEM CPA $RQP1 CLASS REQ.ATTEMPTED? JMP L.10 NO, FORCE NON-BUFR'D I/O JMP $ER04 YES, ERR:"I?O04" * L.06B JSB CKTYP MAKE SURE NOT N0-WAIT CLASS I/O LDA L.LNG REQUESTED BLOCK LENGTH STA $TMP1,I IS SAVED IN ID SEG LDB B61 MEM SUSPEND LIST STATE JMP L.SUS PUT PGM ON LIST * * L.06 JSB $ALC *ALLOCATE MEM.FROM SAM L.LNG NOP =BLOCK LNG, WORDS JMP L.06A -NEVER ANY FREE MEM JMP L.06B -OUT OF MEM FOR NOW STA T6 ALLOC OK, POST ADDR STB L.LNG & ACTUAL LNG ADB $DV8,I UPDATE BUFFER ACCUM. STB $DV8,I * SKP * * BUILD I/O BLOCK, BUFR'D & CLASS REQUESTS * (CARVED OUT OF SYSTEM AVAILABLE MEMORY) * WORD1: I/O LIST LINKAGE * WORD2: I/O CONTROL WORD * WORD3: REQ.PARM1/PRIME.BUFR.ADDR * WORD4: REQ.PARM2/PRIME.BUFR.LNG(& XLOG) * WORD5: REQ.PARM3/OPT.BUFR.ADDR * WORD6: REQ.PARM4/OPT.BUFR.LNG * WORD7: REQUEST PRIORITY(& CLASS COMP.STATUS) * WORD8: I/O BLOCK LNG * WORD9: IF CLASS, CLASS INFO, IF BUFFERED, ID SEG/RUN # * WORD10:IF CLASS, USER-DEFINED VALUE * WORD10/11 : BUFFERED DATA... * L.07 SWP CCE,INB POINT TO CONWD LDA T4 T4=9 IF BUFRD,10 IF CLASS AND .3 ERA,RAR A=140000B IF CLS, 40000B IF BUFRD IOR T3 INCLUDE "TY" FIELD STA 1,I STORE NEW CONWD INB STB T3 =RUNNING I/O BLOCK ADDR * LDB T6 WORD3=PRIMARY BUFR ADDR ADB T4 @SAM+9, IF BUFR'D R/W STB T4 @SAM+10, IF CLASS R/W LDA RQPX CPA .3 CONTROL? JMP L.076 YES, GET OPT.PARM L.071 STB T3,I LDB B1LNG SZB DO BUFR MOVE FOR CPA .1 NON-ZERO LNG JMP L.072 WRITE REQ.ONLY LDA $RQP3 (A)=SOURCE BUFR,(USER) LDB T4 (B)=DESTINATION BUFR,(SAM+8/10) JSB .MVW MOVE IT! DEF B1LNG =BUFR LNG, WORDS NOP * L.072 ISZ T3 CLA (IN CASE $RQP4=0)  LDB $RQP4,I STB T3,I WORD4=R/W BUFR LNG ISZ T3 OR OPT.PARM * LDB $RQP2,I BLF,SLB 2-BUFR REQ(Z BIT=1)? JMP L.078 YES, GET 2ND BUFR ADDR LDB $RQP5,I WORD5=OPT.PARM L.073 STB T3,I (B)=DESTINATION BUFR.ADDR. CPA B2LNG SKIP BUFFER MOVE ON JMP L.074 ZERO LNG REQUEST LDA $RQP5 (A)=SOURCE BUFR,(USER) JSB .MVW MOVE IT NOW DEF B2LNG =OPT.BUFR.LNG NOP * L.074 ISZ T3 CLA,CLE (IN CASE $RQP6=0) LDB $RQP6,I WORD6=OPT.PARM4 OR STB T3,I OPT.BUFR.LNG ISZ T3 LDB T2 WORD7=PRIORITY STB T3,I ISZ T3 LDB L.LNG WORD8=I/O BLOCK LNG STB T3,I ISZ T3 LDB RQPX CPB $RQP1 CLASS OR BUFFERED? JMP L.12 BUFFERED, JUMP CPB .3 TYPE=3? CCE SET E IF CLASS CONTROL LDB $RQP8,I WORD 10=USER PARAMETER LDA $RQP7,I WORD9=CLASS INFO DST * T3 EQU *-1 SEZ,RSS CONTROL? CLA NO, USER'S A = 0 AND MSK13 ISOLATE CLASS # (IF CTL) ISZ T5,I BUMP PENDING COUNT LDB T6 (B)=LINK ITEM ADDR JMP L.133 * L.076 CLA IF CONTROL REQ, LDB $RQP3,I WORD3=OPT.PARM3 JMP L.071 * L.078 LDB T4 IF 2-BUFR REQ, ADB B1LNG WORD5=OPT.BUFR ADDR JMP L.073 WORD5=OPT.PARM5 * MSK13 OCT 17777 SKP * BUILD I/O BLOCK, NORMAL REQUEST * (INFO.MAINTAINED IN ID SEG AREA) * $XQT : I/O LIST LINKAGE * $TMP1 : I/O CONTROL WORD * $TMP1+1: REQ.PARM1/PRIME.BUFR.ADDR. * $TMP1+2: REQ.PARM2/PRIME.BUFR.LNG. * $TMP1+3: REQ.PARM3/OPT.BUFR.ADDR. * $TMP1+4: REQ.PARM4/OPT.BUFR.LNG. * $PRIO : PROGRAM PRIORITY * L.10 LDA T3 POST I/O CONTROL INFO STA $TMP1,I IN ID.SEG. LDB RQPX CLA CPB .3 BRANCH IF CONTROL q JMP L.106 LDB $RQP3 =BUFR ADDR L.102 STB $TMP2,I POST @ ID.SEG LDB $RQP4,I GET BUFR LNG/OPT.PARM2 STB $TMP3,I & POST @ ID.SEG LDB $RQP5,I LDA $RQP2,I CHECK Z-BIT FOR ALF,SLA 2-BUFR REQ LDB $RQP5 =OPT.BUFR.ADDR, IF Z ON STB $TMP4,I POST @ ID.SEG. CLA LDB $RQP6,I GET OPT.BUFR LNG/PARM4 STB $TMP5,I & POST @ ID.SEG * LDB $XQT JSB $LIST MOVE PROG TO .2 DEC 2 I/O SUSPENSION LIST LDB $XQT USE I/O BLK ADDR FOR LINKAGE LDA $SUSP,I ($A)=SUSPENSION POINT * L.133 STA $A,I SET USER'S A REG L.134 LDA $RQRT SET RETURN ADDR STA $SUSP,I IN ID.SEG CLE (E)=I/O BLK SELECT LDA T1 (A)=LINK PRIORITY JSB LINK & ADD USER REQUEST DEF $DV2,I TO DVT INIT.Q. SEZ,RSS LONE ITEM IN Q? JMP LI.00 YES, SO START LOGICAL JMP IOCX * L.106 LDB $RQP3,I GET OPT PARM1 JMP L.102 & POST @ ID SEG * L.12 LDB $XQT JSB $RUN# FORM ID SEG#/ RUN # STA T3,I BUF'RD REQ, WORD 9= ID SEG/RUN# LDB T6 JMP L.134 SKP * * STATUS SECTION * L.15 LDB $RQCT INSURE AT LEAST ADB M2 2 PARMS ARE GIVEN SSB JMP $ER01 NO, ERR:"IO01" * LDA $DV6,I RETURN DEVICE STATUS STA $RQP3,I AT 1ST PARM LDA $DV5,I GET IFT ADDR SZA RETURN 0 IF NO IFT ADA .5 POINT TO IFT6 LDA 0,I RETURN INTERFACE STATUS STA $RQP4,I AT 2ND PARM * LDA $RQP2,I CHECK FOR Z-BIT ALF,SLA IN CONWD ?? JMP L.152 * NOTE: IF BIT BUCKET, DVTP DATA IS MEANINGLESS DLD $DVTP,I OFF, RETURN: STA $RQP5,I $DVX @ 3RD PARM STB $RQP6,I $DVX+1 @ 4TH PARM L.151 LDA $DV10,I CURRENT MAX REC SIZE RAL,CLE,ERA STA $B,I RETURN IN B REG  JMP L.RTN * L.152 CLA INSURE 5 PARMS LDA $RQP6,I ARE SUPPLIED ADB M3 & SSB,RSS BUFR LNG >=0 ? SSA JMP $ER01 NO, ERR:"IO01" LDB 0 ADB $RQP5 INSURE BUFR EXISTS CMB,CLE,SSB,INB,RSS IN USER'S AREA JMP $ER04 ADB $ROM CMA,SEZ,RSS JMP $ER04 NO, ERR:"IO04" LDB $DVTP OK, SET TO MOVE STB T1 DVTP AREA TO USER * L.153 INA,SZA,RSS JMP L.151 ALL DONE LDB T1,I STB $RQP5,I ISZ T1 ISZ $RQP5 JMP L.153 * SKP $ER01 CLB,INB,RSS $ER02 LDB .2 EREX LDA IO07 ="IO" JMP $ERAB SPC 2 * DATA AREA FOR REQUEST PROCESSING SECTION T1 NOP T2 NOP T4 NOP T5 NOP T6 NOP CHAN NOP RQPX NOP B1LNG NOP B2LNG NOP .1 DEC 1 .9 DEC 9 .12 DEC 12 M3 DEC -3 M5 DEC -5 M41 DEC -41 B50 OCT 50 B61 OCT 61 B77 OCT 77 B603 OCT 603 B7703 OCT 7703 B377C OCT 37700 C100K OCT 77777 IO07 ASC 2,IO07 $D$DV DEF BUCKT DUMMY DVT FOR BIT BUCKET SKP * * $XSIO - HERE FOR SYSTEM REQUESTS * * JSB $XSIO * DEC (BIT14="Q"=1 IF CALL FROM I/O SYS/DVR) * DEF * NOP * OCT * DEF * DEC * DEC * DEC * DEC - COMPLETION LOG ON RTN * (RESERVED FOR DMS FUTURE USAGE) * * $XSIO NOP LDB $XSIO LDA 1,I GET LU WORD RAL XSIO2 ADB .2 SET ADDR OF I/O BLOCK CCE,SSA IS "Q" FLAG SET? JMP XSIOQ YES, JUST QUEUE IT STB T1 CCE,INB LDA 1,I GET I/O CONTROL WORD ELA,CLE,ELA & RAR,RAR SET TY-FIELD=2 STA 1,I ADB .5 COMPUTE ADDR OF STB T2 PRIORITY WORD CCA ADA $XSIO,I EXTRACT LU & INDEX INTO LUT AND B77 ADA $LUTA & LDB 0,I (=DVT ADDR) SZB,RSS LDB $D$DV (FOR BIT BUCKET) JSB @DVT SETUP DVT ADDRS LDB T1 (B)=LINK ITEM LDA $DV6,I GET "AV" RAL DOWN FLAG INTO SIGN BIT CLE,SSA IS DEVICE DOWN? JMP XDOWN YES LDA T2,I GET PRIORITY JSB LINK & ADD REQUEST DEF $DV2,I TO DVT INIT.Q. * XSIO6 LDA $XSIO,I GET LU WORD SSA WAS THIS A "Q" XSIO DE-Q? JMP IX.XS YES ADB .8 POINT TO XSIO CONTINUE ADDR SEZ LONE ITEM IN Q? JMP 1,I NO, TAKE EXIT NOW! SKP * $INIO STB $$RTN SAVE RETURN FROM IOC * * LOGICAL DRIVER INITIATION * * ENTERED FROM #IORQ,$XSIO FOR REQUEST INITIATION * DVT ADDRESSES ARE ASSUMED TO HAVE BEEN SETUP. * LI.00 LDB $DV7,I GET FLAGS BLF,SLB TEST LOGICAL "HOLD" JMP IOCX SET, DONT START THIS REQ. LDB $DV3 NODE LIST LI.02 LDB 1,I GET LINK SSB IS THIS ONE BUSY? JMP IOCX YES, CAN'T START REQ CPB $DV3 ALL IN NODE LIST CHECKED? CLA,CCE,INA,RSS YES, START REQ JMP LI.02 NO ADA $DV2,I MOVE REQUEST PARMS ELA,CLE,ERA (STRIP Q-BIT) LDB $DV15 TO ACTIVE PARMS AREA JSB .MVW AT $DV15-$DV19 DEF .5 NOP LDB $DV1 CPB $D$DV IS THIS "BIT BUCKET" JMP LD.42 YES, GO TO LOG.DONE LDA $DV6,I ALR,ERA SET DVT BUSY RAR,ELA CLEAR BIT 0 (E) STA $DV6,I LDA $DV3,I IOR BIT15 SET NODE BUSY STA $DV3,I CLA,INA (A)=INIT NEW REQ * LI.20 JSB L.DVR CALL LOGICAL DRIVER JMP LW.00 -LOGICAL WAIT. JMP PI.00 -PHYSICAL INIT. JMP LD.00 -LOGICAL DONE. JMP PI.00 NO LOG.DVR, SKIP TO PHY. SPC 5 * ENTER HERE TO QUEUE AN XSIO REQUEST ON Q.SD AND RETURN * IMMEDIATELY TO THE CALLER (PRESUMABLY A DRIVER) XSIOQ ERA,CLE SET BIT15 TO IDENTIFY IT STA $XSIO,I STORE IN LU WORD JSB LINK ADD XSIO REQUEST TO SYS.DONE QUEUE DEF Q.SD ADB .8 POINT TO XSIO CONTINUE ADDR JMP 1,I RETURN IMMEDIATELY TO CALLER SPC 4 * DEVICE IS DOWN ADD XSIO BLOCK TO SYS DONE QUEUE - XLOG = 0 XDOWN CLA STA T2,I RETURN XLOG OF ZERO JSB LINK ADD XSIO BLOCK TO SYS DONE QUEUE DEF Q.SD CCE FORCE RETURN FROM I/O SYS JMP XSIO6 SKP * * LOGICAL WAIT SECTION * * $DV7(15-11)= M0IHT, WHERE: * M=LOCK MAINTENANCE REQUESTED BY LOG.DVR * I=ILL.INTRPT ENTRY REPORTED BY LOG.DVR * H=HOLD ASSERT/MAINTAIN REQ'ED BY LOG.DVR * T=TIMEOUT REQ'ED BY LOG.DVR * LW.00 BLF GET "T" CLE,SSB TIMEOUT REQUESTED? JSB ONTO YES, ALLOW TIME OUT LDA $DV7,I RAL,RAL ILL INTRPT REPORT SSA,RSS REQUESTED? JMP LW.06 NO * LW.05 LDB $DV1 JSB $DVLU GET ASSOCIATED LU LDB ASCLU ="LU" CCE JSB ILLIN GIVE ILLEGAL INTERRUPT MSG LDA $DV7,I RAL,RAL * LW.06 RAR,SLA LOCK MAINTAINANCE REQ? JMP IOCX YES, DON'T DISTURB! LDB $DV5,I JSB @IFT ELSE, SET IFT ADDRS LDB $IF3,I & CHECK FOR LOCK ELB,CLE,ERB CONDITION, THIS DVT LDA $IF6,I RAL,SLA IS IFT BUSY? JMP IOCX YES CPB $DV1 DVT @ IFT Q-HEAD? CCE,SSA,RSS LOCKED? JMP PW.30 NO, PROCEED JSB UNLNK REMOVE DVT FROM DEF $IF3,I IFT INIT Q LDB $IF6,I (RELEASE LOCK) ELB,ELB & RBR,CLE,ERB SET IFT AV=0 STB $IF6,I SZA,RSS IFT Q EMPTY? JMP IOCX YES LDB $IF3,I NO, GET NEW DVT HEAD JSB @DVT SET DVT POINTERS HJMP PI.18 INITIATE NEW HEAD * SKP * * LOGICAL RESUME SECTION * * THIS SECTION ALLOWS A PHYSICAL DRIVER TO "INTERRUPT" * LOGICAL DRIVER ACTIVITY. THE APPROPRIATE LOGICAL * DRIVER IS SELECTED FROM THE DVT REFERENCE WORD POSTED * AT $IF5. IF A LOGICAL DRIVER DOES NOT EXIST FOR THIS * DVT, THEN THE PHY.DRIVER REQUEST IS DISMISSED. * LR.00 LDB $IF5,I GET DVT REF.WORD JSB @DVT & SETUP ADDRS LDA .5 (A)=RESUME JSB L.DVR CALL LOGICAL DRIVER JMP LW.00 -LOGICAL WAIT JMP PI.02 -PHYSICAL INIT JMP LD.00 -LOGICAL DONE JMP LW.05 NO LOG.DVR, SO LOSE! *NOTE **WHAT ABOUT CHECKING T AT LR.00** * SKP * * LOGICAL DONE * LD.00 BLF,CLE ENABLE LOG.TIME OUT SSB IF REQUESTED BY JSB ONTO LOGICAL DRIVER LDB $DV5,I SET IFT ADDRS JSB @IFT LDB $DV7,I BLF,ERB MOVE "HOLD" TO E-REG LSR 5 MOVE "AB" TO BIT 0 SLB,RSS ACTIVE ABORT PROCESS? JMP LD.02 NO LDA $DV16,I *I/O ABORT HANDLING AND B77 EXTRACT ERR CODE CPA .1 ILL.REQ.ERR? JMP LD.10 YES * LD.02 LDA $DV3,I RAL,ERA CLEAR NODE BUSY UNLESS HOLD SET STA $DV3,I LDA $DV1,I INA,SZA,RSS DVT LINKAGE CLEAR? JMP LD.08 YES, GO CHECK FOR ERRS * LDA $DV7,I *ABNORMAL COMPLETION AND .3 LDB AQ.DO POINTER TO "DONE QUEUE" CMA,INA,SZA,RSS Q'ED ON $IF? (RS=0)? LDB $IF3 YES, FREE FROM $IF.Q CCE,INA,SZA,RSS Q'ED @IFT-HEAD? (RS=1)? JMP LD.16 YES, FREE IFT & START NXT STB LD.05 LDB $DV1 (B)=ITEM ADDR, (E)=DVT SELECT JSB UNLNK REMOVE DVT FROM LD.05 DEF * INDICATED QUEUE * LD.08 LDA $IF3,I ELA,CLE,ERA LDB $IF6,I SZA IFT QUEUE EMPTY? RBL,SLB,ELB NO, IFT BUSY? JMP LD.30 YES, JUMP LDA $IF7,I SEZ,RSS LOCKED? ALF,SLA NO, IS HOLD SET? JMP LD.30 YES * PHYSICAL HOLD IS RELEASED, PUT DVT ON DONE QUEUE AND * START REQUEST AT HEAD OF IFT QUEUE LDB $DV1 JSB LINK LINK ONTO DONE QUEUE DEF Q.DO LDA $DV7,I IOR .3 SET RS=3 STA $DV7,I LDB $IF3,I JSB @DVT SET-UP DVT POINTERS AND JMP PI.22 DO PHYSICAL INITIATE * * ILLEGAL REQUEST FROM LOG DVR ON ABORT ENTRY LD.10 CLB LDA $DV15,I IOR .4 SET FLAG TO NOT CALL LOG DVR STA $DV15,I JMP PR.04 CALL PHYSICAL DRIVER * * LOGICAL DONE WHILE REQUEST IS ACTIVE AT IFT LD.16 LDA $IF6,I *RELEASE IFT BUSY/LOCK ALR,ARS SET IFT FREE, AV=0 STA $IF6,I LDB $DV1 (B)=ITEM ADDR, (E)=1 JSB UNLNK REMOVE DVT FROM DEF $IF3,I IFT INIT QUEUE LDB .3 RS=3 CCE,SZA QUEUE NOW EMPTY? JMP PD.21 NO, GO START NEXT AT IFT * LD.30 LDB $DV6,I *NORMAL COMPLETION STB LD.05 (TEMP SAVE-AV FIELD) ELB,CLE,ERB CLEAR SIGN LDA $DV16,I *CHECK ERROR HANDLING AND B77 CCE,SZA ERRS REPORTED BY DVR? RBR,ELB YES, SET "E-BIT" STB $DV6,I SZA,RSS ERRS? JMP LD.37 NO, SO SKIP IT CLB CPA .1 ILLEGAL REQUEST? STB $DV17,I YES, FORCE XLOG=0 STA MSG1+4 (TEMP SAVE-ERR CODE) LDA $DV16,I GET ERROR CODE WITH "FLUSH" FLAG RAL MOVE FLAG TO BIT15 LDB BLNKS ASCII BLANK SSA FLUSHING? LDB MSG.F YES, GET AN "F" LDA $DV2,I GET I/O BLOCK ADDR ELA,CLE,ERA CLEAR SIGN INA LDA 0,I GET CONWD RAL,RAL PUT "U"-BIT IN BIT15 CCE,SSA,RSS CALLER PROCESSING ERRORS? JMP LD.32 NO, OBEY THE DOWN/FLUSH FLAGS RAR,SLA TEST FOR XSIO REQUEST SSRA (SY=10 BINARY) JMP LD.37 NOT AN XSIO REQ, SO FLUSH, DONT DOWN LDB MSG.F ITS AN XSIO WITH "UE", FORCE FLUSH LD.32 STB MSG1+9 SAVE FLUSH INDICATOR IN MSG LDB $DV1 JSB $DVLU GET LU LDB $DV16,I CPA .1 DON'T DOWN RBL,ERB SYSTEM CONSOLE! STB $DV16,I STA MSG1+7 (TEMP SAVE-LU) LDA MSG1+9 =",F" OR BLANKS RAR,ERA SET E IF FLUSHING SSB,RSS DON'T DOWN BIT SET? JSB $IODN NO, SO DOWN THE DEVICE LDA MSG1+4 *GIVE ERR REPORT CPA B77 UNLESS CODE IS 63 JMP LD.36 SO NO MESSAGE LDB 0 RECOVER ERR CODE ADB ERCNT SSB IF CODE DEFINED ADA ERTBA USE ERR MNEMONIC SSB ELSE GIVE ERR LDA 0,I NUMBER PROVIDED CCE,SSB,RSS BY LOG.DRIVER JSB $CVT1 & STA MSG1+4 POST IN MSG LDA MSG1+7 JSB $CVT1 GET LU TO MSG STA MSG1+7 LDB $DV16,I LDA MSG.D RBL,SLB IF DVT HAS BEEN LDA BLNKS SET DOWN, ADD STA MSG1+8 INDICATION TO MSG JSB $SYMG NOTIFY USER DEF MSG1-1 * LD.36 LDA MSG1+9 CPA BLNKS FLUSH THIS REQUEST? JMP LD.80 NO, DON'T DEQUEUE IT * LD.37 LDA LD.05 RECOVER AV-FIELD CLE,SSA,RSS DVT BUSY? JMP LD.80 NO, RELEASE OF HOLD BY DVR * LD.40 LDA $DV17,I CHECK XMISSION LOG SSA POSITIVE? CMA,INA NO, THEN MAKE IT SO LD.41 STA $DV17,I LDB $DV2,I (B)=ITEM, (E)=I/O BLK SEL. ELB,CLE,ERB CLEAR "Q"-BIT STB RQPX SAVE BLOCK ADDR FOR LATER JSB UNLNK REMOVE COMPLETED REQ. DEF $DV2,I FROM DVT INIT Q INB LDA 1,I GET I/O CNTRL WORD RAL,SLA,ELA & CHECK TY-FIELD JMP LD.60 IT'S CLASS OR SYSTEM REQ SEZ TY=0? JMP LD.50 NO, HANDLE BUFFERED REQUEST LDA $DV16,I NORMAL REQ, GET STATUS AND B77 CPA .1 ILLEGAL REQUEST? JMP LD.45 YES * * PROCESS COMPLETION OF NORMAL I/O REQUEST LDA $DV16,I STA 1,I SAVE EXTENDED STATUS INB LDA $DV17,I STA 1,I INB LDA $DV18,I STA 1,I INB LDA $DV19,I STA 1,I ADB .5 LDA $DV6,I GET DVT STATUS STA 1,I TO USER'S A REG INB & LDA $DV17,I TRANSMISSION LOG STA 1,I TO USER'S B REG LDB RQPX ID SEG ADDR JSB $LIST RETURN USER PROGRAM OCT 60 TO SCHEDULE LIST JMP LD.80 * BIT BUCKET LOGICAL DONE LD.42 CLA,CLE STA $DV16,I NO ERRORS JMP LD.40 * REQUEST ERROR ON NORMAL I O REQUEST LD.45 LDB RQPX JSB $LIST PUT PGM IN SCHEDULE LIST OCT 60 LDB RQPX JSB $IDSQ SET ID SEG REFS LDA $A,I STA $SUSP,I RESET POINT OF SUSPENSION LDB $DV1 ADDR OF DVT STB ACDVT SAVE IT DLD IO07 ="IO07" JSB $ERMG GIVE ERROR/ ABORT USER LDB ACDVT GET DVT ADDR AGAIN JSB @DVT RE-SETUP POINTERS JMP LD.80 * LD.50 LDB RQPX *BUFFERED REQ (TY=1) LDA $DV1 PASS DVT ADDR JSB $RTSM RETURN SAM, CHECK FOR BELOW B.L. JMP LD.80 * LD.60 LDB RQPX I/O BLOCK ADDR LDA $DV17,I GET TRANSMISSION LOG SEZ JMP LD.70 GO HANDLE CLASS REQUEST * ADB .6 POINT TO WORD FOR LOG STA 1,I SAVE IT THERE * LDB RQPX *SYSTEM REQUEST (TY=2) JSB LINK SAVE I/O BLOCK DEF Q.SD ON SYSTEM DONE QUEUE JMP LD.80 TRY NEXT REQUEST * * PROCESS CLASS I/O COMPLETION LD.70 JSB $C.CL GO TO CLASS COMPLETION ROUTINE * * FIND ANOTHER REQUEST USING NODE LIST - DO LOGICAL INITIATION * FOR NEXT DVT IN NODE LIST WHICH HAS A REQUEST QUEUED, DOES NOT * HAVE HOLD SET, AND IS FREE. * LD.80 LDA $DV7,I AND M5 CLEAR AB FLAG STA $DV7,I LDB $DV3,I FIND NXT DVT REQUEST LD.81 SSB WAS HOLD LEFT SET? JMP IOCX YES, HOLD OFF ENTIRE NODE LIST CCA ADA 1 CHECK NEXT NODE FOR LDA 0,I PENDING REQUEST ON ELA,CLE,ERA ROUND ROBIN BASIS SZA JMP LD.85 FOUND A REQUEST LD.82 CPB $DV3 JMP IOCX END OF NODE LIST, SO QUIT! LDB 1,I JMP LD.81 * LD.85 ADB .4 LDA 1,I GET $DV7 ADB M1 POINT TO $DV6 ALF,SLA HOLD IN EFFECT ON THIS $DV? JMP LD.87 YES, BYPASS IT LDA 1,I GET $DV6 RAL CMA,CCE,SSA,SLA DVT FREE? JMP *+3 YES, OK TO PROCEED LD.87 ADB M3 MUST SKIP THIS REQUEST JMP LD.82 ADB M5 POINT TO START OF DVT JSB @DVT SET-UP DVT ADDRS JMP LI.00 INITIATE THE REQUEST SKP * ERTBA DEF * ASC 1,RQ ERR 1 ASC 1,NR ERR 2 ASC 1,TO ERR 3 ASC 1,ET ERR 4 ASC 1,TE ERR 5 ASC 1,WP ERR 6 ASC 1,AD ERR 7 ASC 1,SP ERR 8 ASC 1,GP ERR 9 ASC 1,FA ERR 10 ASC 1,DC ERR 11 ERCNT ABS ERTBA-* =-(# ENTRIES+1) * SUP OCT 40001 XSIO QUEUE REQ MSG1 DEC -18 ASC 9,**I/O-XX @LUXX,D,F UNS * ASCLU EQU MSG1+6 BLNKS OCT 20040 MSG.D ASC 1,,D MSG.F ASC 1,,F ACDVT NOP SKP * PHYSICAL DRIVER INITIATION PI.00 LDB $DV5,I FIND IFT & JSB @IFT SETUP ADDRS PI.02 LDA $DV1,I *CHECK DVT REQUEST STATE CCE,INA,SZA,RSS REQUEST STARTED YET? JMP PI.10 NO, THEN START NOW LDA $DV7,I AND .3 CMA,INA,SZA,RSS QUEUED ON $IF? (RS=0)? JMP PW.10 YES CCE,INA,SZA,RSS RUNNING AT $IF? (RS=1)? JMP PI.20 YES, BREAK IN WFITH NEW REQ. LDB $DV1 BEFORE PROCEEDING. JSB UNLNK DEF Q.DO DONE QUEUE CCE * PI.10 LDA $DV20,I GET DEVICE PRIORITY AND B77 ISOLATE IT LDB $DV1 POINTER TO THIS DVT JSB LINK ADD LOG.DVR.REQ. DEF $IF3,I TO PHY.INIT.Q LDA $DV7,I & AND C3 SET REQUEST STATE, RS=0 STA $DV7,I (QUEUED ON $IF) SEZ REQ AT Q-HEAD? JMP PW.10 NO, SO WAIT PI.18 ISZ $DV7,I MARK @Q-HEAD, (RS=1) * PI.20 LDA $IF7,I *START REQ.@ $IF ALF,SLA HOLD ASSERTED BY PHY.DVR? JMP IOCX YES, HONOR IT! * PI.22 LDA $DV7,I RAL,CLE,ERA GET LOCK BIT IN E STA $DV7,I CLEAR IT IN DV7 ELA,CLE LDB $IF6,I SET AVAILABILITY RBL,RBL AV=2, BUSY, OR RRR 2 AV=3 BUSY & LOCKED STB $IF6,I RAR MOVE "T" TO BIT 9 CMA IOR $IF7,I "M" OR NOT "T" LSL 6 SSA,RSS IS "T"=1 AND "M"=0? JSB ONTO YES, ALLOW LOGICAL TIME OUT LDA $DV1 STA $IF5,I LDA $DV7,I RAL,RAL ALLOW ABORT REQUEST CLB,INB FROM LOG.TO PHY.DVR. SSA CLB JMP PR.04 GO CALL PHYSICAL DRIVER SKP * * PHYSICAL CONTINUE - AWAIT INTERRUPT * PW.00 LDB $IF7,I GET FLAGS RBL,RBL *CHECK FOR ERROR REPORT SSB,RSS ILL.INTRPT REPORTED? JMP PW.10 NO CLE,RSS * PW.05 JSB DOCLF CLEAR FLAG (NO DVT FOR INTERRUPT) * LDB ASCSC ="SC" LDA $IF6,I (A)=I/O CHAN JSB ILLIN GIVE ILLEGAL INTERRUPT MSG * PW.10 LDA $IF6,I SSA CHECK FOR IFT BUSY JMP IOCX IT IS, SO DONE * * * ENTER HERE WHEN PHYSICAL DRIVER HAS EXITED WHILE IFT * WAS NOT BUSY. CHECK FOR RELEASED HOLD. * PW.30 LDB $IF3,I GET ADDR OF DVT AT HEAD ELB,CLE,ERB CLEAR SIGN SZB,RSS ANYTHING AT HEAD? JMP IOCX NO, NOTHING WAS HELD JSB @DVT SET-UP DVT ADDRESSES RAL A(15)=IFT LOCK FLAG AND $DV7,I AND WITH "MAINTAIN LOCK" FLAG SSA IS IFT LOCK MAINTENANCE IN EFFECT? JMP IOCX YES! WAIT FOR LOG DVR TO INITIATE JMP PI.20 GO START NEXT REQUEST * HI.2 OCT 100002 C3 OCT 177774 SKP * * PHYSICAL RESUME - INTERRUPT SERVICE * PR.00 JSB @IFT SETUP ADDRS CLA,CLE CPA $IF5,I DOES IFT REFERENCE A DVT? JMP PW.05 NO, DON'T GO TO PHY.DVR. LDB HI.2 (B)=CONTINUE PR.04 JSB P.DVR & CALL PHYSICAL DVR JMP LR.00 -LOGICAL RESUME JMP PW.00 -PHYSICAL CONT SKP * * PHYSICAL DRIVER DONE-CONTINUE LOGICAL * * THE PRIORITY OF OPERATIONS IS AS FOLLOWS: * 1) IF IFT LOCKED, CONTINUE LOGICAL DRIVER * 2) IF IFT REQUESTS PENDING, MOVE COMPLETED * LOGICAL REQUEST TO PHYSICAL DONE QUEUE * AND INIT NEXT IFT OPERATION * 3) IF NO PENDING IFT REQUESTS, CONTINUE LOGICAL * PD.00 LDB $IF3,I GET ADDR OF DVT AT IFT HEAD ELB,CLE,ERB STB TMPA1 SAVE IT LDA $IF6,I GET IFT "AV" FIELD ELA,CLE,ERA CLEAR SIGN (BUSY FLAG) LDB $IF5,I GET CURRENT DVT REF CPB TMPA1 DID DVR CHANGE DVT REF? STA $IF6,I NO, STORE $IF6 WITH BUSY CLEAR CLE,SZB,RSS WAS ANY DVT ADDR SPECIFIED? JMP PW.30 NO,CHK RELEASE OF HOLD JSB @DVT SET DVT REFERENCE FROM $IF5 LDB $DV11 JSB OFTO REMOVE ANY LOG.TIME OUT * LDB $IF7,I GET SYSTEM FLAGS LDA $IF6,I GET $IF6 LOCK FLAG RAL,ELA *TEMP SEZ,CCE,SSB,RSS IFT NOT LOCKED & ADVANCE Q? SEZ,SSB,RSS **TEMP JMP PD.20 YES, UNLINK THIS REQUEST * DVT LOCKED TO IFT OR PHY DVR SET "Q"-BIT, DONT UNLINK DVT * PD.12 LDB $IF7,I RBL SSB DID PHYSICAL WANT TO BYPASS LOGICAL? JMP IOCX YES, DONE * PD.15 LDA .2 LOGICAL CONTINUATION JSB L.DVR CALL LOG. DVR. JMP LW.00 -LOGICAL WAIT JMP PI.02 -PHYSICAL INIT JMP LD.00 -LOGICAL DONE JMP LD.00 NO, LOG.DVR, ASSUME DONE SKP * * ENTER HERE TO DEQUEUE THIS DVT FROM IFT AND IF ANOTHER DVT * WAS ON THE IFT'S QUEUE, PUT THIS DVT ON THE DONE QUEUE ("Q.DO") * AND IMMEDIATELY CALL THE PHYSICAL DRIVER FOR THE NEW DVT AT * THE HEAD OF THE IFT INITIATION QUEUE. * PD.20 LDB $DV1 *DO IFT REQ CLEANUP CCE **TEMP JSB UNLNK UNLINK COMPLETED DEF $IF3,I REQ FROM IFT Q LDB $IF6,I B HAS IFT "AV" SZA IFT INITIATION QUEUE EMPTY? SSB NO, IS IFT FREE? JMP PD.12 YES LDA $IF7,I RAL GET SYS FLAGS CCE,SSA PHY DVR WANT TO CALL LOGICAL? JMP PD.22 NO, LEAVE DVT OFF QUEUES LDB .2 RS=2 * PD.21 LDA $DV7,I GET RS FIELD AND C3 IOR 1 UPDATE RS STA $DV7,I LDB $DV1 JSB LINK MOVE DVT TO AQ.DO DEF Q.DO DONE QUEUE * HEAD OF PHYSICAL INITIATION QUEUE WILL NOW BE STARTED PD.22 LDB $IF3,I SET DVT ADDRS JSB @DVT FOR NXT REQ JMP PI.18 & START NOW! SKP * * TIME OUT PROCESSING * $IOTO EQU * CCB 1ST TIME FLAG TO.00 LDA Q.TO TIME OUT QUEUE CLE,SZA,RSS EMPTY?? JMP IX.30 YES, DONE INA STA TMPA1 SAVE ADDR OF CLOCK CLA CPA TMPA1,I IS CLOCK AT HEAD = 0? JMP TO.04 YES, TIME OUT! SZB HAVE WE TICKED YET? ISZ TMPA1,I NO, SO BUMP IT JMP IX.30 & LEAVE * TO.04 LDB TO.AD STB $$RTN RETURN TO "TO.00" FROM IOCX LDB Q.TO JSB UNLNK REMOVE ITEM FROM DEF Q.TO TIME OUT LIST * NOTE FOLLOWING CODE PRESUMES DVT'S PRECEDE IFT'S IN CORE LDA $IFTA  ADDRESS OF IFT AREA CMA,CLE,INA ADA 1 IS ITEM ADDR >= CLA,SEZ,RSS START OF IFT'S? JMP TO.20 NO, LOG.TIME OUT! * JSB @IFT *PHYSICAL LEVEL T.O. CPA $IF5,I IS THERE A DVT FOR THIS IFT? JMP IX.20 NO, SO IGNORE THE T.O. LDB .3 JMP PR.04 SET, GIVE TO PHY.DVR * TO.20 ADB M10 *LOGICAL LEVEL T.O. JSB @DVT LDA .3 JMP LI.20 GIVE TO LOG.DVR. * TO.AD DEF TO.00 * M10 DEC -10 * Q.DO OCT 100000 SIGN=FIFO QUEUE Q.SD OCT 100000 SIGN=FIFO QUEUE SPC 3 * * THIS ENTRY PROVIDED FOR DRIVERS TO UP DEVICE * $UPIO JSB $IOUP GO TO UP ROUTINE SKP * * IOCX - EMPTY COMPLETION QUEUES * $IOCX EQU * IOCX LDB Q.DO DONE QUEUE CPB BIT15 QUEUE EMPTY? JMP IX.20 CCE NO,(E)=DVT SELECT JSB UNLNK REMOVE $DV DEF Q.DO FROM Q.DO JSB @DVT SET DVT ADDRESSES LDA $DV7,I GET DVT STATE .8 SLA PHYSICAL OR LOGICAL DONE? JMP LD.30 LOGICAL, GO COMPLETE IT JMP PD.15 PHYSICAL, DO SAME * IX.20 LDA $$RTN CLE,SZA,RSS IS IOC REALLY DONE? JMP IX.30 YES CLB,CCE NO, CONTINUE TIMER, FLUSH, UP, POWER- STB $$RTN FAIL, LA, OR XSIO PROCESSING. JMP 0,I * * ENTER HERE WHEN AN XSIO REQUEST PREVIOUSLY QUEUED ON Q.SD * CAN NOW BE INITIATED IF IT IS AT HEAD OF DVT INIT. QUEUE. IX.XS ELA,CLE,ERA CLEAR BIT 15 OF LU WORD STA $XSIO,I *TEMP SEZ,CLE,RSS IS REQ NOW AT IFT HEAD? SEZ,RSS **TEMP JMP LI.00 YES, INITIATE IT NOW CLE **TEMP * E ALWAYS ZERO WHEN WE GET HERE IX.30 LDB Q.SD SYSTEM DONE CPB BIT15 QUEUE EMPTY? JMP $TYPE YES JSB UNLNK REMOVE I/O BLOCK DEF Q.SD FROM Q.SD ADB M2 COMPUTE ADDR OF BLOCK STB $XSIO LDA 1,I GET LU WORD <-RAL,CLE,SLA,ERA WAS BIT15 SET? JMP XSIO2 YES, START XSIO REQ NOW INB NO, THIS IS A COMPLETED REQ LDA 1,I COMPLETION ADDRESS CLE,SZA,RSS DEFINED? JMP IX.30 NO, EMPTY Q.SD JMP 0,I YES, GO TO XSIO COMPLETION SKP * $IOFL PERFORMS I/O ABORT PROCESSING. * * IT IS ENTERED WITH THE ABORTING ID SEGMENT ADDRESS IN * THE A REGISTER. $IOFL WILL DEQUEUE AND DEALLOCATE ALL * BUFFERED REQUESTS INITIATED BY THE ABORTING PROGRAM AS * WELL AS ALL CLASS REQUESTS FOR WHICH IT IS THE DESIGNATED * OWNER. IN THE LATTER CASE, THE CLASS NUMBER WILL BE * DEALLOCATED. ALL REQUESTS ACTIVE * AT THE PHYSICAL LEVEL MIGHT NOT BE COMPLETED WHEN $IOFL * IS EXITED. HOWEVER, THE SYSTEM WILL FLUSH THE REQUESTS * AS A MATTER OF COURSE IN THE LOGICAL DONE PROCESSING * SECTION. * $IOFL NOP STA T2 SAVE ABORTING ID SEG ADDR JSB $F.CL FLUSH ALL "OWN"ED & COMPLETED DEC 0 CLASS BUFFERS CLA STA T5 SET IF REQUEST AT IFT HEAD MUST ABORT LDA $DVT# # OF DVT'S CMA,INA STA T4 USE AS RUNNING COUNTER LDB T2 ID SEG ADDR JSB $RUN# COMPUTE ID SEG # / RUN # STA T1 LDA $DVTA ADDR OF 1ST DVT * ENTER HERE FOR EACH LU FL.05 STA T3 GET ASSOCIATED DVT ADDR INA ADDRESS OF $DV2 STA FL.52 * ENTER HERE FOR EACH REQUEST FL.10 LDA 0,I GET ADDRESS OF NEXT REQUEST FL.11 ELA,CLE,ERA CLEAR POSSIBLE SIGN SZA,RSS END OF CHAIN? JMP FL.60 YES STA TMPE2 SAVE REQUEST'S ADDRESS CPA T2 IS THIS THE ID SEGMENT ITSELF? JMP FL.30 YES LDB 0 NO INB POINT TO CONTROL WORD LDB 1,I GET IT RBL,SLB IS THIS A BUFFERED REQUEST? JMP FL.10 SSB,RSS JMP FL.10 NO, TRY NEXT REQUEST LDB 0 ADB .8 9TH WORD OF REQUEST HAS ID SEG/RUN # LDB 1,I OF INITIATING PROGRAM CPB T1 IS IT OURS? RSS YES JMP FL.10 NO, TRY NEXT REQUEST SKP * AT THIS POINT A NORMAL OR BUFFERED REQUEST TO BE FLUSHED * HAS BEEN FOUND. FL.30 XOR FL.52,I ELA,CLE,ERA CLE,SZA IS THIS REQ AT THE DVT HEAD? JMP FL.50 NO, JUST UNLINK / DEALLOCATE IT LDB T3 GET DVT ADDR ADB .5 POINT TO $DV6 LDA 1,I GET IT SSA,RSS IS DVT BUSY? JMP FL.50 NO, FLUSH IT NOW * ISZ T5 FLAG THAT HEAD OF DVT MUST BE LDA TMPE2 ABORTED BY DRIVER CALL JMP FL.10 DO REST OF DVT BEFORE CALLING DVR * * NOW UNLINK THE REQUEST FROM THE $DV FL.50 LDB TMPE2 REQUEST ADDRESS LDA 1,I GET LINK TO NEXT REQUEST STA TMPE2 FOR LATER JSB UNLNK UNLINK REQUEST FROM LOG. INITIATE QUEUE FL.52 NOP (CONTAINS ADDR OF DVT2) CPB T2 WAS THIS A NORMAL REQUEST? JMP FL.54 YES, DO SCHED REQ TO ABORT IT LDA T3 GET DVT ADDR JSB $RTSM RETURN SAM, CHECK FOR BELOW B.L. JMP FL.56 DO NEXT REQUEST * FL.54 JSB $LIST DO SCHEDULE CALL TO ABORT PGM OCT 60 FL.56 LDA TMPE2 LINK TO NEXT JMP FL.11 GO PROCESS IT SKP * * THE DVT HAS NOW BEEN PROCESSED, AND ANY NON-ACTIVE * NORMAL OR BUFFERED REQUESTS HAVE BEEN FLUSHED FL.60 LDB T3 GET DVT ADDRESS LDA T2 A= ID SEG ADDR JSB $F.CL GO FLUSH "OWNED" PENDING CLASS DEC 2 REQUESTS ON THIS DVT LDB T3 GET DVT ADDRESS CLA CPA T5 ACTIVE ENTRY TO ABORT? JMP FL.70 NO STA T5 CLEAR FLAG FOR NEXT TIME JSB @DVT SET-UP DVT ADDRS LDA $DV6,I GET DVT WORD 6 AND .034 CHECK DEV TYPE CPA .014 IS THIS A DISC? JMP FL.70 YES, DON'T DO ABORT JSB $ABRQ DO ABORT` INITIATION * FL.70 LDB T3 ADB .20 ADDR OF DVT21 LDB 1,I GET # OF DVR PARAMS CLA RRL 7 RIGHT JUSTIFY IN A REG ADA T3 + DVT ADDR ADA .22 + DVT SIZE = NEXT DVT ADDR ISZ T4 ALL PROCESSED? JMP FL.05 NO, EXAMINE NEXT DEVICE * * ALL REQUESTS ON ALL $DV'S RELATED TO THIS ID SEGMENT * HAVE BEEN FLUSHED IF INACTIVE, AND ABORTION HAS BEEN * INITIATED ON ALL ACTIVE REQUESTS JMP $IOFL,I EXIT * TMPE2 NOP .20 DEC 20 .22 DEC 22 .034 OCT 34000 .014 OCT 14000 SKP * * $IOCL FLUSHES AN XSIO REQUEST * * CALLING SEQUENCE: * JSB $IOCL * DEF (XSIO CALL LU WORD) * * IF THE SPECIFIED REQUEST IS ACTIVE, IT IS ABORTED, OTHERWISE * IT IS SIMPLY DEQUEUED FROM THE DVT. ANY XSIO COMPLETION * ROUTINE WILL BE CALLED FROM IOCX THE NEXT TIME THE I/O * SYSTEM EXITS NORMALLY (SINCE $IOCL IMMEDIATELY RETURNS TO * CALLER). * * NOTE: DON'T USE THIS ROUTINE UNLESS XSIO CONTROL BLOCK * SPECIFIES A COMPLETION ROUTINE! * $IOCL NOP LDB $IOCL,I GET XSIO REQ ADDR ISZ $IOCL POINT TO RTN ADDR CCA ADA 1,I LU-1 AND B77 ADA $LUTA ADDR OF LU ENTRY IN LUT LDA 0,I GET IT ADB .2 POINT TO XSIO LINK WORD CCE,INA STA TMPE1 SAVE ADDR OF DVT2 * CL.10 LDA 0,I GET NEXT REQ ON DVT ELA,CLE,ERA CPA 1 IS THIS IT? JMP CL.20 YES, FLUSH IT CLE,SZA,RSS END OF LIST? JMP $IOCL,I NOT ON INITIATION QUEUE JMP CL.10 TRY NEXT * CL.20 LDA TMPE1 ADA .4 POINT TO DVT6 LDA 0,I GET DVT6 *TEMP SEZ,CLE,SSA AT HEAD AND BUSY? SEZ,SSA **TEMP JMP CL.40 YES, GO ISSUE ABORT TO DVR CLE **TEMP JSB UNLNK NO, DEQUEUE THE REQ FROM DVT TMPE1 NOP CLE JSB LINK ADD TO SYSTEM DONE QUEUE DEKF Q.SD JMP $IOCL,I BACK TO CALLER NOW * CL.40 CCB ADB TMPE1 COMPUTE ADDR OF DVT1 JSB $ABRQ ABORT REQUEST AT HEAD JMP $IOCL,I DONE! NOW BACK TO CALLER SKP * * $IOUP IS CALLED WHEN A DEVICE IS TO BE "UP"ED. * * DVT ADDRESSES HAVE ALREADY BEEN SET WHEN ENTERED. * $IOUP NOP LDA $DV1 RESCHEDULE ALL WAITERS FOR JSB $SCHD A DOWNED DEVICE B54 OCT 54 LDA $DV6,I GET AVAILABILITY FIELD RAL,CLE,RAL ERA,RAR CLEAR DOWN FLAG STA $DV6,I LDB $DV2,I ELB,CLE,ERB SZB ANYTHING QUEUED ON DEVICE? SSA YES, IS DEVICE NON-BUSY? JMP $IOUP,I NO, DONE LDB $$RTN SZB,RSS ENSURE $$RTN NOT SET (I.E. P.F.) LDB $IOUP RETURN ADDR FOR JMP $INIO GO START LOGICAL REQUEST SKP * * $IODN IS CALLED WHEN A DEVICE IS "DOWN"ED * * DVT ADDRESSES HAVE BEEN SET WHEN ENTERED. THE * ROUTINE CHECKS FOR ANY PROGRAMS IN I/O SUSPENSION * FOR THE DEVICE AND PLACES THOSE FOUND INTO THE * WAIT LIST WITH POINT OF SUSPENSION RESET SO * THAT THE REQUEST WILL BE REINITIATED WHEN THE * DEVICE IS UP'ED. * XSIO REQUESTS WILL BE IMMEDIATELY COMPLETED WITH * TRANSMISSION LOGS OF ZERO. THIS IS TO ALLOW THE XSIO * ROUTINES TO BE AVAILABLE TO OTHER DEVICES WHICH * ARE NOT DOWN BUT SHARE THE SAME XSIO CTL BLOCK. * ON ENTRY, E=0 IF CALLED FROM LOG.DONE & DON'T FLUSH * $IODN NOP LDA $DV6,I IOR BIT14 SET DEVICE DOWN STA $DV6,I IN DVT "AV" FIELD LDB $DV2,I GET HEAD OF LOG INITIATION QUEUE SEZ,SSA,RSS AV=NOT BUSY AND DON'T FLUSH? JMP IODN2 YES, DON'T SKIP HEAD ELB,CLE,ERB CLEAR SIGN SZB DVT QUEUE EMPTY? LDB 1,I NO, SKIP 1ST IODN2 ELB,CLE,ERB CLEAR SIGN SZB,RSS MORE ON QUEUE? JMP $IODN,I NO, RETURN * STB TMPA4 SAVE REQUEST ADDRESS LDA 1,I STA TMPA5 d SAVE LINK TO NEXT INB LDA 1,I GET CONTROL WORD RAL CLE,SSA TEST REQUEST TYPE JMP IODN4 BUFFERED OR CLASS, IGNORE STA $IOUP SAVE CONWD LDB TMPA4 REQ BLOCK ADDR JSB UNLNK REMOVE FROM DVT INIT QUEUE DEF $DV2,I LDA $IOUP GET CONWD CLE,SLA NORMAL REQUEST? JMP IODN6 NO, XSIO REQUEST BLOCK * ADB .9 LDA 1,I STEP TO SAVE A REG., GET SAVED ADB M1 POINT OF SUSPENSION, AND STORE STA 1,I IT IN $SUSP FOR THIS PROGAM. LDB TMPA4 GET REQ BLOCK ADDR LDA $DV1 DVT ADDRESS JSB $LIST LINK THIS PROGRAM INTO THE OCT 54 DOWN DEVICE LIST IODN4 LDB TMPA5 GET ADDR OF NEXT REQUEST JMP IODN2 PROCESS IT SPC 2 IODN6 JSB LINK ADD XSIO BLOCK TO SYS DONE QUEUE DEF Q.SD ADB .6 POINT TO XLOG WORD CLA STA 1,I RETURN ZERO XMISSION LOG JMP IODN4 SKP * * THIS ROUTINE INITIATES REQUEST ABORT PROCEEDINGS FOR THE * ACTIVE REQUEST FOR THE GIVEN DEVICE. IF IF HEAD IS NOT * ACTIVE, IT IS SIMPLY FLUSHED. * CALLING SEQUENCE: * LDB (DVT ADDRESS) * JSB $ABRQ * (RETURN) * $ABRQ NOP JSB @DVT SET DVT ADDRESSES LDA $ABRQ ENSURE WE RETURN TO STA $$RTN CALLER FROM IOCX LDA $DV6,I GET "AV" SSA,RSS BUSY? JMP NOTBZ NO, DO IMMEDIATE FLUSH LDA $DV7,I IOR .4 SET "AB" FLAG STA $DV7,I BIT13 XOR 0 A=0 (ABORT) * JSB L.DVR CALL LOGICAL DRIVER JMP LW.00 LOGICAL WAIT JMP PI.00 PHYSICAL INITIATE JMP LD.00 LOGICAL DONE * ADB BIT13 NO LOG DVR, SO CALL PHY DVR STB $DV7,I FOR ABORT NOW JMP PI.00 GO TO PHYSICAL INITIATE * * NOTBZ CLA STA $DV16,I RETURN NO ERROR JMP LD.41 FLUSH WITH XLOG=0 I SKP * LINK - QUEUING IS ON EITHER A PRIORITY OR A FIFO * BASIS, AS DIRECTED BY THE Q-BIT LOCATED AT BIT15 * OF THE LIST HEAD. IF PRIORITY IS INDICATED, THE * E-REQ. DEFINES WHERE THE PRIORITY WORD FOR THE * CURRENTLY LINKED REQUESTS WILL BE FOUND: * (E)=0 - PRIORITY WORD @ (LINK WORD+6) * (E)=1 - PRIORITY WORD @ (LINK WORD+1),I+6 * * (E)=0/1 - I/O BLK / DVT SELECT * (A)=LINK PRIORITY, (NOT NEEDED IF FIFO QUEUE) * (B)=LINK ITEM ADDR * JSB LINK * DEF * RETURN: P+1, B=ITEM ADDR, A MEANINGLESS * (E)=0/1 - QUEUE WAS EMPTY/NOT EMPTY ON ENTRY * * LINK NOP STA TMPA1 =LINK PRIORITY ELB,CLE,ERB STB TMPA2 =LINK ITEM ADDR LDB LINK (SIGN MUST NOT BE SET HERE!) LINK1 ELB,CLE,ERB (DON'T DISTURB E-REQ) LDB 1,I GET Q-HEAD ADDR SSB & CHASE INDIRECTS JMP LINK1 LDA 1,I GET Q-TYPE TO A(15) ERA,CLE,RAL & BLK/DVT SELECT TO A(0) STA TMPA3 START SCAN PROCESS RSS **TEMP LINK9 CCE,RSS **TEMP * LINK2 LDA TMPA3 LINK3 STB TMPA4 SAVE PREVIOUS ENTRY ADDR LDB 1,I & ADVANCE TO NEXT ELB,CLE,ERB (CLEAR POSSIBLE SIGN) SZB,RSS END OF LIST? JMP LINK6 YES, GO LINK NEW ITEM *TEMP SEZ,CCE SKIP IF FIRST TIME SEZ **TEMP SSA NOT 1ST, SKIP IF PRIORITY Q'ING *TEMP JMP LINK3 FIFO, SO CONTINUE SCAN JMP LINK9 **TEMP * STB TMPA5 ITEM ADDR SLA I/O BLK OR DVT? JMP LINK4 DVT, JUMP ADB .6 LDA 1,I USE REQ PRIORITY JMP LINK5 (WORD 7 OF I/O BLOCK * LINK4 ADB .19 DVT SO FIND DEVICE LDA 1,I PRIORITY IN DVT20 AND B77 BITS 5-0 * LINK5 LDB TMPA5 CMA,INA NEGATE THIS PRIORITY ADA TMPA1 COMPARE TO CURRENT CCE,SSA,RSS IF CURRENT IS HIGHER THAN NEW JMP LINK *2 (LOWER #), THEN CONTINUE SCAN * LINK6 STB TMPA2,I SET LINK WD OF NEW BLOCK LDA TMPA4,I ADD NEW REQUEST TO AND BIT15 APPROPRIATE I/O Q AND IOR TMPA2 MAINTAIN SIGN BIT OF STA TMPA4,I CURRENT REQUEST LDB TMPA2 RETURN ITEM ADDR IN B ISZ LINK JMP LINK,I * TMPA3 BSS 1 TMPA4 BSS 1 .19 DEC 19 SKP * * UNLNK - REMOVE ITEM FROM INDICATED LIST * * (E)=0/1 : 0/-1 TO LINK WORD * (B)=ITEM ADDR * JSB UNLNK * DEF * RETURN P+2 * (B)=ITEM ADDR * (A)=0 IF QUEUE NOW EMPTY * $UNLK EQU * UNLNK NOP ELB,CLE,ERB STRIP SIGN OF ITEM ADDR CCA,SEZ,RSS (E)=1 GETS -1 TO LINK WORD CLA (E)=0 GETS 0 TO LINK WORD STA TMPA1 LDA UNLNK UNLN1 LDA 0,I GET Q-HEAD ADDR RAL,CLE,SLA,ERA & CHASE INDIRECTS JMP UNLN1 STA TMPA2 =Q-HEAD ADDR * UNLN2 STA TMPA3 SAVE PREV.ITEM ADDR. LDA 0,I GET NEXT ITEM RAL,CLE,ERA EXTRACT SIGN BIT CPA 1 ITEM FOUND? JMP UNLN3 YES, GO UNLINK IT SZA END OF LIST? JMP UNLN2 NO, CONTINUE JMP UNLN4 YES, QUIT! * UNLN3 LDA 1,I REMOVE THE ITEM RAL,ERA (MAINTAIN SIGN) STA TMPA3,I & LDA TMPA1 INIT.LINK WORD STA 1,I OF UNLINKED ITEM * UNLN4 LDA TMPA2,I ELA,CLE,ERA A NOW = 0 IF EMPTY Q ISZ UNLNK JMP UNLNK,I * SKP * * ONTO - ADD $DV/IFT TO TIME OUT QUEUE * * (E)=0/1 : LOGICAL/PHYSICAL LEVEL SELECT * JSB ONTO * ONTO NOP LDB $IF1 CHOOSE LOGICAL OR SEZ,RSS PHYSICAL LEVEL LDB $DV11 CLOCK BLOCK STB TMPA1 =LINK ITEM ADDR INB LDA 1,I GET CLOCK VALUE CMA,INA,SZA,RSS REQUESTED?? JMP ONTO,I NO, LEAVE STB TMPA2 =CLOCK WORD ADDR LDB AQ.TO * ONTO1 STB TMPA3 9gSAVE PREV ITEM ADDR LDB 1,I & GET NEXT ONE SZB,RSS END OF LIST? JMP ONTO3 YES CLE,INB MOVE TO CLOCK TIME ADA 1,I & ACCUMULATE SEZ,RSS CURR.ENT.BEYOND NEW? JMP ONTO2 YES, POSITION FOUND ADB M1 CMA,INA ELSE, POST NEGATIVE STA TMPA2,I TIME VALUE REMAINS CMA,INA JMP ONTO1 * ONTO2 STA 1,I UPDATE NEXT ITEM'S CLOCK ADB M1 B= ADDR OF NEXT * ONTO3 STB TMPA1,I SET NXT INTO NEW LDA TMPA1 SET NEW ITEM ADDR STA TMPA3,I INTO PREV.ITEM LINK JMP ONTO,I & LEAVE * SKP * * OFTO - REMOVE LOG/PHY LEVEL FROM TIME OUT QUEUE * * JSB OFTO * OFTO NOP LDA 1,I INA,SZA,RSS IN T.O.LIST?? JMP OFTO,I NO, SO LEAVE ALONE STB TMPA5 TMPA5 EQU *+1 DLD * GET LINK AND CURRENT TIMER CCE,INA POINT TO TIMER OF NEXT ADB 0,I ADD THIS TIMER TO NEXT ENTRIES STB 0,I STORE IN NEXT ENTRY (OR B IF NO MORE) LDB TMPA5 JSB UNLNK UNLINK THIS ENTRY FROM T.O.QUEUE AQ.TO DEF Q.TO JMP OFTO,I & LEAVE * SKP * * L.DVR - LOGICAL DRIVER ENTRY ROUTINE * * -CLEARS LOGICAL TIME OUT CLOCK * -REMOVES DVT FROM TIME OUT QUEUE * -CALLS LOGICAL DRIVER * -POSTS LOG.DVR'S REQ @ $DV7, BITS 15-11 * * (A)=DRIVER DIRECTIVE: * 0=ABORT, 1=INIT, 2=CONT, 3=TO, 4=PF, 5=RESUME * JSB L.DVR * P+1: LOGICAL WAIT REQUESTED * P+2: PHYSICAL INIT REQUESTED * P+3: LOGICAL DONE REQUESTED * P+4: NO LOGICAL DRIVER * L.DVR NOP STA TMPA4 LDB $DV11 JSB OFTO REMOVE DVT FROM .O.QUEUE CLA CLEAR LOGICAL STA $DV12,I TIME OUT CLOCK LDB $DV15,I RBR,RBR GET CONWD BIT 2 SLB,RSS DON'T CALL LOGICAL DRIVER SET? LDA $DV14,I NO, GET LOG.DVR ADDR SZA ANY?? JMP *+3 YES ISZ L.DVR NO, EXIT P+4 JMP L.DV2 STA TMPA5 LDA TMPA4 (A)=DVR.DIRECTIVE LDB $DV1 (B)=DVT ADDRESS JSB TMPA5,I CALL LOGICAL DVR. L.DV2 ISZ L.DVR -LOG.DONE, P+3 ISZ L.DVR -PHY.INIT, P+2 LDB $DV7,I & POST DVR'S RETURNED BLF,RBL CNTRL INFO AT $DV7 RRR 5 STB $DV7,I JMP L.DVR,I * SKP * P.DVR - PHYSICAL DRIVER ENTRY ROUTINE * * -SET VALIDATE I/O CHIP GLOBAL REG * -INIT TIME CLOCK TO TIME OUT VALUE * -REMOVE IFT FROM TIME OUT QUEUE * -CALL PHYSICAL DRIVER * -POST PHY.DVR'S REQUEST @ $IF7, BITS 15-11 * * (B)=DRIVER DIRECTIVE, BIT15=1 IF INTRPT ENTRY * 0=ABORT, 1=INIT, 2=CONT, 3=TO, 4=PF * JSB P.DVR * P+1: LOGICAL RESUME REQUESTED * P+2: PHYSICAL CONTINUE REQUESTED * P+3: PHYSICAL DONE REQUESTED * P.DVR NOP LIA 2 GET CURRENT GLOBAL REG STA TMPE1 LDA $IF6,I GET I/O CHAN RBL,CLE,SLB,ERB INTRPT ENTRY? LDA CHAN YES, USE SOURCE CHAN CLC 4 DISALLOW P.F. OTA 2,C SET/ENABLE GLOBAL REG CLA LIA 2,C RE-READ GLOBAL REG SZA,RSS IS CARD THERE? JMP P.DV8 NO, CAN'T LEAVE GLOBAL REG INVALID STC 4 NEW GLOBAL REG OK, PROCEED STB TMPE1 LDA $IF7,I GET "M" FLAG LSL 6 MOVE TO SIGN SSA IS IT SET? JMP P.DV4 YES, DON'T TOUCH T.O. LIST LDB $IF1 JSB OFTO REMOVE IFT FROM Q.TO LDB $IF5,I GET DVT ADDR ADB .12 & BUMP TO $DV13 LDB 1,I GET TIME OUT VALUE STB $IF2,I & POST IN IFT CLOCK * P.DV4 LDA TMPE1 (A)=DRIVER DIRECTIVE LDB $IF4,I STB TMPE1 =DRIVER ENTRY ADDR LDB $IF5,I (B)=DVT ADDR JSB TMPE1,I CALL PHY.DVR P.DV6 ISZ P.DVR -PHY.DONE, P+3 ISZ P.DVR -PHY.CONT, P+2 < LDB $IF7,I -LOG.RESUME, P+1 BLF,RBL (A)=5-BIT DVR CONTROL INFO RRR 5 POST IN IFT STB $IF7,I BLF CCE,SSB "T" SET? JSB ONTO YES, PUT IFT ON TIME-LIST JMP P.DVR,I SPC 2 * INTERFACE CHIP HAS FAILED OR IS NOT THERE. RESTORE * GLOBAL REG TO PREVIOUS VALUE SO IN CASE OF POWER FAIL * SYSTEM STATE IS RESTORABLE, NOTABLY PRIVILEGED MASK. * RETURN A "NOT READY" & FLUSH THIS REQUEST. P.DV8 LDB TMPE1 PREVIOUS GLOBAL REG OTB 2,C RESTORE IT STC 4 REENABLE P.F. & LEV 3 INRUPS LDB $IF5,I JSB @DVT SET-UP DVT POINTERS LDB NRDYF =140002, NOT READY, FLUSH STB $DV16,I SET DVT ERROR JMP P.DV6 DO PHY DONE, A=0 * NRDYF OCT 140002 SKP * * THIS ROUTINE PERFORMS BUFFER LIMIT CHECKING * ON ENTRY, B=0 IF UPPER LIMIT CHECK, OR * B=RETURNED SIZE IF LOWER LIMIT CHECK * EXITS TO RETURN+1 UNLESS ALREADY BUFFER LIMITED * ON UPPER LIMIT CHECK(RETURN+2). * $BLIM NOP LDA $DV9,I BUFFER LIMITS FOR THIS $DV AND B377 CMB,INB,SZB LOWER LIMIT CHECK? JMP BLIM2 YES STA TMPA1 LDA $DV9,I SSA ALREADY LIMITED? JMP BLIM3 YES, DO RTN+2 LSR 8 RIGHT JUSTIFY ADA TMPA1 A = UPPER LIMIT MODULO 16 BLIM2 ALF ADJUST FROM MODULO 16 CMA,INA,SZA,RSS LDA BUMAX USE BUMAX IF IT WAS ZERO STA TMPA1 LDA $DV8,I GET CURRENT ACCUMULATION ADA 1 SUBTRACT ANY RTN'D LENGTH STA $DV8,I RAL,CLE,ERA CLE ADA TMPA1 TEST LIMIT (E=0 IF BELOW) LDA $DV9,I SZB CHECK WHICH LIMIT JMP BLIM4 LOWER, JUMP ELA,SLA,RAR IF ABOVE, SET "S", DON'T SKIP BLIM3 ISZ $BLIM RTN+2, LIMITING STA $DV9,I JMP $BLIM,I * BLIM4 RAL,SLA,ERA SKIP IF NOT BUFFER LIMITED SSA WAS ABeOVE, ARE WE NOW BELOW? JMP $BLIM,I NO, JUST EXIT STA $DV9,I YES, CLEAR "S"-BIT LDA $DV1 AND JSB $SCHD SCHEDULE ANY B.L. WAITERS B55 OCT 55 JMP $BLIM,I * BUMAX DEC -32766 SKP * * THIS ROUTINE RETURNS A BLOCK OF SYSTEM AVAILABLE * MEMORY AND CALLS "$BLIM" TO ADJUST THE B.L. ACCUMULATOR * AND SCHEDULE WAITERS IF IT GOES BELOW THE LOWER B.L. * ON ENTRY: A=DVT ADDR , B=BLOCK ADDRESS * $RTSM NOP STB TMPA1 SAVE BLOCK ADDR ADB .7 POINT TO WD 8 LDB 1,I STB TMPA2 SAVE RETURNED SIZE LDB 0 JSB @DVT ENSURE DVT POINTERS SET JSB $RTN RETURN S.A.M. TMPA1 NOP TMPA2 NOP LDB TMPA2 GET RETURNED SIZE JSB $BLIM LOWER BUFFER LIMIT CHECK JMP $RTSM,I SKP * * $DIOC - ADVANCE DVT REFERENCES AND/OR SETUP $DV/IFT ADDRS * * * 2 * 1 * 0 * WHERE: * ************* A=1 TO ADVANCE DVT REF @ $IF5 * (A)=* A * I * D * I=1 TO SETUP IFT ADDRESSES * ************* D=1 TO SETUP DVT ADDRESSES * * (B)=DVT ADDR * JSB $DIOC * RETURN: P+1 REG MEANINGLESS * $DIOC NOP ELB,CLE,ERB INSURE WE HAVE TRUE ADDR SZB,RSS BIT BUCKET? LDB $D$DV YES STA TMPA1 SAVE DVR'S SETUP REQ. RAR,RAR SLA,RSS A-BIT SET? JMP DI2 NO, SKIP IT ADB .3 GET NEXT DVT IN LDB 1,I CIR.LIST @ $DV4 ELB,CLE,ERB (STRIP SIGN) LDA 1 ADA .4 GET IFT REFERENCE LDA 0,I AT $DV5 ELA,CLE,ERA & ADA .4 POINT TO $IF5 STB 0,I POST NEW DVT REF IN IFT WORD 5 * DI2 LDA TMPA1 SLA D-BIT SET? JSB @DVT YES, POST DVT ADDRS ADB .4 GET IFT ADDR TO (B) LDB 1,I RAR,SLA I-BIT SET? JSB @IFT YES, POST IFT ADDRS JMP $DIOC,I SKP * ROUTINE TO SET PHYSICAL TIMEOUTS FOR PHYSICAL * DRIVERS WHICH MANAGE THEIR OWN TIMEOUTS * CALLING SEQUENCE: * LDB (IFT ADDRESS) * LDA (PHYSICAL TIMEOUT VALUE) * JSB $IOTI * $IOTI NOP STA $DIOC JSB @IFT SET-UP IFT POINTERS LDB $IF1 JSB OFTO REMOVE IFT FROM T.O.QUEUE LDA $DIOC GET VALUE FROM PHY.CLOCK STA $IF2,I STORE PHY.T.O.VALUE CCE IFT INDICATOR JSB ONTO ADD IFT TO T.O.LIST JMP $IOTI,I RETURN TO THE DRIVER SPC 1 * THIS ROUTINE IS CALLED BY THE POWER-FAIL DRIVER "PD.43" TO * PERFORM I/O PROCESSING ON AN IFT OR DVT WHEN POWER IS UP'ED. * CALLING SEQUENCE: * LDB (IFT ADDRESS) * CCE * JSB $POWF (P.F. PROCESSING FOR PHYSICAL LEVEL) * OR * LDB (DVT ADDRESS) * CLE * JSB $POWF (P.F. PROCESSING FOR LOGICAL LEVEL) * $POWF NOP LDA $POWF GET RETURN ADDR SEZ DOING IFT OR DVT? JMP PF.50 IFT JSB @DVT DVT, SET-UP ADDRESSES LDB $DV6,I GET "AV" RBL,SLB IS DVT BUSY? JMP PF.30 YES SSB,RSS NO, IS DEVICE DOWN? JMP $POWF,I NO, RETURN STA $$RTN SET RTN ADDR FROM IOCX & GO UP JMP $UPIO DEVICE IN CASE SET DOWN BY P.F. * PF.30 LDB $DV14,I LOG DVR ADDR SZB IS THERE A LOGICAL DRIVER? LDB $DV4,I YES, GET "P"-BIT SSB,RSS NOW SKIP IF LOG DVR AND "P"=1 JMP $POWF,I ELSE RETURN NOW STA $$RTN SAVE RETURN ADDR LDA .4 DO POWER-FAIL ENTRY TO JMP LI.20 LOGICAL DRIVER * PF.50 STA $$RTN SET RETURN TO $POWF CALLER JSB @IFT SET-UP IFT ADDRESSES LDB .4 POWER-FAIL ENTRY TO JMP PR.04 PHYSICAL DRIVER SKP * ORB $DV1 NOP $DV2 NOP $DV3 NOP $DV4 NOP $DV5 NOP $DV6 NOP $DV7 NOP $DV8 NOP $DV9 NOP $DV10 NOP ŀ $DV11 NOP $DV12 NOP $DV13 NOP $DV14 NOP $DV15 NOP $DV16 NOP $DV17 NOP $DV18 NOP $DV19 NOP $DV20 NOP $DV21 NOP $DV22 NOP $DVTP NOP $IF1 NOP $IF2 NOP $IF3 NOP $IF4 NOP $IF5 NOP $IF6 NOP $IF7 NOP $IFTX NOP ORR SPC 3 * * Q.TO NOP TIME-OUT QUEUE HEAD $Q.TO EQU Q.TO $$RTN NOP * .3 DEC 3 .4 DEC 4 .5 DEC 5 .7 DEC 7 B377 OCT 377 SKP * * ROUTINE TO COMPUTE LU FROM DVT ADDRESS * CALLING SEQUENCE: * LDB (DVT ADDRESS) * JSB $DVLU * (A HAS LU ON RETURN, B & E UNCHANGED) * $DVLU NOP LDA $LUTA STA $RUN# SET ADDRESS OF LUT CLA,INA * DVL2 CPB $RUN#,I LUT ENTRY DVT MATCH? JMP $DVLU,I YES, RETURN CPA $LUT# DONE? CLA,RSS YES, EXIT WITH A=0 (NO MATCH) INA,RSS NO, BUMP LUT COUNTER JMP $DVLU,I RETURN ISZ $RUN# POINT TO NEXT LUT ENTRY JMP DVL2 SPC 3 * B ON ENTRY = ID SEG ADDR (ASSUMED TO BE VALID) * A ON RETURN = ID SEG/RUN #, B MEANINGLESS, E=0 $RUN# NOP ADB .28 POINT TO ID SEG+28 LDA 1,I GET CURRENT RUN # AND B17XX ISOLATE IT STA $DVLU LDA $IDA ADDR OF 1ST ID SEG CMA,INA ADA 1 COMPUTE OFFSET (+24) OF OURS CLB DIV $IDSZ COMPUTE ID SEG # CLE,INA IOR $DVLU INCLUDE RUN # JMP $RUN#,I RETURN * B17XX OCT 170000 .6 DEC 6 .28 DEC 28 SKP * * @DVT - SETUP DVT ADDRESSES * * (B)=DVT ADDR * JSB @DVT * (B)=DVT ADDR (A & E REG UNCHANGED) * @DVT NOP ELB,CLE,ERB CPB $DV1 DVR ADDRS SET YET? JMP @DVT,I YES, EXIT STB $DV1 POST DVT ADDRESSES INB STB $DV2 INB STB $DV3 INB STB $DV4 INB STB $DV5 INB STB $DV6 INB STB $DV7 INB STB $DV8 INB STB $DV9 ] INB STB $DV10 INB STB $DV11 INB STB $DV12 INB STB $DV13 INB STB $DV14 INB STB $DV15 INB STB $DV16 INB STB $DV17 INB STB $DV18 INB STB $DV19 INB STB $DV20 INB STB $DV21 INB STB $DV22 INB STB $DVTP LDB $DV1 (B)=DVT ADDR JMP @DVT,I SPC 4 * * @IFT - SETUP IFT ADDRESSES * * (B)=IFT ADDR * JSB @IFT * @IFT NOP CPB $IF1 JMP @IFT,I STB $IF1 INB STB $IF2 INB STB $IF3 INB STB $IF4 INB STB $IF5 INB STB $IF6 INB STB $IF7 INB STB $IFTX JMP @IFT,I RETURN (A REG UNCHANGED) SKP * BUCKT DEC -1,0 DEF * OCT 0 DEF *-2 EXEC(13) PICKS UP DVT8 OCT 0 TYPE=0 , STATUS = 0 DEC 0,0,0,0 DVT7 - DVT10 BIT14 OCT 040000 DVT11 BIT15 OCT 100000 DVT14 M1 DEC -1 OF BIT BUCKET M2 DEC -2 ARE UNUSED DEC 0,0,0,0,0 DVT15 - DVT 19 * NOTE: DVT20 - DVT22 NOT NECESSARY FOR BIT BUCKET * SIZE EQU * * END P + 92070-18093 1941 S C0122 &CLASS              H0101 ASMB,R * * NAME: CLASS * SOURCE: 92070-18093 * RELOC: 92070-16093 * PGMR: E.J.W.,C.H.W. * * **************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT * * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * **************************************************************** * * NAM CLASS,0 92070-16093 REV.1941 800407 * * * ENT $I.CL,$C.CL,$G.CL,$F.CL ENT $$CLA,$.CLA * EXT $IDNO,$LIST,$XEQ,$BLIM,.MVW EXT $SCHD,$RTN,$ERAB,$ABRQ,$UNLK,$RTSM EXT $CLTA,$ROM,$XQT,$SUSP,$A,$B EXT $DV6,$DV8 EXT $RQRT,$RQP1,$RQP2,$RQP3,$RQP4,$RQP5 EXT $RQP6,$RQP7,$RQP8,$RQCT SPC 1 EXT .MVW * A EQU 0 B EQU 1 HED ** RTE-L CLASS I/O MODULE - INITIATION CALL ** * * * CLASS I/O ALLOCATE CLASS FROM HIGH END OF TABLE * IF HE DID NOT SPECIFY A CLASS. * * LDA WORD2 (A) = CONTROL WORD * LDB T2 (B) = PRIORITY * JSB $I.CL CALL FROM IOC MODULE * (RTN) P+1: PENDING COUNT AT MAX * (RTN) P+2: DO RETHREAD * (RTN) P+3: B=ADDR OF CLASS ENTRY * $I.CL NOP CALLED BY $MIO MODULE STA TEMP1 SAVE CONWD STB TEMP2 SAVE PRIORITY CLA STA $A,I A=0 FOR INIT.GOOD RETURN STA NEWCL STA NEWC2 CLB,INB CPA $RQP7 IF NO CLASS WORD IN REQ, JMP ERRIO FLUSH IT OUT (IO01). LDA $RQP7,I GET CLASS WORD AND B377 MASK TO THE CLASS DEF. SZA IF SUPPLIED JMP L.4 SKIP ALLOCATION CODE * * * ALLOCATE A CLASS FROM THE HIGH END OF THE TABLE * LDA B160K GET BITS 15,14, & 13 FROM AND $RQP7,I USER'S CLASS WORD STA SECCD  LDB $XQT GET ID SEG ADDR JSB $IDNO CONVERT TO ID # STA TEMP0 SAVE ID # AND B37 FOR USE AS SECURITY CODE ALF,ALF IOR SECCD FILL IN USER'S BIT15,14,13 STA $RQP7,I FOR RETURN AS CLASS NUMBER * LDB $CLTA,I GET THE LENGTH OF THE TABLE SZB,RSS IF NO CLASSES DEFINED JMP ERRIO REJECT THE CALL ADB $CLTA ADD THE TABLE ADDRESS CLA,CCE * L.1 CPA 1,I IS THE ENTRY FREE (0)? JMP L.3 YES, GO USE IT ADB N1 NO, STEP TO NEXT ONE CPB $CLTA END OF TABLE? CCA,RSS YES SKIP (A = -1) JMP L.1 NO - GO TEST NEXT ONE. * STA $A,I SET REASON FOR REJECT IN A REG. LDA $CLTA SET A=CLASS TABLE ADDR LDB $RQP7,I FOR L.8 IN CASE OF SUSPEND SSB,RSS NO-WAIT REQUESTED? JMP L.8 NO, SUSPEND UNTIL CLASS AVAILABLE * L.2 LDA $RQRT UPDATE THE STA $SUSP,I RETURN ADDR JMP $XEQ & EXIT * L.3 LDA $CLTA CMA,INA ADA 1 COMPUTE RELATIVE POSITION IOR $RQP7,I ADD SECURITY CODE AND USER BIT STA $RQP7,I RETURN NEW CLASS WORD TO USER AND B174C GET SECURITY CODE FOR CLASS QUEUE-HEAD RAL,ERA SET THE ALLOCATED BIT STA B,I PUT INTO CLASS QUEUE STB NEWCL SAVE ADDR OF NEW CLASS ENTRY ADB $CLTA,I POINT TO CLASS TBL WD #2 LDA TEMP0 GET SEG ID # OF CALLER STA 1,I ASSIGN OWNERSHIP STB NEWC2 SAVE ADDR FOR POSSIBLE CLEAN-UP * L.4 LDA $RQP7,I GET CLASS JSB VERFY VERIFY/SET-UP CLASS * LDA CLSAD L.45 STA B SET B TO ADDR OF QUEUE ENTRY LDA B,I CLE,SSA,RSS A POINTER? JMP L.45 YES, TRACE IT MORE * JSB SECCK CHECK SECURITY CODE LDA 1,I GET CLASS WORD AND B377 ISOLATE PENDING COUNT CPA B377 FULL? JMP $I.CL, I YES ISZ $I.CL LDA $RQCT # OF PRAMS IN EXEC CALL ADA N7 SET E IF 8 OR MORE PRAMS LDA CLASS GET BIT 13 OF CLASS WD RAL,RAL MOVE "RETHREAD" TO BIT15 SEZ,SSA RETHREAD BIT & 2ND CLASS SPECIFIED? JMP L.5 YES, TREAT AS A RETHREAD * ISZ $I.CL JMP $I.CL,I RETURN, B HAS ADDR OF CLASS WORD SKP * RETHREAD, 1ST VERIFY PREVIOUS CLASS L.5 STB TEMP SAVE ADDR OF CLASS WORD CLA LDA $RQP8,I GET OLD CLASS JSB VERFY VERIFY IT SSA COMPLETED BUFFER ON CLASS? JMP ERR04 NO, ERROR LDB 0 LDA 0,I SSA,RSS CLASS WD? JMP *-2 NO, TRACK IT DOWN JSB SECCK CHECK SECURITY CODE STB TMP8 SAVE ADDR OF HDR INB LDA TEMP1 NEW CONWD XOR 1,I ALF,SLA WAS "Z" BIT CHANGED? JMP ERR04 YES, THAT'S UNACCEPTABLE INB STB TEMP9 SAVE ADDR OF HDR WD 3 (PRAM1) ADB .2 STB TEMP0 SAVE ADDR OF HDR WD 5 (PRAM3) ADB .3 LDA 1,I GET TOTAL BLOCK SIZE OUT OF WD 8 ADA TMP8 POINT TO END OF BLOCK+1 STA TEMP6 SAVE FOR SIZE CHECKS LDA TEMP1 ALF,SLA Z-BIT SET? RSS YES JMP L.52 NO, SKIP Z LEN CHECK * VERIFY CTL BUFFER LENGTH NOT > THAN ORIGINAL LDA $RQP6,I USERS "Z" LENGTH LDB TEMP0,I GET Z BUFFER ADDR IN SAM JSB SIZCK CHECK SIZE OF Z BUF OVERWRITE LDA TEMP4 STA TEMP5 SAVE LEN FOR Z BUFR MOVE STB TEMP6 REDEFINE END OF DATA BUFR * L.52 LDA $RQP1 USERS REQUEST CODE RAR SSA,SLA IS THIS A CLASS CONTROL RETHREAD? JMP L.9 YES, BYPASS DATA BUFFER CK/MOVE * VERIFY DATA BUFFER LENGTH NOT > THAN ORIGINAL LDA $RQP4,I USERS LEN SZA,RSS ANY OVERWRITE? JMP L.6 NO, LEAVE BUFFER/LENGTH IN TACT LDB TEMP9,I NGET DATA BUFFER ADDR IN SAM * NOW RECOMPUTE SIZE OF DATA BUF SINCE "XLOG" MAY * BE IN POSITIVE BYTES JSB SIZCK CHECK SIZE OF DATA OVERWRITE LDA $RQP3 ADDR OF USER'S BUFFER JSB .MVW OVERWRITE NONE/PART/ALL DEF TEMP4 OF CLASS DATA BUFFER NOP ISZ TEMP9 POINT TO DATA LEN IN HEADER LDA $RQP4,I GET USER'S LENGTH STA TEMP9,I UPDATE DATA LENGTH CLA * * RETHREAD ACCEPTED, SO DO IT L.6 STA $A,I SET USER'S A REG LDA TEMP1 PASSED CONWD IOR B1400 SET "TY"=3 ISZ TMP8 STA TMP8,I STORE IN CLASS HDR ALF,SLA "Z" BIT SET? JMP L.7 YES, DON'T OVERRIDE PARMS LDA $RQP5,I NO, PICK-UP PASSED LDB $RQP6,I OPT PARMS & DST * STORE THEM IN CLASS HEADER TEMP0 EQU *-1 JMP L.75 SKIP Z BUFFER MOVE SECTION * MOVE IN NEW "Z" BUFFER L.7 LDB TEMP0,I POINT TO CTL BUFFER IN BLOCK LDA $RQP5 USERS CTL BUFFER ADDR JSB .MVW OVERWRITE ALL/PART/NONE OF Z BUF DEF TEMP5 NOP * L.75 LDB TEMP0 ADB .2 LDA TEMP2 PRIORITY STA 1,I STORE IN 7TH WD INB POINT TO TOTAL SAM BLOCK SIZE LDA 1,I ADA $DV8,I UPDATE BUFFER ACCUMULATOR STA $DV8,I ON NEW DVT INB LDA $RQP7,I GET NEW CLASS WD STA 1,I STORE IN WD 9 ADB N8 POINT TO START ISZ TEMP,I BUMP PENDING COUNT LDA 1,I STA CLSAD,I UNLINK BUFFER FROM OLD CLASS JMP $I.CL,I RETURN * L.8 LDB $XQT ID SEG ADDR JSB $LIST PUT PROGRAM IN SUSPEND LIST OCT 52 UNTIL CLASS RESOURCE AVAILABLE JMP $XEQ EXIT * L.9 LDB $RQP4,I GET OPT PARAM # 2 LDA $RQP3,I GET OPT PARAM # 1 DST * STORE IN HDR WORDS 3 & 4 TEMP9 EQU *-1 LDA $RQP7,I GET NEW CLASS AND B.017 BITS 12-0 JMP L.6 FINISHA; RETHREAD, RTN CLAS IN (A) SPC 3 * ROUTINE TO TO CHECK THAT RETHREAD DOESNT TRY TO OVERLAY MORE * WORDS THAN THE ORIGINALLY ALLOCATED BUFFER SIZE SIZCK NOP SSA,RSS JMP *+3 ALREADY A POSITIVE LENGTH ARS CMA,INA CONVERT BYTES TO +WORDS STA TEMP4 SAVE FOR MVW ADA 1 ADD BUFFERS ADDRESS CMA,INA ADA TEMP6 LAST WD+1 - LAST OVERWRITTEN+1 SSA,RSS SIZE TOO LARGE? JMP SIZCK,I NO, SIZE OK SO RETURN JMP ERR04 YES, HE BLEW IT SPC 3 * SECCD NOP CLASS NOP B174C OCT 17400 BITS 8-12 N1 DEC -1 N7 DEC -7 N8 DEC -8 N10 DEC -10 N12 DEC -12 .2 DEC 2 .3 DEC 3 .4 DEC 4 .7 DEC 7 .9 DEC 9 .10 DEC 10 B37 OCT 37 B377 OCT 377 B.017 OCT 17777 B1400 OCT 140000 SKP HED ** RTE-L CLASS I/O MODULE - COMPLETION CALL ** * CLASS REQUEST COMPLETION * * CLASS COMPLETION IS HANDLED AS FOLLOWS: * * 1. THE EXCESS BUFFER IS RETURNED ON WRITE COMPLETION * UNLESS "SAVE BUFFER" WAS SET * 2. IF THE CLASS QUEUE IS NOT EXPECTING A REQUEST * THE WHOLE BUFFER IS RELEASED AND WE EXIT. * 3. IF A PROGRAM IS WAITING FOR THE REQUEST IT IS * RESCHEDULED. * 4. THE REQUEST IS MODIFIED TO PUT THE STATUS WORD * AND THE TRANSMISSION LOG (TLOG) IN WORDS * 7 (PRIORITY) AND 4 (USER LENGTH WORD) * 5. THE CLASS QUEUE IS UPDATED AND WE EXIT. * * SEE DESCRIPTION OF CLASS QUEUE IN COMMENTS AT BEGINNING * OF SECTION ON USER REQUESTS. * * LDA TLOG (A) = TRANSMISSION LOG * LDB PTR (B) = CLASS QUEUE POINTER * JSB $C.CL CALL FROM $MIO * RETURN * * * $C.CL NOP STA TEMP6 SAVE TRANSMISSION LOG STB HEAD SAVE QUEUE ADDR ADB .7 POINT TO BUFFER SIZE STB TEMP5 SAVE ADDR LDB 1,I GET SIZE JSB $BLIM YiADJUST BUFR ACCUM & TEST B.L. LDB TEMP5 INB LDA 1,I GET CLASS WD FROM BLOCK ADB N7 POINT TO CONWD STA TEMP4 SAVE CLASS RAL,ELA E=BIT 14 LDA B,I GET THE CON WORD SEZ,RSS IF "SAVE" BUFFER SET SLA OR IF A READ, JMP C.04 SKIP BUFFER DEALLOCATE * LDA TEMP5,I GET BLOCK SIZE TO A. ADA N12 IF LESS THAN 2 WDS WILL BE LEFT SSA THEN SKIP JMP C.04 THE RETURN OF SAM ADA .2 STA TEMP2 SAVE LENGTH FOR RETURN * ADB .9 STEP TO RETURN BUFFER ADDRESS STB TEMP1 SET THE BUFFER ADDRESS JSB $RTN RETURN THE WRITE BUFFER TEMP1 NOP BUFFER ADDRESS TEMP2 NOP BUFFER LENGTH * LDA .10 SET BLOCKSIZE= HEADER LEN STA TEMP5,I * C.04 LDA TEMP4 GET THE CLASS JSB SETCA SETUP CLASS ENTRY ADDRS * JSB PENDG DECR.PENDING CNT SEZ FLUSH FLAG SET? JMP C.09 YES LDA CLSAD LDB TMP8,I GET CONTENTS OF CLASS HEAD RBL,CLE,ELB IF PROGRAM WAITING SEZ,RSS JMP C.05 SKIP,ELSE GO LINK IN THE RQ. * * PROGRAM IS WAITING, CLEAR THE WAIT FLAG * AND RESCHEDULE THE PROGRAM * RBR,RBR CLEAR THE WAIT FLAG STB A,I AND RESET IN THE QUEUE. JSB $SCHD SCHEDULE ANY PROGRAMS WAITING OCT 52 * C.05 LDB TMP8,I GET CLASS ENTRY STB HEAD,I SET IN NEW END OF LIST LDB HEAD SET NEW ELEMENT IN STB TMP8,I THE LIST. * ADB .3 POINT TO 4TH WD OF HDR LDA TEMP6 TRANSMISSION LOG STA 1,I OVERLAYS BUFFER LENGTH ADB .3 POINT TO 7TH WD OF HDR LDA $DV6,I DVT STATUS STA 1,I OVERLAYS PRIORITY JMP $C.CL,I RETURN TO $MIO MODULE * C.09 LDB TEMP5,I GET BUFFER SIZE STB TEMP4 JSB $RTN RTN SAM HEADNW NOP TEMP4 NOP JMP $C.CL,I RETURN SKP HED ** RTE-L CLASS I/O MODULE - GET CALL ** * $G.CL IS THE ENTRY POINT FOR A 'GET' EXEC CALL * * JMP $G.CL CALL FROM $MEX * * $G.CL EQU * CLA STA NEWCL ENSURE NO DEALC ON ERROR STA NEWC2 LDA $RQP2,I GET THE CLASS JSB VERFY VERIFY/SET-UP CLASS * LDA $RQP4,I GET THE LENGTH SSA,RSS POS WORDS? JMP *+3 YES ARS CMA,INA CONVERT -BYTES TO +WORDS STA TMP8 SAVE. ADA $RQP3 CHECK IF AREA EXTENDS INTO THE CMA,CLE,SSA,INA,RSS ROM AREA OF MEMORY JMP ERR04 ERROR, LNGT TOO LARGE ADA $ROM MUST BE < 1ST WORD OF ROM AREA SEZ,RSS IF NOT THEN JMP ERR04 ERROR 4 DIAGNOSTIC * * LDB CLSAD,I GET QUEUE HEAD SSB IF A COUNTER JMP G.06 GO SUSPEND THE PROGRAM * STB PTR SAVE THE ADDRESS INB GET THE CON WORD LDA B,I AND AND .3 ISOLATE THE REQUEST CODE STA $RQP7,I RETURN IT TO USER'S IRCLS ADB .2 INDEX TO THE LDA 1,I LOG AND SET IT IN STA $B,I THE 'B' REG INB INDEX TO THE 1ST LDA 1,I OPTIONAL WORD AND SET IT STA $RQP5,I IN THE USER'S BUFFER INB NOW DO THE LDA 1,I 2ND OPTIONAL STA $RQP6,I WORD INB STEP TO STATUS WORD LDA B,I GET COMPLETION STATUS. STA $A,I AND SET IT IN THE A REG. INB GET THE BUFFER LENGTH LDA B,I AND SET IT STA TEMP5 FOR RETURN INB STEP TO USER CLASS WORD LDA B,I GET IT JSB SECCK CHECK SECURITY CODE INB LDA 1,I GET OPT. USER PARAMETER STA $RQP8,I & RETURN IT STB TEMP4 SAVE THE BUFFER ADDRESS LDA TEMP5 ADA N10 LOP THE aHEADER LENGTH TO LDB 0 GET DATA LENGTH CMA,INA SET MOVE COUNT NEG ADA TMP8 USE LESSOR OF THE TWO COUNTS SSA USE QUEUE COUNT IF SMALLER LDB TMP8 SSB IF COUNT LESS THAN ZERO THEN JMP G.05 THEN SKIP MOVE * ISZ TEMP4 STEP THE BUFFER ADDRESS. LDA TEMP4 (A)= SOURCE STB TEMP SAVE COUNT LDB $RQP3 (B)= DESTINATION JSB .MVW DEF TEMP $$CLA EQU * $.CLA EQU * NOP G.05 LDA $RQP2,I IF SAVE RAL,RAL QUEUE OPTION SLA,ELA THEN JMP L.2 THEN EXIT * LDA PTR,I ELSE STA CLSAD,I UPDATE THE LIST SSA IF POINTER, SKIP COUNT CHECK AND B377 GET # PENDING REQUESTS LEFT SEZ,SZA,RSS NO REQUESTS LEFT STA CLSAD,I AND IF DEALLOCATE WANTED, DO IT. SEZ,SZA,RSS STA CLSA2,I 2ND WORD AS WELL JSB $RTN RETURN THE MEMORY PTR NOP AND TEMP5 NOP THEN JMP G.08 SCHEDULE WAITERS AND EXIT * G.06 LDA 1 JSB SECCK CHECK SECURITY CODE RBL,CLE,ELB MOVE BIT14 (SOMEONE WAITING) TO E G.065 LDA CLSAD,I GET CLASS WORD AND B377 CMA,SEZ ANYONE WAITING? (SET ONES COMP) JMP SCEDT YES,SORRY SOMEBODY BEAT YOU TO IT * STA $A,I SET A FOR POSSIBLE RTN (NON-POSITIVE) INA GET CORRECT 2'S COMPLEMENT STA B LDA $RQP2,I GET THE OPTION FLAG ELA,RAL SET E=BIT15 NO-WAIT OPT. SZB,RSS IF PENDING CNT= 0 SSA AND BIT13 SET, JMP G.07 DON'T DEQUEUE * STB CLSAD,I IF Q-H=0 AND BIT14=0 DEQUEUE! STB CLSA2,I G.08 LDA $CLTA NOW SCHEDULE ALL THOSE WAITING JSB $SCHD FOR AN AVAILABLE CLASS NUMBER. OCT 52 JMP L.2 RETURN * G.07 CLA,SEZ,INA JMP L.2 BIT15=1 FOR NO-WAIT. RETURN. RAR,RAR 1 INTO$ BIT 14 IOR CLSAD,I SET "SOMEONE IS WAITING" FLAG STA CLSAD,I IN CLASS TABLE LDA CLSAD GET CLASS ADDR IN A FOR L.8 JMP L.8 PUT PGM INTO SUSPENSION * * SCEDT ERB,RBR CLEAR THE BIT AND STB CLSAD,I RESET THE CLASS HEAD LDA CLSAD GET HEAD ADDRESS TO A AND JSB $SCHD RESCHEDULE THE WAITER IF ANY OCT 52 LDB .10 LDA $LIST CLE,SZA WAS THERE A WAITER? JMP ERRIO YES, DOUBLE REQ ON CLASS - ERROR JMP G.065 NO. MUST HAVE BEEN ABORTED, CONTINUE SKP * * SUBROUTINE TO VERIFY USER'S CLASS NUMBER * ON RETURN, A&B HAVE CLASS TABLE VALUES * VERFY NOP STA CLASS USER'S CLASS AND B174C ISOLATE SECURITY CODE STA SECCD LDA CLASS JSB SETCA SETUP CLASS ENTRY ADDRS CMA,CLE,INA,SZA,RSS NEGATE, WAS IT ZERO? JMP ERR00 YES, ERROR IO00 ADA $CLTA,I SET E IF CLASS IN RANGE LDA CLSAD,I GET CONTENTS OF ENTRY LDB CLSA2,I GET "FLUSH" FLAG SEZ,SZA ALLOCATED AND WITHIN RANGE? SSB YES, SKIP IF NOT FLUSHING JMP ERR00 OTHERWISE GIVE IO00 JMP VERFY,I RETURN SPC 1 * * THIS SUBROUTINE DECREMENTS THE PENDING COUNT, AND * IF IT GOES TO ZERO AND THE "FLUSH" FLAG IS SET, THE * CLASS IS DEALLOCATED. ON EXIT, E-REG=1 IF FLUSH SET. * PENDG NOP LDA CLSAD STA TMP8 LDA TMP8,I CHASE THE CLASS LIST SSA,RSS CLASS WORD FOUND? JMP *-3 NO, KEEP GOING ADA N1 DECREMENT PENDING COUNT STA TMP8,I LDA CLSA2,I GET 2ND WORD CLE,SSA,RSS FLUSHING? JMP PENDG,I NO, RTN LDA TMP8,I AND B377 EXAMINE PENDING COUNT SZA,RSS MORE PENDING? JSB CLRCL NO, CLEAR CLASS, RESCHED WAITERS CCE FLAG FLUSH JMP PENDG,I SPC 1 * SUBROUTINE TO CLEAR CLASS & SCHEDULE WAITERS FOR NaA CLASS # CLRCL NOP STA CLSAD,I A IS ZERO ON ENTRY STA CLSA2,I CLEAR BOTH WORDS OF CLASS TABLE LDA $CLTA ADDR OF CLASS TABLE JSB $SCHD RESCHEDULE THOSE WAITING OCT 52 FOR A CLASS # JMP CLRCL,I SPC 1 * SUBROUTINE TO SET-UP ADDRESSES FOR CLASS TABLE ENTRY SETCA NOP AND B377 LDB 0 LEAVE CLASS # IN A REG ADB $CLTA POINT TO 1ST WORD OF CLASS ENTRY STB CLSAD ADB $CLTA,I POINT TO 2ND WORD STB CLSA2 JMP SETCA,I HED ** RTE-L CLASS I/O MODULE - FLUSH CALL ** * CLASS FLUSH ROUTINE * * THIS ROUTINE ALLOWS THE FLUSHING OF CLASS I/O REQUESTS * AND CLASS NUMBERS WITH VARIOUS OPTIONS FOR THE USE OF * PROGRAM TERMINATION/ABORT PROCESSING AND THE "CLRQ" * CLASS MANAGEMENT SUBROUTINE. * * CALLING SEQUENCE: * LDB (DVT ADDRESS) (CODE 2&3 ONLY) * LDA (ID SEG ADDR (CODE 0&2) OR CLASS # (CODE 1&3) * JSB $F.CL * (CODE) * * CODES ARE 0 = FLUSH ALL COMPLETED BUFFERS FOR CLASSES OWNED * BY THE PASSED ID SEGMENT. IF PENDING COUNT * IS ZERO, DEALLOCATE THE CLASS, ELSE SET THE * "FLUSH" FLAG IN THE CLASS TABLE ENTRY. * (USED UPON PGM TERMINATION OR ABORT) * 1 = SAME AS ABOVE USING ONLY THE CLASS # PASSED * IN THE A REGISTER (I.E. INDEPENDENT OF * CLASS OWNERSHIP. * (USED BY "CLRQ" CLASS FLUSH) * 2 = FLUSH ALL NON-ACTIVE PENDING REQUEST BUFFERS * FOR CLASSES OWNED BY THE PASSED ID SEGMENT. * FOR ALL ACTIVE REQUESTS (DVT BUSY), CALL * "$ABRQ" TO INITIATE A REQUEST ABORT. IF * PENDING COUNT IS ZERO AND "FLUSH" FLAG IS * SET, DEALLOCATE THE CLASS. * (USED UPON PGM ABORT) * 3 = SAME AS ABOVE USING ONLY THE CLASS # PASSED * IN THE A REGISTER. * (USED BY "CLRQ" CLASS FLUSH AND LU FLUSH) * $F.CL NOP STA TEMP1 SAVE CLASS OR OWNER STB TEMP2 INB STB TEMP6 SAVE POSSIBLE ADDR OF DVT2 LDB $F.CL,I GET CODE SLB OWNER OR CLASS? JMP F.05 CLASS LDB TEMP1 OWNER JSB $IDNO COMPUTE ID SEG # STA TEMP1 SAVE IT JMP F.08 * F.05 JSB SETCA SETUP CLASS ENTRY ADDRS LDA CLSAD,I GET 1ST WORD SZA,RSS IS CLASS ALLOCATED? JMP F.EX NO SSA END OF STATE 2 LIST? JMP *+3 YES B160K LDA 0,I GET NEXT LINK JMP *-3 XOR TEMP1 COMPARE SECURITY CODE IN AND B174C BITS 12-8 SZA SECURITY CODE OK? JMP F.EX NO, RTN ON INVALID CLASS * F.08 LDB $F.CL,I GET CODE AGAIN RBR,SLB FLUSH PENDING OR COMPLETED BUFFERS? JMP F.30 GO FLUSH PENDING REQUEST BUFFERS. * SSB BY CLASS OR OWNER? JMP F.20 CLASS * CODE = 0, FLUSH OWNED AND COMPLETED CLASS BUFFERS LDA $CLTA,I CMA,INA STA TEMP2 COUNT OF CLASSES CLA JSB SETCA SETUP CLASS ENTRY ADDRS * F.10 ISZ CLSAD ADVANCE CLASS TABLE ISZ CLSA2 POINTERS LDA CLSA2,I GET OWNER ID CPA TEMP1 MATCH? JSB FL.BF YES, FLUSH IT ISZ TEMP2 JMP F.10 EXAMINE NEXT CLASS * F.EX ISZ $F.CL JMP $F.CL,I RETURN * * CODE = 1 FLUSH COMPLETED REQUEST BUFFERS & DEALLOCATE CLASS * F.20 JSB FL.BF FLUSH COMPLETED BUFFERS JMP F.EX & EXIT SKP * * FLUSH PENDING REQUESTS * F.30 CCA STA TEMP4 INITIALIZE "ACTIVE ABORT FLAG" LDB TEMP6,I GET ADDR OF 1ST ENTRY RBL,CLE,ERB CLEAR SIGN STB HEAD SAVE IT'S ADDRESS * F.32B SZB,RSS MORE ENTRIES? JMP F.60 NO LDA 1,I GET LINK TO NEXT STA TEMP5 STB PTR SAVE ADDR OF REQUEST BLOCK INB POINT TO CONWD LDA 1,I GET IT RAL SSA,SLA,RSS CLASS REQUEST? JMP F.35 NO, SKIP IT ADB .7 LDA 1,I GET CLASS WORD STA TEMP JSB SETCA SET-UP CLASS ENTRY ADDRS LDB $F.CL,I GET CALLING CODE SLB DOING IT BY CLASS? JMP F.40 YES LDA CLSA2,I GET 2ND WD OF CLASS ENTRY XOR TEMP1 TEST OWNER AND B377 SZA,RSS OWNER MATCH? JMP F.50 YES, GO FLUSH * F.35 LDB TEMP5 GET LINK TO NEXT RBL,CLE,ERB CLEAR SIGN JMP F.32 GO EXAMINE NEXT * F.40 LDA TEMP GET CLASS XOR TEMP1 AND B.017 SZA IS THIS THE FLUSHING CLASS? JMP F.35 NO * * DEALLOCATE THE PENDING REQUEST F.50 LDB PTR ADDR OF THIS REQUEST CPB HEAD IS THIS AT HEAD OF THE DVT? CLE,RSS YES JMP F.55 NO LDA TEMP6 ADDR OF DVT2 ADA .4 POINT TO DVT6 LDA 0,I GET "AV" FIELD CLE,SSA IS THIS DVT BUSY? JMP F.58 YES, WE'LL ABORT IT SHORTLY * F.55 JSB $UNLK UNLINK REQ FROM DVT INIT Q TEMP6 NOP LDA TEMP2 JSB $RTSM RTN SAM & CHK FOR BELOW B.L. JSB PENDG DECR.PENDING CNT, CHK FLUSH JMP F.35 EXAMINE NEXT * F.58 STB TEMP4 SET FLAG SO $ABRQ GETS CALLED JMP F.35 * F.60 LDB TEMP2 GET ADDRESS OF DVT ISZ TEMP4 ACTIVE ENTRY TO ABORT? JSB $ABRQ YES, THEN DO IT JMP F.EX SKP * * THIS SUBROUTINE FLUSHES COMPLETED CLASS BUFFERS, AND DEALLOCATES * THE CLASS IF PENDING COUNT IS ZERO, OTHERWISE THE FLUSH FLAG IS * SET. FL.BF NOP LDA CLSAD GET CLASS TBLE ADDR JSB $SCHD RESCHEDULE ANY WAITER OCT 52 NLHLDA CLSAD,I GET 1ST WORD OF CLASS TABLE FL.B2 SSA MORE COMPLETED BUFFERS? JMP FL.B4 NO STA TEMP SAVE BLOCK ADDRESS LDB 0,I STB TEMP5 SAVE LINK WD OF BLOCK ADA .7 LDB 0,I GET BLOCK LENGTH OUT OF 8TH WD STB TMP8 * JSB $RTN RETURN SYSTEM AVAILABLE MEMORY TEMP NOP TMP8 NOP LDA TEMP5 GET LINK WD JMP FL.B2 ITERATE * FL.B4 STA CLSAD,I STORE CLASS WORD IN TABLE AND B377 ISOLATE PENDING COUNT CCE,SZA,RSS ANYTHING PENDING? JMP FL.B5 NO, DEALLOCATE CLASS NOW * LDA CLSA2,I GET 2ND WORD RAL,ERA SET FLUSH FLAG STA CLSA2,I IN 2ND WORD JMP FL.BF,I RETURN * FL.B5 JSB CLRCL CLEAR THE CLASS & SCHED WAITERS JMP FL.BF,I * CLSAD NOP CLSA2 NOP NEWCL NOP NEWC2 NOP SKP * * THIS ROUTINE CHECKS SECURITY CODE SECCK NOP AND B174C ISOLATE SEC.CODE CPA SECCD MATCH? JMP SECCK,I YES, RETURN * ERR00 CLB,RSS ILLEGAL CLASS# OR SECURITY CODE ERR04 LDB .4 ILLEGAL BUFFER ADDRESS ERRIO CLA STA NEWCL,I CLEAR-OUT IF NEW CLASS STA NEWC2,I WORD 2 ALSO LDA ERIO (A) = ASCII "IO" JMP $ERAB WRITE MESSAGE AND EXIT * ERIO ASC 1,IO ORG * LENGTH OF MODULE END N  92070-18094 1941 S C0122 &CLRQ              H0101 ~hASMB,R * * NAME: CLRQ * SOURCE: 92070-18094 * RELOC: 92070-1X094 * PGMR: C.H.W. * * **************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT * * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * **************************************************************** * * NAM CLRQ,6 92070-1X094 REV.1941 790321 * ENT CLRQ * EXT $LIBR,$LIST,$ERAB,$F.CL,$IDNO,$XEQ EXT $SUSP,$RQRT,$A,$PVCN,$STAT EXT $LUTA,$LUT#,$CLTA,$XQT EXT $ID#,$IDSZ,$IDA SKP * * THIS LIBRARY SUBROUTINE PERFORMS CLASS MANAGEMENT FUNCTIONS. IT WILL * ALLOW THE ASSIGNMENT OF OWNERSHIP TO CLASSES SO THAT IN THE EVENT * OF A PROGRAM TERMINATING OR ABORTING WITHOUT CLEANING UP THE CLASSES * AND CLASS BUFFERS ASSIGNED TO IT, THE SYSTEM WILL BE ABLE TO * DEALLOCATE THESE RESOURCES. THIS ROUTINE ALSO ALLOWS PROGRAMMATIC * FLUSHING OF PENDING CLASS BUFFERS ON AN LU OR FLUSHING OF ALL CLASS * BUFFERS (PENDING OR COMPLETED) WITH DEALLOCATION OF THE CLASS ITSELF. * THE CALLING SEQUENCE IS AS FOLLOWS: * EXT CLRQ * . * . * JSB CLRQ TRANSFER CONTROL TO SUBROUTINE * DEF RTN RETURN ADDRESS * DEF ICODE CONTROL INFORMATION (BIT14=NO ABORT)(15=NO WAIT) * DEF CLASS CLASS NUMBER * DEF IPRAM CALL DEPENDENT PARAMETER (PGM NAME OR LU) * RTN RETURN POINT CONTINUE EXECUTION * . * . * ICODE OCT 1 ASSIGN CLASS OWNERSHIP. IPRAM CONTAINS THE NAME * OF THE PROGRAM ASSIGNED OWNERSHIP OF THE CLASS. * IF IPRAM IS ZERO, NO OWNERSHIP IS ASSIGNED. IF * IPRAM IS DEFAULTED, THE CALLING PROGRAM IS ASSIGNED * ! OWNERSHIP. IF CLASS IS ZERO, A NEW CLASS NUMBER IS * ALLOCATED BY THE CALL. IN THIS CASE, A ZERO IS * RETURNED IN THE A REG IF ALLOCATION WAS SUCCESSFUL * IF NO CLASSES ARE AVAILABLE, THE USER IS SUSPENDED * UNLESS THE NO-WAIT FLAG WAS SET IN WHICH CASE A * -1 IS RETURNED IN THE A REGISTER. * * " " OCT 2 FLUSH CLASS REQUESTS & DEALLOCATE CLASS. ALL NON- * ACTIVE PENDING REQUESTS WILL BE DEALLOCATED. ABORT * REQUESTS WILL BE ISSUED BY THE SYSTEM FOR ALL ACTIVE * I/O REQUESTS, IN WHICH CASE THE BUFFER WILL BE * DEALLOCATED AT LOGICAL DONE. ALL PREVIOUSLY * COMPLETED REQUESTS WILL BE IMMEDIATELY DEALLOCATED. * THE CLASS TABLE ENTRY WILL BE FLAGGED SO THAT NO * NEW REQUESTS WILL BE ISSUED ON THE CLASS (IO00 * ERROR RETURNED) AND SO THAT UPON THE PENDING * COUNT REACHING ZERO, THE SYSTEM CAN DEALLOCATE THE * CLASS. * * " " OCT 3 FLUSH CLASS REQUESTS ON LU DESIGNATED BY IPRAM. * NON-ACTIVE REQUESTS FOR THE DESIGNATED CLASS * PENDING ON THE LU ARE DEALLOCATED AND IF A * REQUEST IS ACTIVE, AN ABORT REQUEST IS ISSUED BY * THE SYSTEM. THE BUFFER WILL BE DEALLOCATED AT * LOGICAL DONE. THE CLASS IS NOT DEALLOCATED BY * THIS CALL. * ERRORS: CL01 - ILLEGAL CLASS # OR NULL CLASS TABLE * CL02 - PARAMETER OR CALL SEQUENCE ERROR * SC05 - PROGRAM NOT FOUND (ONLY WHEN ICODE=1) * SKP * CLRQ NOP JSB $LIBR GO PRIVILEGED NOP CLA STA $A,I TENTATIVELY RTN A=0 STA $PVCN CLEAR $LIBR CNTR CCB ADB CLRQ STB $SUSP,I SAVE POSSIBLE >POINT OF SUSPENSION LDA CLRQ,I STA $RQRT SAVE POINT OF RETURN CMA,INA ADA CLRQ ADA .2 A= -# OF PRAMS +1 SSA,RSS AT LEAST 2 PARAMS? JMP CLER2 NO, THAT'S A CL02 STA OPTNA = -1 IF 2 PARAMS ADB .2 POINT TO 1ST PARAMETER ADDR LDA 1,I GET ADDRESS LDA 0,I GET "ICODE" STA ICODE SAVE CONTROL WORD RAL,ELA MOVE NO ABORT BIT TO E SEZ,INB ISZ $RQRT BUMP RTN ADDR IF N.A. SET LDA $STAT,I RAL,RAL ERA,RAR MOVE NO ABORT TO "NA" STA $STAT,I UPDATE ID SEG DLD 1,I GET 2ND / (3RD) PRAM ADDRESSES STA CLASA SAVE ADDR OF CLASS PARAM ISZ OPTNA SKIP IF NO 3RD PARAM STB OPTNA SAVE OPT.PARAMETER ADDR LDA CLASA,I GET PASSED CLASS AND B377 ISOLATE CLASS TABLE INDEX LDB 0 ADA $CLTA POINT TO CLASS TABLE STA TEMP SAVE ADDR OF CLASS ENTRY CMB,CLE,INB,SZB,RSS B=NEG CLASS TABLE INDEX JMP CL.05 CLASS # NOT SPECIFIED ADB $CLTA,I CHK CLASS # : E=1 IF OK LDA 0,I GET CLASS HEAD SEZ,SZA NO CLASS OR OUT OF RANGE? CLB,RSS NO, OK JMP CLER1 YES, ERROR CL01 SSA,RSS FOUND CLASS ID? JMP *-5 NO, TRACK IT DOWN XOR CLASA,I TEST CLASS AND B174C TO SEE IF SECURITY CODE OK CLE,SZA YES, SEC CODE MATCH? JMP CLER1 NO, ERROR * CL.05 LDA ICODE FUNCTION CODE AND .3 CMA,INA,SZA,RSS =3? JMP CLER2 YES, ERROR INA,SZA,RSS ASSIGN OWNERSHIP? JMP CL.10 YES CCB,SEZ WAS EXISTING CLASS GIVEN? JMP CLER1 NO, ERROR INA,SZA,RSS FLUSH CLASS? JMP CL.20 YES * * FLUSH ONLY PENDING REQUESTS ON DESIGNATED LU * CLA ADB OPTNA,I GET OPT. PARAM -1 LDA $LUT# CMA,INA A= NEG # OF LU'S ADA 1 CHECK AGAINST REQUESTED LU SSA TOO LARGE? SSB NO, TOO SMALL? JMP CLER2 YES, ILLEGAL PARAMETER ADB $LUTA POINT TO LUT ENTRY LDB 1,I GET IT'S DVT ADDRESS SZB,RSS IS DVT THERE? JMP CLER2 NO, ERROR - LU UNASSIGNED LDA CLASA,I GET PASSED CLASS # JSB $F.CL FLUSH PENDING REQUESTS OCT 3 * EXIT LDA $RQRT STA $SUSP,I SET RETURN ADDR JMP $XEQ & GO TO SYSTEM SKP * * ASSIGN CLASS OWNERSHIP * CL.10 CPB OPTNA PGM NAME DEFAULTED? JMP CL.15 YES, USE CALLER'S NAME CPB OPTNA,I WAS ZERO SPECIFIED? JMP CL.16 YES, NO OWNER * * NOW VERIFY NAME, AND COMPUTE ITS ID SEGMENT NUMBER LDB $IDA ADDR OF 1ST ID SEGMENT ADB .12 POINT TO PGM NAME * CL.12 CPA $ID# ALL ID SEGS CHECKED? JMP ESC05 YES, GIVE "SC05" INA STA CNTR BUMP ID SEG # STB PNTR STB TEMP1 LDB OPTNA LDA 1,I GET 1ST 2 CHARS CPA TEMP1,I MATCH? INB,RSS YES JMP CL.13 NO ISZ TEMP1 LDA 1,I GET 3RD & 4TH CPA TEMP1,I MATCH? INB,RSS YES JMP CL.13 NO ISZ TEMP1 LDA 1,I XOR TEMP1,I TEST 5TH CHAR CLB LSL 8 CL.13 LDA CNTR CURRENT ID SEG # SZB,RSS NAME MATCH? JMP CL.16 YES * LDB PNTR ADB $IDSZ POINT TO NEXT ID SEG JMP CL.12 GO CHECK IT * ESC05 LDB .5 ERROR "SC05" LDA ASCSC JMP $ERAB CALL ERROR ABORT ROUTINE * CL.15 LDB $XQT CALLER'S ID SEG ADDR JSB $IDNO COMPUTE PGM # CL.16 STA TEMP1 ALF,ALF ISOLATE BITS FOR SECURITY CODE AND B174C IN BITS 12-8 LDB TEMP ADDR OF CLASS TABLE STA TEMP LDA CLASA,I GET USER CLASS AND B377 CLE,SZA DOES 0HE WANT A NEW ONE? JMP CL.18 NO, SKIP CLASS # ALLOCATE ADB $CLTA,I POINT TO END OF CLASS TABLE CL.17 CPB $CLTA MORE ENTRIES? JMP CL.19 NO CLASSES AVAILABLE CPA 1,I IS THIS ENTRY ALLOCATED? JMP *+3 NO, WE'LL USE IT ADB N1 POINT TO NEXT ENTRY JMP CL.17 ITERATE * LDA $CLTA CMA,INA ADA 1 COMPUTE CLASS # IOR TEMP INCLUDE SECURITY CODE STA CLASA,I GIVE USER HIS NEW CLASS # LDA TEMP RAL,ERA SET TO STATE 3 STA 1,I SET NEW CLASS TABLE ENTRY * CL.18 ADB $CLTA,I ADDR OF 2ND WORD OF CLASS TABLE LDA 1,I GET CURRENT VALUE SSA FLUSHING? JMP CLER1 YES, ERROR LDA TEMP1 USER ID SEGMENT # STA 1,I STORE IN 2ND WD OF ENTRY JMP EXIT DONE * CL.19 CCA,SEZ,RSS IS THERE A CLASS TABLE? JMP CLER1 NO, ERROR "CL01" STA $A,I SET ERROR CODE IN A OF -1 LDB ICODE SSB WAS "NO WAIT" FLAG SET? JMP EXIT YES, RETURN NOW (A=-1) LDB $XQT NO LDA $CLTA JSB $LIST SUSPEND CALLER NOW OCT 52 JMP $XEQ SKP * * FLUSH CLASS * CL.20 LDA CLASA,I GET USER'S CLASS JSB $F.CL FLUSH COMPLETED REQUESTS OCT 1 LDB $LUTA ADDR OF LU'S STB PNTR LDA $LUT# SIZE OF LU TABLE CMA,INA STA CNTR COUNTER * CL.25 LDB PNTR,I GET NEXT LU TABLE ENTRY SZB,RSS POINT TO A DVT? JMP CL.26 NO, SKIP IT LDA CLASA,I GET FLUSHING CLASS # JSB $F.CL FLUSH PENDING REQUESTS .3 OCT 3 CL.26 ISZ PNTR POINT TO NEXT LU ISZ CNTR MORE? JMP CL.25 YES JMP EXIT NO, DONE SPC 3 * CLER1 CLB,INB,RSS * CLER2 LDB .2 LDA ASCCL JMP $ERAB ABORT SPC 2 * * DATA ICODE NOP CLASA NOP OPTNA NOP PNTR2|$" NOP CNTR NOP TEMP NOP TEMP1 NOP * .2 DEC 2 .5 DEC 5 .12 DEC 12 B377 OCT 377 B174C OCT 17400 N1 DEC -1 ASCCL ASC 1,CL ASCSC ASC 1,SC * END $  92070-18095 2040 S C0122 &ID.37 RTE-L HPIB DRIVER             H0101 \ASMB,R * NAME: ID.37 * SOURCE: 92070-18095 * RELOC: 92070-16095 * PGMR: C.H.W. * * **************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT * * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * **************************************************************** * * NAM ID.37,0 92070-16095 REV.2040 800722 * * * GEN 13,EID.37,QU:PR,TX:124,IT:37B * ENT ID.37 * EXT $IF2,$IF3,$IF5,$IF6,$IF7,$IFTX EXT $DV1,$DV13,$DV15,$DV16 EXT $DV17,$DV18,$DV19,$DV20,$DVTP EXT $LIST,$NAME,$RUN#,$DIOC,$IDSZ,$IDA EXT .MVW,$DVLU,$SYMG,$CVT1,$DMPR * SUP ** DEFINE SELECT CODES - ALWAYS ENTERED WITH GLOBAL REG ENABLED ** DMA EQU 20B DMA SELECT CODE PHI EQU 30B PHI DATA CARD EQU 31B CARD CONTROL DATA * * ENTRY CODE MEANING * A REGISTER * * 0 ABORT * 1 INITIATE * 2 CONTINUE * 3 TIME OUT * 4 POWERFAIL * SKP ID.37 NOP LDB $IFTX STB DMNXT ADDR FOR BUILDING QUADS ADB B60 STB BUFST ADDR FOR BUILDING CMD BUFFERS ADB B34 SKIP TO 76TH WORD OF IFT EXT CPB IFX1 ARE EXTENSION ADDRS SET? JMP BEGIN YES * STA TEMP2 LDA N9 SET-UP 9 EXT POINTERS (16 WORDS) STA TEMP1 LDA IFX STB 0,I SET NEXT INA INB ISZ TEMP1 JMP *-4 ADB B37 POINT TO SERIAL POLL STB 0,I ENTRY * NOW DETERMINE # OF ENTRIES IN SERIAL POLL TABLE LDA $IF7,I AND B777 9-BIT FIELD ADA N116 REST OF EXT. = 116 WORDS ARS,ARS CMA,INA # OF WORDS FOR SRQ TABLE / -4 w[ STA SRQ# NEG # OF ENTRIES (NONE IF +) LDA TEMP2 * BEGIN AND B7 REQ CODE IN BITS 0-2 STA CACON INITIALIZE CACON 15=0 CPA B2 JMP CONT --CONTINUE-- CPA B1 JMP INIT --INITIATE-- SZA,RSS JMP ABORT --ABORT-- SLA JMP TIMOT --TIMEOUT-- SPC 2 * POWER FAILURE - RESET CARD, SEND IFC FOR 10 MSECS, AND * FORCE REISSUE OF CURRENT REQUEST JSB DOIFC RESET ALL LDB $IF6,I GET IFT STATUS SSB,RSS BUSY? JMP PCONT NO, DO A CONTINUE EXIT LDA BN2 =100077B - DON'T DOWN, FLUSH, OR LOG JMP ERSET HED 92070-18056 HPIB DRIVER - REQUEST INITIATION SECTION * INIT LDA $IF7,I -INITIATE A NEW REQUEST- CHECK FOR FIRST ENTRY AND NOT10 TEST BIT 10 CPA $IF7,I FIRST TIME? JMP NEWRQ NO STA $IF7,I YES, CLEAR FIRST-TIME FLAG LDA BN6 INITIAL INTERRUPT MASK (PHI 3) STA IFX3,I ENABLES PPOLL BUT NOT SRQ LDA .04 =40000B - INITIALIZE PPOLL MASK STA IFX4,I FOR NO LINES ENABLED LDA .05 INITIALIZE PARALLEL POLL STA IFX5,I NORMALIZATION MASK LDA BN8 =60040 - PHI 6, STA IFX6,I SET REN JSB DOIFC INITIALIZE CARD * NEWRQ LDB IFX1,I LAST PROCESSING STATE LDA B3 SZB DID LAST REQUEST CLEAN-UP? JMP ABORX NO! TRY AGAIN & DOWN IF IT FAILS * STB IFX7,I INITIALIZE RESIDUE POINTER AND $DV15,I GET CONWD SZA,RSS CHECK FOR MULTI BUFFER REQUEST JMP MUBUF --MULTIBUFFER-- LDB 0 LDA IFX6,I CURRENT REN STATE IOR B3 SET TO OUTPUT FIFO, & CLEAR IT JSB SDPHI SET INITIAL CONDITION CPB B3 JMP CNTRL --CONTROL-- * ************************************************** * THIS IS A READ OR WRITE REQUEST * ******************************R********************** * LDB $DV15,I SET "CONWD" STB CONWD * LDA $DVTP,I GET HPIB ADDRESS ADA N30 SZA CHECK FOR CONTROLLER ADDRESS JMP ATOAD --DEVICE LU-- HED 92070-18056 HPIB - REQ INITIATION - READ/WRITE SKP * ********************************************* * THIS IS DIRECT IO. NO AUTO-ADDRESSING TO HPIB LU ************************************************** * CPA $DV19,I CHECK FOR EMPTY CONTROL BUFFER JMP OVR10 --NO CONTROL BUFFER-- * *********************************************** * THIS REQUEST HAS A CONTROL BUFFER TO OUTPUT * *********************************************** * JSB SENDZ SEND CMD (Z) BUFFER JMP REJ1 ERROR IF Z-BIT NOT-SET CLA CPA $DV17,I DATA BUFFER SPECIFIED? JMP BUFEM NO, DO ADDRESSING ONLY * OVR10 CPA $DV17,I CHECK XLOG OF DATA BUFFER JMP PDONE REQUEST COMPLETE * ******************************************** * THIS REQUEST HAS A DATA BUFFER. EITHER READ OR WRITE ******************************************** * LDA $DV15,I GET CONWD FOR DATA BUFFER SLA,RSS IS THIS A WRITE? JMP OVR25 YES, NO XFER COUNT QUAD NEEDED LDB $DV17,I XFER DATA LENGTH STB LEN LDA .1410 DMA CONWD=CONT,STC,FOUR CLB JSB PUT2 LDA BUFST JSB PUT SET BUFFER ADDR LDA $DV15,I CONWD=READ JSB PHIST SET PHI 0 & PHI 6 FOR INPUT JMP OVR25 SKP ************************************* * AUTOADDRESS REQUEST FOR DEVICE LU AUTOADDRESSING ONLY * * A SINGLE DATA BUFFER IS ALLOWED ************************************* * ATOAD BLF,SLB IS Z-BIT SET? JMP REJ1 YES, REQ ERROR LDA $DV17,I STA LEN SAVE LENGTH FOR "PHIST" LDA $DV18,I GET SECONDARY ADDR SZA WAS ONE SPECIFIED? IOR B140 YES, ENSURE A VALID SECONDARY JSB,B BDADS BUILD ADDRESS QUAD. LDA $DV17,I SZA,RSS $DV17 IS XLOG JMP OVR30 DATA BUFFER XLOG =0 * OVR25 JSB BWRDS GO BUILD CARD AND DMA CONTROL WORDS LDA $DV16,I GET BUFFER ADD. JSB PUT LDA DMNXT ADDR WHERE RESIDUE WILL BE LEFT STA IFX7,I IS SAVED FOR LATER LDA $DV17,I GET DATA BUFFER LENGTH CMA,SSA,INA,RSS SKIP IF WORDS CMA,INA,RSS LEAVE IT AS NEG BYTES CLE,ELA CONVERT WORD TO NEG BYTE COUNT JSB PUT STORE IN QUAD * OVR30 LDA $DV15,I CHECK FOR TERMINATOR (ASCII OR BINARY) AND B2101 BIT10=TRANSPARENCY,BIT6=ASCII/BINARY LDB $DV17,I GET REQ LENGTH SZA JMP BINRY NOT A NON-TRANSPARENT ASCII WRITE SZB,RSS ANY DATA? JMP OVR32 NO, NO BACKARROW CHECK CPB N1 ONE BYTE OF DATA? JMP OVR31 YES, NO BACKARROW, CLEAR EOI ON DATA * CHECK IF LAST CHARACTER IS A BACK ARROW, & DONT ADD CR,LF IF IT IS CCE,SSB,RSS SKIP IF GIVEN IN BYTES CMB,CLE,INB,RSS NEG.WORD COUNT ERB -(# BYTES+1)/2 CMB WORDS-1 OR (BYTES+1) 2-1 ADB $DV16,I POINT TO LAST WD IN BUFFER LDA 1,I GET IT CCB,SEZ IN LHW? ALF,ALF YES AND B377 ISOLATE RHW OVR31 ADB DMNXT QUAD POINTER -1 CPA B137 IS IT A BACK ARROW? JMP ARROW YES, DONT SEND "CR,LF" * ADB N2 POINT TO CARD CONWD OF LDA B2000 PREVIOUS QUAD & STA 1,I CLEAR "EOI" BIT * * BUILD THE DMA QUADRUPLET FOR THE CRLF TERMINATOR * OVR32 LDA .1610 DMA CONWD=CONT,STC,BYTE,FOUR LDB B3000 CARD CONWD=BYTE,EOI,OUT JSB PUT2 STORE 2 DMA QUAD WORDS LDA #CRLF ADDR OF CRLF * OVR50 LDB N2 LEN=2 CHARS OVR51 JSB PUT2 STORE 2 DMA QUAD WORDS RSS SKIP BACKARROW REMOVAL SPC 3 ARROW ISZ 1,I SUB 1 FROM NEG BYTE COUNT Z SPC 5 * HERE WHEN LAST DMA QUAD IS A WRITE. THIS BUILDS AN ADDITIONAL * QUAD TO ENABLE THE "BUFFER EMPTY" INTERRUPT. WHEN THIS QUAD * HAS COMPLETED, AND THE OUTBOUND FIFO IS EMPTY, THE CARD WILL * INTERRUPT TO SIGNIFY THE ENTIRE OPERATION IS COMPLETE. * NOTE THAT "CINT" IS 1 SO THAT THE DMA COMPLETION INTERRUPT * WILL NOT OCCUR. * BUFEM LDA .03 CLEAR ALL CARD INTERRUPTING JSB SDPHI CONDITIONS IN PHI REG 3 LDA .0450 STC,WORD,CINT,FOUR,OUT LDB B4 CARD CONTROL IS INTERRUPT ENABLE JSB PUT2 STORE 2 DMA QUAD WORDS LDA #P3BE SEND A "30002" = ENABLE BUFFER EMPTY CCB INTERRUPT, LENGTH= 1 WORD DST DMNXT,I STORE 2 DMA QUAD WORDS SPC 2 ***************************************************** * START THE DMA SELF CONFIGURATION OPERATION * $$$SRQ AND PPOLL ARE NOT ENABLED$$$ ***************************************************** * LDA $IFTX GET DMA QUAD START ADDR OTA DMA SET DMA STARTING ADDRESS B2400 CLA OTA CARD CLEAR CARD CLF PHI CLEAR FLAG STC DMA,C START DMA SELF CONFIGURATION CLA,INA "T" BIT * EXITC ISZ ID.37 RTN+2 = PHYSICAL WAIT JMP ID.37,I EXIT SPC 3 * BINRY SZB SKIP IF NO DATA STRTX SLA,RSS SKIP IF LAST QUAD WAS A READ JMP BUFEM GO SET BUFFER EMPTY INTERRUPT SPC 3 * * HERE WHEN LAST DATA TRANSFER WAS A READ. "CLRIN" IS CALLED * TO EMPTY THE INBOUND FIFO BY BUILDING A QUAD TO SET PHI REG 3 * TO UNMASK THE "INBOUND FIFO NOT EMPTY" INTERRUPT, AND TO * BUILD A 2ND QUAD TO READ 8 BYTES FROM THE INBOUND FIFO WITH * DMA COMPLETION INTERRUPT ENABLED ("CINT"=0) AND THE CARD CONTROL * SET TO CAUSE THE DMA INTERRUPT WHEN THE "INBOUND FIFO NOT EMPTY" * INTERRUPT IS NO LONGER PRESENT. (THE CARD INTERRUPT IS DISABLED). * THE ABOVE EFFECTIVELY CAUSES THE DMA COMPLETION INTERRUPT AS SOON * AS THE "INBOUND FIFO NOT EMPTY" INTERRUPT FLAG GOES TO ZERO, I.E. * THE INBOUND FIFO IS EMPTIED. * JSB CLRIN CLEAR INBOUND FIFO OCT 61200 DMA CONWD: STC,BYTE,FOUR,IN * JMP BUFEM SPC 2 * #P3BE DEF EMPTY .03 OCT 30000 .05 OCT 50000 .102 OCT 102000 B37 OCT 37 B7 OCT 7 B777 OCT 777 BN2 OCT 100077 BN8 OCT 60040 N116 DEC -116 N30 DEC -30 NOT10 OCT 175777 HED 92070-18056 HPIB - REQ INITIATION - MULTI-BUFFERED REQ ************************************************************** * MULTIBUFFER REQUESTS LOOK LIKE THIS: * $DV FUNCTION * 15 RQ=0 * 16 ADD. OF FIRST SUBREQ. #IFX# * 17 NEGATIVE # OF SUBREQUESTS * 18 NOT USED * * DVTX CONWD AND RQ * DVTX+1 SUBREQUEST BUFFER ADD. * DVTX+2 " " LENGTH * DVTX+3 CARD CONTROL "CACON" * DVTX+4 OPTIONAL SECONDARY * * CACON BIT MEANING * 1 XLOG FROM THIS DATA GOES INTO DVT17 * 13 COMPLETE ON XLOG XFER, DO A PP RESUME TO LOG DVR * 15 AWAIT PPOLL BEFORE STARTING THIS OP. **************************************************************** * "MUBUF" BUILDS THE DMA QUADRUPLETS FROM LOGICAL * DRIVER MULTIPLE BUFFER REQUESTS *********************************************************** MUBUF LDB $DV16,I GET ADDRESS OF FIRST QUINT * MUB1 STB REQAD SAVE ADDR OF NEXT MUBUF QUINT LDA 1,I SET HPIB ADDRESS DIRECTION PER RQ STA CONWD ADB B2 DLD 1,I 3RD & 4TH WORDS OF QUINTUPLET STA LEN SAVE XFER LEN STB CACON SAVE CACON SSB,RSS BIT 15 OF CACON SET? JMP MUB2 NO * BUILD QUAD TO ENABLE PPOLL INTERRUPT LDA $DVTP,I DEVICE ADDR CMA,INA ADA B10 8-ADDR = DIO LINE # JSB VLINE GET PPOLL LINE MASK LDA .1410 DMA CONWD=CONT,STC,FOUR CLB CARD CONTROL =0  JSB PUT2 LDA BUFST LDB N3 3 WORD CMD BUFFER JSB PUT2 LDA .04 PHI REG 4 IOR TEMP1 SET BIT FOR DIO LINE JSB PUTB STORE IN CMD BUFFER LDA .05 PHI REG 5 JSB PUTB NO NORMALIZATION LDA BN6 ENABLE PHI PPOLL INTERRUPT JSB PUTB * MUB2 LDB REQAD ADB B4 POINT TO SECONDARY IN QUINT LDA 1,I GET SECONDARY ADDR * JSB BDADS GO BUILD AUTO-ADDRESS QUAD & BUFR * JSB BWRDS * ISZ REQAD ADDRESS OF BUFR ADDR IN QUINT LDA REQAD,I GET BUFFER ADDRESS JSB PUT LDB CACON GET CACON LDA LEN GET BUFFER LENGTH RBR,SLB CACON BIT 1 SET? STA FUNCT YES, SAVE REQ LEN CMA,SSA,INA,RSS SKIP IF IN WORDS CMA,INA,RSS ELSE LEAVE BYTE CNT ALONE CLE,ELA CONVERT WORD TO NEG BYTE CNT STA DMNXT,I STORE IN QUAD LDA DMNXT ADDR OF THIS QUADS LENGTH WORD SLB,BLF WAS CACON BIT 1 SET? STA IFX7,I YES, SAVE ADDR OF RESIDUE ISZ DMNXT BUMP QUAD POINTER * SLB CACON BIT 13 SET? JMP MUB9 YES, COMPLETE NOW (& RESUME ON PPOLL) LDA CONWD ISZ $DV17,I MORE QUINTUPLETS? JMP MUB6 YES * MUB5 LDB FUNCT DATA XFER REQ LEN STB $DV17,I STORE FOR LATER XLOG UPDATE JMP STRTX GO WRAP IT UP * MUB6 SLA,RSS IS LAST SUBREQUEST A READ? JMP *+3 NO JSB CLRIN POSSIBLE IN-FIFO CLEAR OCT 165200 DMA CONWD:CONT,STC,BYTE,CINT,FOUR,IN LDB REQAD ADB B4 POINT TO NEXT SUBREQUEST JMP MUB1 GO PROCESS NEXT SUBREQUEST * MUB9 LDA $DVTP,I GET DEVICE ADDR CMA,INA ADA B10 8 - ADDR = DIO LINE # JSB PPENT GET A PPOLL ENTRY LDA $DV1 THIS DVT'S ADDR CLB LOGICAL RESUME ON PPOLL DST * BUILD PPOLL ENTRY TEMP5 EQU *-1 LDA CONWD JMP MUB5 HED 92070-18056 HPIB - REQ INITIATION - CONTROL REQUESTS * *********************************************** * THIS IS A CONTROL REQUEST * *********************************************** CNTRL LDA $DV15,I LSR 6 AND B77 STA FUNCT SAVE CONTROL SUBFUNCTION LDB $DVTP,I GET HPIB ADDRESS CPB B36 JMP HPCNT THIS IS AN HPIB LU CONTROL * THIS IS A DEVICE LU CONTROL REQUEST * LDB $DV15,I BLF,SLB TEST "Z"-BIT JMP REJ1 ERROR IF SET * CLE,SZA,RSS JMP CLRLU CLEAR CPA B6 JMP SRQST SERIAL POLL (DYNAMIC STATUS) CPA B16 JMP RENDV REN ENABLE FOR DEVICE CPA B17 JMP LOCDV REN DISABLE FOR DEVICE CPA B20 JMP SRENB SET PROGRAM TO SCHEDULE PROG. CPA B21 JMP SRDIS REMOVE SCHEDULE PROGRAM CPA B22 JMP NEWTO SET NEW TIMEOUT CPA B23 JMP INTEX INTERRUPT EXPECTED CPA B24 JMP PRAM1 CHANGE DEVICE ADDR CPA B27 JMP TRIGR GROUP EXECUTE TRIGGER CNPP CPA B40 JMP PENAB PARALLEL POLL ENABLE CPA B41 JMP PDSAB PARALLEL POLL DISABLE JMP PDONE NOT RECOGNIZED, IGNORE SPC 3 * SET PHYSICAL TIMEOUT FOR DEVICE NEWTO LDA $DV16,I PASSED TIMEOUT VALUE SZA,RSS DISABLE TIMEOUT? JMP *+3 YES CMA,SSA,RSS NEGATE, WAS IT POSITIVE? JMP REJ1 NO ,ERROR STA $DV13,I NEW PHYSICAL T.O. JMP PDONE SPC 3 * CHANGE DEVICE ADDR PRAM1 LDA $DV16,I GET NEW ADDR LDB 0 ADB N30 SSB LESS THAN 30 SSA & POSITIVE? JMP REJ1 NO, ERROR STA $DVTP,I OK, SET NEW ADDR JMP PDONE SPC 3 * * DEVICE LU CLEAR (0) * CLRLU LDA B4 SDC RSS SPC 3 * * GROUP EXECUTE TRIGGER * TRIGR LDA B10 !J * * HERE TO SEND ADDRESSED HPIB COMMAND IN A REGISTER SDCMD CLB STB CONWD ENSURE FUNCTION IS WRITE JSB BDADS BUILD AUTO-ADDRESS BUFFER WITH CMD JMP BUFEM TERMINATE WITH "BUFFER EMPTY" INTERRUPT * * * THIS IS A HPIB LU CONTROL REQUEST * HPCNT SZA,RSS JMP CLEAR CLEAR HPIB CPA B6 JMP PSTAT DYNAMIC STATUS CPA B16 JMP REN JMP RENBU REMOTE CPA B17 JMP LOCBU LOCAL CPA B23 JMP INTBU INTERRUPT EXPECTED CPA B25 JMP LLOCK LOCAL LOCKOUT CPA B27 JMP TRGBU UNIVERSAL G.E.T. CPA B51 JMP ABTBU ABORT JMP CNPP CHK FOR PPOLL ENABLE/DISABLE SPC 3 * * SEND UNIVERSAL LOCAL LOCKOUT COMMAND * LLOCK LDA B421 LOCAL LOCKOUT CMD * * SDNOW JSB SDPHI SEND HPIB CMD JMP BUFEM WAIT FOR WORD TO LEAVE FIFO SPC 3 * ABORT (BUS LU) - SEND IFC FOR 10MSECS ABTBU LDA IFX6,I IOR B20 SET "IFC" JSB SDPHI SET PHI 6 CCB JSB EXIT3 WAIT FOR 10 MSECS WITH HOLD SET * HERE AFTER TICK LDA IFX6,I PHI 6, NO IFC JMP SDEND PROGRAM PHI 6 SPC 3 * * BUS LU CLEAR REQUEST * CLEAR LDA B404 SDC LDB $DV16,I PRAM 1 SZB,RSS ZERO? JMP ADCMD YES, SEND ADDRESSED SDC JSB DOIFC DO INTERFACE CLEAR JMP PDONE SPC 2 * RENDV LDA BN8 =60040 - PHI 6 "REN" STA IFX6,I JSB SDPHI PROGRAM PHI 6 CLA NO SECONDARY JMP SDCMD GO ADDRESS THE DEVICE * LOCDV CLA,INA GO TO LOCAL CMD JMP SDCMD SEND WITH AUTOADDRESSING BUFFER * * RENBU LDA BN8 =60040 - REN STA IFX6,I IOR B2 SET OUTPUT JSB SDPHI PROGRAM PHI 6 (NO REN) * JSB SENDZ SEND POSSIBLE ADDR BUFFER JMP PDONE DONE IF NONE SPECIFIED JMP BUFEM APPEND A BUFFER EMPTY INT. QUAD P * * LOCBU LDA B401 "GTL" LDB $DV16,I PRAM 1 SZB JMP ADCMD ADDRESSING REQUIRED LDA .06 CLEAR "REN" STA IFX6,I SDEND JSB SDPHI PROGRAM PHI 6 JMP PDONE IMMEDIATE COMPLETION SPC 3 * HERE FOR GROUP EXECUTE TRIGGER TRGBU LDA B410 G.E.T. * ADCMD STA BUFST,I SAVE CMD JSB SENDZ CHECK FOR ADDRESS BUFFER JMP SDNOW NONE, SO SEND CMD NON-DMA LDA .1410 DMA CONWD=CONT,STC,FOUR CLB CARD CONTROL=0 JSB PUT2 LDA BUFST CCB ISZ BUFST JMP OVR51 GO BUILD BUFR EMPTY INT. QUAD SPC 2 * .06 OCT 60000 .1610 OCT 161000 .1710 OCT 171000 B140 OCT 140 B200 OCT 200 B2000 OCT 2000 B21 OCT 21 B2101 OCT 2101 B22 OCT 22 B23 OCT 23 B24 OCT 24 B25 OCT 25 B27 OCT 27 B36 OCT 36 B377 OCT 377 B4 OCT 4 B401 OCT 401 B404 OCT 404 B41 OCT 41 B410 OCT 410 B421 OCT 421 B51 OCT 51 B6 OCT 6 FUNCT NOP REQAD NOP N5 DEC -5 HED 92070-18056 HPIB - REQUEST INITIATION - SUBROUTINES * *********************************************** * BDADS BUILDS THE AUTOADDRESSING QUAD * BUFFER IS PHI WRITE+REN,UNTK,UNL,CONTROL TLK/LSN * DEVICE TLK/LSN,(DEVICE SECONDARY,(PHI REG 6 IF INPUT) * * IT ALSO SETS UP PHI REG 6 FOR THE DATA XFER(IN\OUT) * PHI REG 0 IS SET FOR ASCII OR BINARY IF A READ. * * PASS REQAD =ADDRESS OF FIRST REQUEST WORD * PASS DIR =R\W= 0\40 * * THIS QUADRUPLET IS OF THE BELOW CONSTRUCTION: * DMA CONTROL (141400) * CARD CONTROL (0) OR (10 IF WAIT ON INT.) * BUFFA * BUFFL (4 MINIMUM) * * BUFFA * PHI WRITE (PHI REG 6 W/ REN) * UNT * UNL * MTA\MLA * YTA\YLA * (OPTIONAL SECONDARY) * (PHI 0 FOR READ ONLY. ASCII OR BINARY) * (PHI 6 FOR READ ONLY - INPUT + REN) * ON ENTRY: A=SECONDARY ADDR OR COMMAND ********************************************** *********************************************** E BDADS NOP STA TEMP1 SECONDARY ADDR LDA B2 JSB UNTLK BUILD UNTALK,UNLISTEN ERA,CLE,ELA A=476 = CONTROLLER LSN ADDR LDB CONWD SLB,RSS SKIP IF A READ XOR B140 A=536 = CNTRLLER TALK ADDR IF WRITE JSB PUTB LDA $DVTP,I GET DEVICE ADDR IOR B500 A=500+ADDR FOR DEVICE TALK SLB,RSS SKIP IF A READ XOR B140 A=440+ADDR FOR DEVICE LSN JSB PUTB * LDB N5 CMD BUFFER LENGTH SO FAR * LDA TEMP1 GET OPTIONAL SECONDARY ADDR SZA,RSS SECONDARY SPECIFIED? JMP BDAD8 NO SECONDARY CPA B405 PPC? JMP BDAD9 YES, SEND 2 CMDS BDAD7 IOR B400 SET ATN JSB PUTB STORE CMD/SEC-ADDR IN BUFFER ADB N1 INCEMENT WORD COUNT FOR SECONDARY BDAD8 LDA CONWD JSB PHIST SET PHI 6 AND PHI 0 JMP BDADS,I RETURN * BDAD9 JSB PUTB STORE PPC ADB N1 BUMP WORD COUNT LDA TEMP2 PPD OR PPE JMP BDAD7 SPC 5 * ******************************************************** * "BWRDS" BUILDS THE DMA CONTROL AND HPIB CARD * CONTROL WORD FOR THE USER REQUEST * EOI IS RECOGNIZED ON ALL INPUTS EXCEPT BINARY TRANSPARENT * EOI IS ONLY SET ON LAST CHAR OF NON-TRANSPARENT WRITES * NOTE THAT ON DEVICE ASCII WRITES, EOI IS SENT WITH CR,LF * * NO PHI PROGRAMMING IS DONE HERE ******************************************************** * BWRDS NOP LDA CONWD GET FIRST WORD TO SET DMA CONTROL AND B2101 CPA B2001 ASCII TRANSPARENT READ? CLA,INA YES, REQUIRES EOI AND B2001 IF BIT 10=1, NO EOI RAR BIT15=1 IF READ, BIT9=1 IF NO EOI XOR B3000 SET "BYTE", REVERSE "EOI" LDB 0 LDA .1710 DMA CONTROL WORD SSB READ? ADA B200 YES, SET INPUT IN DMA CONWD JSB PUT2 STORE 1ST 2 QUAD WORDS JMP BWRDS,I --THIS IS A STANyDARD REQUEST -- SKP * ************************************************ * "CLRIN" CLEARS THE INBOUND PHI FIFO UNDER DMA CONTROL * CALLED FROM "ABORT" & "MUBUF" ************************************************ CLRIN NOP ISZ XCNFG WAS IT UNCOUNTED RCV? JMP CLRI9 NO, DO IMMEDIATE RTN LDA B3 JSB UNTLK BUILD UNTALK,UNLISTEN LDA N3 LENGTH OF CMD BUFFER = 3 JSB PUT LDA CLRIN,I GET DMA CONWD FOR READ LDB .102 =102000 CARD CONTROL JSB PUT2 TO STOP ON NON-INTERRUPTS LDA GARBG GET GARBAGE BUFFER LDB N8 SET FOR MAX 8 BYTES JSB PUT2 CLRI9 ISZ CLRIN JMP CLRIN,I SPC 4 **************************************************************** * "DOIFC" SETS "IFC" IN THE PHI 6 REGISTER FOR 10 MILLISECS * & IS REENTERED ON THE TICK (IFC MUST BE ASSERTED FOR A * MINIMUM OF 100 USECS). A DEVICE CLEAR ("DCL") IS THEN * SENT AND RETURN IS PASSED TO THE "DOIFC" CALLER. **************************************************************** * DOIFC NOP CLC DMA+1 SUSPEND DMA & CLC DMA+3,C CLEAR CARD LDA .0700 JSB SDPHI OFF-LINE LDA .0702 JSB SDPHI ON-LINE CLA,INA OTA CARD RESET CARD LDA B23 DO OUT-FIFO FLUSH, IFC IOR IFX6,I INCLUDE REN STATE JSB SDPHI PROGRAM PHI 6 LDB DOIFC SAVE DOIFC RTN ADDR STB IFX8,I SAVE CONTINUATION ADDR CCB SINGLE TICK JSB EXIT3 DO A PHY CONTINUE & AWAIT TIMEOUT * * ENTER HERE AFTER NEXT TIME TICK LDA IFX6,I JSB SDPHI CLEAR IFC LDB IFX8,I JMP 1,I RETURN TO "DOIFC" CALLER SKP * *************************************************** * "PHIST" STORES QUAD LENGTH. IF A READ IT SETS * PHI 6 FOR INPUT AND SETS ASCII\BINARY TERM. * IT IS CALLED FROM ROUTINES "BDADS" & "OVR10" ********************************************!******************* * PHIST NOP STB DMNXT,I STORE CMD BUFR LEN SLA,RSS READ? JMP PHIS9 NO, EXIT LDB LEN GET DATA LENGTH SZB,RSS ANY DATA? JMP PHIS9 NO SSB SKIP IF WORDS CMB,INB,RSS POSITIVE BYTE CNT & SKIP RBL CONVERT WORD TO BYTE CNT CPB B400 LEN=256? CLB YES, CNTED XFER OK AND B100 ISOLATE BINARY FLAG ALF,CLE,RAR MOVE TO BIT 9 IOR 1 FORM BYTE XFER CMD ADB .1774 SEZ WAS LEN > 255? LDA B1400 YES, DO UNCOUNTED XFER CLB,SEZ CCB SET UNCOUNTED XFER FLAG STB XCNFG SAVE FOR CLRIN'S CHECK JSB PUTB STORE BYTE XFER CMD LDA IFX6,I PHI 6 FOR INPUT JSB PUTB PROGRAM PHI 6 LDB DMNXT,I ADB N2 ALLOW FOR 2 MORE CMD WORDS STB DMNXT,I * PHIS9 ISZ DMNXT JMP PHIST,I RETURN SKP * ************************************************** * PUT STORES A REG. CONTENTS IN DMA QUADRUPLET * WHICH RESIDE IN EXTENSION. PUT2 STORES A&B. * "DMNXT" IS A RUNNING ADDRESS POINTER FOR DMA QUAD LIST * * PUTB STORES A REG. CONTENTS IN DATA BUFFERS WHICH RESIDE * IN EXTENSION. ************************************************ PUT NOP STA DMNXT,I ISZ DMNXT JMP PUT,I * PUT2 NOP DMNXT EQU *+1 DMA QUAD POINTER DST * STORE 2 DMA QUAD WORDS ISZ DMNXT ISZ DMNXT JMP PUT2,I * * PUTB NOP STORES CONTENTS OF AUTO ADDRESSING BUFFERS STA BUFST,I ISZ BUFST JMP PUTB,I SPC 4 ************************************************** * THIS ROUTINE SETS-UP QUAD FOR USER SUPPLIED * ADDRESS BUFFER IF Z-BIT WAS SET. ************************************************** SENDZ NOP LDB $DV15,I GET CONWD BLF,SLB CHECK Z-BIT OF CONWD RSS SKIP IF SET q JMP SENDZ,I NO Z-BIT, RETURN+1 * LDA .1410 DMA CONWD=CONT,STC,FOUR LDB $DV19,I GET LENGTH RBL,SLB,ERB GIVEN IN BYTES? LDA .1610 YES, ALSO SET "BYTE" LDB B400 SET CARD CONTROL. OUT,ATN SEZ BYTES? LDB B2400 YES JSB PUT2 SET 2 DMA QUAD WORDS * LDA $DV18,I SET CONTROL BUFF ADD. LDB $DV19,I SET CONTROL BUFF LENGTH SSB,RSS CMB,INB NEGATE WORD COUNT JSB PUT2 ISZ SENDZ RETURN+2 JMP SENDZ,I SPC 3 ****************************** * BUILD QUAD TO SEND: * 1. PHI 6 (REN) + OUTPUT * 2. UNTALK * 3. UNLISTEN * QUAD LENGTH NOT SET HERE ****************************** * UNTLK NOP IOR IFX6,I FORM PHI 6 WORD STA BUFST,I STORE IN CMD BUFFER CLB LDA CACON SSA IS THIS A MUBUF "CONT ON INT" LDB B10 YES, CARD CONTROL WD = 10 LDA .1410 DMA CONWD=CONT,STC,FOUR JSB PUT2 STORE 2 DMA QUAD WORDS LDA BUFST CMD BUFFER ADDR JSB PUT STORE AS DMA QUAD DATA ADDR ISZ BUFST BUMP CMD BUFFER POINTER LDA B537 UNTALK JSB PUTB LDA B477 UNLISTEN JSB PUTB JMP UNTLK,I SPC 2 * #CRLF DEF CRLF GARBG DEF GARB .04 OCT 40000 .0700 OCT 70000 .0702 OCT 70200 .1 OCT 100000 .14 OCT 140000 .1774 OCT 177400 B1400 OCT 1400 B2001 OCT 2001 B3000 OCT 3000 B17 OCT 17 B20 OCT 20 N100 DEC -100 CONWD NOP CONTROL WORD CACON NOP LEN NOP XCNFG NOP =-1 IF UNCOUNTED INPUT HED 92070-18056 HPIB - ABORT, & TIMEOUT SECTIONS * ************************************************ * "ABORT" HANDLES ABORT * (CAN'T GET HERE WHILE SERIAL POLLING BECAUSE "HOLD" IS SET) *************************************************************** ABORT LDA B4 INDICATE NORMAL ABORT IS IN PROGRESS * ABORX STA IFX1,I SET CURRENT OPER~)ATIONAL STATE JSB RESET CLEAR CARD CCB STB XCNFG JSB CLRIN CLEAR IN-FIFO OCT 165200 LDB N100 1 SEC OF TICKS LDA $IF2,I GET TIMEOUT SZA,RSS ANY SPECIFIED (FROM DVT) STB $IF2,I NO, THEN USE 1 SECOND LDB IFX1,I PROCESSING STATE LDA SPD SERIAL POLL DISABLE CPB B3 CLEAN-UP FROM PRIOR OP? JSB SDPHI YES, ENSURE SERIAL POLLING DISABLED JMP BUFEM TERM ON "BUFFER EMPTY" INTERRUPT SPC 4 * RESET NOP CLC DMA+1 SUSPEND DMA CLC DMA+3,C THEN CLEAR IT CLA,INA OTA CARD RESET CARD LDA B3 CLR OUT-FIFO IOR IFX6,I INCLUDE REN STATE JSB SDPHI PROGRAM PHI 6 JMP RESET,I SKP * ******************************* * "TIMOT" HANDLES TIMEOUT ****************************** TIMOT LDB IFX1,I GET CURRENT OPERATIONAL STATE LDA B2 SZB,RSS OPERATION STATE=0? JMP ABORX YES, SET STATE FOR TIMEOUT CLR & DO IT CPB B1 CONTINUATION ADDR? JMP TIMO2 YES SSB TIMEOUT EXPECTED? JMP CONTT YES, GO TO SPECIFIED ADDR * * THINGS ARE REALLY SOUR IF WE GET HERE CLC DMA+1 SUSPEND THEN CLC DMA+3,C CLEAR DMA * NOTE: IFX1,I IS LEFT NON-ZERO SO WE CAN RETRY TO INITIALIZE * WHEN THE NEXT REQUEST IS INITIATED SPC 3 * TIMEX LDA B3 DOWN, DON'T FLUSH, TIMEOUT ERROR CPB B4 IN THE MIDDLE OF AN ABORT? IOR .04 YES, FORCE A FLUSH * ERROR LDB $IF5,I GET ADDR OF DVT ADB B23 POINT TO DVT20 LDB 1,I GET "CNFG" BIT RBL FROM BIT 14 OF DVT 20 SSB USER HANDLING OWN ERRORS? IOR .14 YES, FORCE FLUSH, DON'T DOWN JMP ERSET DO PHYSICAL DONE * * TIMO2 LDB $IF6,I GET IFT "AV" FIELD CCE,SSB BUSY? JMP ABORX YES, CLEAR INTERFACE z STA IFX1,I ENSURE CLEANUP IF THIS IS LAST POLL JSB EMSG GIVE ERROR MSG "NO RESP" ASC 2,RESP JSB RESET CLEAR CARD JMP SRQ4 REGARD IT AS A NEG POLL RESPONSE HED 92070-18056 HPIB DRIVER - CONTINUATION (INTERRUPT) SECTION ********************************************************* * ALL CONTINUE INTERRUPTS ARRIVE HERE * * NOTE: $DV ADDRS MAY NOT BE SET ON CONTINUATION OR * TIMEOUT INTERRUPTS. ID.37 IS WRITTEN SO THEY ARE NOT * USED IN THESE CASES (UNLESS A CONTINUATION ADDR WAS * SPECIFIED IN IFX2 IN WHICH CASE $DIOC IS CALLED). * THIS SAVES CONSIDERABLE SETUP OVERHEAD. ********************************************************* CONT SFC DMA+2 DMA PARITY RCVD? JMP $DMPR YES! GO TO SYSTEM SFS DMA+1 DMA COMPLETION? SFC PHI OR CARD FLAG INTERRUPT? JMP INFLG YES JSB ILLIN NO, REPORT ILLEGAL INTERRUPT * INFLG CLC DMA+1 SUSPEND DMA CLC DMA+3,C TURN-OFF DMA LDA IFX1,I GET CURRENT STATE CLB STB IFX1,I CLEAR PROCESSING STATE INDICATOR CPA B1 CONTINUE ADDR? JMP CONTX+1 YES LDB $IF6,I IFT BUSY? SSB,RSS JMP NOBZY NO CPA B2 WAS IT TIMEOUT CLEANUP? JMP TIMEX YES, NOW RETURN ERROR CPA B3 CLEAN-UP PRIOR TO NEW REQ? JMP DVSET YES, OK TO START IT NOW SPC 3 * **************************************************** * SUCCESSFUL REQUEST COMPLETION - POST XMISSION LOG **************************************************** LDB $IF5,I DVT ADDR ADB B16 POINT TO DVT15 STB TEMP1 SAVE IT ADB B2 POINT TO DVT17 STB TEMP2 SAVE IT LDA 1,I GET ORIGINAL REQ LENGTH SSA GIVEN IN WORDS? CMA,INA,RSS NO, GET POSITIVE BYTES, SKIP RAL CONVERT WORD TO BYTE COUNT LDB IFX7,I SAVED ADDR OF RESIDUE (IN QUAD ARE A) SZB,RSS WAS IT SPECIFIED? JMP DONE5 NO, RETURN XLOG=0 ADA 1,I XLOG = ORIGINAL LEN - RESIDUE STA LEN SAVE XLOG (IN BYTES) LDB TEMP1,I GET CONWD SLB,RBR IF READ, E=1, BIT0=0 SLB,BLF MOVE ASCII FLAG TO BIT9, SKIP JMP DONE3 NO BUFFER POST-PROCESSING SKP *********************************************** * INPUT - PERFORM BUFFER POST-PROCESSING *********************************************** SZA,RSS JMP DONE3 NOTHING RECEIVED ADA N1 # OF BYTES -1 CLE,ERA A= # OF WORDS RCVD -1 BLF,ELB BIT14=0 IF ASCII; BIT0=1 IF EVEN BYTES ISZ TEMP1 POINT TO DVT16 ADA TEMP1,I POINT TO LAST WD IN BUFR STA TEMP1 SAVE POINTER ADA N1 NEXT TO LAST WORD STA TEMP4 SAVE IT ALSO LDA TEMP1,I GET LAST WD IN BUFFER CLE,SLB,RBL EVEN # OF BYTES? JMP DONE1 YES, NO FILL NEEDED * PAD RHW WITH FILL CHARACTER AND .1774 CLEAR RHW CCE,SSB,RSS ASCII? IOR B40 YES, FILL WITH A SPACE STA TEMP1,I LAST WD WITH FILL CHAR * DONE1 SSB BINARY OR ASCII? JMP DONE3 BINARY, NO CRLF REMOVAL * REMOVE CR,LF IF LAST TWO CHARACTERS LDB TEMP4,I GET NEXT TO LAST WD SEZ SKIP IF EVEN # OF BYTES RRR 8 ENSURE A HAS LAST 2 CHARS LDB N2 ADB LEN B=XLOG-2 CPA #CRLF,I "CR,LF"? SSB YES, SKIP IF XLOG >1 JMP DONE3 ELSE NO CHARACTER REMOVAL LDA TEMP4,I GET NEXT TO LAST WD XOR B55 TURN "CR" INTO A BLANK SLB UNLESS EVEN # OF BYTES STA TEMP4,I REMOVE CR & ADD BLANK RSS USE XL0G-2 * DONE3 LDB LEN GET XLOG LDA TEMP2,I ORIGINAL REQ LENGTH SSA GIVEN IN WORDS? JMP DONE5 NO CLE,SLB,ERB WORDS=(BYTES+1)/2 INB ROUND O`DD BYTE UP DONE5 STB TEMP2,I RETURN TRANSMISSION LOG SKP ********************************** * HERE TO TAKE PHYSICAL DONE EXIT ********************************** * PDONE CLA * ERSET LDB $IF3,I DVT ADDR ELB,CLE,ERB CLEAR SIGN SZB,RSS ANY DVT? JMP SETRG NO STB $IF5,I ENSURE IFT5 IS CORRECT ADB B17 DVT16 ADDR STA 1,I RETURN COMPLETION CODE * SETRG LDA IFX4,I CURRENT PHI 4 SETTING JSB SDPHI SET PPOLL MASK LDA IFX5,I CURRENT PHI 5 SETTING JSB SDPHI SET PPOLL NORMALIZATION MASK JSB STAT2 GET INTERRUPT STATE LDB IFX3,I CURRENT PHI 3 SETTING OTB PHI SET PHI REG 3: PPOLL,(SRQ) STC PHI,C AND 1 ISOLATE POSSIBLE PPOLL & SRQ SZA EITHER WAITING? LDA B2 YES, SET HOLD SO INTERRUPT IS SERVICED JMP ID.37,I EXIT VIA PHYSICAL DONE SPC 5 * HERE UPON EXPECTED TIMEOUT CONTT CLB STB IFX1,I CLEAR PROCESSING STATE * CONTX CLA,INA LDB $IF5,I GET DVT ADDR JSB $DIOC SET-UP DVT ADDRS LDB IFX2,I JMP 1,I GO TO CONTINUATION ADDR * DVSET LDB $IF5,I DVT ADDR CLA,INA JSB $DIOC SET-UP DVT ADDRS JMP NEWRQ NOW START REQUEST SKP * * "NOBZY" HANDLES ASYNCHRONOUS INTERRUPTS WHEN IFT IS * AVAILABLE. INTERRUPT MUST BE A PARALLEL POLL OR SRQ. * * NOBZY JSB STAT2 GET PHI 2 STAT AND IFX3,I ASR 4 SLA,ERA WAS SRQ SET? JMP SRQIN YES, GO PROCESS IT SLA,RSS WAS PPOLL INTERRUPT SET? JSB ILLIN NO, ILLEGAL INTERRUPT * PARALLEL POLL INTERRUPT RECEIVED LDA .1 JSB RDPHI READ PHI REG 0 (P.POLL) AND IFX4,I TEST ONLY THOSE ENABLED LDB N8 STB TEMP1 STB TEMP2 CLB,INB * PPOL1 SLA,RAR SEARCH FOR RAISED LINE JMP PPOL2 FOUND IT RBL ISZ TEMP2 n)JMP PPOL1 KEEP LOOKING JSB ILLIN ILLEGAL INTERRUPT * PPOL2 JSB PPCLR DISABLE THIS PPOLL LINE ASR 16 CMA A HAS POLL LINE MASK, B=-1 ADB IFXPP PPOLL TABLE ADDR PPOL3 ADB B4 POINT TO 4TH WORD CPA 1,I IS THIS ENTRY FOR THIS LINE JMP RESUM YES ISZ TEMP1 ALL EXAMINED? JMP PPOL3 NO PCONT ISZ ID.37 YES, NOT FOUND, IGNORE INTERRUPT JMP SETRG SET PHI, GO OUT PHY CONTINUE * .0450 OCT 45000 .11 OCT 110000 .12 OCT 120000 .1410 OCT 141000 B1 OCT 1 B10 OCT 10 B100 OCT 100 B137 OCT 137 B16 OCT 16 B2 OCT 2 B3 OCT 3 B34 OCT 34 B40 OCT 40 B400 OCT 400 B405 OCT 405 B425 OCT 425 B500 OCT 500 B55 OCT 55 B77 OCT 77 BN6 OCT 31040 ENABLE PPOLL INT ONLY .4ALL OCT 40377 N1 DEC -1 N2 DEC -2 N3 DEC -3 N4 DEC -4 N8 DEC -8 N9 DEC -9 HED 92070-18056 HPIB DRIVER - PARALLEL POLL HANDLING * ***************************************************** * "PSTAT" READS THE HPIB PARALLEL POLL STATUS (SUBFUNCTION 6) ***************************************************** PSTAT CLA,INA FLUSH IOR IFX6,I INCLUDE REN STATE JSB SDPHI PHI CONDUCTS PPOLL WHEN FIFOS EMPTY LDA .4ALL ENABLE ALL POLL LINES JSB SDPHI (PHI 4) LDA .05 NO NORMALIZATION JSB SDPHI (PHI 5) LDA .1 JSB RDPHI READ PHI REG 0 LDB 0 LIA CARD+1 READ CARD STATUS REG AND .1774 RTN HI BITS ONLY IOR 1 INCLUDE PHI REG 0 STA $DV18,I STORE PP RESPONSE IN $DV18 * LDA .12 JSB RDPHI READ PHI REGISTER 2 ALF,ALF LDB 0 SAVE IN BITS 15-8 OF B LDA .11 ADDRESS PHI REG 1 JSB RDPHI READ PHI STATUS REG. 1 IOR 1 MERGE WITH REG 2 STATE STA $DV19,I JMP PDONE COMPLETE REQUEST SPC 3 * * ENTER HERE FOR A PARALLEL POLL ENABLE CONTROL REQUEST (FUNCTION 40) * PENAB LDA N8 LDB IFXPP ADDR OF PPOLL TABLE JSB PTBLE BUILD ENTRY IN TABLE JMP PDONE EXIT SPC 3 * * HERE FOR PARALLEL POLL DISABLE CONTROL REQUEST (FUNCTION 41) * PDSAB LDA N8 LDB IFXPP ADDR OF PPOLL TABLE JSB SERCH FIND ENTRY CLA STA 1,I CLEAR IT INB POINT TO ID SEG # STA 1,I CLEAR IT ADB B2 STB TEMP4 LDB 1,I GET DIO LINE STA TEMP4,I CLEAR TABLE JSB PPCLR CLEAR MASKS FOR PHI 4,5 JMP PDONE EXIT SKP * * HERE FOR PPOLL INTERRUPT ENABLE CONTROL REQUEST (FUNCTION 23) * INTBU LDB $DV16,I BUS LU - GET PRAM1 LDA B425 PPU (WITH ATN) CPB B2 PRAM1=2? JMP SDNOW YES, SEND UNIVERSAL PPU * JSB SENDZ SEND CALLER-SPECIFIED ADDRS NOP OK IF NO Z-BUFFER * INTEX LDB $DV16,I CPB B1 IS IT A DISABLE? JMP INTOF YES * PROCESS PPOLL INTERRUPT ENABLE LDA $DV17,I GET DIO LINE # (1-8) SSA CMA,INA ABS VALUE OF DIO LINE JSB PPENT VERIFY IT & GET MASK LDA $DV1 DVT ADDRESS CPA TEMP5,I SETTING UP NEW ENTRY? JMP INTE3 NO CLB YES DST TEMP5,I SET DVT ADDR, NO PGM INTE3 LDB $DV17,I GET DIO LINE PARAMETER SSB,RSS WAS SENSE REVERSED? JMP INTE5 NO LDA TEMP1 YES IOR IFX5,I SET NORMALIZE MASK STA IFX5,I FOR PHI 5 PROGRAMMING CMB,INB GET POSITIVE DIO LINE # ADB B10 SET "S"=1, INTERRUPT WITH A 0 INTE5 ADB B537 BUILD PPE: DIO RANGE= 0-7, ATN JMP INTO9 GO SET-UP TO BUILD CMD BUFFER * * DISABLE PPOLL INTERRUPT FOR THIS DIO LINE INTOF LDA N8 LDB IFXPP JSB SERCH FIND PPOLL TABLE ENTRY ADB B3 YES, POINT TO DIO LINE LDB 1,I GET MASK (MAY BE ZERO) V JSB PPCLR CLEAR PHI4 & PHI5 MASK BITS LDB B560 GET A "PPD" - PARALLEL P0LL DISABLE INTO9 LDA $DVTP,I GET DEVICE ADDR CPA B36 IS THIS THE BUS LU? JMP PPLBU YES STB TEMP2 SAVE 2ND CMD WORD FOR "BDADS" LDA B405 "PPC" JMP SDCMD SEND ADDRESSED CMDS * PPLBU LDA B405 PPC + ATN DST * BUFST EQU *-1 DEFINE CMD BUFFER PNTR LDA .1410 DMA CONWD=CONT,STC,FOUR CLB JSB PUT2 STORE 1ST 2 QUAD WORDS LDA BUFST SEND 2 (PPC,PPD) OR (PPC,PPE) JMP OVR50 COMPLETE WITH B.E. INTERRUPT SKP * * THIS SUBROUTINE CLEARS PARALLEL POLL MASK BITS PASSED * IN THE A REGISTER. THE PHI REG 4 & 5 MASKS SAVED IN THE IFT * EXTENSION ARE UPDATED & THE WORDS ARE OUTPUT IMMEDIATELY TO * PROGRAM PHI REGS 4 & 5 TO DISABLE THE PPOLL INTERRUPT. * PPCLR NOP CMB LDA IFX4,I CLEAR THE BIT IN THE MASK WD AND 1 STA IFX4,I LDA IFX5,I AND 1 CLEAR NORMALIZE BIT STA IFX5,I NORMALIZE MASK WORD JMP PPCLR,I SPC 2 * * SUBROUTINE TO VERIFY A PASSED PARALLEL POLL LINE # * FIND A PPOLL TABLE ENTRY, & SET THE PHI 4 MASK WORD * PPENT NOP JSB VLINE GET DIO LINE MASK LDA N8 LDB IFXPP JSB SERCH FIND PPOLL ENTRY STB TEMP5 SAVE ITS ADDR ADB B3 LDA TEMP1 BIT MASK STA 1,I STORE IN 4TH WD OF TABLE IOR IFX4,I UPDATE PHI 4 MASK STA IFX4,I JMP PPENT,I RETURN SPC 2 * * SUBROUTINE TO COMPUTE MASK FOR DIO LINE * VLINE NOP ADA N1 RANGE FROM 0-7 SSA WAS IT LESS THAN 1? JMP REJ1 YES, ERROR ADA N8 CMA,SSA,INA WAS IT > 8? JMP REJ1 YES, ERROR ADA ASR0 STA TEMP1 FORMED ASR INSTRUCTION LDB B400 TEMP1 NOP SHIFT BIT INTO POSITION STB TEMP1 SAVE MASK JMP VLINE,I 1 RETURN ASR0 OCT 101020 ASR 0 HED 92070-18056 HPIB - SERIAL POLL PROCESSING * * ENABLE SERIAL POLL (FUNCTION=20) * IF DVT16-18 NOT ZERO, IT CONTAINS NAME OF PROGRAM TO * SCHEDULE UPON POSITIVE RESPONSE TO A SERIAL POLL. IN * THIS CASE, THE PARAMETER IN DVT19 WILL BE PASSED TO THE * PGM IN ITS 2ND SCHEDULING PARAMETER. * SRENB LDA SRQ# NEG # OF SPOLL TABLE ENTRIES LDB IFXSP ADDR OF SPOLL TABLE JSB PTBLE BUILD ENTRY LDA BN3 ENSURE SRQ INTERRUPT IS ENABLED JMP SRDI8 GO OUT PHYSICAL DONE SPC 3 * * PROCESS DISABLE SERIAL POLL CONTROL REQUEST (FUNCTION = 21) * SRDIS LDA SRQ# STA TEMP4 LDB IFXSP ADDR OF SPOLL TABLE JSB SERCH FIND ENTRY FOR THIS DEVICE CLA CPA 1,I IS THIS ENTRY BUILT? JMP PDONE NO, FINISHED STA 1,I CLEAR SPOLL TABLE ENTRY LDB IFXSP * SEE IF ANY ENTRIES ARE LEFT IN SPOLL TABLE, IF NOT, DISABLE SRQ SRDI4 CPA 1,I IS THIS ONE EMPTY? RSS YES JMP PDONE NO, LEAVE SRQ ENABLED ADB B4 ISZ TEMP4 MORE? JMP SRDI4 YES LDA BN6 =31040 - PHI 3 - ENABLE PPOLL * SRDI8 STA IFX3,I SET INTERRUPT MASK JMP PDONE DONE SPC 5 * * CONDUCT A SERIAL POLL (FUNCTION = 6) * SRQST LDA SRQ# LDB IFXSP ADDR OF SPOLL TABLE JSB SERCH FIND ENTRY CLA CPA 1,I WAS THERE AN ENTRY? JMP SRQS5 NO, POLL IT NOW ADB B3 YES, POINT TO POSSIBLE STATUS WD * NOW SEE IF A POSITIVE SERIAL POLL RESPONSE WAS RECEIVED IN WHICH * THE REQUIRED PROGRAM COULD NOT BE SCHEDULED BECAUSE IT WAS NON- * DORMANT (AFTER 2 TRIES) CPA 1,I IS THERE ONE? JMP SRQS5 NO, SO POLL NOW LDA 1,I YES, GET THAT STATUS BYTE STA $DV18,I & RETURN IT NOW JMP POLEX GO CLEAR BYTE FROM TABLE * SRQS5 LDA $DVTP,I GET DEVICE ADDR JS@B SPOLL SET-UP POLL QUAD & DO IT * HERE AFTER POLL IS COMPLETED LDA .1 NOW READ INBOUND FIFO TO JSB RDPHI GET RETURNED STATUS BYTE STA $DV18,I & RETURN IT IN DVT18 JMP PDONE PHY DONE SKP ************************************************************* * THIS SECTION IS ENTERED TO CONDUCT SERIAL POLLS OF ALL * DEVICES IN THE SERIAL POLL TABLE WHEN AN SRQ INTERRUPT IS * RECEIVED. WHEN A POSITIVE RESPONSE IS RECEIVED, EITHER * A DESIGNATED PGM WILL BE SCHEDULED OR THE LOGICAL DRIVER * WILL BE RESUMED. THE ENTIRE POLL IS CONDUCTED WITH PHY. * HOLD SET SO THAT NO NEW REQUESTS WILL BE INITIATED. ************************************************************* * SRQIN LDB SRQ# SIZE OF S.POLL TABLE INB CMB,INB GET POS #-1 BLS,BLS *4 TO INDEX TO LAST ADB IFXSP POINT TO LAST ENTRY IN TABLE * SRQ2 LDA 1,I RAL,CLE,SLA,ERA IS THIS ENTRY EMPTY? JMP SRQ6 NO * SRQ4 CPB IFXSP ALL ENTRIES EXAMINED? JMP *+3 YES ADB N4 JMP SRQ2 GO CHECK NEXT * NO DEVICE GAVE A POSITIVE SERIAL POLL RESPONSE LDA BN6 SET PHI 3 INTERRUPT ENABLE MASK STA IFX3,I TO NOT ENABLE SRQ JSB SDPHI LDA B4 BIT2= ENABLE CARD INTERRUPT OTA CARD SET IT CLF PHI CLEAR CARD FLAG JSB ILLIN SERIAL POLL FAILURE, GIVE ILLEGAL INT * SRQ6 STB IFX8,I SAVE SPOLL ENTRY'S ADDR ADA B14 POINT TO DVT13 LDB 0,I GET DEVICES T.O. STB $IF2,I MOVE PHY T.O. ADA B12 POINT TO DVTP (HP-IB ADDR) LDA 0,I GET DEVICE ADDR JSB SPOLL PERFORM A SERIAL POLL OF THE DEVICE LDA .1 ADDRESS INBOUND FIFO JSB RDPHI READ THE STATUS BYTE STA TEMP1 SAVE STATUS BYTE AND B100 TEST BIT 6 LDB IFX8,I GET SPOLL ENTRY ADDR SZA,RSS IS THIS A POSITIVE RESPONSE? JMP SRQ4 NO ADB B3 POINT TO SPOLL WORD 4 LDA TEMP1 STATUS BYTE STA 1,I SKP ****************************************************************** * THIS SECTION IS ENTERED WHEN A PARALLEL POLL OR POSITIVE * RESPONSE TO A SERIAL POLL IS RECEIVED. THE ADDRESS OF * THE POLL TABLE ENTRY IS IN THE B REGISTER. ***************************************************************** * RESUM ADB N3 POINT TO 1ST WORD OF POLL TABLE STB IFX8,I ENTRY & SAVE IN IFT EXT. CCA STA IFX7,I SET 1ST TRY FLAG * RESU2 INB 2ND WORD OF TABLE LDA 1,I SZA,RSS IS LOGICAL DRIVER RESUME REQUIRED? JMP LGRES YES STB TEMP2 AND B377 ISOLATE ID SEGMENT # ADA N1 MPY $IDSZ ADA $IDA A= ID SEG ADDR STA DMNXT SAVE IT ADA B34 POINT TO WORD 29 LDA 0,I GET SCHEDULING SEQ # XOR TEMP2,I AND .17 ISOLATE BITS 15-12 CCE,SZA HAS ID SEGMENT BEEN RERUN? JMP PGERR YES, CLEAR TABLE ENTRY & GIVE MSG * LDA DMNXT ID SEGMENT ADDR ADA B17 LDA 0,I GET ID SEG STATUS AND B77 BITS 5-0 SZA DORMANT? JMP BZPGM NO * WE CAN NOW GO AHEAD & SCHEDULE THE PROGRAM LDB DMNXT B = ID SEG ADDR JSB $LIST PUT PGM IN SCHEDULED LIST B60 OCT 60 LDB IFX8,I GET DVT ADDR LDB 1,I ELB,CLE,ERB CLEAR SIGN JSB $DVLU COMPUTE LU ISZ DMNXT JSB PUT STORE 1ST PARAMETER LDB IFX8,I ADDR OF TABLE ENTRY ADB B2 POINT TO 3RD WORD OF ENTRY LDA 1,I GET OPT PARAMETER JSB PUT RETURN AS 2ND USER PARAMETER INB LDA 1,I 4TH WORD OF SPOLL ENTRY HAS SERIAL STA DMNXT,I POLL STATUS, RTN IN PGMS TEMP3 * POLEX CLA STA 1,I ZERO OUT POLL TABLE WORD JMP PCONT * PGERR JSB EMSG XGPRINT "NO PROG" ASC 2,PROG JMP POLEX SPC 4 * * HERE WHEN UNABLE TO SCHEDULE PGM BECAUSE IT'S BUSY * BZPGM ISZ IFX7,I 1ST TRY? JMP PDONE NO, LEAVE STATUS BYTE IN SPOLL WD 4 LDB N10 100 MSEC DELAY JSB EXIT3 EXIT WITH HOLD SET * RETURN HERE AFTER DELAY LDB IFX8,I GET ADDR OF POLL TABLE ENTRY JMP RESU2 AND TRY SCHEDULE ONE MORE TIME SPC 3 * * HERE WHEN LOGICAL DRIVER RESUME IS REQUIRED LGRES ADB B2 POINT TO POLL TABLE WORD 4 CLA STA 1,I CLEAR DIO LINE ADB N3 POINT TO POLL TABLE WORD 1 STB TEMP2 LDB 1,I GET DVT ADDR STA TEMP2,I CLEAR FROM TABLE ISZ ID.37 SET TO GO OUT LOGICAL RESUME EXIT ISZ ID.37 JMP ERSET+1 SKP *************************************************** * THIS SUBROUTINE BUILDS A SERIAL POLL QUAD, MOVES * THE COMMAND BUFFER TO THE IFT EXTENSION AND * INITIATES DMA TO PERFORM THE POLL * A REG HAS HPIB DEVICE ADDRESS ON ENTRY *************************************************** * SPOLL NOP IOR B500 FORM DEVICE TALK CMD STA DEVLN STORE IN CMD BUFFER LDA .03 DISABLE ALL CARD INTERRUPTING JSB SDPHI CONDITIONS (PHI 3) LDA B3 SET OUT,FLUSH IOR IFX6,I & CURRENT STATE OF REN JSB SDPHI & SEND IT LDB $IFTX IFT EXTENSION ADDR STB DMNXT ADDR OF QUAD LDA .0450 STC,CINT,FOUR JSB PUT STORE DMA QUAD CONWD LDA B4 ENABLE CARD INTERRUPT OTB DMA SET DMA SELF-CONFIG. ADDR ADB B60 COMPUTE ADDR OF CMD BUFFER JSB PUT2 STORE 2ND & 3RD QUAD WDS LDA N8 8 WORDS IN CMD BUFFER JSB PUT PUT 4TH QUAD WD LDA #SPOL LOCAL CMD BUFFER ADDR JSB .MVW MOVE 8 WORDS TO IFTX DEF B10 NOP CLA OTA CARD CLEAR CARD CLF PHI & ITS FLAG STC DMA,C START DMA LDB SPOLL RTN ADDR FOLLOWING INTERRUPT STB IFX2,I SAVE CONTINUATION ADDR CLB,INB PROCESSING STATE = 1 JMP EXIT4 EXIT SPC 2 ******************************************************** * SEARCH FOR A TABLE ENTRY FOR THIS DVT ******************************************************** SERCH NOP SSA,RSS JMP ER20 NO ENTRIES IN TABLE STA TEMP4 NEG # OF ENTRIES CLA STA TEMP2 CONTAINS ADDR OF AVAILABLE TABLE ENTRY * SERC2 LDA 1,I GET 1ST WORD ELA,CLE,ERA CLEAR SIGN CPA $DV1 ENTRY ALREADY IN TABLE? JMP SERCH,I YES CPA TEMP2 IS THIS 1ST ENTRY AVAILABLE? STB TEMP2 YES, SAVE ITS ADDR ADB B4 POINT TO NEXT TBL ENTRY ISZ TEMP4 MORE? JMP SERC2 YES LDB TEMP2 SZB WAS THERE AN AVAILABLE ENTRY? JMP SERCH,I YES, RETURN ADDR OF AVAILABLE ENTRY * ER20 LDA BN5 =40024 - NO TABLE SPACE JMP ERROR SPC 4 * .17 OCT 170000 B12 OCT 12 B14 OCT 14 B560 OCT 560 BN3 OCT 31060 BN5 OCT 140024 SPOLL TABLE FULL ERROR N10 DEC -10 ***************************************************************** * THIS SUBROUTINE IS USED TO SET UP TABLE ENTRIES FOR * BOTH THE SERIAL POLL AND PARALLEL POLL TABLE * THE FORMAT OF A POLL TABLE ENTRY IS: * WORD 1 - BIT 15 = 1(SERIAL POLL) OR 0(PARALLEL POLL) * BITS 14-0 = DVT ADDRESS * (ALL ZERO IF ENTRY NOT IN USE) * WORD 2 - BITS 15-12= ID SEGMENT SCHEDULING SEQUENCE # * - BITS 7-0 = ID SEGMENT # (1-255) * (ALL ZERO IF LOGICAL DRIVER RESUME REQUIRED) * WORD 3 - OPTIONAL PARAMETER TO BE RETURNED TO PGM TO * BE SCHEDULED * WORD 4 - STATUS BYTE RETURNED FROM SERIAL POLL IF UNABLE * TO SCHEDULE DESIGNATED PGM ON POSITIVE RESPONSE ***************************************************************** PTBLE NOP JSB SERCH FIND POLL TABLE ENTRY STB TEMP4 SAVE ENTRY ADDRESS LDA $DV16,I GET 1ST 2 CHARS OF PGM NAME CLE,SZA,RSS SPECIFIED? JMP PTBL2 NO, THEN LOGICAL RESUME LDB $DV16 ADDR OF 16-18TH DVT WORDS STB *+2 POINTS TO PGM NAME JSB $NAME CONVERT NAME TO ID SEG ADDR TEMP2 NOP SZB,RSS DOES PGM EXIST? JMP REJ1 NO, RETURN ILLEGAL REQUEST ERROR JSB $RUN# GET SEQ#/ID # PTBL2 LDB FUNCT CPB B20 SERIAL POLL ENTRY? CCE YES LDB 0 VALUE FOR 2ND TABLE WD LDA $DV1 RAL,ERA SET SIGN IF SPOLL DST * STORE 1ST 2 WORDS TEMP4 EQU *-1 ISZ TEMP4 ISZ TEMP4 LDA $DV19,I CALLERS OPT PARAMETER CLB STATUS/DIO LINE = 0 DST TEMP4,I STORE WORD 3 & 4 OF POLL ENTRY JMP PTBLE,I RETURN SPC 4 **************************************** * PRINT MESSAGE FOR SERIAL POLL FAILURE **************************************** EMSG NOP DLD EMSG,I DST MTYP ISZ EMSG ISZ EMSG BUMP RTN ADDR LDB IFX8,I GET PPOLL ENTRY ADDR LDB 1,I GET DVT ADDR ELB,CLE,ERB JSB $DVLU COMPUTE LU JSB $CVT1 CONVERT TO ASCII STA MLU JSB $SYMG LOG MSG ON CONSOLE DEF SPMSG LDB IFX8,I GET POLL TABLES ADDR JMP EMSG,I HED 92070-18056 HPIB DRIVER - GENERAL SUBROUTINES ******************************************************************* * "EXIT1" IS USED WHENEVER A CONTINUATION INTERRUPT IS EXPECTED * THE RETURN ADDRESS IS AT IFX8 ******************************************************************* EXIT3 NOP STB $IF2,I SET TIMEOUT VALUE LDA EXIT3 RTN ADDR STA IFX2,I CONTINUE ADDR ON TIMEOUT EXIT4 LDA B3 SET HOLD AND TIMEOUT FLAGS STB IFX1,I STORE PROCESSING{ STATE JMP EXITC GO OUT PHYSICAL WAIT SPC 2 ******************************************* * ILLEGAL REQUEST ERROR ******************************************* REJ1 LDA BN7 =140001 - DON'T DOWN,FLUSH JMP ERSET TAKE DONE EXIT SPC 2 ************************************************ * ILLEGAL INTERRUPT DETECTED ************************************************ ILLIN NOP **TEMP JSB RESET LDA B4 JMP EXITC GO OUT PHY CONTINUE SPC 2 ****************************************************** * "STAT2" READS PHI REG STATUS ****************************************************** STAT2 NOP CLB OTB DMA+1 CLR DMA CONWORD SO IN WORD MODE LDA BN4 =30377 ENABLE ALL INT FLAGS JSB SDPHI LDA BN9 =120004 - ENABLE CARD INT JSB RDPHI READ PHI REG 2 (INTERRUPTS) JMP STAT2,I SPC 2 ****************************************************** * "SDPHI" SENDS WORD IN A REGISTER TO PHI ****************************************************** SDPHI NOP OTA PHI STC PHI,C JMP SDPHI,I SPC 2 **************************************************** * READ A PHI REGISTER **************************************************** RDPHI NOP OTA CARD SELECT PHI VIA CARD S.C. STC PHI,C LIA PHI READ SELECTED PHI REGISTER AND B377 BITS 15-8 ALWAYS ZERO JMP RDPHI,I RETURN * BN4 OCT 30377 BN7 OCT 140001 REQ ERROR, FLUSH, DON'T DOWN BN9 OCT 120004 * SRQ# NOP * CRLF OCT 6412 CARRAIGE RTN, LINE FEED #SPOL DEF *+1 B537 OCT 537 UNTALK B477 OCT 477 UNLISTEN OCT 430 SPE DEVLN NOP OCT 476 CONTROLLER LISTENS OCT 1001 COUNTED RCV ONE EMPTY OCT 31002 PHI OUT FIFO EMPTY INT SPD OCT 431 SPD * SPMSG OCT 40001 DEC -22 ASC 6,*POLL ER:NO MTYP BSS 2 ASC 2, LU MLU NOP * TEXTENSION FOR MISC STORAGE IFX DEF IFX1 * IFX1 - 0=NORMAL PROCESSING, 1=CONTINUE ON INTERRUPT, 2=TIMEOUT * CLEANUP IN PROGRESS, 3=CLEANUP PRIOR TO STARTING NEW, * REQUEST, 4=ABORT IN PROGRESS, NEGATIVE=TIMEOUT EXPECTED IFX1 NOP CURRENT PROCESSING STATE IFX2 NOP CONTINUATION ADDR (IF NON-ZERO) IFX3 NOP CURRENT PHI 3 INTERRUPT MASK IFX4 NOP CURRENT PHI 4 PPOLL MASK IFX5 NOP CURRENT PHI 5 PPOLL NORMALIZE MASK IFX6 NOP CURRENT PHI 6 REN STATE IFX7 NOP RESIDUE LOC OR SPOLL 1ST PGM SCHED FLAG IFX8 NOP "DOIFC" RTN ADDR OR POLL TABLE ADDR IFXPP NOP 32 WORD PPOLL TABLE ADDR IFXSP NOP 4*N WORD SPOLL TABLE * GARB BSS 4 GARBAGE BUFFER FOR INPUT FIFO CLEANOUT * END ߮ ! 92070-18096 1941 S C0122 &ID.43              H0101 []ASMB,R * * NAME: ID.43 * SOURCE: 92070-18096 * RELOC: 92070-16096 * PGMR: C.H.W. * * **************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT * * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * **************************************************************** * * NAM ID.43,0 92070-16096 REV.1941 800324 * ENT PI.43,ID.43,$PIFT ENT $$POW,$.POW * EXT $IOTI,$LIST,$POWF EXT $NAME,$MESS,$IOCX EXT $IFTA,$IFT#,$DVTA,$DVT# EXT $MPTF,$MPFN,$Q.PV,$TIME SUP * * * * THIS IS THE RTE-L POWER FAIL AUTO RESTART ROUTINE. * * ID.43 REQUIRES AN IFT ENTRY: * 04,ID.43 * * ID.43 REQUIRES AN INTERRUPT ENTRY: * 04,ENT,PI.43 * * * * IT WORKS AS FOLLOWS: * * ON POWER FAILURE: * 1. LEVEL 2 (POWER-FAIL) & LEVEL 3 INTERRUPTS ARE DISABLED * 2. ALL REGISTERS ARE SAVED, ALSO RETURN ADDRESS * 3. THE DRIVER WAITS FOR POWER TO BE RESTORED (HLT 4). * * ON POWER UP: * 1. THE CURRENT SYSTEM TIME IS SAVED (THIS WILL BE THE * TIME OF POWER FAILURE). * 2. THE CLOCK IS RESTARTED * 3. THE IFT FOR THE POWER-FAIL DRIVER IS QUEUED ON THE * SYSTEM "PRIVILEGED DONE QUEUE" AND IFT7(15) IS SET * SO ID.43 WILL BE REENTERED FROM THE SYSTEM ON A * CONTINUATION. * 4. LEVEL 2 & 3 INTERRUPTS ARE REENABLED AND A RETURN WITH * REGISTERS RESTORED IS MADE TO THE POINT OF THE * POWER FAIL INTERRUPT. * * * ON THE FOLLOWING CONTINUATION ENTRY THE FOLLOWING ACTION IS * TAKEN: * * 1. THE PHYSICAL DRIVER FOR EACH IFT ENTRY IS CALLED (USING * "$POWF" IN IOC) FOR A POWER-FAILURE. * 2. EACH DVT ENTRY WHICH IS BUSY WITH A REQUEST HAS IT'S * "P"-BIT CHECKED. IF SET, AND A LOGICAL DRIVER EXISTS, * IT IS CALLED FOR A POWER-FAIL. * * SOME DEVICES WILL BE REPORTED DOWN IF THEIR POWER * WAS ALSO CUT E.G. MAGTAPE, DISC. THESE DEVICES * MAY BE UPPED BY THEIR DRIVERS WHEN THEY * COME BACK ON LINE E.G. THE DISC. * * 3. IF THE DEVICE IS DOWN THE SYSTEM UP PROCESSOR WILL * BE CALLED TO UP THE DEVICE. THIS WILL CAUSE * THE DOWNED DEVICES TO HAVE NEW MESSAGES POSTED * ON THE SYSTEM TTY. * * 4. THE PROGRAM "AUTOR" IS CHECKED, AND IF DORMANT, IT IS * SCHEDULED AND PASSED THE TIME OF THE LATEST POWER-FAIL. * IF IT IS NON-DORMANT, IT IS ABORTED WITH A "$MESS" CALL * AND ID.43 PUTS ITSELF IN THE TIME LIST FOR 100 MSECS. * WHEN ID.43 IS REENTERED ON A TIMEOUT, IT RETRIES TO * SCHEDULE AUTOR (UP TO 100 TIMES). * (THE ABORT IS TO ALLOW FOR MOMENTARY POWER UPS.) * AUTOR SHOULD TAKE WHATEVER ACTION IS NEEDED TO * BRING UP THE SYSTEM IN TERMS OF ENABLING TERMINALS - * COMMUNICATION LINES ETC. * * * NOTE THE FOLLOWING: * THE 21-L PROCESSOR ALLOWS 10 MILLISECONDS OF POWER-DOWN * PROCESSING FOLLOWING THE DOWN INTERRUPT, THEREFORE THIS * DRIVER ACTUALLY DISABLES THE P.F. INTERRUPT DURING CRITICAL * PORTIONS OF PROCESSING TO SIMPLIFY P.F. REENTRANCE AVOIDANCE * TECHNIQUES WHICH WERE PREVALENT IN PREVIOUS RTE P.F. DRIVERS * * THE POWER-FAIL IFT IS ALWAYS CREATED WITH "M" SET SO THAT * ONLY ID.43 ITSELF WILL PLACE THE IFT IN THE TIME-LIST USING * THE IOC "IOTI" ROUTINE. HED POWER UP/DOWN ENTRY POINT/ DOWN CODE. PI.43 NOP POWER UP/DOWN ENTRY CLC 4 DISABLE LEVEL 2 & 3 INTERRUPTS SFC 4 UP? JMP UP YES, GO RESTORE MACHINE STATE * * DOWN ROUTINE * STA ASAVE SAVE A-REG. LIA 0 STA IMASK SAVE INTERRUPT MASK LIA 2 SFS 2 SKIP IF GLOBAL REG DISABLED IOR BIT15 BIT15=1 WHEN ENABLED CLC 0,C DO CRS, INITIALIZE/STOP ALL I/O CLC 4 & LEAVE P.F. INTERRUPT OFF STA GLOBL SAVE GLOBAL REGISTER STB BSAVE SAVE B-REG ERA,ALS SOC SET LEAST BIT OF A IF OVERFLOW INA WAS SET, SIGN = E REG STA EOSAV SAVE E/O LDA PI.43 SAVE INTERRUPT STA PSAVE LOCATION CLA CPA SWTCH LAST A DOWN? JMP HALT YES! 2 SUCCESSIVE DOWNS BUY THE FARM STA SWTCH INDICATE LAST WAS SUCCESSFUL DOWN * * WAIT FOR POWER-UP, IF POWER GOES ALL THE WAY DOWN, "UP" * WILL BE REENTERED BY INTERRUPT. WAIT SFS 4 JMP *-1 HED POWER UP ROUTINE UP LDA SWTCH SZA LAST A DOWN? JMP HALT NO! 2 SUCCESSIVE UP'S * LDA TIME+2 IF TIME IN HAND SZA THEN DO NOT JMP NIXTM SAVE IT AGAIN * DLD $TIME GET THE TIME OF DAY DST TIME AND SAVE IT LDA $TIME+2 GET ADDRESS STA TIME+2 * NIXTM STC 6 START TBG LDA STC7 INSTRUCTION TO ENABLE M.P. LDB $MPTF GET SYSTEM MEMORY PROTECT FLAG CCE,SZB DID P.F. COME WHILE IN THE SYSTEM LDA STC4 YES, LEAVE MEMORY PROTECT DISABLED STA SWTCH * * NOW ENTER THE POWER-FAIL IFT ON THE PRIVILEGED DONE QUEUE * SO THAT THE SYSTEM WILL REENTER ID.43 ON A NORMAL CONTINUATION * JSB ONPRV SEE IF ALREADY ON PRIV QUEUE JMP REGUP IT IS, DON'T LINK IT TO ITSELF LDA $Q.PV HEAD OF PRIVILEGED DONE QUEUE STB $Q.PV PUT P.F. IFT AT HEAD (LIFO) STA 1,I ADB N1 POINT TO IFT7 LDA 1,I RAL,ERA SET BIT 15 STA 1,I FORCING CONTINUATION RETURN * REGUP LDA EOSAV RESTORE THE REGISTERS CLO n SLA,ELA STO * LDA IMASK OTA 0 RESTORE INTERRUPT MASK LDA GLOBL OTA 2,C RESTORE/ENABLE GLOBAL REG SSA,RSS WAS IT DISABLED? STF 2 YES LDA $MPFN OTA 7 RESTORE THE FENCE LDA ASAVE LDB BSAVE STF 0 STC4 STC 4 ENABLE LEVEL 2 & 3 INTERRUPTS SWTCH STC 7 ENABLE M.P. UNLESS IN SYSTEM JMP PSAVE,I RETURN TO POINT OF INTERRUPT * SPC 3 STC7 STC 7 ASAVE NOP BSAVE NOP EOSAV NOP IMASK NOP GLOBL NOP * .2 DEC 2 .3 DEC 3 .6 DEC 6 .7 DEC 7 .12 DEC 12 .20 DEC 20 .22 DEC 22 BIT15 OCT 100000 N1 DEC -1 N10 DEC -10 N100 DEC -100 B177 OCT 177 B777 OCT 777 * IDSGA NOP NCNT NOP TRIES NOP ABFLG NOP PSAVE DEF HALT P-REG SAVE (HLT DEF IF HALTED) TIME DEC 0,0,0 TIME SAVE LOCATION ON UP ATIME DEC 0,0,0 TIME TO PASS TO "AUTOR" $PIFT NOP * HALT HLT 4,C JMP *-1 HED NON-PRIVILEGED POWERFAIL PHYSICAL DRIVER * ID.43 NOP CPA .3 ENTERED ON TIMEOUT? JMP SCHED YES, RETRY AUTOR SCHEDULE CPA .2 CONTINUE? JMP CONT YES CLA ISZ ID.43 GET OUT IMMEDIATELY JMP ID.43,I PHY CONTINUE EXIT * * JUST POWER-UP'ED, PERFORM POWER-FAIL ENTRY TO DRIVERS * CONT LDA $IFT# # OF IFTS IN SYSTEM LDB $IFTA ADDRESS OF IFTS CMA,CCE,RSS DVRPF CMA,CLE STA NCNT - # OF TABLE ENTRIES -1 * DVRNX ISZ NCNT MORE ENTRIES? JMP DCALL YES * LDA $DVT# # OF DVTS LDB $DVTA ADDR OF DVTS SEZ ALREADY DID DVTS? JMP DVRPF NO, GO DO THEM * * ALL I/O REQUEST RECOVERY IS COMPLETED * LDA N100 STA TRIES TRY UP TO 100 TIMES TO SCHED AUTOR * SCHED JSB $NAME GET ID SEG ADDR OF "AUTOR" DEF AUTOR SZB,RSS IS IT IN SYSTEM? JMP $IOCX NO, DONE CC<E,SZA IS IT DORMANT? JMP AUTBZ NO STB IDSGA SAVE AUTOR ID SEG ADDR * DISABLE ANY P.F. INTERRUPT TIL AUTOR IS SCHEDULED CLC 4 LDB ABFLG STA ABFLG FLG THAT AUTOR WAS DORMANT SZB DID LAST AUTOR RUN FINISH? JMP TPASS NO, KEEP TIME IN HAND * LAST AUTOR SCHEDULE COMPLETED, SO LATEST TIME OF * POWER-FAIL ("TIME") CAN NOW BE PASSED LDA TIME STA ATIME LDA TIME+1 STA ATIME+1 LDA TIME+2 STA ATIME+2 STB TIME+2 "UP" CAN NOW SAVE TIME OF NEXT P.F. * * NOW SCHEDULE AUTOR & PASS THE TIME OF POWER-FAIL TPASS LDB IDSGA LDA ATIME INB STA 1,I INB STB NXADR DLD ATIME+1 DST * PASS 2ND & 3RD TIME WORDS NXADR EQU *-1 * LDB IDSGA JSB $LIST SCHEDULE AUTOR OCT 60 RENBL STC 4 REENABLE POWER-FAIL INTERRUPTS JMP $IOCX EXIT * * AUTOR NON-DORMANT, ABORT IT ONCE & KEEP TRYING TO SCHEDULE * IT FOR 10 SECONDS AT 100 MILLISECOND INTERVALS. AUTBZ ISZ TRIES CCE,RSS * TRIED 100 TIMES WITHOUT SUCCESS, SO LEAVE JMP $IOCX * LDA N10 100 MSEC DELAY LDB $PIFT P.F. IFT ADDR JSB $IOTI PUT IFT IN TIME-LIST * CCA CPA ABFLG ALREADY ABORTED IT? JMP $IOCX YES STA ABFLG NO, SET FLAG THAT WE DID ABORT LDA DOF LDB .12 JSB $MESS "OFF,AUTOR,FL" JMP $IOCX SHOULDN'T GET HERE * * PROCESS IFTS/DVTS FOR POWER-FAIL * DCALL STB NXADR SAVE ADDR OF NEXT IFT CLC 4 DISABLE LEVEL 2&3 INTERRUPTS JSB ONPRV SEE IF ANOTHER P.F. OCCURRED JMP RENBL IT HAS! GET OUT IMMEDIATELY STC 4 REENABLE LEVEL 2 & 3 INTERRUPTS LDB NXADR SEZ,RSS DOING DVT'S? JMP DCAL5 YES CPB $PIFT IS THIS THE P.F. IFT? RSS YES, DON'T CALL OURSELF * CALL I/O SYSTEM TO DO`$" DRIVER POWER-FAIL ENTRY JSB $POWF E=1 IF IFTS, 0 IF DVTS LDB NXADR ADB .6 POINT TO IFT 7 LDA 1,I GET LENGTH OF CONTIGUOUS AUX. AREA AND B777 IN BITS 8-0 ADB 0 ADD TO POINTER CCE,INB JMP DVRNX ITERATE * DCAL5 JSB $POWF DO DEVICE DRIVER POWER-FAIL LDB NXADR ADB .20 LDB 1,I LSR 9 RIGHT JUSTIFY DVTP SIZE ADB .22 ADD DVT SIZE ADB NXADR POINT TO NEXT DVT CLE JMP DVRNX * * SUBROUTINE TO DETERMINE IF POWER-FAIL IFT IS ON THE * "PRIVILEGED DONE QUEUE". IF IT IS, A POWER-FAILURE * HAS OCCURED SINCE THE LAST ENTRY INTO THE ID.43 NON- * PRIVILEGED CONTINUATOR SECTION. * ONPRV NOP LDB $PIFT ADDR OF P.F. IFT SZB,RSS DOES IFT EXIST? JMP HALT NO, WE'RE OUT OF LUCK ADB .7 POINT TO IFT EXTENSION * CHECK TO SEE IF POWER-FAIL IFT ALREADY ON PRIV. DONE QUEUE LDA $Q.PV HEAD OF PRIVILEGED DONE QUEUE CPA 1 IS THIS THE P.F. IFT? JMP ONPRV,I YES, ON QUEUE, DO RTN+1 LDA 0,I GET NEXT SZA MORE? JMP *-4 YES ISZ ONPRV DO RTN+2 JMP ONPRV,I * DOF DEF *+1 ASC 2,OFF, AUTOR ASC 4,AUTOR,FL * $$POW EQU * $.POW DEC 0 * END $  92070-18097 1941 S C0122 &ID.50              H0101 ]ZASMB,R * * NAME: ID.50 * SOURCE: 92070-18097 * RELOC: 92070-16097 * PGMR: C.H.W. * * **************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT * * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * **************************************************************** * * NAM ID.50,0 92070-16097 REV.1941 800424 * SUP * * * * THIS IS THE GENERAL PURPOSE I/O & PARALLEL INTERFACE CARD * DRIVER FOR THE 21LC SYSTEM. IT SERVICES SINGLE REQUESTS (NON- * MULTIBUFFERED) ALWAYS USING DMA FOR ITS OPERATIONS. IT MAY ALSO * BE CALLED TO DESIGNATE A PROGRAM TO BE SCHEDULED ON AN ASYNCHRONOUS * CARD INTERRUPT. * * GEN 9,EID.50,TX:6,IT:50B * ENT ID.50 * EXT $DIOC,$DMPR,$LIST,$DVLU,$RUN#,$NAME EXT $IDA,$IDSZ EXT $DV1,$DV15,$DV16,$DV17,$DV18,$DV19 EXT $DVTP,$IF5,$IF6,$IFTX * DMA EQU 20B 1ST SELECT CODE FOR DMA SELF-CONFIG CARD EQU 30B CARD S.C. W/ GLOBAL REG ENABLED SPC 4 * * ID.50 NOP AND B7 ISOLATE ENTRY TYPE ADA JMPTB POINT TO ADDR OF PROCESSING JMP 0,I ROUTINE AND JUMP TO IT SKP * * THIS SECTION HANDLES A NEW REQUEST (LOGICAL INITIATION) * PI.00 LDB $DV15,I GET REQUEST CONTROL WORD RBR SSB,SLB CONTROL REQUEST? JMP CN.00 YES LDA $IFTX ADDR OF IFT EXTENSION AREA ADA B2 STA TEMP USE AS RUNNING POINTER FOR OTA DMA BUILDING QUADRUPLET LDA CONWD DMA CONTROL WORD (41400) SSB IS THIS A READ? XOR B600 YES, SET FOR INPUT, NO AUTO LDB $DVTP INB LDB 1,I GET DVT PRAM 2 SLB LSB INDICATES 8 BIT OR 16 BIT INTERFACE : IOR BIT13 LSB=1, SO ITS 8-BIT - SET BYTE MODE ERB,SLB AUTO ON INPUT? IOR B400 YES STA TEMP,I STORE DMA CONWD IN IFT EXTENSION ISZ TEMP POINT TO NEXT LDA $DV18,I GET OPTIONAL PARAM IOR $DVTP,I FORM CONTROL REGISTER WORD STA TEMP,I STORE DEVICE CONWD IN IFT EXT ISZ TEMP LDA $DV16,I GET BUFFER ADDRESS STA TEMP,I STORE IN IFT EXTENSION ISZ TEMP LDA $DV17,I GET REQUEST LENGTH SZA,RSS ZERO LENGTH? JMP PDONE YES, DO IMMEDIATE COMPLETION CMA,SSA,INA,RSS GIVEN IN WORDS? CMA,INA,RSS NO, BYTES ALS YES, SO CONVERT TO NEG BYTES SEZ,RSS 16 BIT INTERFACE? ARS YES, FORM NEG. WORD COUNT STA TEMP,I STORE IN IFT EXTENSION STA $DV19,I SAVE FOR POST-PROCESSING CLC CARD,C DISABLE CARD INTERRUPTS DURING DMA STC DMA,C DO SELF-CONFIGURATION & GO ISZ ID.50 TAKE PHYSICAL CONTINUE EXIT CLA,INA REQUEST TIME-OUT JMP ID.50,I EXIT (PHYSICAL CONTINUE) SKP SPC 3 * * THIS SECTION HANDLES CONTROL REQUESTS * CN.00 EQU * LDA 1 AND B3740 ISOLATE SUBFUNCTION CPA REQ20 SCHEDULE PROGRAM? JMP CN.20 YES CPA REQ21 DISABLE PGM SCHEDULE? JMP CN.21 YES CPA REQ40 SET CONTROL REGISTER & PRAM #2 JMP CN.40 YES SZA,RSS CLEAR REQUEST? OTA CARD+2 YES, CLEAR REG 32 JMP STTUS * CN.20 JSB $NAME CONVERT NAME TO ID SEG ADDR DEF $DV16,I SZB,RSS DOES PGM EXIST? JMP REJ1 NO, RETURN ILLEGAL REQUEST ERROR JSB $RUN# GET SEQ#/ ID # LDB $DV19,I GET OPT PRAM DST $IFTX,I STORE RUN/IDNO & PRAM IN IFTX JMP STTUS * REJ1 LDA RQERR RETURN REQUEST ERROR & FLUSH IT JMP STTUS SPC 3 CN.21 CLA STA $IFTX,I CLEAR PGM # JMP ST$TUS SPC 3 CN.40 DLD $DV16,I OUTPUT DEVICE CTL WORD + PRAM 2 DST $DVTP,I SAVE IN DVT PARAMETER # 1 JMP STTUS SKP SPC 3 * * ENTER HERE ON INTERFACE INTERRUPT (PHYSICAL RESUME) * PR.00 CLA,INA LDB $IF5,I ADDRESS OF ACTIVE DVT JSB $DIOC SET-UP DVT ADDRESSES SFC 22B PARITY? JMP $DMPR YES LDA $IF6,I GET IFT STATUS SFS 21B DMA INTERRUPT? JMP ASYNC NO SSA,RSS BUSY? JMP ILLIN NO, THEN WHY THE HELL DID DMA INTERRUPT * AN ACTIVE DMA TRANSFER HAS COMPLETED DLD $DVTP,I GET 2ND PRAM IN B LIA DMA+3 READ REMAINING COUNT CMA,INA ADA $DV19,I A=NEG. XMISSION COUNT CMA,INA SLB,RSS 16 BIT INTERFACE? ALS YES, CONVERT FROM -WORDS TO -BYTES LDB $DV17,I GET USER SPECIFIED LENGTH SSB GIVEN IN BYTES? JMP *+3 YES, SO WE'RE ALL SET INA NO, SO CONVERT TO POSITIVE ARS WORD COUNT STA $DV17,I RETURN XMISSION LOG * AB.00 EQU * ABORT EXIT STTUS CLA NO ERRORS * PDONE LDB $IF5,I GET DVT ADDR ADB B17 POINT TO DVT16 STA 1,I SET COMPLETION ERROR STATUS ADB B2 POINT TO DVT18 LIA CARD+2 READ CARD STATUS STA 1,I & RETURN IN 1ST OPT.PARAMETER CLC DMA+1 SUSPEND DMA THEN CLC DMA+3,C CLEAR THE CARD'S DMA CLA EXIT WITH NO SYSTEM FLAGS SET * EXIT CLC CARD,C DISABLE CARD CLB CPB $IFTX,I PROG TO SCHED? JMP ID.50,I NO, BACK TO I/O SYS * OTB CARD+1 CLEAR CARD CTL REGISTER STC CARD ALLOW ASYNC INTERRUPTS JMP ID.50,I DONE SKP * ENTER HERE ON NON-DMA INTERRUPT. USE RUN #/ID # IN 1ST WORD * OF IFT EXTENSION TO SCHEDULE PROGRAM TO HANDLE INTERRUPT. * THE PROGRAM IS PASSED THE FOLLOWING PARAMETERS: * PARAM 1 = LU * PARAM 2 = PARAMETER PASSED IN EXEC(3,2000B+LU) REQST * PARAM 3 = CARD STATUS FROM REG 32 * ASYNC SSA,RSS CARD NON-BUSY? SFS 30B YES, CARD INTERRUPT? JMP ILLIN NO, WHAT THEN? * CARD HAS INTERRUPTED LDA $IFTX,I SZA,RSS ANY PROG TO SCHEDULE? JMP ILLIN NO, ILLEGAL INTERRUPT AND B377 ISOLATE ID SEGMENT # ADA N1 MPY $IDSZ ADA $IDA A= ID SEG ADDR LDB 0 SAVE IT IN B ADA B34 POINT TO WORD 29 LDA 0,I GET SCHEDULING SEQ # XOR $IFTX,I AND .17 ISOLATE BITS 15-12 CCE,SZA HAS ID SEGMENT BEEN RERUN? JMP PGERR YES, CLEAR TABLE ENTRY & GIVE MSG * LDA 1 ID SEGMENT ADDR INA STA TEMP ADDR OF 1ST TEMP WORD ADA B16 LDA 0,I GET ID SEG STATUS AND B77 BITS 5-0 SZA DORMANT? JMP PCONT-1 NO, JUST EXIT * WE CAN NOW GO AHEAD & SCHEDULE THE PROGRAM JSB $LIST PUT PGM IN SCHEDULED LIST OCT 60 LDB $DV1 GET DVT ADDR JSB $DVLU COMPUTE LU STA TEMP,I STORE 1ST PARAMETER ISZ TEMP LDB $IFTX INB LDA 1,I GET PGM SCHED PARAMETER LIB CARD+2 READ STATUS DST * 2ND=PASSED PRAM 3RD=CARD STATUS TEMP EQU *-1 CLA * PCONT ISZ ID.50 GO OUT PHYSICAL CONTINUE LDB $IF6,I GET IFT AV RRL 1 SET "T" IF BUSY JMP EXIT CK FOR CARD ENABLE & EXIT SKP * * ENTER HERE ON PHYSICAL TIMEOUT TO.00 LDA B3 RETURN TIME-OUT ERROR STATUS JMP PDONE GO CLEAR CARD & GO OUT PHY DONE SPC 3 * * ENTER HERE ON A POWER-FAIL * PF.00 LDA RETRY SET TO RESTART ANY CURRENTLY JMP PDONE ACTIVE REQUEST SPC 3 * PROGRAM TO SCHEDULE HAS BEEN RERUN PGERR XOR 0 STA $IFTX,I CLEAN-OUT PGM SCHED ENTRY * ILLEGAL INTERRUPT ILLIN LDA B2w SET "I" BIT IN A REG JMP PCONT GO OUT CONTINUE * * DATA AREA * B2 OCT 2 B3 DEC 3 B7 OCT 7 B16 OCT 16 B17 OCT 17 B34 OCT 34 B77 OCT 77 B377 OCT 377 REQ20 OCT 1000 SUBFUNCTION=20 REQ21 OCT 1040 SUBFUNCTION=21 REQ40 OCT 2000 SUBFUNCTION=40 B400 OCT 400 B600 OCT 600 B3740 OCT 3740 MASK FOR SUBFUNCTION FIELD BIT13 EQU PGERR .17 OCT 170000 RETRY OCT 100077 RQERR OCT 140001 N1 DEC -1 CONWD OCT 41400 DMA SELF-CONFIG CONTROL WORD * JMPTB DEF *+1,I JUMP TABLE DEF AB.00 ABORT DEF PI.00 PHYSICAL INITIATE DEF PR.00 PHYSICAL RESUME DEF TO.00 PHYSICAL TIMEOUT DEF PF.00 POWER-FAIL * END   92070-18098 1941 S C0122 &BL..              H0101 _CASMB,R * * NAME: BL.. * SOURCE: 92070-18098 * RELOC: 92070-1X098 * PGMR: C.H.W. * * **************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT * * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * **************************************************************** * * NAM BL..,0 92070-1X098 REV.1941 790712 * * * * * * ACTION SUBROUTINE TO EXECUTE THE "BL" OPERATOR COMMAND * * COMMAND SYNTAX: * BL,LU(,"UN" OR "BU"(,LOWER,UPPER)) * * ENT BL.. * EXT EXEC,$LIBR,$LIBX,$CVT3,$SCHD EXT CAM.O,$LUTA,$LUT#,CNOPT * SKP * THIS ACTION ROUTINE IS PASSED A LOGICAL UNIT PARAMETER, AND * OPTIONAL PARAMETERS TO SPECIFY BUFFERED OR UNBUFFERED OPERATION * AND THE LOWER AND UPPER BUFFER LIMITS. * IF THE LU PARAMETER IS NON-NUMERIC OR OUTSIDE OF THE RANGE * 0<=LU<="$LUT#", AN ERROR 56 IS RETURNED. OTHERWISE, THE LU IS USED * TO RETRIEVE THE CONTENTS OF THE LUT ENTRY. IF THE LUT CONTAINS A * ZERO, THE MESSAGE "LU XX UNASSIGNED" IS RETURNED, WHERE XX IS THE * ENTERED LU #. IF THE LUT CONTAINS A NON-ZERO VALUE, IT IS SAVED AS * THE DVT ADDRESS. THE NUMBER OF PASSED PARAMETERS IS NEXT EXAMINED, * AND IF THE LU WAS THE LAST PARAMETER, CONTROL IS PASSED DIRECTLY TO * THE BUFFER LIMITS DISPLAY SECTION. * * BUFFER LIMITS MODIFICATION SECTION * * THE 3RD PARSED PARAMETER IS CHECKED, AND IF NOT DEFAULTED, IT * MUST BE A "BU" OR "UN", OTHERWISE AN ERROR 56 IS RETURNED. THE * VALUE FOR LATER SETTING THE BUFFERING FLAG IN DVT8 IS SAVED (1 IF "BU", * AND 0 IF "UN"). * THE LOWER BUFFER LIMIT IN PARSED PARAMETER 4 IS NEXT EXAMINED. * IF DEFAULTED, THE UPPER LIMIT MUST NOT HAVE BEEN SPECIFIED, OTHERWISE * AN ERROR 56 IS RETURNED. IF LOWER L8IMIT SPECIFIED, IT MUST BE NUMERIC * AND IN THE RANGE 0<=VALUE<=4095 ELSE AN ERROR 56 IS RETURNED. IF OK, * THE VALUE IS DIVIDED BY 16 WITHOUT ROUNDING AND SAVED IN THE VARIABLE * "LIMIT". THE UPPER LIMIT IN PARSED PARAMETER 5 IS CHECKED, AND IF * DEFAULTED, NON-NUMERIC, OR OUT OF RANGE : LIMIT<=VALUE/16<=LIMIT+127, * AN ERROR 56 IS RETURNED. IF OK, "$LIBR" IS CALLED TO GO PRIVILEGED, * AND THE NEW BUFFER LIMITS ARE STORED IN DVT WORD 9. THE VALUE * STORED FOR LOWER (BITS 7-0) IS "LIMIT", AND THE VALUE STORED FOR * UPPER (BITS 14-8) IS (ENTERED UPPER LIMIT)/16-"LIMIT". IF * THE BUFFERING MODE PARAMETER WASN'T DEFAULTED, THE SIGN BIT OF DVT8 * IS CLEARED/SET TO INDICATE THE NEW VALUE. "$LIBX" IS CALLED TO GO * UN-PRIVILEGED AND CONTROL IS PASSED TO THE BUFFER LIMITS DISPLAY * SECTION. * * BUFFER LIMITS DISPLAY SECTION * * THE BUFFER LIMITS DISPLAY SECTION IS ENTERED DIRECTLY IF LU * WAS THE ONLY PARAMETER SPECIFIED, OR FOLLOWING AN UPDATE AS DESCRIBED * ABOVE. IT PREPARES A MESSAGE OF THE FORM: * LU #XX YY BL= LL, HH AC= ZZ * THE SIGN BIT OF DVT8 IS CHECKED, AND A "BU" (IF SET) OR AN "UN" (IF * CLEAR) IS STORED IN THE "YY" FIELD OF THE MESSAGE. THE ENTERED LU # * IS CONVERTED TO ASCII AND STORED IN THE "XX" FIELD OF THE MESSAGE. * "$LIBR" IS CALLED TO GO PRIVILEGED. THE BUFFER ACCUMULATOR IN BITS * 14-0 OF DVT8 IS CONVERTED TO ASCII USING ROUTINE "$CVT3" AND STORED * IN THE "ZZ" FIELD OF THE MESSAGE. BITS 7-0 OF DVT9 (LOWER LIMIT) * ARE MULTIPLIED BY 16, CONVERTED TO ASCII USING "$CVT3" AND STORED IN * THE "LL" FIELD OF THE MESSAGE. BITS 14-8 OF DVT9 (UPPER LIMIT) ARE * ADDED TO THE LOWER LIMIT (BITS 7-0), MULTIPLIED BY 16, CONVERTED TO * ASCII USING "$CVT3" AND STORED IN THE "HH" FIELD OF THE MESSAGE. * "$LIBX" IS CALLED TO GO UN-PRIVILEGED. THE FORMED MESSAGE IS MOVED * TO "C.BUF" IN THE MAIN, AND IT'S LENGTH IS STORED IN "ECH". ROUTINE * "ECHO" IS CALLED TO OUTPUT THE MESSAGE. THE BL ACTION ROUTINE THEN * RETURNS TO IFTS CALLER. SKP * BL.. NOP ISZ BL.. LDB BL..,I STB NUMBA SAVE ADDR OF # PRAMS ISZ BL.. 2ND PARAMETER IS THE PARSE BUFFER ADDR LDB BL..,I GET IT STB TMPAD ISZ BL.. * * PROCESS LU PARAMETER CCE JSB CKPAR GET LU PARAMETER JMP ER50 NO PARAMETER, ERROR CMB,INB,SZB,RSS NEGATE LU JMP ER56 ERROR IF LU=0 ADB $LUT# ADD TOTAL # OF LU'S SSB OK? JMP ER56 NO, LU OUT OF RANGE STA M.BU SAVE LU CLB,CCE DIV .10 SEPARATE HI & LO DIGITS SZA LEADING ZERO? IOR B20 NO ,FORM NUMERIC ALF,ALF LEFT JUSTIFY IOR 1 INCLUDE LSB IOR ASC.0 FORM ASCII STA M.LU SAVE IN MSG STA M.LU2 CCA -1 ADA M.BU ADD NUMERIC LU # ADA $LUTA ADD ADDRESS OF LUT LDB 0,I GET THE DVT ADDRESS SZB,RSS ASSIGNED TO BIT BUCKET? JMP BL.90 YES * * B REG HAS DVT ADDRESS STB DVT1 ADB .7 ADDR OF DVT8 STB DVT8 SAVE IT LDA NUMBA,I # OF PARSED PARAMS CPA .1 =1? JMP BD.00 YES, DISPLAY PRESENT B.L. STATE * * PROCESS "UN"/"BU" PARAMETER CCA,CLE STA M.BU FLAG FOR POSSIBLE DEFAULT JSB CKPAR GET UN/BU PARAMETER JMP BL.30 DEFAULTED, SO LEAVE IT ALONE LDB BIT15 CPA ASCBU BUFFERING REQUESTED? JMP BL.20 YES CPA ASCUN UNBUFFER REQUESTED? CLB,RSS YES JMP ER56 NO, PARAMETER ERROR BL.20 STB M.BU SAVE FOR LATER "OR" * * PROCESS LOWER LIMIT BL.30 CCE JSB CKPAR GET LOWER LIMIT JMP BL.80 AND B7777 CPA 1 <4096? RSS YES, OK LDA B7777 NO, USE MAX=4095 CLB,CCE LSR 4 STA LIMIT SAVE LOWER LIMIT/16 * * PROCESS UPPER L}IMIT JSB CKPAR GET UPPER LIMIT JMP ER56 NOT SPECIFIED, ERROR ASR 4 LDA LIMIT CMA,INA -LOWER LIMIT/16 ADA 1 + UPPER LIMIT/16 SSA WAS UPPER >= LOWER? JMP ER56 NO, PARAMETER ERROR LDB 0 AND B177 CPA 1 UPPER-LOWER/16 < 128? RSS YES LDA B177 NO, USE 127 ALF,ALF IOR LIMIT INCLUDE LOWER LIMIT LDB DVT8 INB POINT TO DVT9 JSB $LIBR LOWER FENCE NOP STA 1,I SET NEW B.L. IN DVT9 JMP BL.60 * BL.50 JSB $LIBR LOWER FENCE NOP * BL.60 LDA DVT8,I RAL,CLE,ERA CLEAR OLD "B"-BIT LDB M.BU GET NEW BUFFERING FLAG IOR 1 SET IT IN BIT15 INB,SZB SKIP IF "UN"/"BU" DEFAULTED STA DVT8,I LDA DVT1 JSB $SCHD TRY TO SCHED ANY B.L. WAITERS OCT 55 JMP BD.10 NOW DISPLAY LIMITS * * BL.80 LDA NUMBA,I GET # OF PRAMS CPA .2 EXACTLY 2? JMP BL.50 YES, JUST UPDATE BUFFERING FLAG JMP ER56 NO, THEN ERROR * * LU WAS ASSIGNED TO BIT BUCKET BL.90 JSB CNOPT WRITE "LU XX UNASSIGNED" DEF *+5 DEF .2 DEF CAM.O DEF MUNAS DEF MS2LN JMP B.EX SKP * * * THIS SECTION DISPLAYS CURRENT BUFFER LIMITS * BD.00 JSB $LIBR LOWER THE FENCE NOP BD.10 LDA DVT8,I GET "B"-BIT LDB ASCUN CCE,SSA CURRENTLY BUFFERED? LDB ASCBU YES STB M.BU ELA,CLE,ERA ISOLATE BUFFER ACCUMULATOR JSB $CVT3 CONVERT ACCUM TO ASCII LDB 0,I STB M.AC MOVE 1ST TWO CHARS CCE,INA DLD 0,I GET NEXT 4 CHARS DST M.AC+1 ISZ DVT8 POINT TO DVT9 LDA DVT8,I GET DVT9 CONTENTS AND B377 ISOLATE LOWER B.L. STA LIMIT ALF * 16 JSB $CVT3 CONVERT LOWER LIMIT TO ASCII CCE,INA DLD 0,I USE LAST 4 ASCII CHARS DST M.LO PUT INTO MSG LDA DVT8,I GET DVT9 AGAIN ALF,ALF RIGHT JUSTIFY UPPER LIMIT AND B177 ISOLATE IT ADA LIMIT ADD LOWER ALF MULTIPLY BY 16 JSB $CVT3 CONVERT UPPER TO ASCII JSB $LIBX RAISE THE FENCE DEF *+1 DEF *+1 LDB 0 LDA 1,I GET 1ST 2 CHARS AND B377 CLEAR THE 1ST ONE IOR COMMA AND INSERT A COMMA STA M.HI STORE IN MSG INB DLD 1,I GET LAST 4 CHARS DST M.HI+1 * JSB CNOPT WRITE RESPONSE LINE DEF *+5 DEF .2 DEF CAM.O DEF MSGBF DEF MSGLN * B.EX ISZ BL.. JMP BL..,I RETURN SPC 3 * * SUBROUTINE TO GET NEXT PARAMETER FROM PARSE BUFFER * CKPAR NOP DLD * GET TYPE AND VALUE TMPAD EQU *-1 CMA,INA,SZA,RSS NULL? JMP CKEX YES, DO RTN+1 ISZ CKPAR FOR ALL ELSE DO RTN+2 SSB,RSS >=0? SEZ,INA,SZA YES, SKP UNLESS ILLEGAL ASCII JMP ER56 PARAMETER ERROR * CKEX LDA TMPAD ADA .4 POINT TO NEXT PRAM STA TMPAD LDA 1 RETURN VALUE IN BOTH A AND B JMP CKPAR,I * ER50 LDA .50 50 = NOT ENOUGH PARAMETERS RSS ER56 LDA .56 56 = BAD PARAMETER LDB BL..,I GET ADDR OF ERROR PARAM STA 1,I RETURN ERROR VALUE JMP B.EX AND RETURN * * DATA AREA * LIMIT NOP DVT1 NOP DVT8 NOP NUMBA NOP * .1 DEC 1 .2 DEC 2 .4 DEC 4 .7 DEC 7 .10 DEC 10 .50 DEC 50 .56 DEC 56 B20 OCT 20 B177 OCT 177 B377 OCT 377 B7777 OCT 7777 BIT15 OCT 100000 ASCUN ASC 1,UN ASCBU ASC 1,BU ASC.0 ASC 1, 0 COMMA OCT 26000 * MSGBF EQU * ASC 2,LU# M.LU BSS 1 ASC 1, M.BU BSS 1 ASC 3, BL= M.LO BSS 2 M.HI BSS 3 ASC 3, AC= M.AC BSS 3 Ec$" MSGLN ABS *-MSGBF * MUNAS ASC 2,LU # M.LU2 NOP ASC 6, UNASSIGNED MS2LN ABS *-MUNAS * END $  92070-18099 1941 S C0122 &CN..              H0101 bDASMB,R * * NAME: CN.. * SOURCE: 92070-18099 * RELOC: 92070-1X099 * PGMR: C.H.W. * * **************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT * * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * **************************************************************** * * NAM CN..,7 92070-1X099 REV.1941 791004 * * * * * ACTION SUBROUTINE TO EXECUTE THE "CN" OPERATOR COMMAND * THIS ROUTINE PERFORMS AN I/O CONTROL REQUEST * (EXEC,3,..) TO THE DESIGNATED DEVICE FOR ALL * FUNCTIONS EXCEPT "PR" AND "AB". ON "PR", THE * DEVICE PRIORITY IN DVT WORD 20 IS MODIFIED * DIRECTLY. ON "AB", IF THE DEVICE CURRENTLY HAS * A REQUEST AT THE HEAD OF ITS INITIATION LIST (DVT * WORD 2) THE ROUTINE "$ABRQ" IN "RTIOL" IS CALLED * DIRECTLY TO ABORT THE REQUEST. THIS WILL INITIATE * THE ABORT CALL AND RTIOL WILL IMMEDIATELY RETURN * TO "CN..". * * COMMAND SYNTAX: * CN,LU,FUNC(,OPTN1,OPTN2,OPTN3,OPTN4) * * ENT CN.. * EXT EXEC,$LIBR,$LIBX,$ABRQ EXT $LUT#,$LUTA * * CN.. NOP LDA CN.. ADA .2 2ND PARAMETER IS THE PARSE BUFFER ADDR LDB 0,I GET IT STB TMPAD INA LDA 0,I STA ERRTN SAVE ADDR OF ERROR PARAM LDA CN..,I STA CN.. SAVE RETURN ADDR * INB POINT TO LU PARAMETER LDA 1,I GET IT STA LU * VERIFY ENTERED LU SZA CMA,SSA,INA,RSS JMP ER56 ERROR IF LU <1 ADA $LUT# MAX LU - ENTERED LU CMA,SSA,RSS ENTERED > MAX? JMP ER56 YES, PARAMETER ERROR ADA $LUT# A NOW = LU-1 ADA $LUTA LDA 0,I GET LUT CONTEN%TS FOR LU SZA,RSS ASSIGNED? JMP CN..,I NO, EXIT STA OPTNS SAVE DVT ADDRESS ADB .3 POINT TO FUNC PARAMETER TYPE STB FUNCA LDB 1,I GET TYPE ISZ FUNCA POINT TO VALUE LDA FUNCA,I GET IT CPB .3 WAS IT ENTERED IN ASCII? JMP *+3 YES AND B77 USE ONLY 5-0 JMP CN.30 * LDB OPTNS GET DVT ADDRESS CPA ASCPR "PR"? JMP PRIOR YES, CHANGE DEVICE PRIORITY CPA ASCAB "AB"? JMP ABORT YES LDB CNVTA ADDR OF ASCII FUNCTIONS CN.10 LDA 1,I INB POINT TO OCTAL EQUIVALENT CPA FUNCA,I IS THIS THE ENTERED FUNCTION JMP CN.20 YES INB NO, POINT TO NEXT FUNCTION SZA END OF TABLE? JMP CN.10 NO JMP ER56 YES, INCORRECT FUNC CODE * CN.20 LDA 1,I GET FUNC CODE OCTAL EQUIVALENT * CN.30 LDB TMPAD ADB .9 ADDR OF 1ST OPT. PARAM STB OPTNS STORE IN EXEC CALL ADB .4 ADDR OF 2ND STB OPTNS+1 ADB .4 ADDR OF 3RD STB OPTNS+2 ADB .4 ADDR OF 4TH STB OPTNS+3 CPA .9 FORM CONTROL? JMP FORMS YES * CN.40 LSL 6 FUNC CODE INTO BITS 11-6 IOR LU INCLUDE ENTERED LU STA LU STORE FOR EXEC CALL * JSB EXEC ISSUE THE CONTROL REQUEST! DEF *+7 DEF K3N NO ABORT DEF LU OPTNS BSS 4 MODIFIED ABOVE JMP ER56 GIVE ERROR IF ABORT RETURN JMP CN..,I RETURN SPC 3 * DOING FORMS CONTROL, IF DEFAULTED PARAMETER, USE -2 FORMS ADB N13 LDB 1,I GET TYPE OF 1ST OPT PRAM LDA N2 SZB,RSS DEFAULTED? STA OPTNS,I YES, DO A TOP-OF-FORM LDA .9 GET FORM CTL VALUE AGAIN JMP CN.40 SET LU & DO IT SPC 3 * CHANGE DEVICE IFT QUEUEING PRIORITY PRIOR ADB .19 - STB TMPAD POINT TO DVT20 LDB FUNCA ADB .4 LDA 1,I GET NEW PRIORITY AND B77 CPA 1,I PRIO > 63? RSS NO JMP ER56 ERROR, TOO LARGE LDA TMPAD,I AND B1777 IOR 1,I SET NEW PRIO IN DVT WD 20 JSB $LIBR GO PRIVILEGED NOP STA TMPAD,I MODIFY DVT TABLE JMP PVEX SPC 3 * ABORT REQUEST AT HEAD OF DVT FOR LU ABORT ISZ OPTNS POINT TO DVT2 * JSB $LIBR LOWER FENCE NOP LDA OPTNS,I GET ADDR OF HEAD ELA,CLE,ERA CLEAR "Q" BIT SZA ANYTHING QUEUED? JSB $ABRQ YES, ABORT REQUEST, B HAS DVT ADDR PVEX JSB $LIBX RAISE FENCE & EXIT DEF CN.. * * ER56 LDA .56 56 = BAD PARAMETER STA ERRTN,I RETURN ERROR VALUE JMP CN..,I AND RETURN * * * DATA AREA * TMPAD NOP ERRTN NOP LU NOP FUNCA NOP * .19 DEC 19 .56 DEC 56 B77 OCT 77 B1777 OCT 177700 K3N OCT 100003 N2 DEC -2 N13 DEC -13 ASCPR ASC 1,PR ASCAB ASC 1,AB * CNVTA DEF *+1 ASC 1,AD NEW DEVICE ADDRESS OCT 24 ASC 1,BF BACK SPACE FILE OCT 14 ASC 1,BR BACKSPACE RECORD .2 OCT 2 ASC 1,DP SET DRIVER PARAMETERS OCT 24 ASC 1,EO WRITE END-OF-FILE OCT 1 ASC 1,FF FORWARD SPACE FILE OCT 13 ASC 1,FR FORWARD SPACE RECORD .3 OCT 3 ASC 1,LE PAPER TAPE LEADER OCT 10 ASC 1,RW REWIND MAGNETIC TAPE .4 OCT 4 ASC 1,TO TOP-OF-FORM .9 OCT 11 DEC 0 END OF TABLE * END   92070-18100 1941 S C0122 &IO..              H0101 [AASMB,R * * NAME: IO.. * SOURCE: 92070-18100 * RELOC: 92070-1X100 * PGMR: C.H.W. * * **************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT * * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * **************************************************************** * * NAM IO..,7 92070-1X100 REV.1941 790409 * * * * SUP ENT IO.. * EXT O.BUF,TMP.,OPEN.,WRITF EXT CNUMO,.MVW EXT $LUTA,$LUT#,$DVTA * * IO.. NOP JSB OPEN. OPEN LIST FILE DEF *+5 DEF O.BUF DEF TMP. DEF TMP.+3 DEF ZERO * CLA STA IERR INITIALIZE ERROR FLAG * JSB OUTPT OUTPUT HEADER DEF HDR DEF HDRL * LDB $LUTA ADDR OF "LUT" STB PNTR CLA,INA * IO.10 STA LU SAVE NEXT LU # JSB DECIM CONVERT TO 2 ASCII DIGITS STA M1F1 STA M1F10 * CLA STA TEMP TEMP=DVT # DURING SEARCH CPA PNTR,I THIS LU HAVE A DVT? JMP IO.80 NO LDB $DVTA ADDR OF 1ST DVT IN DVT AREA * HERE WE COMPUTE RELATIVE DVT # FROM ITS ADDRESS IO.20 ISZ TEMP BUMP DVT # CPB PNTR,I IS THIS THE ONE FOR THE LU? JMP IO.25 YES ADB .20 NO, POINT TO DVT21 STB TEMP1 LDB 1,I GET DVTP SIZE LSR 9 RIGHT JUSTIFY IN B ADB TEMP1 COMPUTE ADDR ADB .2 OF NEXT DVT JMP IO.20 AND ITERATE * IO.25 LDA TEMP DVT # JSB DECIM CONVERT TO 2 ASCII DIGITS STA M1F2 * LDB PNTR,I GET DVT ADDR STB DVADR ADB .4 POINT TO DVT5 LDA 1,I GET IT ELA,CLE,ERA CLEAR SIGN ADA .5 PO6INT TO IFT6 LDA 0,I GET IT STA IFT6 JSB OCTAL CONVERT TO ASCII-OCTAL STA M1F3 STORE S.C. IN ASCII * LDA DBLNK STA M1F4 DVR PARAMETER FIELD STA M1F4+1 TO BLANKS IN CASE THERE STA M1F4+2 IS NONE LDB PNTR,I DVT ADDR ADB .20 POINT TO DVT21 LDA 1,I AND B1770 ISOLATE # OF PARAMS SZA,RSS ANY? JMP IO.30 NO ADB .2 YES, POINT TO D.P. (DVT23) LDA 1,I GET 1ST PARAM STA TEMP * JSB CNUMO CONVERT DVR PARAM TO ASCII(OCTAL) DEF *+3 DEF TEMP DEF M1F4 * IO.30 LDB DVADR ADB .19 ADDR OF DVT20 LDA 1,I GET DEVICE PRIORITY JSB OCTAL CONVERT TO ASCII-OCTAL STA M1F5 * JSB CNUMO CONVERT DVT ADDR TO ASCII(OCTAL) DEF *+3 DEF DVADR DEF M1F6 * LDB DVADR ADB .5 POINT TO DVT6 LDA 1,I GET IT ALF,ALF RIGHT JUSTIFY DEVICE TYPE STA TEMP JSB OCTAL CONVERT TO ASCII-OCTAL STA M1F7 STORE DEVICE TYPE IN MSG * LDB DSCTB ADDR OF DEVICE DESCRIPTION TABLE IO.40 LDA 1,I GET CODE WORD CPA N1 END OF TABLE? JMP IO.45 YES, USE BLANKS XOR TEMP SET-UP FIELD COMPARISON STA TEMP1 LDA 1,I GET CODE WORD AGAIN ALF,ALF RAL,RAL GET MASK FOR TEST AND TEMP1 TEST UNDER MASK AND B77 6 BIT DEVICE TYPE ONLY SZA,RSS IS IT THIS DEVICE TYPE? JMP IO.45 YES ADB .7 POINT TO NEXT ENTRY JMP IO.40 & ITERATE IO.45 LDA 1 INA A=ADDR OF DESCRIPTION LDB DESCR ADDR OF DESTINATION JSB .MVW MOVE INTO OUTPUT LINE DEF .6 NOP * LDA IFT6 CONTENTS OF IFT6 ALF,ALF RIGHT JUSTIFY INTERFACE TYPE JSB OCTAL CONVERT TO ASCII-OCTAL STA M1F9 STORE I.TYPE IN MSG * JSB OUTPT PRINT LINE FOR THIS LU DEF MSG1 DEF MSG1L * IO.50 ISZ PNTR POINT TO NEXT LUT ENTRY LDA LU CPA $LUT# ALL LU'S PROCESSED? JMP IO.90 YES INA BUMP LU # JMP IO.10 AND DO IT * * NO DVT ASSIGNED TO LU IO.80 LDA M1F1 ASCII LU # STA M2F1 STORE IN MSG STA M2F2 JSB OUTPT PRINT LU UNASSIGNED LINE DEF MSG2 DEF MSG2L JMP IO.50 SPC 2 * ERROR EXIT ERR LDB IO.. ADB .3 ADDR OF ERROR PARAM ADDR LDB 1,I PICK-UP ERROR PARAM ADDR STA 1,I RETURN ERROR CODE * IO.90 LDA IO..,I JMP 0,I RETURN SPC 3 * * ROUTINE TO CONVERT NUMERIC TO 2 ASCII DIGITS * DECIM NOP CLB DIV .10 SZA,RSS LDA B20 SUPPRESS LEADING ZERO ALF,ALF IOR 1 MERGE 2 DIGITS XOR ASC00 FORM ASCII NUMERICS JMP DECIM,I SPC 3 * * ROUTINE TO CONVERT TO 6-BITS TO 2 ASCII-OCTAL CHARACTERS * OCTAL NOP AND B77 ISOLATE BITS 5-0 CLB DIV .8 A=HI, B=LOW ALF,ALF LEFT JUSTIFY HI IOR 1 MERGE DIGITS IOR ASC00 CONVERT TO ASCII NUMERICS JMP OCTAL,I RETURN SPC 3 * * ROUTINE TO WRITE LINE TO LIST FILE * OUTPT NOP DLD OUTPT,I GET ADDR OF BUFFER & ADDR OF LENGTH DST OUTP5 STORE IN-LINE OF CALL JSB WRITF WRITE LINE DEF *+5 DEF O.BUF DEF IERR OUTP5 BSS 2 LDA IERR GET FMGR ERROR CODE SSA ERROR? JMP ERR YES ISZ OUTPT ISZ OUTPT JMP OUTPT,I RETURN SPC 3 * * DATA AREA * TEMP NOP TEMP1 NOP PNTR NOP IERR NOP IFT6 NOP LU NOP DVADR NOP ZERO DEC 0 .2 DEC 2 .3 DEC 3 .4 DEC 4 .5 DEC 5 .6 DEC 6 .7 DEC 7 .8 DEC 8 .10 F DEC 10 .19 DEC 19 .20 DEC 20 B20 OCT 20 B77 OCT 77 B1770 OCT 177000 N1 DEC -1 ASC00 ASC 1,00 DESCR DEF M1F8 DSCTB DEF TABLE * HDR ASC 18, LU DVT S.C. DP#1 PRIO DVT ASC 17, ADR D.TYPE- DEVICE I.TYPE LU HDRL ABS *-HDR DBLNK EQU HDR+1 * MSG1 ASC 2, M1F1 NOP ASC 2, M1F2 NOP ASC 2, M1F3 NOP ASC 1, M1F4 BSS 3 ASC 1, M1F5 NOP ASC 2, M1F6 BSS 3 ASC 2, M1F7 NOP ASC 1, M1F8 BSS 6 ASC 2, M1F9 NOP ASC 1, M1F10 NOP MSG1L ABS *-MSG1 * MSG2 ASC 2, M2F1 NOP ASC 17, -------------------- LU UNASSI ASC 14,GNED -------------------- M2F2 NOP MSG2L ABS *-MSG2 * * TABLE OF DESCRIPTIONS BASED ON DEVICE TYPE * 1ST WD OF EACH ENTRY: BITS 11-6 CONTAIN MASK FOR TYPE CHECK * BITS 5-0 HAVE VALUE TO TEST UNDER MASK TABLE EQU * OCT 7000 0 - 7 ASC 6,KEYBD CTL DV OCT 7712 12 ASC 6,LINE PRINTER OCT 7010 10-17 ASC 6,SYS PERIPHRL OCT 7020 20-27 ASC 6,SER RECORDNG OCT 7030 30-37 ASC 6,MOV HD DISC OCT 7440 40-43 ASC 6,CPU FUNCTION OCT 7444 44-47 ASC 6,MISC PERPHRL OCT 7050 50-57 ASC 6,A/D MEAS DEV OCT 7060 60-67 ASC 6,CPU COMM DVR OCT 7070 70-77 ASC 6,INSTRUMENT DEC -1 ASC 6, * SIZE EQU * * END k  92070-18101 1941 S C0122 &IT..              H0101 aAASMB,R * * NAME: IT.. * SOURCE: 92070-18101 * RELOC: 92070-1X101 * PGMR: C.H.W. * * **************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT * * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * **************************************************************** * * NAM IT..,7 92070-1X101 REV.1941 790918 * * * * ACTION SUBROUTINE TO EXECUTE THE "IT" OPERATOR COMMAND * * COMMAND SYNTAX: * IT,NAME(,RES,MULT,HR,MIN,SEC,MSEC) OR * IT,NAME(,RES,MULT,-OFFSET) * RESPONSE IS: * (NAME): R=(RES) M =(MULT) HR:MIN:SEC:MSEC * * ENT IT.. * EXT EXEC,$LIBR,$LIBX,$NAME,CAM.O EXT CNOPT * * IT.. NOP LDA IT.. INA LDB 0,I STB NUMBA SAVE ADDR OF # PRAMS INA 2ND PARAMETER IS THE PARSE BUFFER ADDR LDB 0,I GET IT INB POINT TO PARAMETERS STB TMPAD INA LDA 0,I STA ERRTN SAVE ADDR OF ERROR PARAM LDA IT..,I STA IT.. SAVE RETURN ADDR * LDA NUMBA,I GET # OF PARAMS CPA .1 "IT,NAME" ENTERED? JMP IT.50 YES, DISPLAY ONLY CMA STA CNTR - # OF PARAMS LDA DEFXX STA CALL+1 STORE DEF*N+1 IN EXEC CALL ADB .4 LDA 1,I GET PASSED "RES" CPA RESAS "OF"? CLA YES CPA RESAS+1 "MS"? CLA,INA YES CPA RESAS+2 "SC"? LDA .2 YES CPA RESAS+3 "MN"? LDA .3 YES CPA RESAS+4 "HR"? LDA .4 YES STA 1,I NUMERIC RES VALUE * IT.05 LDB TMPAD ADDR OF PARSED PARAMS LDA N8 STA TOTCT MAX PARAMS ALLOWED * IT.10 ISZ CNTR2 MORE PARAMS ENTERED JMP STORA YES, GO STORE NEXT ADDRESS * DLD ENDI CCE,RSS & CLE DST CALL+1,I STORE ABORT RETURN CODE CHK LDB CALL+1 INB CLA,RSS STA 1,I CLEAR UNUSED AREA INB ISZ TOTCT JMP *-3 * CALL JSB EXEC CALL EXEC(12,----) DEF * MODIFIED ABOVE DEF K12N NO ABORT BSS 9 SEZ ABORTIVE ERROR? JMP ERRXX YES SKP * * FORMAT & DISPLAY THE "IT" INFORMATION * IT.50 LDB TMPAD ADB .2 ADDR OF PGM NAME (3RD WD) LDA 1,I GET 5TH CHARACTER AND B1774 CLEAR RHW IOR B40 RHW=BLANK STA M.NAM+2 STORE IN MSG DLD * GET NAME CHARS 1-4 TMPAD EQU *-1 DST M.NAM STORE IN MSG JSB $LIBR GO PRIVILEGED NOP JSB $NAME GET ITS ID SEG ADDR DEF M.NAM JSB $LIBX GO UNPRIVILEGED DEF *+1 DEF *+1 SZB,RSS WAS IT FOUND? JMP ER14 NO, NAME ERROR ADB .17 POINT TO RES/MULT IN ID SEGMENT +17 STB IDADR LDA 1,I GET RES ALF,RAR RIGHT JUSTIFY IT AND .7 ISOLATE IT ADA ASRES ADDR INTO ASCII CONV.TABLE LDA 0,I GET MS,SC,MN, OR HR STA M.RES STORE IN MSG LDA 1,I GET MULT AND B7777 ISOLATE IT CLB DIV .100 SEPARATE HIGH TWO DIGITS SZA,RSS ARE HIGH 2 DIGITS ZERO? JMP IT.70 YES STB M.MUL+1 SAVE LOW JSB DECIM CONVERT HIGH TO ASCII STA M.MUL STORE IN MSG LDA M.MUL+1 GET LOW JSB DECIM CONVERT TO ASCII IOR .01B ENSURE NUMERIC JMP IT.75 * IT.70 LDA BLANK STA M.MUL BLANK-OUT HIGH 2 DIGITS LDA 1 GET LOW DIGITS JSB DECIM CONVERT TO ASCII IT.75 STA M.MUL+1 STORE LOW ORDER DIGITS IN MSG ISZ IDADR POINT TO T ^IME FIELD IDADR EQU *+1 DLD * GET TIME FROM ID SEGMENT ADA PRS1 ADD POSITIVE 24 HRS. SEZ TO GET A POSITIVE INB TIME ADB PRS2 DIV .6000 DIVIDE BY 6000 STA VALX SAVE MIN/HR ASR 16 POSITION B (SEC/10MS) FOR DIVIDE DIV .100 DIVIDE BY 100 TO GET SEC/10MS STB M.MSC SAVE 10'S OF MSECS JSB DECIM CONVERT SECONDS TO ASCII STA M.SEC & STORE IN MSG LDA M.MSC JSB DECIM CONVERT 10'S OF MSECS TO ASCII LDB ASC0C "0:" RRR 8 FORM ":MM0" DST M.MSC STORE MILLISECS IN ASCII CLB SET UP FOR DIVIDE LDA VALX FETCH MIN/HR DIV .60 SEPERATE STB M.MIN SAVE MINUTES CPA .24 HOUR ROLL-OVER CLA JSB DECIM CONVERT HOURS TO ASCII STA M.HR & SAVE IN MESSAGE LDA M.MIN GET MINUTES JSB DECIM CONVERT TO ASCII LDB ASCCL GET "::" RRR 8 FORMAT ":XX:" DST M.MIN STORE INTO MSG * JSB CNOPT WRITE RESPONSE LINE DEF *+5 DEF .2 DEF CAM.O DEF MSGBF DEF MSGLN JMP IT..,I RETURN * * * DECIM NOP CLB DIV .10 SZA,RSS LDA B20 SUPPRESS LEADING ZERO ALF,CLE,ALF IOR 1 MERGE 2 DIGITS XOR ASC00 FORM ASCII NUMERICS JMP DECIM,I * * STORA STB CALL+1,I STORE PRAM ADDR IN CALL ADB .4 POINT TO NEXT PARAMETER ISZ CALL+1 BUMP THE DEF *+N+1 ISZ TOTCT TOO MANY PARAMS? JMP IT.10 NO, CONTINUE * ER56 LDA .56 PARAMETER ERROR STA ERRTN,I RETURN TO CALLER JMP IT..,I * ERRXX CPB ASC02 ILLEGAL PARAMETER? (SC02) JMP ER56 YES * ER14 LDA .14 RETURN ILLEGAL NAME JMP ER56+1 * * DATA AREA * NUMBA NOP ERRTN NOP VALX NOP TOTCT NOP CNTR NOP * s .1 DEC 1 .2 DEC 2 .3 DEC 3 .4 DEC 4 .7 DEC 7 .10 DEC 10 .14 DEC 14 .17 DEC 17 .24 DEC 24 .56 DEC 56 .60 DEC 60 .100 DEC 100 .6000 DEC 6000 B20 OCT 20 B40 OCT 40 .01B OCT 010000 PRS1 OCT 153000 PRS2 OCT 203 B7777 OCT 7777 B1774 OCT 177400 K12N OCT 100014 N8 DEC -8 ASC00 ASC 1,00 ASC0C ASC 1,0: ASC02 ASC 1,02 ASCCL ASC 1,:: * DEFXX DEF CALL+3 ASRES DEF RESAS RESAS ASC 5,OFMSSCMNHR ENDI CCE,RSS CLE MUST FOLLOW ERRI * MSGBF EQU * M.NAM BSS 3 ASC 2, R= M.RES NOP BLANK ASC 2, M= M.MUL DEC 0,0 ASC 1, M.HR NOP M.MIN DEC 0,0 M.SEC NOP M.MSC DEC 0,0 MSGLN ABS *-MSGBF * * END o/  92070-18102 1941 S C0122 &LA..              H0101 ODASMB,R * * NAME: LA.. * SOURCE: 92070-18102 * RELOC: 92070-1X102 * PGMR: C.H.W. * * **************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT * * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * **************************************************************** * * NAM LA..,7 92070-1X102 REV.1941 790926 * * * * ACTION SUBROUTINE TO EXECUTE THE "LA" OPERATOR COMMAND * * COMMAND SYNTAX: * LA,LU(,DVT(,S.C.)) * * ENT LA.. * EXT EXEC,$LIBR,$LIBX,$SCHD,CAM.O,CNOPT EXT $LUTA,$LUT#,$DVTA,$DVT#,$IFTA,$IFT# EXT $DIOC,$INIO,$DVLU,$DV2,$DV6,$DV8 * * LA.. NOP LDA LA.. INA LDB 0,I STB NUMBA SAVE ADDR OF # PRAMS INA 2ND PARAMETER IS THE PARSE BUFFER ADDR LDB 0,I GET IT INA LDA 0,I STA ERRTN SAVE ADDR OF ERROR PARAM LDA LA..,I STA LA.. SAVE RETURN ADDR * * PROCESS LU PARAMETER INB 1ST PARAM IS LU LDA 1,I GET IT STA M.LU CMA,INA A=-LU SSA,RSS WAS LU < 1? JMP ER56 YES, ERROR ADA $LUT# ADD TOTAL # OF LU'S SSA OK? JMP ER56 NO, LU OUT OF RANGE CCA ADA M.LU GET LU AGAIN ADA $LUTA ADD ADDRESS OF LUT STA LUTAD SAVE ADDR OF LU ENTRY LDA NUMBA,I GET # OF PARAMS ENTERED CPA .1 DISPLAY LU? JMP LD.00 YES LDA LUTAD,I GET LUT CONTENTS SZA BIT BUCKET? JSB CKDSK NO, ENSURE IT'S NOT A DISC * * PROCESS DVT PARAMETER ADB .4 ADDR OF DVT # LDA 1,I GET IT SSA JMP ER56 ERROR IF DVT # NEGATIVE u; CMA,INA,SZA,RSS NEGATE DVT # JMP LA.45 ASSIGN LU TO BIT BUCKET STA TEMP USE TO COUNT DVT'S ADA $DVT# ADD # OF DVT'S IN SYSTEM SSA JMP ER56 ERROR, DVT # TOO LARGE ADB .4 ADDR OF PRAM 3 STB M.SC LDB $DVTA ADDR OF 1ST DVT RSS * LA.05 JSB NXDVT GET ADDR OF NEXT DVT ISZ TEMP IS THIS THE ONE? JMP LA.05 NO, ITERATE * STB DVTAD SAVE DVT'S ADDRESS LDA 1 JSB CKDSK ENSURE NOT SWITCH TO A DISK LDA NUMBA,I GET # OF PARAMS CPA .2 JUST LU SWITCH? JMP LA.50 YES HED ******* DVT SWITCHING TO NEW IFT ******* ADB .4 ADDR OF DVT5 STB DVT5 SAVE IT CPA .3 DVT SWITCH? INB,RSS YES JMP ER56 NO, CALLING ERROR JSB $LIBR GO PRIVILEGED NOP LDA 1,I GET DVT6 "AV" SSA IS DEVICE BUSY? JMP ER37 YES, CAN'T SWITCH NOW * * PROCESS SELECT CODE PARAMETER LDA $IFT# NUMBER OF IFT'S IN SYSTEM CMA,INA NEGATE STA TEMP SAVE COUNTER LDB $IFTA ADDR OF 1ST IFT * FIND IFT WITH SPECIFIED SELECT CODE LA.10 STB IFTAD SAVE ADDR OF IFT ADB .5 ADDR OF THIS IFT'S WORD 6 LDA 1,I GET IFT6 AND B77 ISOLATE SELECT CODE CPA M.SC,I DOES IT MATCH PARAM #4? JMP LA.15 YES * FIGURE OUT STARTING ADDR OF NEXT IFT INB LDA 1,I GET IFT7 AND B777 ISOLATE EXT LENGTH INA ADB 0 B NOW HAS NEXT IFT'S ADDR ISZ TEMP HAVE ALL IFT'S BEEN EXAMINED? JMP LA.10 NO, ITERATE LDA .56 YES, SELECT CODE IN ERROR JMP ERPRV * IFT FOUND, ENSURE IT'S SAME INTERFACE TYPE ELSE ERROR 35 LA.15 LDA 1,I GET "ITYPE" LDB DVT5,I GET ORIGINAL IFT ADDR ELB,CLE,ERB CLEAR SIGN ADB .5 POINT TO ITS "ITYPE" XOR 1,I COMPARE THE TWO AND TYFLD ISOLATE BITS 13-8 SZA DOES ITYPE MATCH? JMP ER35 NO, GIVE ERROR * * UNLINK DVT FROM IT'S OLD CIRCULAR DVT LIST CCB ADB DVT5 POINT TO DVT4 STB TEMP LA.20 LDA 1,I GET NEXT DVT ADDR IN LIST RAL,CLE,ERA CLEAR SIGN CPA DVTAD IS IT THE REMOVED DVT? JMP LA.25 YES ADA .3 LDB 0 JMP LA.20 LOOP LA.25 LDA TEMP,I GET LINK FROM REMOVED DVT RAL,ERA RESTORE SIGN BIT STA 1,I SET UPDATED LINK WORD IN PREV. DVT * * UPDATE IFT'S DVT REFERENCE IF IT POINTS TO REMOVED DVT * LDB DVT5,I GET IFT ADDRESS ELB,CLE,ERB CLEAR SIGN ADB .4 POINT TO IFT5 LDA 1,I GET DVT REFERENCE IN IFT CPA DVTAD IS IT THE REMOVED DVT? RSS YES JMP LA.30 NO, IGNORE LDA TEMP,I ADDR OF NEXT DVT IN OLD DVT LIST ELA,CLE,ERA STRIP SIGN CPA DVTAD THIS DVT ONLY ONE ON LIST? CLA YES, THEN ZERO THE DVT REFERENCE STA 1,I STORE NEW DVT REFERENCE IN IFT5 SKP * * NOW QUEUE THE DVT ON ITS NEW INTERFACE'S DVT LIST * LA.30 LDA DVT5,I GET IFT REFERENCE ELA SAVE "P"-BIT LDA IFTAD RAL,ERA MOVE "P" INTO NEW IFT ADDR WD STA DVT5,I UPDATE THE IFT REFERENCE LDB IFTAD NEW IFT'S ADDR ADB .4 IFT5 ADDR LDA 1,I GET IFT'S DVT REF SZA,RSS ANY DVT REFERENCED? JMP LA.40 NO ADA .3 POINT TO IT'S CIRCULAR LIST LDB 0,I GET IT RBL,CLE,ERB SAVE/CLEAR SIGN STB TEMP SAVE ADDR OF NEXT DVT LDB DVTAD RBL,ERB RESTORE SIGN STB 0,I & LET DVT REFERENCE THE NEW ONE LA.35 CCB ADB DVT5 DVT4 OF REQUEUED DVT LDA 1,I ELA SAVE SIGN OF REQUEUED DVT4 LDA TEMP REFERENCE TO NEXT DVT ON NEW LIST RAL,ERA RESTORE SIGN STA 1,I & UPDATE LINK IN REQUEUE'D DVT4 WORD * THE DVT IS NOW REQUEUED ON IT'S NEW IFT JMP LA.60 * LA.40 LDA DVTAD THE REQUEUED DVT IS ONLY ONE ON STA 1,I THE INTERFACE, SO IFT5 POINTS TO IT STA TEMP SET POINTER TO LINK DVT4 TO SELF JMP LA.35 HED ******* LU SWITCHING TO NEW DVT ******* * HERE FOR ASSIGNMENT OF LU TO BIT BUCKET LA.45 LDA NUMBA,I GET # OF PARAMS CPA .2 EXACTLY 2? CLA,RSS YES, SWITCH TO BIT BUCKET OK JMP ER56 NO, HE DOESN'T KNOW WHAT HE'S DOING STA DVTAD PUT A ZERO IN LUT TABLE ENTRY SPC 3 * * ENTER HERE FOR LU SWITCH * LA.50 JSB $LIBR GO PRIVILEGED NOP * LA.60 LDB LUTAD,I GET OLD ASSIGNMENT LDA DVTAD STA LUTAD,I SET LU TABLE TO REFLECT NEW DVT SZB,RSS BIT BUCKET? JMP LA.90 YES, DONT WORRY ABOUT LOCK OR WAITERS * SEE IF OLD DVT WAS LOCKED STB TEMP SAVE OLD DVT ADDRESS ADB .6 POINT TO DVT 7 LDA 1,I AND LUMSK ISOLATE LOCK FLAG SZA,RSS IS PREVIOUS DVT LOCKED? JMP LA.75 NO * CLEAR OLD DVT'S LOCK FLAG STA NUMBA SAVE LOCK FLAG XOR 1,I CLEAR FLAG BITS IN DVT7 STA 1,I & UPDATE DVT LDB DVTAD GET NEW DVT ASSIGNMENT SZB,RSS BIT BUCKET? JMP LA.70 YES, FORGET ABOUT LOCK FLAG * MOVE LOCK FLAG TO NEW DVT UNLESS IT IS ALREADY LOCKED ADB .6 POINT TO DVT 7 OF NEW ASSIGNMENT LDA 1,I AND LUMSK ISOLATE ITS LOCK FLAG SZA ALREADY LOCKED? JMP LA.70 YES! TOUGH LUCK FOR SWITCHED LOCKER LDA 1,I NO, MOVE LOCK IOR NUMBA FLAG FROM PREVIOUS TO NEWLY STA 1,I ASSIGNED DVT * LA.70 LDA TEMP PREVIOUS DVT ADDR JSB $SCHD IN CASE MORE THAN 1 LU ON OLD DVT, OCT 50 RESCHEDULE LOCK WAITERS * LA.75 LDA TEMP PREVIOUS DVT ADDR JSB $SCHD RESCHEDULE ANY WAITERS ON DOWN LIST OCT 54 FOR OLD DVT LDA TEMP GET OLD DVT AGAIN JSB $SCHD RESCHEDULE ANY WAITERS FOR BUFFER LIMITS OCT 55 FOR OLD DVT SKP * * NOW MOVE ANY NON-ACTIVE QUEUED REQUESTS TO THE NEW DVT UNLESS * THE OLD DVT IS REFERENCED BY ANOTHER LU. UPDATE BUFFER * ACCUMULATORS FOR MOVED CLASS & BUFFERED I/O BLOCKS. IF * ANY REQUESTS ARE MOVED AND THE NEW DVT IS NOT ACTIVE, THE * I/O SYSTEM IS CALLED TO INITIATE THE HEAD OF THE DVT * INITIATION LIST. LDB TEMP JSB $DVLU FIND ANY LU REFERENCING OLD DVT SZA ANY LU? JMP LA.90 YES, LEAVE INIT. LIST ALONE ADB .5 POINT TO DVT6 LDA 1,I GET "AV" ADB .2 STB NUMBA SAVE ADDR OF OLD DVT BUF ACCUMULATOR ADB N6 POINT TO DVT2 SSA IS OLD DEVICE BUSY? LDB 1,I YES, SKIP HEAD OF INIT LIST * B NOW HAS ADDRESS OF POINTER TO 1ST ENTRY TO BE MOVED ELB,CLE,ERB CLEAR SIGN LDA 1,I GET ADDR OF 1ST TO MOVE RAL,CLE,ERA CLEAR/SAVE SIGN BIT STA TEMP1 CLA ERA MAINTAIN SIGN BIT STA 1,I STORE 0 TO MARK END OF LIST * FIND END OF NEW DVTS CURRENT INITIATION LIST LDB DVTAD ADDR OF NEW DVT CLA,INA JSB $DIOC SET DVT LINKS LDA $DV2 POINT TO DVT2 LA.82 LDB 0 GET ADDR OF NEXT LDA 1,I GET LINK TO NEXT RAL,CLE,ERA CLEAR/SAVE SIGN SZA END OF INITIATION LIST? JMP LA.82 NO, KEEP GOING * LINK MOVED REQUESTS AT END OF THE NEW DVT'S LIST LDA TEMP1 GET ADDR OF HEAD OF CHAIN TO MOVE RAL,ERA MAINTAIN SIGN STA 1,I ADD CHAIN TO NEW INIT LIST * RECOMPUTE OLD & NEW DVT BUFFER ACCUMULATORS FOR BLOCKS IN SAM LA.84 LDB TEMP1 GET ADDR OF 1ST MOVED BLOCK ?SZB,RSS MORE ON MOVE CHAIN? JMP LA.88 NO LDA 1,I GET LINK TO NEXT STA TEMP1 SAVE IT INB POINT TO 2ND WORD IN BLOCK LDA 1,I GET CONWD RAL SSA,RSS IS THIS A CLASS OR BUFRD REQ? JMP LA.84 NO, DOESN'T AFFECT ACCUMS ADB .6 POINT TO BLOCK SIZE (WORD 8 OF BLOCK) LDA 1,I GET BLOCK TOTAL SIZE ADA $DV8,I UPDATE NEW DVT'S ACCUMULATOR STA $DV8,I LDA 1,I GET SIZE AGAIN CMA,INA ADA NUMBA,I SUBTRACT SIZE FROM OLD DVT'S STA NUMBA,I BUFFER ACCUMULATOR JMP LA.84 ITERATE * CLEAR OLD DVT'S BUFFER-LIMITED FLAG LA.88 ISZ NUMBA POINT TO DVT9 OF OLD DVT LDA NUMBA,I ELA,CLE,ERA CLEAR "BUFFER-LIMITED" FLAG (15) STA NUMBA,I * DETERMINE IF NEW DVT IS NOT DOWN & HAS A NON-ACTIVE REQUEST * AT THE HEAD OF ITS DVT INITIATION LIST LDA $DV6,I GET AV LDB $DV2,I GET HEAD OF INIT LIST ELB,CLE,ERB CLEAR SIGN RAL SZB INIT LIST EMPTY? CMA,SSA,SLA,RSS IS DEVICE BUSY OR DOWN? JMP LA.90 YES, DON'T INITIATE * INITIATE THE HEAD OF THE NEW DVTS INITIATION QUEUE NOW! * ( ALL IS KOSHER EVEN IF THIS IS THE BIT BUCKET) LDB *+2 GET RETURN ADDR FOR I/O SYS JMP $INIO JUMP INTO I/O SYS FOR LOGICAL INIT DEF LA.90 * LA.90 JSB $LIBX RAISE FENCE DEF *+1 DEF *+1 HED ******* DISPLAY LU ASSIGNMENT ******* * LD.00 LDA M.LU GET LU # JSB DECIM CONVERT TO ASCII-DECIMAL STA M.LU OF LU LDA LUTAD,I GET LUT ENTRY SZA,RSS BIT BUCKET? JMP LD.90 YES STA DVTAD SAVE DVT ADDRESS * NOW COMPUTE THIS DVT NUMBER CLA,INA STA TEMP LDB $DVTA ADDR OF 1ST DVT LD.10 CPB DVTAD DVT ADDR MATCH? JMP LD.15 YES JSB NXDVT GET ADDR OF NEXT DVT ISZ TEMP JMP LDm.10 ITERATE * CONVERT DISPLAY VALUES TO ASCII LD.15 LDA TEMP GET DVT # JSB DECIM CONVERT TO 2 DIGIT DECIMAL VALUE STA M.DVT STORE ASCII OF DVT # LDB DVTAD ADB .5 ADDR OF DVT6 LDA 1,I ALF,ALF RIGHT JUSTIFY DEVICE TYPE JSB OCTAL CONVERT TO ASCII-OCTAL STA M.DTY STORE DEVICE TYPE IN MSG LDB DVTAD ADB .4 DVT5'S ADDR LDB 1,I GET IFT REF ELB,CLE,ERB CLEAR SIGN ADB .5 ADDR OF IFT6 LDA 1,I GET INTERFACE SELECT CODE STA TEMP JSB OCTAL CONVERT TO ASCII-OCTAL STA M.SC & STORE IN MSG LDA TEMP GET IFT6 WORD AGAIN ALF,ALF RIGHT JUSTIFY INTERFACE TYPE JSB OCTAL CONVERT TO ASCII-OCTAL STA M.ITY & STORE IN MSG LDB MSGLN LD.80 STB TEMP * JSB CNOPT WRITE RESPONSE LINE DEF *+5 DEF .2 DEF CAM.O DEF MSGBF DEF TEMP JMP LA..,I RETURN * LD.90 LDA ASC.0 BIT BUCKET, SO DISPLAY STA M.DVT DVT # OF ZERO LDB .6 & SHORTEN MSG JMP LD.80 HED ******* ROUTINES & CONSTANTS ******* ER56 LDA .56 56 = BAD PARAMETER STA ERRTN,I RETURN ERROR VALUE JMP LA..,I AND RETURN * ER35 LDA .35 IFT SWITCH TO WRONG ITYPE RSS * ER37 LDA .37 37 = DEVICE BUSY ERROR ERPRV STA ERRTN,I RETURN ERROR JSB $LIBX GO UNPRIVILEGED & RETURN DEF LA.. * * SUBROUTINE TO CONVERT VALUE TO ASCII-OCTAL * OCTAL NOP AND B77 JUST USE BITS 5-0 JSB CONVT CONVERT TO ASCII DEC 8 BASE 8 JMP OCTAL,I * * SUBROUTINE TO CONVERT VALUE TO ASCII-DECIMAL * 2-DIGIT VALUE, SUPPRESSING A LEADING ZERO * DECIM NOP JSB CONVT CONVERT TO ASCII DEC 10 BASE 10 JMP DECIM,I * CONVT NOP CLB DIV CONVT,I SZA LEADING ZE\?0.*RO? IOR B20 NO, FORM NUMERIC ALF,ALF LEFT JUSTIFY IOR 1 INCLUDE LSB IOR ASC.0 FORM ASCII ISZ CONVT JMP CONVT,I RETURN * * SUBROUTINE TO COMPUTE ADDR OF NEXT DVT, CURRENT DVT ADDR IN B * NXDVT NOP ADB .20 POINT TO DVT21 STB CONVT LDA 1,I GET DVTP LENGTH CLB RRL 7 RIGHT JUSTIFY DVTP LENGTH IN B ADB CONVT COMPUTE ADDR OF NEXT ADB .2 SEQUENTIAL DVT JMP NXDVT,I RETURN * * THIS SUBROUTINE RETURNS AN ERROR 56 IF ADDRESSED * DVT IS A DISK CKDSK NOP ADA .5 POINT TO DVT6 LDA 0,I GET IT AND .034 HI BITS OF DEVICE TYPE CPA .014 TYPE = 30-37? JMP ER56 YES, DISC, GIVE ERROR JMP CKDSK,I ELSE JUST RETURN * * DATA AREA * NUMBA NOP ERRTN NOP LUTAD NOP DVTAD NOP IFTAD NOP DVT5 NOP TEMP NOP TEMP1 NOP * .1 DEC 1 .2 DEC 2 .3 DEC 3 .4 DEC 4 .5 DEC 5 .6 DEC 6 .20 DEC 20 .35 DEC 35 .37 DEC 37 .56 DEC 56 B20 OCT 20 B77 OCT 77 B777 OCT 777 LUMSK OCT 3770 TYFLD OCT 37400 .034 OCT 34000 .014 OCT 14000 N6 DEC -6 ASC.0 ASC 1, 0 * * MSGBF EQU * ASC 2, LU# M.LU BSS 1 ASC 2,,DV# M.DVT BSS 1 ASC 2,,DT= M.DTY BSS 1 ASC 2,,SC# M.SC BSS 1 ASC 2,,IT= M.ITY BSS 1 MSGLN ABS *-MSGBF * * END 0  92070-18103 1941 S C0122 &ON..              H0101 ]GASMB,R * * NAME: ON.. * SOURCE: 92070-18103 * RELOC: 92070-1X103 * PGMR: C.H.W.,H.L.C. * * **************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT * * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * **************************************************************** * * NAM ON..,7 92070-1X103 REV.1941 791004 * * * * ACTION SUBROUTINE TO EXECUTE THE "ON" OPERATOR COMMAND * * COMMAND SYNTAX: * ON,NAME(,PASSED PARAMETERS) * * ENT ON.. * EXT $LIBR,$LIBX,$CON,$WORK,$NAME EXT $TADD,$TMSC,$TIME,$ALCS,$RQP8,$RQP9 EXT $XQT,$SUSP,ECH,$TMP1,$SBLN EXT $LIST,$PVCN,$XEQ,C.BUF * * ON.. NOP RETRY LDA ON.. ADA .2 2ND PARAMETER IS THE PARSE BUFFER ADDR LDB 0,I GET IT INB POINT TO PARAMETERS STB TMPAD INA LDA 0,I STA ERRTN SAVE ADDR OF ERROR PARAM LDA ON..,I STA RTN SAVE RETURN ADDR * JSB $LIBR GO PRIVILEGED NOP JSB $NAME GET ID SEG ADDR TMPAD NOP SZB,RSS NAME FOUND? JMP ER14 NO, ERROR SZA DORMANT? JMP ER18 NO, ERROR ADB .10 ID SEG WORD 11 STB TEMP0 SAVE ADDR OF B REG SAVE ADB .7 ID SEG WORD 18 STB TEMP1 ADB .11 ID SEG WORD 29 STB TEMP2 LDA TEMP1,I AND B160K ISOLATE RESOLUTION CODE SZA,RSS SPECIFIED? JMP ER36 NO, ERROR ADB N27 POINT TO ID SEG WORD 2 STB PRMPT STB TEMP3 LDA DC.BF STA $RQP8 STRING ADDR LDA ECH RAL STRING BYTE LEN STA $RQP9 LDB $WORK JSB $ALCS SZB  JMP SUSP NOT ENOUGH SAM LDB PRMPT STB TEMP0,I B POINTS TO PRAMS LDB TMPAD LDA N5 SET TO MOVE STA TEMP0 5 PARAMETERS NPRM ADB .4 LDA 1,I GET PARSED PARAMETER STA PRMPT,I MOVE INTO ID SEG ISZ PRMPT ISZ TEMP0 MORE? JMP NPRM YES * LDA $CON,I AND B77 LOG LU OF FMGR LDB TMPAD ADB .3 LDB 1,I ANY PRAMS? SZB,RSS STA TEMP3,I NO, GIVE HIM LOG LU LDB 0 LDA TEMP2,I AND HIGH8 IOR 1 STA TEMP2,I ISZ TEMP1 DLD * CHECK TIME FOR NEG ZERO TEMP1 EQU *-1 XOR RS1 CPB RS2 SZA JMP ZCHK NOW DLD $TIME TIME=0, USE CURRENT DST TEMP1,I LDB $WORK JSB $TADD ADD TO TIME LIST LDB $WORK JSB $TMSC TIME SCHEDULE NOW EXIT JSB $LIBX DEF RTN * ZCHK SZB,RSS JMP NOW POSITIVE ZERO LDB $WORK NON-ZERO START TIME JSB $TADD ADD TO TIME LIST JMP EXIT * * ER14 LDA .14 REQUIRED ID SEG NOT FOUND JMP EREX * ER18 LDA .18 PROGRAM NOT DORMANT JMP EREX * ER36 LDA .36 NO TIME PARAMETERS SPECIFIED * EREX STA ERRTN,I STORE ERROR CODE JMP EXIT * * SUSP LDA DRTRY STA $SUSP,I SUSPEND FOR RETRY LDA $SBLN STA $TMP1,I SAVE AMOUNT OF SAM NEEDED LDB $XQT JSB $LIST SUSPEND CALLER OCT 61 FOR MEMORY CLA STA $PVCN CLEAR PRIV COUNT JMP $XEQ * * .2 DEC 2 .3 DEC 3 .4 DEC 4 .7 DEC 7 .10 DEC 10 .11 DEC 11 .14 DEC 14 .18 DEC 18 .36 DEC 36 N5 DEC -5 N27 DEC -27 B77 OCT 77 HIGH8 OCT 177400 B160K OCT 160000 * RS1 OCT 25000 RS2 OCT 177574 * DRTRY DEF RETRY DC.BF DEF C.BUF * TEMP0 NOP TEMP2 NOP TEMP3 NOP ERRTN NOP PRMPT NOP RTN NOP * END #   92070-18104 1941 S C0122 &PL..              H0101 \HASMB,R * * NAME: PL.. * SOURCE: 92070-18104 * RELOC: 92070-1X104 * PGMR: C.H.W. * * **************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT * * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * **************************************************************** * * NAM PL..,7 92070-1X104 REV.1941 790607 * * * ENT PL.. * EXT O.BUF,TMP.,OPEN.,WRITF EXT $LIBR,$LIBX,$CVT3 EXT MESSS EXT $IDA,$ID#,$IDSZ * SUP * * PL.. NOP JSB OPEN. OPEN LIST FILE DEF *+5 DEF O.BUF DEF TMP. DEF TMP.+3 DEF ZERO * CLA STA IERR INITIALIZE ERROR FLAG * LDB $ID# CMB,INB NEG # OF ID SEGS STB IDCNT LDA PL.. ADA .2 LDA 0,I ADDRESS OF PARAMETER BUFFER INA LDA 0,I GET TYPE OF LIST CPA ASCMB MEMORY BOUNDS ("MB")? JMP PB.00 YES CPA ASCIT TIME LIST ("IT")? JMP PT.00 YES SZA,RSS DO ALL? JMP PL.30 YES * * LIST ONLY THOSE PROGRAMS OF REQUESTED STATUS STA TEMP SAVE STATUS TYPE LDB TYPES LIST OF VALID STATI PL.10 LDA 1,I SSA END OF LIST? JMP ER56 YES, PARAMETER ERROR CPA TEMP FOUND? JMP PL.20 YES ADB .2 JMP PL.10 ITERATE * PL.20 INB LDB 1,I GET NUMERIC EQUIVALENT * PL.30 STB STTUS SAVE LIST TYPE LDB $IDA ADDR OF ID SEGMENTS * PL.40 STB IDADS LDA STTUS SSA DOING ALL? JMP PL.50 YES ADB .15 POINT TO IDSEG WD 16 XOR 1,I AND B77 STATUS IN BITS 5-0 SZA STATUS MATdCH? JMP PL.60 NO LDB IDADS * PL.50 ADB .12 POINT TO NAME IN IDSEG LDA 1,I GET 1ST 2 CHARS SZA,RSS JMP PL.60 ID SEG NOT USED STA MSNAM MOVE TO BUFR INB DLD 1,I GET LAST 3 CHARS DST MSNAM+1 DLD PSCMD " PS," DST MSBUF MOVE CMD * JSB MESSS CALL MESSAGE PROCESSOR DEF *+3 DEF MSBUF DEF .9 SSA,RSS ANY REPLY? JMP ER56 ERROR?? ADA N2 STA LEN JSB OUTPT WRITE RESPONSE TO LIST DEVICE DEF MSBUF-1 DEF LEN * PL.60 LDB IDADS ADB $IDSZ POINT TO NEXT ID SEGMENT ISZ IDCNT MORE? JMP PL.40 YES * PL.EX LDA PL..,I JMP 0,I EXIT SKP * * LIST ALL PROGRAMS IN TIME LIST * PT.00 LDB $IDA ADDR OF ID SEGMENTS * PT.20 STB IDADS SAVE ID SEGMENT ADDR ADB .17 POINT TO RES/MULT IN ID SEGMENT +17 STB IDADR LDA 1,I GET RES ALF,SLA,RAR RIGHT JUSTIFY IT, SKIP IF T=0 RSS IN TIME LIST JMP PT.70 NOT IN TIME LIST, IGNORE IT AND .7 ISOLATE IT ADA ASRES ADDR INTO ASCII CONV.TABLE LDA 0,I GET MS,SC,MN, OR HR STA M.RES STORE IN MSG * LDB IDADS ADB .14 ID SEG WORD 15 LDA 1,I HAS LAST CHAR OF NAME AND HIGH8 CLEAR RHW IOR B40 FILL WITH A BLANK STA M.NAM+2 STORE IN LINE ADB N2 POINT TO ID+12 DLD 1,I GET 1ST 4 CHARS OF NAME DST M.NAM * LDA IDADR,I GET MULT AND B7777 ISOLATE IT CLB DIV .100 SEPARATE HIGH TWO DIGITS SZA,RSS ARE HIGH 2 DIGITS ZERO? JMP PT.40 YES STB M.MUL+1 SAVE LOW JSB DECIM CONVERT HIGH TO ASCII STA M.MUL STORE IN MSG LDA M.MUL+1 GET LOW JSB DECIM CONVERT TO ASCII IOR .01B ?ENSURE NUMERIC JMP PT.45 * PT.40 LDA BLANK STA M.MUL BLANK-OUT HIGH 2 DIGITS LDA 1 GET LOW DIGITS JSB DECIM CONVERT TO ASCII PT.45 STA M.MUL+1 STORE LOW ORDER DIGITS IN MSG ISZ IDADR POINT TO TIME FIELD IDADR EQU *+1 DLD * GET TIME FROM ID SEGMENT ADA PRS1 ADD POSITIVE 24 HRS. SEZ TO GET A POSITIVE INB TIME ADB PRS2 DIV .6000 DIVIDE BY 6000 STA TEMP SAVE MIN/HR ASR 16 POSITION B (SEC/10MS) FOR DIVIDE DIV .100 DIVIDE BY 100 TO GET SEC/10MS STB M.MSC SAVE 10'S OF MSECS JSB DECIM CONVERT SECONDS TO ASCII STA M.SEC & STORE IN MSG LDA M.MSC JSB DECIM CONVERT 10'S OF MSECS TO ASCII LDB ASC0C "0:" RRR 8 FORM ":MM0" DST M.MSC STORE MILLISECS IN ASCII CLB SET UP FOR DIVIDE LDA TEMP FETCH MIN/HR DIV .60 SEPERATE STB M.MIN SAVE MINUTES CPA .24 HOUR ROLL-OVER? CLA YES JSB DECIM CONVERT HOURS TO ASCII STA M.HR & SAVE IN MESSAGE LDA M.MIN GET MINUTES JSB DECIM CONVERT TO ASCII LDB ASCCL GET "::" RRR 8 FORMAT ":XX:" DST M.MIN STORE INTO MSG * JSB OUTPT WRITE RESPONSE LINE DEF MSGBF DEF MSGLN * PT.70 LDB IDADS ADB $IDSZ ISZ IDCNT MORE ID SEGMENTS? JMP PT.20 YES JMP PL.EX NO, DONE SKP * * LIST PROGRAM MEMORY BOUNDS * * PB.00 JSB OUTPT WRITE HEADER DEF MBHDR DEF MBHLN LDB $IDA ADDR OF ID SEGS * PB.20 STB IDADS LDA MSF2A ADDR OF MESAGE FIELDS STA TEMP ADB .14 POINT TO NAME IN ID SEG LDA 1,I GET LAST CHAR AND HIGH8 ISOLATE IT IOR B40 BLANK STA MBF1+2 STORE IN MSG ADMB N2 POINT TO 1ST WD OF NAME DLD 1,I GET 4 CHARS OF NAME SZA,RSS JMP PB.50 ID SEG NOT USED DST MBF1 STORE IN MSG LDB IDADS ADB .20 POINT TO HI CORE START LDA 1,I GET IT RAL,CLE,ERA CLEAR SIGN JSB $LIBR LOWER FENCE NOP JSB CONVL CONVERT TO ASCII OCT 24000 "(" CCA ADA 1,I GET HI CORE LAST RAL,CLE,ERA JSB CONVL CONVERT TO ASCII OCT 26000 "," ISZ TEMP INB POINT TO BASE PAGE LIMITS LDA 1,I GET LOW BASE PAGE AND B1777 USE BITS 9-0 JSB CONVL CONVERT TO ASCII OCT 24000 "(" CCA ADA 1,I HIGH BASE PAGE AND B1777 USE BITS 9-0 JSB CONVL CONVERT TO ASCII OCT 26000 "," * JSB $LIBX RAISE FENCE DEF *+1 DEF *+1 * JSB OUTPT PRINT BOUNDS DEF MBMSG DEF MBLEN * PB.50 LDB IDADS ADB $IDSZ POINT TO NEXT ID SEG ISZ IDCNT MORE? JMP PB.20 YES JMP PL.EX DONE * * CONVL NOP CLE,INB POINT TO NEXT ID SEG WD JSB $CVT3 CONVERT A REG TO ASCII STA TEMP2 SAVE ADDR OF RESULT LDA 0,I GET 1ST 2 CHARS AND B377 1ST MUST BE ZERO CPA B60 IS 2ND ZERO? LDA B40 YES, USE A SPACE IOR CONVL,I FILL 1ST CHAR STA TEMP,I STORE IN MSG ISZ TEMP2 POINT TO 3RD & 4TH CHARS ISZ TEMP LDA TEMP2,I MOVE ASCII VALUE STA TEMP,I INTO MESSAGE ISZ TEMP2 ISZ TEMP LDA TEMP2,I STA TEMP,I ISZ TEMP ISZ CONVL JMP CONVL,I RETURN * * * * DECIM NOP CLB DIV .10 SZA,RSS LDA B20 SUPPRESS LEADING ZERO ALF,CLE,ALF IOR 1 MERGE 2 DIGITS XOR ASC00 FORM ASCII NUMERICS JMP DECIM,EI SPC 3 * ER56 LDA .56 * ERR LDB PL.. ADB .3 LDB 1,I GET ADDR FOR ERROR PRAM STA 1,I RETURN ERROR JMP PL.EX EXIT SPC 3 * * ROUTINE TO WRITE LINE TO LIST FILE * OUTPT NOP DLD OUTPT,I GET ADDR OF BUFFER & ADDR OF LENGTH DST OUTP5 STORE IN-LINE OF CALL JSB WRITF WRITE LINE DEF *+5 DEF O.BUF DEF IERR OUTP5 BSS 2 LDA IERR GET FMGR ERROR CODE SSA ERROR? JMP ERR YES ISZ OUTPT ISZ OUTPT JMP OUTPT,I RETURN SPC 3 * * DATA AREA * TEMP NOP TEMP2 NOP IERR NOP IDADS NOP IDCNT NOP STTUS NOP LEN NOP ZERO DEC 0 .9 DEC 9 .10 DEC 10 .12 DEC 12 .14 DEC 14 .15 DEC 15 .17 DEC 17 .20 DEC 20 .24 DEC 24 .56 DEC 56 .60 DEC 60 .100 DEC 100 .6000 DEC 6000 B20 OCT 20 B40 OCT 40 B77 OCT 77 B377 OCT 377 B1777 OCT 1777 B7777 OCT 7777 HIGH8 OCT 177400 .01B OCT 010000 N2 DEC -2 * PRS1 OCT 153000 PRS2 OCT 203 ASCIT ASC 1,IT ASCMB ASC 1,MB ASC00 ASC 1,00 ASC0C ASC 1,0: ASCCL ASC 1,:: PSCMD ASC 2, PS, MSF2A DEF MBF1+3 * ASC 1, MSBUF BSS 2 MSNAM BSS 3 BSS 16 * MSGBF EQU * ASC 1, M.NAM BSS 3 ASC 2, R= M.RES NOP BLANK ASC 2, M= M.MUL DEC 0,0 ASC 1, M.HR NOP M.MIN DEC 0,0 M.SEC NOP M.MSC DEC 0,0 MSGLN ABS *-MSGBF * MBMSG ASC 2, MBF1 BSS 9 ASC 1,) BSS 6 ASC 1,) MBLEN ABS *-MBMSG * ASRES DEF *+1 CONVERT RES CODE TO ASCII ASC 5,XXMSSCMNHR * TYPES DEF *+1 ASC 1,OF DORMANT OCT 0 ASC 1,IO I/O SUSPEND .2 OCT 2 ASC 1,WT PROGRAM WAIT SUSPEND .3 OCT 3 ASC 1,SS OPERATOR SUSPEND OCT 6 ASC 1,PA PAUSE .7 OCT 7 ASC 1,TM TIME SUSPEND OCT 47 ASC 1,LK LOCKED DEVICE SUSPEND OCT 50 ASC 1,RN RESOURCE N$$"UMBER SUSPEND OCT 51 ASC 1,CL CLASS GET OR CLASS # SUSPEND OCT 52 ASC 1,QU QUEUE SUSPEND OCT 53 ASC 1,DN DOWN DEVICE SUSPEND OCT 54 ASC 1,BL BUFFER LIMIT SUSPEND OCT 55 ASC 1,LD LOAD SUSPEND OCT 56 ASC 1,SR SHARED SUBROUTINE SUSPEND OCT 57 ASC 1,SC SCHEDULED B60 OCT 60 ASC 1,XQ EXECUTING OCT 60 ASC 1,MM MEMORY SUSPEND OCT 61 OCT 100000 END OF TABLE * MBHDR ASC 26, PGM LIST: NAME (LO MAIN,HI MAIN) (LO BASE,HI BASE) MBHLN ABS *-MBHDR * SIZE EQU * END $  92070-18105 1941 S C0122 &TM..              H0101 ^LASMB,R * * NAME: TM.. * SOURCE: 92070-18105 * RELOC: 92070-1X105 * PGMR: C.H.W. * * **************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT * * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * **************************************************************** * * NAM TM..,7 92070-1X105 REV.1941 790918 * * * * ACTION SUBROUTINE TO EXECUTE THE "TM" OPERATOR COMMAND * * COMMAND SYNTAX: * TM(,HR,MIN,SEC,MONTH,DAY,YEAR) * RESPONSE IS: * HR:MIN:SEC MONTH,DAY,YEAR WKDAY * * * ENT TM.. * EXT EXEC,$LIBR,$LIBX,$TIME,CAM.O,$TMLS EXT CNOPT * * SUP * TM.. NOP LDA TM.. INA LDB 0,I STB NUMBA SAVE ADDR OF # PRAMS INA 2ND PARAMETER IS THE PARSE BUFFER ADDR LDB 0,I GET IT ADB N3 PARAMETER POINTER STB TMPAD INA LDA 0,I STA ERRTN SAVE ADDR OF ERROR PARAM LDA TM..,I STA TM.. SAVE RETURN ADDR * LDA PCHEK INITIALIZE FOR MAX STA PCHKP VALUE CHECK IN "CHECK" CLA CPA NUMBA,I TEST # OF PARAMS JMP TM.50 JUST DISPLAY CURRENT TIME CPA $TMLS ANYTHING IN TIME-LIST? RSS NO, PROCEED JMP ER34 YES, CAN'T CHANGE TIME JSB CHECK GET/CHECK ENTERED HOUR MPY .60 CONVERT TO MINUTES JSB CHECK GET/CHECK ENTERED MINUTES ADA VALX ADD HRS*60 JSB CHECK GET/CHECK SECONDS MPY .100 CONVERT TO 1O'S OF MSECS STA M.SEC LDA VALX GET 60*HR+MIN MPY .6000 CONVERT TO 10'S OF MSECS ADA M.SEC COMPUTE[(HR*60+MIN)*60+SEC]*100 SEZ OVERFLOW? D INB YES, CARRY INTO B TM.20 CLE,SSB IF POSITIVE JMP TM.30 ADA RS1 SUBTRACT 24 HRS SEZ UNTIL INB ADB RS2 IT IS JMP TM.20 NEGATIVE * TM.30 DST M.MIN SAVE FOR LATER JSB CHECK GET/CHECK MONTH SZA,RSS JMP ER56 ZERO IS ILLEGAL STA M.MON SAVE IT ADA M#DAY COMPUTE POS IN CONVERSION TABLE LDB 0,I GET STARTING JULIAN DAY OF MONTH JSB CHECK GET/CHECK DAY SZA,RSS JMP ER56 ZERO IS ILLEGAL RBL,CLE,SLB,ERB SKIP UNLESS 31 DAY MONTH JMP *+3 31 DAY, SKIP BELOW CHECK CPA .31 DAY=31? JMP ER56 YES, ERROR STA M.DAY ADB 0 ADD START OF MONTH JSB CHECK GET/CHECK YEAR ADA N1976 BEGIN AT 1976 CLE,SSA WAS YEAR < 1976? JMP ER56 YES, ERROR STA VALX SAVE YEAR-1976 LDA .2 CPA M.MON FEBRUARY? INA,RSS YES JMP TM.40 NO AND VALX 2 LSB'S OF YR SZA LEAP-YEAR? CLA,INA NO ADA N30 FORM -(MAX+1) FOR FEB. DAYS ADA M.DAY SSA,RSS TOO MANY DAYS FOR FEB? JMP ER56 YES TM.40 LDA VALX GET YEAR AND .3 A IS NOW ZERO IFF LEAP-YEAR STB M.DAY SAVE JULIAN DAY ADB N60 SET E-REG IF > FEB 28 * BELOW INSTRUCTION SKIPS IF:DAY366? JMP ER56 YES, ERROR ADB .366 CONVERT TO RANGE 0-365 STB M.DAY LDA VALX GET YEAR-1976 MPY .366 CONVERT TO DAYS ADA M.DAY ADD SPECIFIED DAYS JSB $LIBR GO PRIVILEGED NOP STA $TIME+2 STORE IN SYSTEM TIME +2 DLD M.MIN DST $TIME STORE REST OF CURRENT TIME  JSB $LIBX GO UNPRIVILEGED DEF *+1 DEF *+1 * * THIS SECTION FORMATS THE "TM" DISPLAY * TM.50 LDA $TIME+2 GET DAY CLB STB M.MON INITIALIZE MONTH DIV .366 A HAS YR, B HAS DAY OF YEAR ADA .1976 ADD OFFSET STA M.YR SAVE YEAR STB M.DAY & DAY STB M.DAY+1 AND .3 A=0 IF IT'S LEAP-YEAR CLE,INB ADB N60 E=1 IF IT'S PAST FEB 28 SEZ,SZA SKP UNLESS PAST FEB 28 & NOT LEAP-YR ISZ M.DAY BUMP JULIAN DAY * LDA M.DAY LDB M#DY2 PNTR TO TBLE OF START DAY OF MONTH * TM.60 ISZ M.MON BUMP MONTH INB POINT TO NEXT MONTHS START DAY STA VALX SAVE OFFSET FROM START OF MONTH LDA 1,I GET START OF MONTH RAL,CLE,ERA GET START JULIAN DAY CMA,INA ADA M.DAY CURRENT DAY - START OF MONTH SSA,RSS IS DAY < START OF NXT MONTH? JMP TM.60 NO, TRY NEXT MONTH ISZ VALX COMPENSATE FOR ZERO OFFSET * ** COMPUTE DAY OF WEEK HERE CCA ADA M.YR YEAR-1 ARS,ARS /4 ADA M.YR + YEAR ADA M.DAY+1 +DAY CLB DIV .7 DAY OFFSET MODULO 7 BLS ADB DAYTB DLD 1,I DST M.WDY * LDA VALX GET DAY OF MONTH JSB DECIM CONVERT TO ASCII LDB ASCCM ", " RRR 8 FORMAT= " XX," DST M.DAY STORE DAY IN MSG LDA M.MON ALS 2*MONTH ADA MCONA ADDR OF 4 CHAR MONTH DESCR DLD 0,I GET ASCII MONTH DST M.MON STORE IN MSG LDA M.YR CLB DIV .100 SEPARATE 4 DIGITS OF YR STB VALX JSB DECIM CONVERT HIGH 2 DIGITS TO ASCII STA M.YR & STORE IN MSG LDA VALX JSB DECIM CONVERT LOW 2 DIGITS TO ASCII IOR .01B DON'T SUPPRESS LEADING ZERO STA M.YR+1 & STORE IN MSG * * $TDIMV CODE DLD $TIME ADA PRS1 ADD POSITIVE 24 HRS. SEZ TO GET A POSITIVE INB TIME ADB PRS2 DIV .6000 DIVIDE BY 6000 STA VALX SAVE MIN/HR ASR 16 POSITION B (SEC/10MS) FOR DIVIDE DIV .100 DIVIDE BY 100 TO GET SEC/10MS JSB DECIM CONVERT SECONDS TO ASCII STA M.SEC & STORE IN MSG CLB SET UP FOR DIVIDE LDA VALX FETCH MIN/HR DIV .60 SEPERATE STB M.MIN SAVE MINUTES JSB DECIM CONVERT HOURS TO ASCII STA M.HR & SAVE IN MESSAGE LDA M.MIN GET MINUTES JSB DECIM CONVERT TO ASCII LDB ASCCL GET "::" RRR 8 FORMAT ":XX:" DST M.MIN STORE INTO MSG * JSB CNOPT WRITE RESPONSE LINE DEF *+5 DEF .2 DEF CAM.O DEF MSGBF DEF MSGLN JMP TM..,I RETURN * * ER56 LDA .56 56 = BAD PARAMETER RSS ER34 LDA .34 34 = TIME-LIST NOT EMPTY STA ERRTN,I RETURN ERROR VALUE JMP TM..,I AND RETURN SPC 2 * DECIM NOP CLB DIV .10 SZA,RSS LDA B20 SUPPRESS LEADING ZERO ALF,CLE,ALF IOR 1 MERGE 2 DIGITS XOR ASC00 FORM ASCII NUMERICS JMP DECIM,I SPC 2 * CHECK NOP STA VALX SAVE A FOR CALLER LDA TMPAD POINTER TO PARSE BUFR ADA .4 ADVANCE TO NEXT PARAM STA TMPAD LDA 0,I GET PARAMETER SSA POSITIVE? JMP ER56 NO, ERROR ADA PCHKP,I TEST AGAINST MAX VALUE CLE,SSA,RSS TOO BIG? JMP ER56 YES ISZ PCHKP ADVANCE FOR NEXT CHECK LDA TMPAD,I GET PASSED PARAMETER JMP CHECK,I RETURN WITH E=0 & B UNCHANGED * * DATA AREA * TMPAD NOP PCHKP NOP NUMBA NOP ERRTN NOP VALX NOP * .2 DEC 2 .3 DEC 3 .4 DEC 4 .7 DEC 7 .10 u DEC 10 .56 DEC 56 .60 DEC 60 .34 DEC 34 .100 DEC 100 .366 DEC 366 .1976 DEC 1976 .6000 DEC 6000 B20 OCT 20 RS1 OCT 25000 RS2 OCT 177574 PRS1 OCT 153000 PRS2 OCT 203 N1 DEC -1 N3 DEC -3 N30 DEC -30 N307 DEC -307 N1976 DEC -1976 ASC00 ASC 1,00 ASCCM ASC 1,, ASCCL ASC 1,:: * MCONA DEF MONTH-2 M#DY2 DEF M#DAY+2 DAYTB DEF WKDAY * MSGBF EQU * ASC 1, M.HR NOP M.MIN DEC 0,0 M.SEC NOP ASC 1, M.MON DEC 0,0 M.DAY DEC 0,0 M.YR DEC 0,0 ASC 1, M.WDY DEC 0,0 MSGLN ABS *-MSGBF * * FOLLOWING TABLE DEFINES STARTING JULIAN DAY-1 OF EACH MONTH * VALUES ARE FOR LEAP-YEARS. BIT15=1 IF 31 DAY MONTH. BITS 14-12 * ARE 1ST WEEKDAY OF MONTH (JAN OR FEB) OF WKDAY-1 OTHERWISE (YEAR 0). M#DAY DEF *+1 OCT 100000 MONTH=0 OCT 100000 JAN .31 OCT 000037 FEB OCT 100074 MARCH OCT 000133 APRIL OCT 100171 MAY OCT 000230 JUNE OCT 100266 JULY OCT 100325 AUGUST OCT 000364 SEPTEMBER OCT 100422 OCTOBER OCT 000461 NOVEMBER OCT 100517 DECEMBER .01B OCT 010000 * PCHEK DEF *+1 TBLE OF MAX ALLOWED +1 FOR PARAMS DEC -24 HRS N60 DEC -60 MINUTES DEC -60 SECONDS DEC -13 MONTHS DEC -32 DAYS DEC -2145 YEARS * * ROTATE WEEKDAYS ON MARCH 1,2000 WKDAY ASC 14, SAT SUN MONTUES WEDTHUR FRI MONTH ASC 24, JAN FEB MAR APR MAYJUNEJULY AUGSEPT OCT NOV DEC * * END   92070-18106 1941 S C0122 &TO..              H0101 aLASMB,R * * NAME: TO.. * SOURCE: 92070-18106 * RELOC: 92070-1X106 * PGMR: C.H.W. * * **************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT * * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * **************************************************************** * * NAM TO..,7 92070-1X106 REV.1941 790712 * * * * * ACTION SUBROUTINE TO EXECUTE THE "TO" OPERATOR COMMAND * * COMMAND SYNTAX: * TO,LU(,TIMEOUT VALUE) * * ENT TO.. * EXT EXEC,$LIBR,$LIBX,$CVT3,CAM.O,CNOPT EXT $LUTA,$LUT# * * TO.. NOP LDA TO.. INA LDB 0,I STB NUMBA SAVE ADDR OF # PRAMS INA 2ND PARAMETER IS THE PARSE BUFFER ADDR LDB 0,I GET IT INB STB TMPAD INA LDA 0,I STA ERRTN SAVE ADDR OF ERROR PARAM LDA TO..,I STA TO.. SAVE RETURN ADDR * * PROCESS LU PARAMETER LDA 1,I GET LU PARAMETER STA M.VAL CMA,INA A=-LU SSA,RSS WAS LU < 1? JMP ER56 YES, ERROR ADA $LUT# ADD TOTAL # OF LU'S SSA OK? JMP ER56 NO, LU OUT OF RANGE LDA M.VAL GET LU AGAIN CLB,CCE DIV .10 SZA LEADING ZERO? IOR B20 NO, FORM NUMERIC ALF,ALF LEFT JUSTIFY IOR 1 INCLUDE LSB IOR ASC.0 FORM ASCII STA M.LU STORE IN MSG STA M.LU2 CCA -1 ADA M.VAL ADD NUMERIC LU ADA $LUTA ADD ADDRESS OF LUT LDB 0,I GET THE DVT ADDRESS SZB,RSS ASSIGNED TO BIT BUCKET? JMP TO.90 YES ADB .12 ADDR OF DVT13 (PHY T.O.) LDA NUMBA,I v GET NUMBER OF ENTERED PARAMS CPA .1 JMP TO.50 1 ENTERED, SO DISPLAY CURRENT T.O. CPA .2 RAL,SLA 2 ENTERED, OK JMP ER56 ELSE WRONG # OF PARAMS * ADA TMPAD COMPUTE ADDR OF 2ND PARM LDA 0,I GET NEW TIMEOUT CMA,INA,SZA NEGATE IT ADA N1 LESS 1 UNLESS 0 JSB $LIBR LOWER FENCE NOP STA 1,I STORE NEW TIMEOUT IN DVT13 JMP TO.60 NOW DISPLAY TIMEOUT * SKP * * * THIS SECTION DISPLAYS CURRENT TIMEOUT * TO.50 LDA 1,I GET CURRENT T.O. JSB $LIBR LOWER FENCE NOP TO.60 CMA,CCE,INA,SZA MAKE POSITIVE ADA N1 LESS 1 UNLESS ZERO JSB $CVT3 CONVERT TO ASCII JSB $LIBX RAISE FENCE DEF *+1 DEF *+1 LDB 0,I GET 1ST 2 CHARS ADB HI.EQ CHANGE 1ST FROM BLANK TO "=" STB M.VAL & STORE IN MSG INA DLD 0,I GET 3RD THRU 6TH CHARS DST M.VAL+1 & PUT IN MSG * JSB CNOPT WRITE RESPONSE LINE DEF *+5 DEF .2 DEF CAM.O DEF MSGBF DEF MSGLN JMP TO..,I RETURN * * LU WAS ASSIGNED TO BIT BUCKET TO.90 JSB CNOPT WRITE "LU UNASSIGNED" DEF *+5 DEF .2 DEF CAM.O DEF MUNAS DEF MS2LN JMP TO..,I * * ER56 LDA .56 56 = BAD PARAMETER STA ERRTN,I RETURN ERROR VALUE JMP TO..,I AND RETURN * * DATA AREA * TMPAD NOP NUMBA NOP ERRTN NOP * .1 DEC 1 .2 DEC 2 .10 DEC 10 .12 DEC 12 .56 DEC 56 B20 OCT 20 N1 DEC -1 ASC.0 ASC 1, 0 HI.EQ OCT 16400 * MSGBF EQU * ASC 2,TO # M.LU BSS 1 M.VAL BSS 3 MSGLN ABS *-MSGBF * MUNAS EQU * ASC 2,LU # M.LU2 NOP ASC 6, UNASSIGNED MS2LN ABS *-MUNAS * END g   92070-18107 1941 S C0122 &TR.SC              H0101 oASMB,R,L,C * NAME: TR.SC * SOURCE: 92070-18107 * RELOC: 92070-16107 * PGMR: M.L.K. * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * NAM TR.SC,7 92070-1X107 REV.1941 790709 * SKP * ENT TR.SC EXT .ENTR,EXEC SUP * * DSLU NOP DISC LU PARAMETER NMTRK NOP NUMBER OF TRACKS PARAMETER NSC/T NOP NUMBER OF SECT/TRACK PARAMETER * TR.SC NOP JSB .ENTR DEF DSLU * LDA DSLU,I GET DISC LU IOR ZBIT ADD IN MULTI BUFFER Z BIT STA DSLU SAVE FOR EXEC CALL * JSB EXEC GET STATUS ON LU DEF ERRTN DEF STCOD NO-ABORT STATUS REQUEST DEF DSLU DISC LU WITH Z BIT SET DEF BUF DUMMY DEF BUF DUMMY DEF BUF STORE 7 DRIVER PARAMETERS DEF .7 INTO BUF ERRTN JMP TR.SC,I ERROR RETURN WITH A = ASCII OF ERROR * LDA TRKS GET NUMBER OF TRACKS STA NMTRK,I SAVE IN USER'S BUFFER LDA SC/T GET # SECTORS/TRACK AND MULTIPLY ALS BY 2 FOR 64 WORD SECTORS STA NSC/T,I SAVE IN USER'S BUFFER CLA A = 0 FOR SUCCESS JMP TR.SC,I - RETURN - * ZBIT OCT 10000 STCOD OCT 100015 .7 DEC 7 * BUF NOP HPIB ADDRESS NOP UNIT # NOP STARTING HEAD NOP STARTING CYLINDER NOP # OF SPARES TRKS NOP NUMBER OF TRACKS SC/T NOP NUMBER OF SECTORS/TRACK END     92070-18108 2026 S C0122 &LOADR              H0101 xASMB,R,L,C * NAME: LOADR * SOURCE: 92070-18108 * RELOC: 92070-16108 * PGMR: D.J.W., B.W. * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1976. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * * NAM LOADR,3,99 92070-16108 REV.2026 800508 * * * THE RTE-L RELOCATING LOADER PROVIDES A MEANS OF LINKING * RELOCATABLE FILES PRODUCED BY COMPILERS OR ASSEMBLERS TO- * GETHER WITH ONE OR MORE LIBRARY FILES. PROGRAMS MAY BE * RELOCATED TO EXECUTE ON THE EXISTING RTE-L OPERATING SYSTEM * OR ANY OTHER RTE-L OPERATING SYSTEM AS DEFINED BY THE * SNAPSHOT FILE. THE RTE-L LOADER BUILDS A MEMORY IMAGE * FILE CONTAINING THE PROGRAM'S ID SEGMENTS, BASE PAGE AREAS, * AND PROGRAM AREAS OF MAIN AND SEGMENTS. THE PROGRAM MAY * THEN RUN IN REAL-TIME OR BACKGROUND, ACCESS SYSTEM COMMON * OR LOCAL COMMON, HAVE APPENDED USER DBUGR, AND HAVE LINKS * IN THE CURRENT PAGE OR THE BASE PAGE. THE LOADER ITSELF MAY * RUN UNDER AN RTE-L SYSTEM OR AN RTE-IVC SYSTEM. * * THE LOADER CONSISTS OF A MAIN, THREE SEGMENTS, AND A NUMBER * OF SUBROUTINES. THE MAIN SERVES TO DO THE FOLLOWING: * * * DEFINE THE FLAGS AND BUFFERS WHICH ARE SHARED BY * SEGMENTS AND SUBROUTINES. * * * DEFINE FLOW OF CONTROL THROUGH THE LOAD PROCESS, * CONTROL THE SCHEDULING OF THE SEGMENTS. * * * PROVIDE COMMAND PROCESSING FOR THOSE COMMANDS WHICH * MAY BE ENTERED AT ANY POINT IN THE LOAD. * * * DEFINE SUBROUTINES 'NAMRR' AND 'CKBKD' WHICH * NEED TO BE ACCESSABLE THROUGHOUT THE LOAD. * * * CHANGE 11/30/79 * UPPED THE MAX NUMBER OF USER LIBRARIES TO 10. THIS CHANGED * BNAMR FROM 30 TO 60 WORDS AND LOAD1 TO CHECK FOR 10 * AS UPPER LIMIT. * * CHANGED FMPER TO CALL LDRER ON A -12 ON OUTPUT FILE. * LDRER OUTPUTS A 'OV OUT' ERROR. * * CHANGED MAIN SO AS TO ALLOW A LIBRARY TO BE SPECIFIED * AT ANY TIME. * * CHANGED THE TIME AT WHICH A SCRATCH FILE IS RENAMED TO * THE PROGRAM NAME. TIME IS NOT IN LOAD2 WHEN NAME IS * FIRST KNOWN. * * CHANGE 1/06/80 * CHANGED LOAD2 TO NOT ALWAYS RESCAN A FILE WHEN A SEGMENT * WAS READ. IF NOT THE FIRST SEGMENT AND NO OTHER SEGMENTS * WERE FOUND PREVIOUSLY IN THE FILE THEN NO RESCAN IS DONE. * * ALONG WITH THIS I CHANGED LOAD2 TO CATCH THE NM SEG ERROR * ( NUMBER SEGMENTS READ GREATER THAN NUMBER SPECIFIED) BEFORE * THE RESCAN AND SYSTEM LIBRARY SCAN IS DONE. * * CHANGE 1/18 * CHANGED THE LENGTH OF ODCB TO 144 FROM 16. THIS IS BECAUSE * I CHANGED THE RENAME TIME TO WHEN THE MAIN HAS BEEN RELOCATED. * NAMF CLOSES THE FILE TO RENAME AND WRITES ON THE 128 WORDS OF * THE DCB EVEN THOUGH THE ACCESS IS TYPE 1. THOSE 144 WORDS * MUST BE ALLOCATED JUST TO BE WRITTEN ON BY NAMF AND OPENF. * NOTE THAT IN RTE-IV NAMF AND OPENF DON'T WRITE ONE THE DCB. * * CHANGE 2/25/80 * FIXED BUG WITH BASE PAGE BUMP. A BASE PAGE BUMP WAS NOT BEING * ZEROED OR PROPERLY PUT OUT TO THE PROGRAM FILE. ENTRY ALC.B * WAS ADDED TO ALLOCATE A BLOCK OF LINKS FOR A BUMP. BLOCC IN * THE MAIN AND LOAD2 WERE CHANGED TO CALL ALC.B ON A BUMP TO * DO THE BUMP AND ZERO THE LINKS. * * LOD 5,SGMENTS,3 ENT #LIBS,#SENT,#SGMT,#SLIB,AB.RT, BCOM ENT BGBP, BGFW,BNAMR,BPFWA,BPLWA, CDCB ENT CKBND, CKSM,C.LEN,CNAMR,COMAD,COMLN ENT COMTP,DBFLG,ERMES,FDONE,FORCD,FWAFS ENT FWAVB,FWSYB,I.ERR,ID.CB,INAMR,IN.TR ENT IPBUF,IPTYP,ISTRC, LCOM, LDCB,LI.PR,LNAMR ENT LOADR,LOGDV,LWABP,LWAFS,LWSYB, MERR ENT MSEGF,MXREC,NAMRR,NEXTF,NLWBP,NOCMD ENT NOUDF,NXTOP, ODCB,ONAMR,OTDFT,OUTBF ENT OUTOP,PGFWA,PGLWA,PL.ST,PRERR,PROGN ENT PROGT,P.ROR, ROM, RTBP,RSTRT, RTFW EN:T RTNS2, SDCB,SLONG,SNAMR, SYBP,TMSTG * EXT .MVW,ALC.B,CBP.L,CNFLT,CNUMO, END EXT EXEC,FMPER,FOPEN,IECHO,L.BUF,LDRER EXT NAMR,NEXTL,OUTAB,PARST,PRMTR, PUDF EXT READF,RE.LC,REMDR,SAVST,SEGLD,SE.MS EXT SUMAP,SYOUT,SYSCN,TH1.L,TH2.L * A EQU 0 B EQU 1 * SUP PRESS EXTRANIOUS LISTING HED BUFFERS AND FLAGS IPBUF BSS 10 PARSE BUFFER FOR NAMRR ROUTINE IPTYP EQU IPBUF+3 TYPE WORD TMSTG BSS 15 BUFFER FOR TIME STRING * LDCB BSS 144 LIST DEVICE DCB ID.CB BSS 272 RELOCATABLE INPUT DCB ODCB BSS 144 OUTPUT FILE DCB OUTBF BSS 128 OUTPUT FILE BUFFER SDCB BSS 144 SNAPSHOT DCB CNAMR BSS 6 COMMAND NAMR BUFFER LNAMR BSS 8 LIST NAMR BUFFER INAMR BSS 6 INPUT NAMR BUFFER ONAMR BSS 8 OUTPUT NAMR BUFFER SNAMR BSS 6 SNAPSHOT NAMR BUFFER BNAMR BSS 60 USER LIBRARY FILE NAMRS, 10 FILES MAX * #LIBS BSS 1 -VE NUMBER USER LIBRARIES OTDFT BSS 1 DEFAULT OUTPUT FILE USED PL.ST DEC 1 LIST LEVEL FLAG P.ROR BSS 1 PROGRAM PRIORITY FLAG COMTP DEC -1 -1/ 2, NO OR LOCAL/ SYSTEM COMMON IN.TR BSS 1 INTERACTIVE FLAG FDONE BSS 1 MAIN LOADED FLAG DBFLG BSS 1 DEBG FLAG, 0/1, NO/YES DEBG INCLUDED FORCD BSS 1 FORCE LOAD FLAG #SGMT BSS 1 NUMBER OF SEGMENTS IN LOAD OUTOP BSS 1 0/1, OUTPUT FILE OPEN FLAG MXREC BSS 1 MAXIMUM RECORD WRITTEN IN PROGRAM FILE I.ERR BSS 1 FMP ERROR PARAMETER MERR DEF ERMES+0 LOADER ERROR CODE PROGT BSS 1 PROGRAM TYPE WORD NEXTF BSS 1 NEXT LOAD FLAG MSEGF BSS 1 FINAL SEGMENT FLAG LOGDV BSS 1 LOG LU NUMBER * PGLWA BSS 1 PROGRAM LAST WORD AVAILABLE PGFWA BSS 1 PROGRAM FIRST WORD AVAILABLE BSS 1 DUMMY FILLER BPLWA BSS 1 BASE PAGE LAST WORD AVAILABLE BPFWA BSS 1 BASE PAGE FIRST WORD AVAILABLE * #SENT BSS 1 NUMBER S:YSTEM ENTRIES IN SNAPSHOT #SLIB BSS 1 LOW BYTE = NUMBER MEM RES LIB ENTRIES, * HIGH BYTE = NUMBER SYSTEM LIBS IN SNAP. ROM BSS 1 LAST WORD BACKGROUND + 1 BGFW BSS 1 FIRST WORD BACKGROUND AREA RTFW BSS 1 FIRST WORD REAL-TIME AREA SYBP BSS 1 LAST WORD BACKGROUND BASE PAGE + 1 BGBP BSS 1 FIRST WORD BACKGROUND BASE PAGE RTBP BSS 1 FIRST WORD REAL-TIME BASE PAGE BCOM BSS 1 ADDRESS BLANK SYSTEM COMMON LCOM BSS 1 CKSM BSS 1 SYSTEM ID CHECKSUM WORD * FWAFS BSS 1 FIRST WORD FREE SPACE LWAFS BSS 1 LAST WORD FREE SPACE LWABP BSS 1 LAST WORD AVAILABLE BASE PAGE NLWBP BSS 1 -VE LWABP FWAVB BSS 1 FIRST WORD AVAILABLE BASE PAGE FWSYB BSS 1 FIRST WORD SYSTEM BASE PAGE LWSYB BSS 1 LAST WORD SYSTEM BASE PAGE COMAD BSS 1 ADDRESS SYSTEM COMMON COMLN BSS 1 LENGTH SYSTEM COMMON * PROGN BSS 3 PROGRAM NAME ARRAY ERMES ASC 3,IL PRM FMP ERROR RETURN * SEG1 ASC 3,LOAD1 SEG2 ASC 3,LOAD2 SEG3 ASC 3,LOAD3 CDCB BSS 144 COMMAND DCB .DCB EQU * HED LOADER CONTROL ********************************************************************** * * OVERLAY AREA * ********************************************************************** * ORG CDCB START OF OVERLAY AREA LOADR JSB SAVST SAVE THE RUN STRING FOR SEGMENT ONE DEF *+1 * JSB SEGLD LOAD SEGMENT ONE TO PARST THE RUN STRING DEF *+4 DEF SEG1 SEGMENT NAME ARRAY DEF I.ERR ERROR PARAMETER DEF APARS DESTINATION ADDRESS JMP NOSEG COULDN'T LOAD SEGMENT ONE * APARS DEF PARST+0 ADDRESS OF PARST SUBROUTINE * * NO COMMAND FILE EXISTS, RELOCATE FILE SPECIFIED IN THE RUN * STRING AND TERMINATE LOAD. * NOCMD CCA DO SOME CHECKING JSB INITL NOP JSB RE.LC RELOCATE THE MODULE 7? JMP AB.RT ERROR ON RELOCATION ISZ FDONE JMP ENDX TERMINATE THE LOAD ORG .DCB * ********************************************************************** * * END OF OVERLAY AREA * ********************************************************************** SKP TERM JSB SEGLD LOAD SEGMENT "LOAD3" FOR FINAL DEF *+4 PROCESSING DEF SEG3 SEGMENT NAME ARRAY DEF I.ERR ERROR PARAMETER DEF P2 JMP NOSEG ERROR ON SEGMENT LOAD * * CMERR JSB FMPER DEF CNAMR+0 * AB.RT JSB SEGLD LOAD SEGMENT THREE DEF *+4 DEF SEG3 SEGMENT NAME ARRAY DEF I.ERR ERROR PARAMETER ON SEGMENT LOAD DEF N1 * NOSEG LDA P9 JSB LDRER COULDN'T LOAD THE SEGMENT JSB EXEC TERMINATE THE LOADER DEF *+2 DEF P6 * P9 DEC 9 ENDR JSB SEGLD LOAD SEGMENT THREE DEF *+4 DEF SEG3 SEGMENT NAME ARRAY DEF I.ERR ERROR PARAMETER DEF P0 DESTINATION ADDRESS JMP NOSEG ERROR RETURN ON SEGLD CALL * P0 DEC 0 RSTRT JSB SEGLD DEF *+4 DEF SEG1 DEF I.ERR DEF ANXTL JMP NOSEG ERROR ON SEGMENT LOAD ANXTL DEF NEXTL+0 HED COMMAND FILE PROCESSOR * * NXTOP LDA IN.TR ARE WE INTERACTIVE ? SZA JSB PRMTR YES, SO ISSUE PROMPT FREAD JSB READF READ THE COMMAND FILE DEF *+6 DEF CDCB COMMAND FILE DCB DEF I.ERR ERROR PARAMETER DEF L.BUF+3 BUFFER STRNG DEF P40 BUFFER LENGTH, WORDS DEF C.LEN LENGTH READ, WORDS * SSA ERROR ON COMMAND READ ? JMP CMERR YES * * LDB C.LEN GET LENGTH OF COMMAND JUST READ SZB,RSS WAS IT ZERO ? JMP FREAD YES, SO DO IT AGAIN SSB,RSS WAS IT NEGATIVE (IE END OF FILE) JMP POSL +VE LENGTH READ LDA IN.TR GET INTERACTIVE FLAG SZA l -VE LENGTH, INTERACTIVE DEVICE ? JMP NXTOP INTERACTIVE, ISSUE READ AGAIN JMP END?? -VE LENGTH, NON-INTERACTIVE POSL CLE,ELB NO, CONVERT TO CHAR COUNT (MULT BY 2) STB SLONG SAVE CHARS READ FOR PARSE * LDA ECHO? ARE WE ECHOING COMMANDS ? SZA JSB IECHO YES, SO GO DO IT * CLA,INA SET UP PARSING OFFSET TO START PARSING STA ISTRC AT THE FIRST CHARACTER JSB NAMRR PARSE THE OPCODE LDB IPBUF GET 1ST AND 2ND CHARS STB OP? AND SET ASIDE JSB NAMRR PARSE REMAINDER OF STRING LDA OP? NOW CHECK OUT COMMAND LDB FDONE SKP * * THESE COMMANDS MAY BE ENTERED ANY TIME * * CPA EN END OF COMMAND FILE ? JMP END?? CPA .E END OF COMMAND FILE ? JMP END?? CPA EX AN EXIT COMMAND ? JMP END?? CPA SE A SEARCH COMMAND ? JMP SECH CPA MS A SEARCH MULTIPLE COMMAND ? JMP MSCH CPA FO A FORCE COMMAND ? JMP FORCE CPA RE A RELOCATE COMMAND ? JMP RELC CPA DI DISPLAY ? JMP DSPLY CPA EC ECHO COMMAND ? JMP ECHO CPA LO MODIFY RELOCATION BASE ? JMP LOCC CPA BL MODIFY BASE PAGE RELOCATION BASE ? JMP BLOCC CPA LI ENTER NEW USER LIBRARY ? JMP LIBRY CPA NE NEXT ? JMP NEXT CPA /N /NEXT ? JMP NEXT CPA AB ABORT ? JMP AB.RT CPA .A ABORT ? JMP AB.RT AND M7740 CPA AS2RK LEADING CHARACTER AN "*" ? JMP NXTOP * SZB HAVE WE LOADED THE MAIN ? JMP PRERR YES, PARAMETER ERROR LDA OP? JSB REMDR NO, CHECK OUT THE REMAINDER OF COMMANDS JMP NXTOP GET NEXT COMMAND JMP ERFMP ERROR, CHECK IF WE CAN RECOVER SKP * * PRERR LD7A IN.TR PARAMETER ERROR SZA,RSS ARE WE IN THE INTERACTIVE MODE? JMP DOERR NO SO DO ERROR THING LDA P2 YES, INTERACTIVE LDB ?? SO SEND A ERROR MESSAGE JSB SYOUT VIA SYOUT JMP NXTOP AND GIVE HER ANOTHER CHANCE * * DOERR LDA C.LEN GET THE READ LENGTH SZA IF NON-ZERO ECHO IT JSB IECHO CLA JSB LDRER JMP AB.RT * ERFMP LDA IN.TR SZA,RSS JMP AB.RT CLA JMP NXTOP * * OP? DEC 1 LAST OPCODE ?? DEF *+1 ASC 2,?? C.LEN BSS 1 CHARACTER LENGTH OF INPUT STRING P2 DEC 2 P6 DEC 6 P40 DEC 40 M7740 OCT 77400 SKP * * THE FOLLOWING ARE THE LEGAL COMMANDS * DI ASC 1,DI DISPLAY,KEYWORD EC ASC 1,EC ECHO RE ASC 1,RE RELOCATE,NAMR SE ASC 1,SE SEARCH,NAMR MS ASC 1,MS MSEARCH,NAMR FO ASC 1,FO FORCE LO ASC 1,LO LOCC ,VALUE BL ASC 1,BL BPLOCC ,VALUE LI ASC 1,LI LIBRARY,VALUE .E ASC 1,/E /END EN ASC 1,EN END EX ASC 1,EX EXIT NE ASC 1,NE NEXT /N ASC 1,/N /NEXT .A ASC 1,/A /ABORT AB ASC 1,AB ABORT AS2RK OCT 25000 AN "*" CHARACTER ECHO? BSS 1 ECHO FLAG SKP *********************************************************************** * * ECHO * ********************************************************************** ECHO CCA SET ECHO FLAG STA ECHO? JMP NXTOP * * SKP ********************************************************************** * * FORCE * ********************************************************************** FORCE CCA SET THE FORCE STA FORCD FLAG JMP NXTOP SKP ********************************************************************** * * LOCC, * **********************************************************************ķ LOCC LDA IPBUF+3 GET THE CURRENT TYPE WORD SZA,RSS IS THIS A DISPLAY REQUEST ? JMP DISPL YES, DISPLAY CURRENT VALUE OF LOCC * ADA N1 HAS USER ENTERED A NUMERIC VALUE ? SZA YES JMP PRERR ILLEGAL BOUND VALUE * LDA IPBUF CLE,SZB,RSS HAS THE MAIN BEEN LOADED ? JMP LOCC1 NO, CHECK VALUE LATER JSB CKBND CHECK OUT THE BOUND JMP ILBND ILLEGAL BOUND CLA LDB IPBUF ADB N1 JSB OUTAB BOUND GOOD, CALL OUTAB TO ZERO DEF NXTOP * LOCC1 STA TH2.L AND TH2.L SO WILL DISPLAY NEW VALUE JMP NXTOP * DISPL LDA PL.ST BUT FIRST, ARE WE LISTING ? SZA,RSS JMP NXTOP NO, GET NEXT COMMAND JSB CNUMO MOVE CURRENT TH2.L VALUE DEF *+3 DEF TH2.L DEF VALUL INTO THE MESSAGE BUFFER * LDB MESSL GET MESSAGE ADDRESS LDA P14 AND LENGTH IN CHARACTER JSB SYOUT OUTPUT TO COMMAND OR LIST DEVICE JMP NXTOP * ILBND LDA P5 OUTPUT 'IL BND' ERROR JSB LDRER JMP ERFMP CHECK FOR RECOVERY * N1 DEC -1 P5 DEC 5 MESSL DEF *+1 ASC 4,LOCC = VALUL ASC 3, P14 DEC 14 SKP ********************************************************************** * * BLOCC, * ********************************************************************** BLOCC LDA IPBUF+3 GET TYPE WORD SZA,RSS IS THIS A DISPLAY COMMAND ? JMP DISPB YES * ADA N1 RESET TO INTEGER VALUE ? SZA YES JMP PRERR NO, BOUND MUST BE ILLEGAL LDA IPBUF GET NEW VALUE CCE,SZB,RSS HAS MAIN BEEN LOADED ? JMP BPLO1 NO, JUST GO SAVE NEW VALUE JSB CKBND YES, CHECK OUT THE BOUND JMP ILBND ILLEGAL BOUND LDA IPBUF GET BUMP VALUE AGAIN JSB ALC.B GO ALLOCATE A BLOCK OF LINKS AND ZERO JMP NXTOP OK, DO NET OPERATION * BPLO1 STA CBP.L MAIN NOT LOADED, SAVE IN CBP.L JMP NXTOP * DISPB LDA PL.ST ARE WE LISTING ? SZA,RSS JMP NXTOP NO, GET NEXT COMMAND JSB CNUMO MOVE CURRENT BP AVAILABLE DEF *+3 INTO MESSAGE BUFFER DEF CBP.L DEF VALUB * LDB MESSB GET MESSAGE ADDRESS LDA P14 AND LENGTH IN CHARACTERS JSB SYOUT OUTPUT TO COMMAND OR LIST DEVICE JMP NXTOP * MESSB DEF *+1 ASC 4,BLOCC = VALUB BSS 3 SKP ********************************************************************** * * LIBRARY, * ********************************************************************** LIBRY JSB LI.PR CALL ROUTINE TO PROCESS THE LIBRARY JMP ERFMP GOT AN ERROR ON THIS JMP NXTOP NO ERROR, GET NEXT OPERATION * LI.PR NOP ROUTINE TO ENTER A NEW LIBRARY LDB #LIBS GET CURRENT NUMBER USER LIBRARIES (-VE) ADB N1 AND INCREMENT (DECREMENT -VE) STB A SET ASIDE ADA MXLIB HAVE WE EXCEEDED MAX LIMIT ? SSA JMP BERR YES, 'LB LIM' ERROR STB #LIBS NO, SET NEW NUMBER USER LIBRARIES STB A CMA +VE VALUE IN A-REG MPY P6 CALCULATE OFFSET INTO BNAMR BUFFER ADA ABNAM AND ACTUAL ADDRESS STA B SET AS DESTINATION ADDRESS LDA AIPBF SOURCE ADDRESS JSB .MVW MOVE NAMR INTO BNAMR DEF P6 NOP ISZ LI.PR TAKE GOOD RETURN JMP LI.PR,I * BERR LDA P4 MAX NUMBER OF LIBRARIES EXCEEDED JSB LDRER OUTPUT THE ERROR MESSAGE JMP LI.PR,I TAKE ERROR EXIT * ABNAM DEF BNAMR ADDRESS OF THE LIBRARY NAMR BUFFER P4 DEC 4 MXLIB DEC 10 MAX NUMBER OF USER LIBRARIES SKP ********************************************************************** * * RELOCATE, * ********************************************************************** * RELC LDA IPBUF+3 IS THERE A NAMR SPECIFIED ? SZA,RSS JMP PRERR IL PRM ( WHO YOU TRING TO FOOL !!) SZB MAIN LOADED YET ? JMP LDSUB YES * LDA INAMR+3 RELOCATABLE IN RUN STRING ? SZA JMP RUNST YES, RUNSTRING RELOCATABLE * LDA AIPBF NO, MOVE NAMR INTO INAMR LDB AINAM JSB .MVW DEF P6 NOP CLA,RSS SET NO RUN STRING FLAG RUNST CCA STA TEMP SET CHECK FLAG CCA SET CHECK FLAG JSB INITL INITIALIZE AND CHECK JSB RE.LC RELOCATE THE MODULE JMP AB.RT ERROR RETURN ISZ FDONE NOW MAIN IS LOADED ISZ TEMP WAS THIS A RUN STRING ? JMP NXTOP NO, GET NEXT OPCODE * LDSUB JSB IOPEN MOVE NAMR INTO INAMR AND OPEN JSB RE.LC RELOCATE THE FILE JMP AB.RT ERROR RETURN ON RE.LC JMP NXTOP GOOD RETURN * AINAM DEF INAMR+0 AIPBF DEF IPBUF+0 * INITL NOP DO INITIAL CHECKING FOR FIRST RELOCATABLE JSB CNFLT CONFLICT CHECKING JMP ERROR ERROR RETURN JSB SEGLD OK, SO LOAD SEGMENT 2 DEF *+3 DEF SEG2 DEF I.ERR JMP AB.RT ERROR, ABORT RTNS2 JMP INITL,I RETURN FROM SEGMENT 1 * ERROR CLA ERROR RETURN FROM CNFLT STA INAMR+3 CLEAR OUT THE GOOD NAMR FLAG JMP ERFMP AND SEE IF WE CAN CONTINUE * IOPEN NOP MOVE NAMR INTO INAMR AND OPEN THE FILE LDA AIPBF SOURCE LDB AINAM DESTINATION JSB .MVW MOVE NAMR DEF P6 NOP JSB FOPEN OPEN FILE AND CHECK ERROR DEF *+5 DEF INAMR PASSING NAMR ADDRESS DEF ID.CB DCB ADDRESS DEF IOPTN OPEN OPTION WORD DEF P272 DCB SIZE JMP ERFMP ERROR RETURN JMP IOPEN,I GOOD RETURN P272 OCT 272 IOPTN OCT 111 BINARY NON-EXCLUSIVE OPEN * SKP ************************2********************************************** * * SEARCH, * ********************************************************************** MULT BSS 1 SECH CCA,RSS SET NO MULTIPLE SCAN FLAG MSCH CLA MULTIPLE SCAN STA MULT SZB MAIN LOADED ? JMP SEC00 YES * LDA INAMR+3 RUN STRING RELOCATABLE ? SZA JMP RUNSG YES JSB INITL NO CHECKING FOR LOD RECORDS ISZ FDONE JMP SEC00 * RUNSG CCA CHECK FOR LOD RECORDS JSB INITL JSB RE.LC RELOCATE THE RUN STRING FILE JMP AB.RT ERROR RETURN ISZ FDONE * SEC00 LDA IPBUF+3 IS THIS A SYSTEM LIB SEARCH ? SZA,RSS JMP SEC01 JSB IOPEN LDA MULT JSB SE.MS RSS CHECK FOR ERROR RETURN JMP NXTOP SSA,RSS FMP? OR LOADR? JMP AB.RT DON'T PRINT LOADR ERRORS JSB FMPER PRINT FMP ERRORS DEF INAMR+0 JMP AB.RT * SEC01 CLA,INA JSB SYSCN JMP AB.RT JMP NXTOP SKP ********************************************************************** * * END,/END,EXIT,NEXT,/NEXT * ********************************************************************** NEXT CCB STB NEXTF NEXT FLAG SET END?? LDB FDONE SZB HAS MAIN BEEN LOADED YET ? JMP ENDX YES LDA INAMR+3 IS THERE A RELOCATABLE IN THE RUN STRING ? SZA,RSS JMP ENDR NO, TERMINATE THE LOAD CCA YES, SET TO CHECK FOR LOD INFORMATION JSB INITL OPEN THE FILE JSB RE.LC RELOCATE THE MODULE JMP AB.RT ERROR RETURN ENDX CLA,INA JSB SYSCN MUST HAVE BEEN AN END, CHECK FOR UNDEFS JMP AB.RT ERROR RETURN SZA,RSS UNDEFS REMAINING ? JMP DONE NO, TERMINATE LOAD JSB SUMAP YES, UNDEFS, PRINT UPPER BOUNDS ON MAIN OR SEG CLA,INA PRINT ALL CURRENT UNDEFS KJSB PUDF YES, PRINT UNDEFS LDA FORCD DID SHE WANT TO FORCE LOAD ? SZA JMP DONEF YES, FORCE LOAD LDA P7 JSB LDRER NO FORCE, ABORT WITH 'UN EXT' JMP AB.RT * P7 DEC 7 * DONE JSB SUMAP PRINT UPPER BOUNDS ON MAIN OR SEG DONEF ISZ MSEGF SET FINAL SEGMENT FLAG JSB END TERMINATE THE LOAD JMP AB.RT ERROR RETURN JMP TERM CALL SEGMENT THREE * * SKP ********************************************************************** * * DISPLAY UNDEFS * ********************************************************************** DSPLY LDA IPBUF SZB,RSS HAVE WE BEGUN THE RELOCATION ? JMP UNDF1 NO, THUS NO UNDEFS CLA,INA PRINT UNDEFS IN MAIN AND CURRENT SEG JSB PUDF YES, PRINT LIST OF UNDEFS JMP NXTOP AND RETURN FOR NEXT COMMAND * UNDF1 LDA P12 OUTPUT MESSAGE "NO UNDEFS" LDB NMESS JSB SYOUT OUTPUT JMP NXTOP AND RETURN FOR NEXT COMMAND * NMESS DEF *+1 NOUDF ASC 6, NO UNDEFS P12 DEC 12 HED PARSE NAMRR * * * THE NAMRR SUBROUTINE USES THE RELOCATABLE LIBRARY * PARSING ROUTINE NAMR. THE INPUT TO NAMR IS A STRING * OF ASCII CHARACTERS. * THE OUTPUT IS A 10 WORD BUFFER PARSED AS : * PRAM1,PRAM2,PRAM3,TYPE,S1,S2,S3,S4,S5,S6 * PARAMETERS BETWEEN COMMAS ARE PARSED. SUBPARAMETERS ARE * DELINEATED BY COLONS. THE TYPE WORD DESCRIBES ALL * PARAMETERS AS ASCII, NUMERIC, OR NULL. * THE TYPE WORD IS BROKEN UP INTO 2 BIT FIELDS TO DESCRIBE * THE INPUT. * 15,14 13,12 11,10 9,8 7,6 5,4 3,2 1,0 * ------------------------------------------------ * ! S6 ! S5 ! S4 ! S3 ! S2 ! S1 ! PRAM ! * ------------------------------------------------ * * PRAM = 0 ...NULL PRAM1 = PRAM2 = PRAM3 = 0 * PRAM = 1....NUMERIC (ONLY PRAM1 USED) PRAM1 = # * PRAM = 2 ...NOT USED * PRAM = 3 ... ASCII (USES PRAM1,PRAM2,PRAM3 ) * * S1 - S6 ARE DEFINED THE SAME EXCEPT THEY ARE ONE WORD ONLY * * NAMRR NOP JSB NAMR THIS IS THE RELO LIBR PARSING ROUTINE DEF *+5 RETURN ADDR DEF IPBUF ADDRESS OF 10 WORD PARSED BUFFER DEF L.BUF+3 ADDRESS OF BUFFER TO BE PARSED DEF SLONG CHARACTER LENGTH DEF ISTRC CHAR OFFSET IN STRNG FOR NEXT PRAM JMP NAMRR,I RETURN TO CALLER * * ISTRC DEC 1 SLONG BSS 1 CHARACTER LENGTH OF BUFFER HED CHECK OUT MEMORY BOUNDS * * THIS SUBROUTINE CHECKS THAT THE DESIRED LOCC OR BLOCC IS * WITHIN THE CURRENT MEMORY BOUNDS. * * CALLING SEQUENCE: * A-REG = VALUE TO BE CHECKED * E-REG = 0/1 MEMORY/BASE PAGE * JSB CKBND * P+1 : ILLEGAL BOUND * P+2 : GOOD BOUND * A-REG = BOUNDRY VALUE * * CKBND NOP STB TEMP CLB ERB CMA,INA STA VALUE LDA PGLWA ASSUME MEMORY SZB LDA BPLWA NO, BASE PAGE ADA VALUE SSA,RSS HIGH - NEW < 0 => ERROR SZA,RSS JMP CKBND,I * LDA FDONE HAVE WE LOADED THE MAIN YET ? SZA,RSS JMP NOMAN NO LDA TH2.L YES, ASSUME MEMORY SZB LDA CBP.L NO, BASE PAGE ADA VALUE SSA LOW - NEW <= 0 => OK JMP RETRN SZA JMP CKBND,I * RETRN LDA VALUE CMA,INA LDB TEMP ISZ CKBND JMP CKBND,I * NOMAN LDA PGFWA ASSUME MEMORY SZB LDA BPFWA NO, BASE PAGE ADA VALUE SSA IF -VE JMP RETRN SZA OR ZERO THEN OK JMP CKBND,I JMP RETRN VALUE BSS 1 TEMP BSS 1 END LOADR BTRNNT  92070-18109 2026 S C0122 &LOAD1              H0101 ydASMB,R,L,C * NAME: LOAD1 * SOURCE: 92070-18109 * RELOC: 92070-16109 * PGMR: D.J.W., B.W. * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1976. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * * NAM LOAD1,5,99 92070-1X109 REV.2026 800507 * * * THE FIRST SEGMENT HAS THREE MAIN FUNCTIONS: * * * PARSE THE RUN STRING PARAMETERS, * * * HANDLE THE COMMANDS WHICH MUST PRECEED RELOCATION, * * * DO CONFLICT CHECKING JUST PRIOR TO RELOCATION. * * * CHANGE 01/08/80 * CHANGED CNFLT SO AS TO DEAL WITH A LOCC INITIAL BUMP IN * TH2.L INSTEAD OF TH1.L AS BEFORE. THIS ALLOWED AN AUTO- * MATIC OUTPUT OF THE SET LOCC VALUE BEFORE RELOCATION HAS * BEGUN. * * CHANGED CNFLT SO AS TO UPDATE TH2.L AND CBP.L WITH PGFWA * AND BPFWA IF AN ILLEGAL BOUND IS FOUND. THE ERROR MESSAGE * IS PRINTED AT ILLOC AND ILBPL RESPETIVELY. JUST BEFORE * THE RETURN TO CALLER OF CNFLT TH2.L AND CBP.L AND UPDATED. * * CHANGE 2/22/80 * FIXED A BUG WITH THE BASE PAGE BUMP PROCESS. ONLY UPDATE * BPFWA WITH A BUMP VALUE FOR A REAL-TIME PROGRAM, NOT A * BACKGROUND PROGRAM. * * * CHANGE 3/8/80 * CHANGED CNFLT SO AS TO ALLOCATE THE EXACT AVAILABLE BASE * PAGE FOR THE DUMMY AREA. I WAS PREVIOUSLY ALLOCATING ONE * TOO MANY ( I NEVER COULD SUBTRACT VERY WELL ). * * CHANGE 5/7/80 BW * SET INL.L FLAG FOR 2026 LOADER LIBRARY CHANGE TO FORCE THE * USE OF AN INDIRECT LINK IF JSB TO EXT OCCURS. THIS ALLOWS * A PROGRAM TO START RELOCATION ON THE SAME PAGE AS THE MEMORY * RESIDENT PROGRAMS AND NOT CALL A SHARED ROUTINE WITHOUT HOLDING * OFF INTERRUPTS FOR ONE INSTRUCTION FETCH. * * HED LOADER INITIALIZATION SE_GMENT ENT CNFLT,LOAD1,NEXTL,PARST,REMDR * EXT INL.L,RTFW EXT .MVW,.DFER, #LIBS,#SGMT,AB.RT,AFWA EXT ARECD, BCOM,BPFWA,BPLWA,C.LEN,CBP.L EXT CDCB, CFWA,CKBND,CNAMR,CNUMO,COMAD EXT COMLN,COMTP,CPL.L,CRECD,DRKEY,DSNAP EXT FMPER,FOPEN,FORCD,FWAVB,FWAFS,GETST EXT HEADR,ID.CB,IECHO,IFTTY,INAMR,IN.TR EXT IPBUF,ISTRC,L.BUF,L.CLS, LCOM,LDRER EXT LI.PR,LNAME,LOGDV,LOGLU,LSTDF,LWABP EXT NAMRR,NOCMD,NLWBP,NXTOP,ONAMR,OUTAB EXT OUTDF,P.ROR,PGFWA,PL.ST,PNAME,PRERR EXT PRMPT,PROGT,READF,RMPAR,SEG.L,SLONG EXT SNAMR,SNPDF,SYOUT, TEST,TH2.L * A EQU 0 B EQU 1 * DEST BSS 5 DUMMY EQU DEST * LOAD1 JSB RMPAR RETRIEVE PARAMETERS FROM THE MAIN DEF *+2 DEF DEST DESTINATION ADDRESS JMP DEST,I * NEXTL JMP NXTOP BEGIN NEXT LOAD HED PARSE THE RUN STRING * * * PARST PARSES THE LOADER RUN STRING. * * RU,LOADER,,,,,, * * N80 DEC -80 * PARST JSB GETST GET THE RUN STRING DEF *+4 DEF L.BUF+3 ADDRESS OF 40 WORD STRING BUFFER DEF N80 LENGTH OF STRING (NEG CHAR LENGTH) DEF SLONG * JSB LOGLU DEF *+2 DEF DUMMY STA LOGDV CLA,INA SET DEFAULT TO CURRENT PAGE LINKING STA CPL.L LOADER LIBRARY FLAG * * PARSE COMMAND FILE NAMR * JSB NAMRR NOW GET THE COMMAND FILE NAME LDB IPBUF+3 GET NAMR TYPE SZB HAVE WE GOT SOMETHING ? JMP GTCMD YES, GO PROCESS * CCA NULL OR END OF STRING STA CMDFL SET 'NO COMMAND FILE FOUND' FLAG LDA LOGDV YES, GET THE LOG DEVICE AS DEFAULT STA CNAMR PUT INTO PARSE BUFFER CLA,INA SET TYPE WORD TO LU (NOT A FILE) STA CNAMR+3 JMP INTR? * CMDFL BSS 1 COMMAND FILE FOUND FLAG * GTCMD LDA AIPBF GET THE NEG COUNT AGAIN LDB ACNAM JSB .MVW AND MOVE NAME TO COMMAND NAMR DEF P6 SOURCE OF MOVE NOP COMMAND FILE NAME ADDRESS * LDA CNAMR+3 GET THE PARSE TYPE WORD AND P3 KEEP ONLY THE LEAST TWO BITS STA CNAMR+3 * CPA P1 IS IT AN LU ? RSS YES JMP GTREL NO, SO GO GET THE REL FILE INTR? JSB IFTTY IS THE LU INTERACTIVE ? DEF *+2 DEF CNAMR CMA,SSA,INA,RSS STA IN.TR SET INTERACTIVE FLAG TO 1 * * PARSE THE RELOCATABLE INPUT FILE NAMR * GTREL JSB NAMRR NOW GET THE INPUT FILE NAME SSA END OF STRING ? JMP SEFIL YES LDA IPBUF+3 SZA,RSS JMP GTLST CCE ALS,ERA STA IPBUF+3 LDA AIPBF NEG COUNT TO A REG FOR MOVE WORDS LDB AINAM JSB .MVW DEF P6 NOP * * PARSE THE LIST FILE NAMR * GTLST JSB NAMRR NOW GO GET THE LIST DEVICE SSA JMP SEFIL NONE INPUT, GO GET DEFAULT JSB LSTDF GOT A LIST FILE, OPEN IT JMP GTOUT NO ERROR, GET OUTPUT DEVICE STA TEMP GOT AN ERROR, SAVE FOR LATER MESSAGE LDA AIPBF AND SAVE NAMR CONTENTS LDB ATMP1 IN A TEMPORARY BUFFER JSB .MVW DEF P4 NOP * SEFIL LDA IN.TR FIRST DEFAULT EQUALS THE COMMAND FILE SZA,RSS BUT ONLY IF INTERACTIVE JMP SEFI2 NO LDA ACNAM YES, LETS TRY IT LDB AIPBF JSB .MVW DEF P6 NOP JSB LSTDF OPEN THE FILE JMP GTOUT NO ERROR SEFI2 LDA LOGDV NEXT DEFAULT IS THE LOG LU STA IPBUF SET THE LU INTO PARSE BUFFER CLA,INA STA IPBUF+3 SET AS TYPE LU JSB LSTDF OPEN THE TYPE 0 FILE JMP GTOUT NO ERROR JMP AB.RT ERROR ON FINAL DEFAULT * * * PARSE THE OUTPUT FILE NAMR * GTOUT JSB NAMRR GET THE OUTPUT FILE NAME SSA ANYTHING ENTERED ? nd JMP SEMOR NO LDA AIPBF LDB AONAM JSB .MVW DEF P8 NOP * * PARSE THE OPTION PARAMETERS * GETOP JSB NAMRR NOW GO GET THE OPCODE PARMS SSA JMP SEMOR LDA IPBUF+3 CPA P1 JMP NSEGM NUMBER OF SEGMENTS IN LOAD LDB IPBUF GET THE 1ST OPCODE JSB TEST CHECK IT OUT RSS ERROR RETURNED JMP GETOP NOW THE NEXT ONE OPERR CCA STA ERFLG JMP SEMOR * NSEGM LDA IPBUF SAVE THE NUMBER SEGMENTS IN THE LDB A ADB N64 CHECK THAT NOT LONGER THAN 63 SSA,RSS SSB,RSS JMP OPERR OPTION ERROR, -VE NUMBER SEGMENTS STA #SGMT LOAD AND GET NEXT COMMAND JMP GETOP * AINAM DEF INAMR+0 AIPBF DEF IPBUF+0 ERFLG BSS 1 ERROR FLAG ON OPTION PROCESSING TEMP BSS 1 BSS 4 P1 DEC 1 P3 DEC 3 * SKP SEMOR JSB HEADR OUTPUT HEADER MESSAGE TO LIST DEVICE JMP AB.RT ERROR ON LIST FILE WRITE JSB PNAME GET PROGRAM NAME FOR SYOUT DEF *+2 DEF LNAME BUFFER IN SYOUT LDA LNAME+2 SET A COLON INTO SIXTH CHARACTER AND LCHAR IOR COLON STA LNAME+2 JSB .DFER MOVE NAME INTO PRMPT SUBROUTINE DEF PRMPT DEF LNAME LDA TEMP WAS THERE AN ERROR ON THE ORIGIONAL LIST ? SSA,RSS JMP NOERR NO ERROR JSB FMPER YES, ERROR, OUTPUT MESSAGE TO GOOD LIST ATMP1 DEF TEMP+1 NOERR ISZ CMDFL IS THERE A COMMAND FILE ? JMP COMND YES, OPEN IT LDA INAMR+3 NO, WAS AN INPUT FILE NAMED ? SZA,RSS JMP COMND GO OPEN IT CLA SET 'COMMAND NOT INTERACTIVE' FLAG STA IN.TR ISZ ERFLG ERROR ON RUN STRING OPTIONS ? JMP NOCMD NO, SO GO CHECK OUT THE INPUT STRING CLA DO ERROR THING JSB LDRER OUTPUT 'IL PRM' MESSAGE JMP AB.RT AND ABORT * COMND JSB FOPEN  OPEN COMMAND DEVICE DEF *+5 DEF CNAMR DEF CDCB DEF IOPTN DEF P144 DCB LENGTH JMP AB.RT ERROR RETURN ISZ ERFLG ERROR ON OPTION PARAMETERS ? JMP NXTOP GET FIRST COMMAND JMP PRERR YES, DO ERROR THING * ACNAM DEF CNAMR+0 LCHAR OCT 77400 COLON OCT 72 P144 DEC 144 IOPTN OCT 1 HED COMMAND PROCESSOR * * * THIS IS THE FINAL SET OF COMMANDS. THESE COMMANDS * MUST BE ENTERED BEFORE RELOCATION BEGINS OR IN THE * 'LOD' PSUDO RECORD. * * CALLING SEQUENCE: JSB REMDR * * ON RETURN: P+1: NO MATCH * P+2: MATCH FOUND * REMDR NOP CPA SN SNAPSHOT COMMAND ? JMP SNAP CPA LL LIST COMMAND ? JMP LIST CPA OU OUTPUT COMMAND ? JMP OUTPT CPA SG SEGMENTS ? JMP SEGMT CPA PR PRIORITY COMMAND ? JMP PRIOR CPA OP OPTION ? LDA IPBUF LDB A JSB TEST LOOK FOR OPTION PARMS JMP PRER PARAMETER ERROR RETRN JMP REMDR,I FOUNE A MATCH PRER ISZ REMDR NO MATCH ERROR ISZ REMDR LOADER OR FMP ERROR JMP REMDR,I * * * LIST OF VALID COMMANDS * SN ASC 1,SN SNAPSHOT, LL ASC 1,LL LL, OU ASC 1,OU OUTPUT, OP ASC 1,OP OPTION,