Trailing-Edge
-
PDP-10 Archives
-
CFS_TSU04_19910205_1of1
-
update/cblsrc/cleanc.mac
There are 20 other files named cleanc.mac in the archive. Click here to see a list.
; UPD ID= 1609 on 5/16/84 at 12:04 PM by HOFFMAN
TITLE CLEANC FOR COBOL V13
SUBTTL CLEANUP AFTER PHASE C W.NEELY/CAM
SEARCH COPYRT
SALL
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
COPYRIGHT (C) 1974, 1983, 1984 BY DIGITAL EQUIPMENT CORPORATION
SEARCH P
%%P==:%%P
IFN TOPS20,< SEARCH MONSYM,MACSYM>
IFE TOPS20,< SEARCH UUOSYM,MACTEN>
;EDITS
;NAME DATE COMMENTS
;V13*****************
;MJC 27-NOV-85 [1620] Fix edit 1502, Don't give warning if the user
; knows that the records will be variable in
; length.
;MJC 24-OCT-85 [1610] Fix SUM item report check for CBL770.
;MJC 22-JUL-85 [1605] Suppress CBL670 warn if 'VARYING' used.
;MJC 5-SEP-84 [1544] Move check for TYPE DETAIL for SUM UPON from
; COBOLC. Setup RW.RSU and RW.UP1 in CLHUPN.
;JEH 16-MAY-84 [1533] Fix edit 1501, jrst back to new label
;JEH 28-MAR-84 [1520] Give error if 'DEPENDING ON D-N' and D-N
; is subscripted;
;V12B****************
;
;JEH 24-OCT-83 [1502] Give warning on records that are smaller than
; maximum record size
;JEH 11-OCT-83 [1501] Syntax error if alternate key is variable length
;JEH 10-OCT-83 [1500] Warning if high/low -values on numeric item
;DMN 15-Feb-82 [1340] 68274 converter does not flag JUSTIFIED clause in VALUE.
;JEH 2-Feb-82 [1335] Declare DATAB entries for all indices if REPORT SECTION
; is scanned for their use by REPORT WRITER statements.
;DAW 14-Nov-80 [1072] Make VALUE clause work correctly for EBCDIC
; signed numeric items
;DAW 29-OCT-80 [1066] BETTER ERROR RECOVERY FOR CONTAB-- PREVENTS
; "?ILL MEM REF.." IN PHASE E WHEN PGM HAS SYNTAX ERRORS
;DAW 8-FEB-80 [770] REPLACE EDIT 742: GENERATE AN ERROR MESSAGE
; IF AN ITEM IN "INDEXED BY" CLAUSE WAS ALSO DEFINED
; AS AN INDEPENDENT ITEM.
;V12A****************
;
;DMN 28-FEB-79 [644] MORE ERROR RECOVERY IN CONTAB
;V12*****************
;V10*****************
; 15-DEC-76 [454] FIX RECOVERY FOR ERROR IN CONTAB
; 10-AUG-76 [434] FOR REPORT WRITER SO SUM COUNTERS OF GT 10 DIGITS ARE HANDLED PROPERLY
; 31-MAR-76 [415] FOR REPORT WRITER SORT THE SUM COUNTER CODE SO THAT LOWEST LEVEL DONE FIRST
; 31-MAR-76 [415] REPORT WRITER DO THE SUM CODE IN ORDER OF LOWEST TO HIGHEST LEVL OF CID
;ACK 12-JAN-75 FILE STATUS CODE - REPLACE THE HLDTAB LINKS BY
; DATAB LINKS.
;ACK 12-MAR-75 MODIFY ROUTINE WHICH ADJUSTS LITERALS SO THAT
; THEY HANDLE COMP-3/EBCIDC LITERALS.
;********************
; EDIT 335 REPORT WRITER ERROR CHECKING
; EDIT 315 REPORT WRITER FIXES SEE P.MAC
; EDIT 300 FLAG AS ERROR SYMBOLIC KEY, OR RECORD KEY IN LINKAGE SECTION
; EDIT 164A FIX TO 164
; EDIT 164 FLAG AS FATAL ANY DEPENDING ITEM NOT 1-WORD COMP OR SUBSCRIPTED OR IN LINK SECTION.
; EDIT 162 GIVE WARNING THE FOLLOWING MAY NOT BE IN LINKAGE SECTION
; VALUE OF ID, DATE-WRITTEN, OR USER-NAME
; FILE-LIMITS, ACTUAL-KEY OR SYMBOLIC-KEY
; EDIT 152 FIXES ILLEGAL MEM REF FOR UNDEFINED VALUES OF ID DATE-WRITTEN, AND PPN.
TWOSEG
.COPYRIGHT ;Put standard copyright statement in REL file
SALL
RELOC 400000
EXTERN RPTSRT,RPTRPT,RPTNEW,RPTRHT,RPTNHT,RPTCIT,RPTCID,RPTNID,RPTFIN
EXTERN TEMLOC,CURTEM,HL.CID,HL.RD ; [415]
EXTERN ETABLB,EFLAGB,EMODEB,ESIZEB,ERESB,EINCRB
EXTERN AS.OCT
%HLDCD==1 ; [415] MEANS THIS HLDTAB THING DONE, SETS MSD OF CODE TO 1
EXTERN HL.FCD,HL.COD
ENTRY CLEANC,GETCHR,ADJUST
ENTRY CLNHLD ;[1335]
;GENERATE LITERALS FOR FILE TABLES
CLEANC: MOVE TA,RPWLOC ;GET STARTING LOCATION OF TABLE
SETZM RPWTYP##
CAMN TA,RPWNXT## ;ANY RD ENTRIES ?
JRST CLRPW4 ;NO, SKIP CLEAN OF RPWTAB
ADDI TA,1
CLRPW0: PUSH PP,TA ;SAVE ADDRESS OF RD ENTRY
LDB TB,RW.DEF##
SKIPE TB ;IS IT DEFINED BY AN RD ?
JRST CLRPW6 ;YES
LDB LN,RW.LN ;NO, GENERATE ERROR ON FD STATEMENT
LDB CP,RW.CP
HRRZI DW,E.793
PUSHJ PP,WARN
SETOM RPWTYP ;DON'T GENERATE ERROR FOR NO DE, CH, CF GROUPS
JRST CLRPW3 ;GO TEST NEXT RD
CLRPW6: LDB TB,RW.COD##
SKIPE TB ;CODE SEEN FOR THIS RD ?
JRST CLRPW5 ;YES
LDB LN,RW.LN ;POINT TO RD ENTRY FOR POSSIABLE ERROR
LDB CP,RW.CP
HRRZI DW,E.778 ;SET UP FOR POSSIABLE ERROR
LDB TA,RW.FIL## ;GET FILTAB LOCATION FOR THIS RD
ADD TA,FILLOC ;ADD OFSET TO FILTAB TABLE
LDB TB,FI.COD##
SKIPE TB ;CODE CLAUSE SEEN FOR FIRST RD
PUSHJ PP,WARN ;YES
MOVE TA,(PP)
CLRPW5: LDB TA,RW.FGP## ;GET DATAB ENTRY FOR FIRST 01 GROUP
JUMPE TA,CLRPW3 ;IF NO 01 GROUPS, GET NEXT RD ENTRY
CLRPW1: PUSH PP,TA
PUSHJ PP,LNKSET##
LDB TA,DA.RPW ;GET RPWTAB ENTRY FOR 01 GROUP
ADD TA,RPWLOC ;CONVER TO ACTUAL ADDRESS
LDB TB,RW.TYP## ;GET TYPE OF THIS 01 GROUP
CAIN TB,%RG.DE ;TYPE DETAIL ?
SKIPA
CAIN TB,%RG.CH ;OR CONTROL HEADING ?
SKIPA
CAIN TB,%RG.CF ;OR CONTROL FOOTING ?
SETOM RPWTYP ;YES, SET FLAG THAT A DE, CH, OR CF WAS SEEN
LDB TB,RW.NLC##
LDB TC,RW.LCD##
LDB TD,RW.RLS##
SKIPN TB ;NEXT GROUP STATEMENT SEEN ?
JRST CLRPW2 ;NO, GO TO NEXT 01 ENTRY
SKIPN TC ;LINE CODE SEEN AT THIS LEVEL ?
SKIPE TD ;OR AT LOWER LEVEL ?
JRST CLRPW2 ;YES
LDB TA,RW.DAT## ;GET DATAB ENTRY
PUSHJ PP,LNKSET
HRRZI DW,E.774
LDB LN,DA.LN
LDB CP,DA.CP
PUSHJ PP,WARN
CLRPW2: POP PP,TA ;RESTORE DATAB ENTRY TO 01 GROUP
MOVE TB,TA
PUSHJ PP,FNDBRO## ;GET BROTHER OF 01 ENTRY
JRST CLRPW3 ;NO MORE BROTHERS, GET NEXT RD ENTRY
MOVE TA,TB
JRST CLRPW1 ;GO REPEAT FOR NEXT 01 GROUP
CLRPWE: LDB LN,RW.LN## ;GET LINE NUMBER OF RD
LDB CP,RW.CP##
HRRZI DW,E.775
PUSHJ PP,WARN
POPJ PP,
CLRPW3: POP PP,TA ;RESTORE LAST RPWTAB ADDRESS FOR RD ENTRY
SKIPN RPWTYP ;WAS A DE, CH, OR CF SEEN ?
PUSHJ PP,CLRPWE ;NO, GENERATE WARNING AND CONTINUE
SETZM RPWTYP
LDB TA,RW.BRO## ;GET NEXT RD ENTRY
JUMPE TA,CLRPW4 ;NO MORE RD ENTRIES, STOP
ADD TA,RPWLOC
CAMGE TA,RPWNXT ;OUTSIDE TABLE ?
JRST CLRPW0 ;NO
CLRPW4: SKIPE TA,COLSEQ## ;IF COLLATING SEQ. SET
TRNE TA,700000 ;IS IT NAMTAB ENTRY?
JRST CLNDSQ ;NO
ADD TA,NAMLOC
SKIPN TA,0(TA) ;GET SPECIAL-NAME
JRST [HRRZI DW,E.718 ;NOT DEFINED
HLRZ LN,COLNCP## ;RESTORE LN
HRRZ CP,COLNCP ;AND CP
PUSHJ PP,FATAL ;GIVE ERROR MESSAGE
SETZM COLSEQ ;NO COLATING SEQUENCE
JRST CLNDSQ] ;AND CONTINUE
PUSHJ PP,LNKSET
MOVE TA,1(TA) ;GET 2ND WORD
TLNE TA,(1B6) ;MAKE SURE ITS ALPHABET NAME
TRNN TA,%AN.AS!%AN.EB ;AND NOT A LITERAL
JRST CLNDSQ ;NO, LEAVE AS IS
HRRZM TA,COLSEQ ;YES, REPLACE BY WHAT IT IS
CLNDSQ: MOVE TA,[XWD RPTSRT,RPTSRT+1] ; [415] CLEAR
SETZM RPTSRT ; [415] THE REPORT WRITER
BLT TA,RPTFIN ; [415] DATA
HRRZ TA,HLDLOC## ;START OF HLDTAB
AOJ TA,
MOVEM TA,CURHLD## ;PTR TO 1ST ENTRY
CLNHLD: HRRZ TA,CURHLD ;NEXT HLDTAB ENTRY
HRRZ TB,HLDNXT## ;PTR TO END
CAILE TA,(TB) ;PAST THE END YET?
JRST [SKIPE BLDIX## ;[1335] IF JUST BUILDING INDICES,
POPJ PP, ;[1335] EXIT
SKIPN RPTRPT ; [415] END OF HLDTAB ANY REPORT CF TO DO?
JRST CLNFIL ;NO RDS,, ALL DONE
JRST CLRPTP ] ; [415] DO LEFT OVER REPRT
LDB TC,HL.FCD ; [415]
CAIN TC,%HL.IX ;20: CK FOR "MAKE INDEX" CODE
JRST CLHIDX
SKIPE BLDIX ;[1335] IF JUST BUILDING INDICES,
JRST CLNHLL ;[1335] LOOP BACK
CAIN TC,%HL.SC ;14: CK FOR "BUILD-SUM-CTR" CODE
JRST CLNRPX ; [415] YES
CAIN TC,%HL.GI ; [315] G.I. ITEM
JRST CLHGIT ; [315] YES
CAIL TC,%HL.SL ; [415] FOR SUM IDS
CAILE TC,%HL.UP ; [415]
TRNA ; [415] NORMAL STUFF
JRST CLNHLL ; [415] SUM ID HANDLE DIFFERENTLY
LDB TB,HLSCOD ; [415] GET MOST SIGN DIGIT OF HL.COD
CAIN TB,%HLDCD ; [415] SEE ALREADY DONE?
JRST CLNHLL ; [415] GO TO NEXT ONE
PUSHJ PP,CLNHLQ ; [415] DO QUALIFIER CHECKS
XCT .(TC) ;DO ACTION FOR TYPE
JRST CLHACK ;1: STORE ACTUAL KEY DATAB LINK
JRST CLHVID ;2: STORE VALUE OF IDENTIFICATION DATAB LINK
JRST CLHVDW ;3: STORE VALUE OF DATE-WRITTEN DATAB LINK
JRST CLHVPP ;4: STORE VALUE OF PROJ-PROG # DATAB LINK
HALT . ;5: STORE LOW FILE-LIMIT DATAB LINK
HALT . ;6: STORE HIGH FILE-LIMIT DATAB LINK
JRST CLHDOC ;7: STORE DEPENDING FOR OCCURS DATAB LINK
JRST CLHKOC ;10: STORE ASCN. KEY FOR OCCURS DATAB LINK
JRST CLHSML ;11: STORE SUM ID DATAB LINK IN LEFT HALF
JRST CLHSMR ;12: STORE SUM ID DATAB LINK IN RIGHT HALF
JRST CLHUPN ;13: STORE SUM-UPON DATAB LINK
0 ;14: (EXECUTED 1ST IF SEEN)
JRST CLHSKY ;15: STORE SYMBOLIC KEY DATAB LINK
JRST CLHRKY ;16: STORE RECORD KEY DATAB LINK
JRST CLHDKY ;17: STORE DESC. KEY FOR OCC. DATAB LINK
0 ;20: (EXECUTED 1ST IF SEEN)
JRST CLHERS ;21: PUT NAMTAB LINKS IN FILE STATUS
; ENTRIES OF THE FILE TABLE.
0 ;22: (EXECUTED 1ST IF SEEN)
JRST CLHAKY ;23: STORE ALTERNATE KEY LINK
JRST CLHVPR ;24: VALUE OF PROTECTION CODE
; HANDLE THE QUALIFIERS
CLNHLQ: SETZM TBLOCK## ; [415] CLR TBLOCK
MOVE TC,[TBLOCK,,TBLOCK+1]
BLT TC,TBLOCK+24
MOVE TC,(TA) ;GET 1ST WORD OF HLDTAB ENTRY (ESSENTIALLY W2)
MOVEM TC,TBLOCK+4 ;& PUT IT IN TBLOCK SETUP
LDB TC,HL.QAL## ;GET # OF QUALS
JUMPE TC,CLNHL8 ;THERE AREN'T ANY
MOVEM TC,CTR##
CLNHL5: AOS TB,TBLOCK+1 ;INDEX TO NEXT QUALIFIER
CAMLE TB,CTR ;DONE ALL?
JRST CLNHL3 ;YES
ADDI TB,3 ;AIM AT THAT QUALIFIER
ROT TB,-1
ADDI TB,(TA)
HLRZ TD,(TB) ;GET QUALIFIER (ASSUMING INDEX ODD)
TLNE TB,400000 ;IF INDEX EVEN, GET RIGHT QUALIFIER
HRRZ TD,(TB) ;TD=NAMTAB LINK FOR QUALIFIER
MOVE TB,TBLOCK+1 ;CTR IS INDEX TO QUALIFIER STORAGE
MOVEM TD,TBLOCK+4(TB) ;STORE QUALIFIER
JRST CLNHL5 ;GET NEXT QUALIFIER
CLNHL3: SOS TBLOCK+1 ;ADJUST QUAL CTR
CLNHL8: PUSHJ PP,FINDAT## ;FIND DATAB LINK FOR ITEM
JUMPE DW,CLNHL7 ;NO ERROR
PUSHJ PP,CLHBA1 ;GIVE ERROR MESSAGE
JRST CLNHL4 ;LEAVE TBLOCK+4 NON-ZERO
CLNHL7: SETZM TBLOCK+4 ;CLR UNDEFINED FLAG
CLNHL4: HRRZ TA,CURHLD ;GET HLDTAB PTR
LDB TB,HL.LNK## ;LINK TO PLACE WHERE DATA LINK WANTED
ANDI TB,077777 ;MASK OFF TABLE BITS
LDB TC,HL.FCD ; [415] TYPE OF THIS HLDTAB ITEM
MOVEI TA,(TB)
ADD TA,FILLOC## ;ASSUME IT'S A FILTAB REFERENCE
POPJ PP, ; [415]
CLNHL9: MOVE TA,CURHLD ;GET HLDTAB PTR
MOVEI TC,%HLDCD ; [415] MARK AS
DPB TC,HLMCOD ; [415] DONE
CLNHLL: MOVE TA,CURHLD ; [415] GET BACK HLDTAB POINTER
LDB TB,HL.QAL ;NUMBER OF QUALIFIERS
MOVEM TB,CTR
ADDI TB,SZ.HLD*2+1 ;ROUND UP + STANDARD # OF HALFWORDS
LSH TB,-1 ;DIVIDED BY 2
ADDM TB,CURHLD ;AIM AT NEXT HLDTAB ENTRY
JRST CLNHLD
TEMNRD==1
; FIRST PASS OF SUM IDS THRU HLDTAB
; FOR EACH RD SET UP IN TEMPTAB
; 0 [ RD LINK,,LINK TO HLDTAB FOR FIRST SUM CTR
; 1 [ # OF IDS,,TEMTAB LINK TO NEXT RD]
; FOR EACH ID LEVEL ONE WORD IN TEMTAB
; [ LEVEL #,,HLDTAB LINK TO FIRST SUM CTR THIS ID]
CLNRPX: SKIPE RPWERR ; [415] UNRECOVERABLE REPORT ERROR?
JRST CLNHL9 ; [415] YES SKIP OVER
LDB TB,HL.RD ; [415] GET RD LINK
CAME TB,RPTRPT ; [415] SAME RD?
PUSHJ PP,CLRDOD ; [415] NEW ONE
HRRZ TA,CURHLD ; [415] GET CURRENT HLDTAB LOC
LDB TC,HL.CID ; [415] GET LEVEL NUMBER
CAMN TC,RPTCID ; [415] SAME ID?
JRST CLNHLL ; [415] YES , SKIP THIS
MOVEM TC,RPTCID ; [415] SAVE NEW LEVEL NUMBER
AOS RPTNID ; [415] COUNT NEW ID
MOVE TA,[CD.TEM,,SZ.TEM]; [415] GET TEMTAB LOCATION
PUSHJ PP,GETENT ; [415]
MOVEM TA,CURTEM ; [415]
MOVE TB,RPTCID ; [415] GET BACK NEW ID LEVEL #
HRLZM TB,0(TA) ; [415] STORE THE NEW ID LEVEL NUMBER INTO TEMTAB
HRRZ TB,CURHLD ; [415] CONVER CURRENT HLDTAB
HRRZ TC,HLDLOC ; [415] TO RELATIVE
SUB TB,TC ; [415] LINK LOCATION
HRRM TB,0(TA) ; [415] STORE START HLDTAB LINK INTO TEMTAB
JRST CLNHLL ; [415] GO TO NEXT HLDTAB
; NEW RD FOUND- FINISH UP LINKAGE
CLRDOD: MOVEM TB,RPTNEW ; [415] STORE NEW RD
MOVE TA,[CD.TEM,,SZ.TM2] ; [415] GET TEMTAB FOR NEW
PUSHJ PP,GETENT ; [415] RD HEADER
MOVEM TA,RPTNHT ; [415] SAVE IT
SKIPN RPTRPT ; [415] FIRST ONE?
JRST CLRDOX ; [415] YES GO ON
HLRZ TA,RPTRHT ;[415] GET CURRENT TEMTAB POINTER
HRRZ TB,TEMLOC ; [415] CONVERT TO REAL
ADDI TA,(TB) ; [415] ADDRESS
HLRZ TB,RPTNHT ; [415] GET BACK NEW TEMTAB LINK
HRRZM TB,TEMNRD(TA) ; [415] STORE INTO CURRENT NEXT LNIK POINTER
MOVE TC,RPTNID ; [415] GET NUMBER OF ID FOR CURRENT
HRLM TC,TEMNRD(TA) ; [415] STORE IN CURRENT HEADER
MOVE TA,RPTNHT ; [415] GET NEW TEMTAB HDR POINTER
CLRDOX: MOVE TB,RPTNEW ; [415] GET NEW RD LINK
MOVEM TA,RPTRHT ; [415] MAKE NEW RD CURRENT ONE
HRLZM TB,0(TA) ; [415] STORE INTO NEW TEMTAB HDR
MOVE TD,RPTNEW ; [415] MAKE NEW POINTER CURRENT
MOVEM TD,RPTRPT ; [415]
SETZM RPTNID ; [415] START # OF IDS OVER
SETOM RPTCID ; [415] SET LEVEL CNT TO NONE
HRRZ TB,CURHLD ; [415] GET CURRENT HLDTAB
HRRZ TC,HLDLOC ; [415] CONVERT
SUB TB,TC ; [415] TO REL ADDRESS
HRRM TB,(TA) ; [415] STORE INTO HEADER
POPJ PP, ; [415] RETURN END OF NEW RD
HLMCOD: POINT 1,1(16),0 ; [415] MSD OF HL.COD
HLSCOD: POINT 1,TC,27 ; [415] WHERE TO PUT MSD OF HL.COD FOR TESTING
; END OF HLDTAB FIRST PASS - FIRST FINISH UP CURREENT RD
CLRPTP: HLRZ TA,RPTRHT ; [415] GET CURRENT RD IN TEMTAB
HRRZ TB,TEMLOC ; [415] CONVERT
ADDI TA,(TB) ; [415] TO REAL
HRLZ TB,RPTNID ; [415] GET NUMBER OF IDS
MOVEM TB,TEMNRD(TA) ; [415] STORE IT AND ZERO NEXT RD POINTER
; PROCESS THE SUM COUNTER HLDTAB
MOVSI TA,1 ; [415] START AT
MOVEM TA,RPTRHT ; [415] POINT TO HEAD OF FIRST RD
HRR TA,TEMLOC ; [415] TOP
AOS TA ; [415] OF TEMTAB
; DO FOR EACH RD
; TA AND RPTRHT HAVE POINTER TO HEAD OF RD IN TEMTAB
CLRRD: HLRZ TB,(TA) ; [415] GET RD LINK
MOVEM TB,RPTRPT ; [415] SAVE AS NEW RD
HLRZ TE,TEMNRD(TA) ; [415] GET # OF CID'S IN THIS RD
MOVEM TE,RPTNID ; [415] SAVE
ADDI TA,2 ; [415] NOW POINT TO FIRST SUM ID THIS RD
MOVEM TA,CURTEM ; [415] SAVE FIRST LEVEL
HRRZM TA,TB ; [415] GET 1ST LEVEL TEMTAB LOC
HRRZ TC,TEMLOC ; [415] COMPUTE ITS
SUBI TB,(TC) ; [415] RELATIVE LOCATION
HRLZM TB,RPTCIT ; [415] KEEP FOR NEXT ID
;
; DO FOR EACH ID
; SEARCH THRU THE TEMP TABLE FOR LOWEST LEVEL ID LEFT TO PROCESS
; CURTEM POINTS TO FIRST LEVEL SEEN IN THIS RD
CLNRDS: MOVEI TB,777777 ; [415] SET ID TO HIGH TO START
MOVEM TB,RPTCID ; [415] RPTCID HOLDS CURRENT LOWEST ID LEVEL #
CLNRD1: HLRZ TB,(TA) ; [415] GET LEVEL NUMBER THIS ID
TRNE TB,400000 ; [415] ALREADY DONE THIS ID?
JRST CLNRDL ; [415] YES GO TO NEXT LEVEL
CAML TB,RPTCID ; [415] CHOOSE LOWER OF CURRENT ID VS LOWEST
JRST CLNRDL ; [415] CURRENT ONE NOT LOWER
MOVEM TB,RPTCID ; [415] KEEP NEW ID LEVEL
HRRZ TC,(TA) ; [415] GET HLTAB POINTER FOR THIS ID
MOVEM TA,CURTEM ; [415] KEEP TEMTAB LOC OF LOWEST ID
CLNRDL: SOSLE TE ; [415] ANY MORE ID THIS TABLE?
AOJA TA,CLNRD1 ; [415] YES GO TO NEXT
;
; TC HAS THE HLDTAB LINK POINTER TO START PROCESSING
; !!!!! NOW PROCESS !!!!!!
PUSHJ PP,RPTDO ; [415] PROCESS THIS ID LLEVEL
SOSG RPTNID ; [415] ANY MORE IDS
JRST CLRNND ; [415] ALL DONE THIS RD DO NEXT
HRRZ TA,CURTEM ; [415] GET TEMTAB LOCATION FOR LOWEST ID
MOVSI TB,777777 ; [415] SET LEVEL PROCESSED TO HIGH
HLLM TB,0(TA) ; [415] SET
HLRZ TA,RPTCIT ; [415] GET FIRST ID LOCATION IN TEMTAB
HRRZ TB,TEMLOC ; [415] CONVERT TO REAL
ADDI TA,(TB) ; [415] TEMTAB LOCATION
MOVEM TA,CURTEM ; [415] KEEP AS CURRENT TEMTAB POINTER
HLRZ TE,-1(TA) ; [415} GET BACK ORIGINAL # OF IDS
JRST CLNRDS ; [415] GO SEARCH AND DO NEXT ID
; END DO FOR EACH ID
;
; FINISHED THIS RD DO NEXT RD IF ANY
CLRNND: HLRZ TA,RPTRHT ; [415] GET HEADER ADDRESS OF THIS RD
HRRZ TB,TEMLOC ; [415] CONVERT TO REAL
ADDI TA,(TB) ; [415] REAL
HRRZ TA,TEMNRD(TA) ; [415] GET LINK TO NEXT RD
JUMPE TA,CLNFIL ; [415] THERE IS NO MORE ALL DONE
HRLZM TA,RPTRHT ; [415] SAVE LINK HEADING LINK FOR NEW RD
ADDI TA,(TB) ; [415] CONVERT LINK TO REAL
JRST CLRRD ; [415] DO NEXT RD
; DO THE LOWEST LEVEL SUM ID IN THIS REPORT
; TC HAS THE HLDTAB LINK TO START PROCESSING, RPTCID HAS THE LEVEL NUMBER
RPTDO: HRRZ TA,HLDLOC ; [415] GET REAL ADDRESS
ADDI TA,(TC) ; [415]
MOVEM TA,CURHLD ; [415] MAKE IT CURRENT HLDTAB POINTER
LDB TB,HL.FCD ; [415] ALREADY DONE?
TRNE TB,400 ; [415] IF SO
POPJ PP, ; [415] EXIT NOW
JRST CLHSCT ; [415] DO TYPE 14 (BUILD SUM COUNTER)
RPTDOL: HRRZ TA,CURHLD ; [415] GET CURRENT HLDTAB POINTER
HRRZ TB,HLDNXT ; [415] END OF HLDTAB?
CAILE TA,(TB) ; [415] CHECK
POPJ PP, ; [415] RETURN
LDB TC,HL.FCD ; [415] GET FULL HL CODE
LDB TB,HLSCOD ; [415] GET MOST SIGN DIGIT OF HL.COD
CAIN TB,%HLDCD ; [415] SEE ALREADY DONE?
JRST RPTDOE ; [415] YES GO TO NEXT ONE
CAIN TC,%HL.SC ; [415] ANOTHER SUM ID
JRST RPTSCT ; [415] YES,CHECK IF OKAY
CAIN TC,%HL.SL ; [415] SUM ID LEFT HALF?
JRST CLHSML ; [415] YES DO IT
CAIN TC,%HL.SR ; [415] SUM ID RIGHT HALF?
JRST CLHSMR ; [415] YES DO IT
CAIN TC,%HL.UP ; [415] SUM UPON?
JRST CLHUPN ; [415] YES DO IT
POPJ PP, ; [415] SOME OTHER CODE RETURN
RPTDOE: MOVE TA,CURHLD ; [415] GET BACK CURRENT HLDTAB POINTER
MOVEI TC,%HLDCD ; [415] MARK AS
DPB TC,HLMCOD ; [415] DONE
LDB TB,HL.QAL ; [415] GET NNUMBER OF QUALIFIERS
MOVEM TB,CTR ; [415] KEEP TRACK OF THEM
ADDI TB,SZ.HLD*2+1 ; [415] OFFSET TO QUALIFIERS
LSH TB,-1 ; [415] DIVIDE BY 2 TO CREATE POINTER
ADDM TB,CURHLD ; [415]
JRST RPTDOL ; [415] GO DO THE NEXT ITEM
RPTSCT: LDB TB,HL.RD ; [415] IS THIS SAME RD?
CAME TB,RPTRPT ; [415]
POPJ PP, ; [415] EXIT
LDB TB,HL.CID ; [415} IS IT SAME
CAME TB,RPTCID ; [415] ID LEVEL?
POPJ PP, ; [415] NO ,EXIT
JRST CLHSCT ; [415] GO PROCESS SUM CTR
;STORE INDIVIDUAL LINKS IN APPROPRIATE TABLES
CLHSML: SKIPGE RPWERR## ; [335] FATAL REPORT GENERATOR ERROR
JRST RPTDOE ; [415] CANT GO ON
PUSHJ PP,CLNHLQ ; [415] PICK UP ANY QUALIFIERS
SUB TA,FILLOC
ADD TA,RPWLOC##
PUSHJ PP,SUMCK ;SEE THAT ITEM IS A SUM CTR
PUSHJ PP,CLHSME ;ERROR
HRLM TE,(TA) ;STORE DATAB LINK TO SUM ADDEND IN LEFT HALF
JRST RPTDOE ; [415] RETURN
CLHSMR: SKIPGE RPWERR ; [335] FATAL REPORT GENERATOR ERROR
JRST RPTDOE ; [415] CANT GO ON
PUSHJ PP,CLNHLQ ; [415] PICK UP ANY QUALIFIERS
SUB TA,FILLOC
ADD TA,RPWLOC
PUSHJ PP,SUMCK ;SEE THAT ITEM IS A SUM CTR
PUSHJ PP,CLHSME ;ERROR
HRRM TE,(TA) ;STORE DATAB LINK TO SUM ADDEND IN RIGHT HALF
JRST RPTDOE ; [415] RETURN
CLHSME: HRRZI DW,E.358 ;NOT A TYPE DETAIL OR CONTROL-FOOTING
JRST CLHBA1
CLHUPN: PUSH PP,TA ;[1544] SAVE HLDTAB POINTER
PUSHJ PP,CLNHLQ ;[1544] DO QUALIFIER CHECKS
PUSH PP,TE ;[1544]
HRRZI TC,(TE) ;[1544] MAKE DATTAB PTR. TO DETAIL LINE
MOVE TA,TC ;[1544]
PUSHJ PP,LNKSET## ;[1544]
LDB TA,DA.RPW ;[1544] GET THE RPWTAB LINK
ADD TA,RPWLOC ;[1544] ADD OFFSET
LDB TB,RW.TYP## ;[1544] MUST BE TYPE DETAIL
CAIE TB,%RG.DE ;[1544]
PUSHJ PP,CLHUPE ;[1544] IT'S NOT - FATAL
SETO TB, ;[1544] SET REFERENCED-BY-SUM-UPON BIT
DPB TB,RW.RSU## ;[1544] IN DETAIL LINE
POP PP,TE ;[1544]
POP PP,TA ;[1544] THE CURRENT HLDTAB ENTRY
LDB TB,HL.LNK ;GET LINK TO RPWTAB UPON ENTRY
HRRZ TA,CURDAT ;GET DATAB ENTRY
LDB TA,DA.RPW ;GET RPWTAB ENTRY
ADD TA,RPWLOC ;ADD OFFSET
DPB TB,RW.UPN## ;STORE UPON LINK
MOVE TA,TB ;[1544] POINT TO THE UPON ENTRY
ADD TA,RPWLOC ;[1544] ADD OFFSET
DPB TC,RW.UP1## ;[1544] UPON ENTRY GETS DATTAB OF DETAIL
JRST RPTDOE ;RETURN
CLHUPE: HRRZI DW,E.364 ;[1544] SUM UPON MUST REF. TYPE DETAIL
JRST CLHBA1 ;[1544]
;MAKE A SUM COUNTER FOR DATAB ITEM
CLHSCT: SKIPGE RPWERR ; [335] FATAL REPORT GENERATOR ERROR
JRST RPTDOE ; [415] CANT GO ON
LDB TB,HL.RD ;[1610]GET THE RD POINTER
HRRZM TB,CURRD## ;[1610]SAVE IT
LDB TE,HL.LNK ;GET DATAB LINK
PUSHJ PP,SUMCTR ;GIVE ITEM A SUM-CTR
JRST RPTDOE ; [415] RETURN
; GROUP INDICATE ITEM HAVING A VALUE CLAUSE- CONVERT TO ITEM WITH
; SOURCE CLAUSE BY CREATING A DATAB ITEM WITH A VALUE CLAUSE
; THEN THIS NEWLY CREATED ITEM BECOMES THE SOURCE ITEM
; FOR THE ORIGINAL ONE
CLHGIT: SKIPGE RPWERR ; [335] FATAL REPORT GENERATOR ERROR
JRST CLNHL9 ; [335] CANT GO ON
LDB TA,HL.LNK ; [315] GET THE ORIG DATAB ITEM WITH THE VALUE CLAUSE
HRRZM TA,SAVDAT## ; [315] SAVE IT
MOVEI TYPE,1000 ; [315] SET TYPE TO USER-NAME FOR NEW ITEM
PUSHJ PP,RPWDAT## ; [315] GO CREATE NEW ITEM USING THE CURRENT ONE ON PUSH-DOWN STACK FOR PARAMETERS
MOVE TA,CURHLD ; [315] GET BACK HLDTAB POINTER
LDB TB,HL.NAM ; [315] GET THE VALUE LINK
ADDI TB,<CD.LIT>B20 ; [315] POINT IN LITAB TABLE ID
MOVE TA,CURDAT ; [315] GET ADDRESS OF NEWLY CREATED ITEM
DPB TB,DA.VAL## ; [315] STORE VALUE PTR TO THIS NEW ITEM
PUSHJ PP,D54.NJ## ; [315] SET ASIDE RUN TIME SPACE FOR NEW ITEM WTIH ITS VALUE
HRRZ TA,SAVDAT ; [315] GET BACK ORIGINAL DATAB ITEM
LDB TB,DA.RPW ; [315] GET ORIGNAL REPORT ITEM POINTER
HRRZ TA,RPWLOC ; [315] CONVERT LINKAGE TO REAL
ADDI TA,(TB) ; [315] ADDRESS
HLRZ TB,CURDAT ; [315] GET LINK ADDRESS OF NEW ITEM
DPB TB,RW.SLK ; [315] AND MAKE IT THE SOURCE ITEM FOR REPORT ITEM
JRST CLNHL9 ; [315] GO TO NEXT HLDTAB ITEM
;CK THAT SUM-ID IS A SUM-CTR
;IF NOT, MAKE ONE FOR THE ITEM
SUMCK: PUSH PP,TA ;SAVE CRUCIAL AC'S
MOVEM TE,(SAVPTR)
HRRZI TA,(TE) ;MAKE PTR TO DATA ITEM
PUSHJ PP,LNKSET
LDB TB,DA.SCT## ;IS THIS A SUM-CTR?
JUMPE TB,SUMCKB ;NO
DPB TB,DA.RBS## ;YES, SET REF'D BY SUM BIT
JRST SUMCKX
SUMCKB: LDB TB,DA.RPW## ;NO, GET PTR TO CORRESP RPW ENTRY
JUMPE TB,SUMCKA ;MUST BE A SOURCE ITEM
HRRZ TA,RPWLOC
ADDI TA,(TB)
LDB TD,RW.RDL## ;GET RD ADDRESS
MOVE TC,CURRD## ;[1610]THE RD OF THIS SUM LINE
CAMN TD,TC ;SAME REPORT ?
JRST SUMCKC ;[1610]YES, NO WARNING
HRRZ TA,CURHLD ;[1610]GET POINTER TO CURRENT HLDTAB
LDB LN,HL.LN ;[1610]GET LINE NUMBER
LDB CP,HL.CP ;[1610] AND CHARACTER POSITION
HRRZI DW,E.770 ;[1610]GENERATE WARNING
PUSHJ PP,WARN ;[1610]
SUMCKC: HRRZ TA,RPWLOC ;[1610]HERE IF NO WARNING
ADDI TA,(TB)
LDB TB,RW.TYP ;GET TYPE
CAIN TB,%RG.CF ;CONTROL-FOOTING?
JRST SUMCKS ;YES, MUST MAKE A SUM-CTR FOR IT
JRST SUMCKE ;NOT A CF & NOT A SOURCE FOR DETAIL
SUMCKA: SETO TB,
DPB TB,DA.RBS ;SET REFERENCED BY SUM BIT
JRST SUMCKX ;EXIT
SUMCKS: HRRZ TE,(SAVPTR) ;MAKE A SUM-CTR FOR CF ITEM
PUSHJ PP,SUMCTR
HRRZI TA,(TB) ;GET PTR TO SUM CTR
SETO TB, ;SET REF'D BY SUM BIT
DPB TB,DA.RBS
JRST SUMCKY
SUMCKX: MOVE TE,(SAVPTR) ;RESTORE TE
SUMCKY: AOS -1(PP) ;SKIP RETURN
SUMCKE: POP PP,TA ;RESTORE TA
POPJ PP,
;MAKE A SUM-CTR FOR A DATA ITEM (WHOSE LINK IS IN TE)
SUMCTR: HRRZ TA,DATLOC ;MAKE LINK & PTR TO ITEM'S DATAB ENTRY
ADDI TA,(TE)
HRLI TA,(TE)
SUBI TA,TC.DAT## ;SUBTRACT TABLE CODE BITS
MOVEM TA,CURDAT##
PUSHJ PP,RPWNAM## ;MAKE A NAME FOR THE GROUP ITEM ("RWITM...")
MOVE TA,[CD.DAT,,SZ.DAT] ;MAKE A DATAB ENTRY FOR SUM CTR
PUSHJ PP,GETENT##
MOVEM TA,(SAVPTR) ;SAVE LINK & PTR TO SUM CTR DATAB ENTRY
HRRZ TA,CURDAT ;MAKE PTR TO CORRESP RPWTAB ENTRY
LDB TB,DA.RPW
HRRZ TA,RPWLOC
ADDI TA,(TB)
HLRZ TB,(SAVPTR) ;PUT SUM CTR DATAB LINK IN RPWTAB
DPB TB,RW.SLK##
HRRZ TA,CURDAT ;GET GROUP ITEMS SAME NAME LINK
LDB TB,DA.SNL##
SETZ TC, ;& PUT 0 WHERE IT WAS
DPB TC,DA.SNL
SETO TC, ;& SET FAKE NAME BIT ON GP ITEM
DPB TC,DA.FAK##
LDB TD,DA.LNC## ;ALSO GET GROUP ITEM'S LINE POSITION
LDB TE,DA.INS## ;& SIZE
LDB TC,DA.NDP## ;& # OF DECIMAL PLACES
HRRZ TA,(SAVPTR) ;MOVE GROUP ITEMS SNL TO SUM CTRS SNL SLOT
DPB TB,DA.SNL
DPB TD,DA.LNC ;PUT GP ITEM'S LINE POS. IN SUM CTR ENTRY
DPB TE,DA.INS ; " SIZE
DPB TE,DA.EXS##
DPB TC,DA.NDP ; " # DEC. PLACES
HRRZ TA,CURDAT ; [315] GET DATA ITEM ADDRESS
LDB TB,DA.FAL ; [315] GET IS FATHER
LDB TC,DA.POP## ; [315] AND ITS POINTER
HRRZ TA,(SAVPTR) ; [315] GET SUM-CTR ITEM
DPB TB,DA.FAL ; [315] COPY ORIGINAL FATHER
DPB TC,DA.POP ; [315] AND ITS LINK INTO IT
HRRZ TD,EAS1PC## ;GET NEXT FREE DATA LOC
DPB TD,DA.LOC## ;STORE ASSIGNED LOC
AOJ TD, ;INCREMENT FOR 1-WORD SUM-CTR
CAILE TE,^D10 ;SUM CTR MORE THAN 10 DIGITS?
AOJ TD, ;YES, NEED A 2-WORD CTR
MOVEM TD,EAS1PC ;& SAVE LAST USED
HRRZI TB,%CL.NU ;SET NUMERIC CLASS IN DATAB
DPB TB,DA.CLA
HRRZI TB,%US.1C ;& 1-WORD COMP USAGE
CAILE TE,^D10 ;[434] IS IT 2-WORD COMP
HRRZI TB,%US.2C ;[434] YES
DPB TB,DA.USG
HRRZI TB,CD.DAT ;SET DATAB CODE
DPB TB,[POINT 3,(TA),2]
HRRZI TB,LVL.77 ;MAKE SUM-CTR LEVEL 77
DPB TB,DA.LVL##
DPB TB,DA.PIC## ;SET PIC SEEN BIT
DPB TB,DA.SGN ;& SIGNED BIT
DPB TB,DA.SCT ;& SUM-CTR BIT
DPB TB,DA.DEF## ;& DEFINED BIT
HRRZ TB,NAMADR## ;PUT GROUP ITEMS DATAB LINK IN 'RWITM' NAMTAB ENTRY
MOVE TA,CURDAT
HLRM TA,(TB)
LDB TC,DA.NAM## ;GET GP ITEMS NAMTAB LINK
HLRZ TD,NAMADR ;& PUT LINK TO 'RWITM' IN ITS PLACE
DPB TD,DA.NAM
HRRZ TA,(SAVPTR) ;MOVE GP ITEMS NAMTAB LINK TO SUM CTR
DPB TC,DA.NAM
HLRZ TE,CURDAT ;NOW SUBSTITUTE SUM CTR FOR GP ITEM IN SNL CHAIN
HRRZ TA,NAMLOC##
ADDI TA,(TC)
HRRZ TB,(TA)
CAIN TB,(TE)
JRST DA103X
DA103L: HRRZI TC,(TB)
ANDI TC,077777
HRRZ TA,DATLOC
ADDI TA,(TC)
HRRZ TB,(TA)
CAIE TB,(TE)
JRST DA103L
DA103X: MOVE TB,(SAVPTR)
HLRM TB,(TA)
POPJ PP,
CLHDOC: SUB TA,FILLOC ;NOT A FILTAB REFERENCE
ADD TA,DATLOC ;BUT A DATAB REFERENCE
SETZ TC,
DPB TC,DA.DLL## ;CLEAR DEPENDING AT LOWER LEVEL SINCE ITS NOT
PUSHJ PP,CLHSUB ;GET PTR TO DATA ITEM
SKIPE TBLOCK+4 ;UNDEFINED?
JRST CLHDOX ;YES
LDB TB,DA.CLA ;CK CLASS OF ITEM
CAIE TB,2 ;NUMERIC?
PUSHJ PP,CLE264 ;NO
LDB TB,DA.USG ;GET USAGE
CAIE TB,%US.1C ;NO CONVERSION IF 1-WORD COMP
CAIN TB,%US.IN ;OR INDEX
JRST CLHDOD ;OK
SETOB TB,RELKEY ;NO, SIGNAL CONVERSION REQUIRED
EXCH TA,TBLOCK+1
DPB TB,DA.DCR##
EXCH TA,TBLOCK+1
CLHDOD: LDB TB,DA.SUB## ;[1520][164] SEE IF SUBSCIPTED
SKIPE TB ;[164] ILLEGAL IF SO
PUSHJ PP,CLE275 ;[164] ERROR
LDB TC,DA.DPR## ;DECIMAL PT. TO RIGHT?
JUMPN TC,CLHDOX ;YES, OK
LDB TB,DA.NDP ;[164A] NUMBER OF DECIMAL PLACES
JUMPE TB,CLHDOX
PUSHJ PP,CLE264 ;NOT AN INTEGER
CLHDOX: MOVE TC,DA.DEP## ;GET DEP-FOR-OCC PTR
JRST CLNSTO
CLHKOC: TLZA TE,-1 ;0 = ASC. KEY FLAG
CLHDKY: HRLI TE,400000 ;DESC. KEY FLAG
SUB TA,FILLOC
ADD TA,DATLOC
MOVEM TE,(TA) ;PUT KEY LINK & FLAG IN DATAB ENTRY WORD
JRST CLNHL9
CLHSKY: PUSHJ PP,CLHLNK ; [300] SEE IF IN LINKAGE SECTION
MOVE TC,FI.SKY## ;GET FILTAB SYMBOLIC KEY PTR
JRST CLNSTO ; [300] STORE POINTER
CLHRKY: PUSHJ PP,CLHLNK ; [300] SEE IF IN LINKAGE SECTION
MOVE TC,FI.RKY## ;GET FILTAB RECORD KEY PTR
JRST CLNSTO ; [300] STORE POINTER
;ALTERNATE KEY ENTRY
CLHAKY: HRRZ TA,CURHLD ;GET CURRENT HLDTAB PTR
LDB TB,HL.LNK## ;LINK TO PLACE WHERE DATA LINK WANTED
HRLZM TB,CURAKT## ;STORE CURRENT PTR
ADD TB,AKTLOC## ;(THAT'S IN ALTERNATE KEY TABLE)
MOVEI TA,(TB) ;GET ABS. LOC OF TABLE ENTRY
DPB TE,AK.DLK## ;STORE DATAB LINK
;IF THIS IS FIRST ENTRY FOR THIS FILE, STORE FILTAB LINK TO THIS
; AKTTAB ENTRY
LDB TA,AK.FLK## ;GET FILTAB LINK
HRLZM TA,CURFIL## ;REMEMBER THAT
ADD TA,FILLOC## ;GET ABS ADDR.
LDB TC,FI.ALK## ;IS LINK ALREADY SETUP FOR THIS FILE?
JUMPN TC,CLHAK1 ;YES
HLRZ TC,CURAKT ;NO, MAKE IT POINT TO THIS ENTRY
DPB TC,FI.ALK##
;MAKE SURE IT IS DEFINED IN A RECORD FOR THIS FILE
;LH (CURFIL) NOW CONTAINS THE FILTAB ENTRY OFFSET.
CLHAK1: MOVE TA,TE ;GET LINK TO DATA ITEM
PUSHJ PP,LNKSET ;LOOK AT DATAB ENTRY
LDB TB,DA.DFS## ;IS IT DEFINED IN THE FILE SECTION?
JUMPE TB,CLHAKE ;NO, GIVE ERROR
CLHAK2: LDB TB,DA.DLL ;[1501] IS THERE A 'DEPENDING' CLAUSE?
JUMPE TB,CLHK2A ;[1501] NO, NO PROBLEM
HRRZI DW,E.612 ;[1501] YES, ERROR
PUSHJ PP,CLHBA1 ;[1501] SET UP HLTAB LN,C P; CALL FATAL
CLHK2A: LDB TB,DA.POP## ;FIND FILENAME
LDB TD,[POINT 3,TB,20] ;GET TYPE
CAIN TD,CD.FIL ;FILENAME?
JRST CLHAK3 ;YES - SEE IF IT'S THE ONE
MOVE TA,TB ;NOT AT TOP YET
PUSHJ PP,LNKSET ;UP TO NEXT LEVEL..
JRST CLHK2A ;[1533] LOOP UNTIL WE GET TO FILE
CLHAK3: HLRZ TA,CURFIL ;GET CURRENT FILE
CAMN TA,TB ;SAME FILE?
JRST CLNHL9 ;YES, GO ON
;NOT DEFINED IN THIS FILE--GIVE ERROR
CLHAKE: HRRZI DW,E.379 ;"RECORD KEY NOT IN RECORD"
HLRZ TA,CURFIL
ADD TA,FILLOC##
LDB LN,FI.LN ;POINT TO FILENAME
LDB CP,FI.CP
PUSHJ PP,FATAL## ;FATAL ERROR
JRST CLNHL9 ;GO BACK FOR NEXT HLDTAB ENTRY
CLHLNK: MOVEM TA,TBLOCK+1 ; [300] SAVE STORAGE PTR
SKIPE TBLOCK+4 ; [300] UNDEFINED ?
POPJ PP, ; [300] YES RETURN
PUSH PP,TE ; [300] SAVE ADDRESS OF KEY
PUSHJ PP,CLHSUB ; [300] CHECK IF IN LINKAGE SECTION-FLAG IF SO
POP PP,TE ; [300] RESTORE KEY ADDRESS
POPJ PP, ; [300] RETURN
;ACTUAL/RELATIVE KEY
CLHACK: MOVEM TA,TBLOCK+1 ; SAVE STORAGE PTR [264]
SKIPE TBLOCK+4 ;UNDEFINED?
JRST CLHACX ;YES
MOVEM TA,CURFIL ;SAVE FILTAB PTR
PUSHJ PP,CLHSUB ;GET USAGE OF DATA ITEM
PUSH PP,TE
PUSH PP,TB
LDB TE,DA.DPR ;ANY P'S IN THE PICTURE?
JUMPN TE,[PUSHJ PP,CLHE41 ;YES, GIVE BETTER MESSAGE
JRST CLHAC1]
LDB TE,DA.SGN ;SEE IF SIGNED
LDB TB,DA.NDP ;OR NOT INTEGER
SKIPN TE
SKIPE TB
PUSHJ PP,CLHE40 ;SHOULD BE UNSIGNED INTEGER
CLHAC1: LDB TE,DA.DFS## ;RELATIVE KEY IN RECORD?
JUMPE TE,CLHAC4 ;NO, ALL'S WELL
CLHAC2: LDB TB,DA.POP## ;FIND FILENAME
LDB TE,[POINT 3,TB,20] ;GET TYPE
CAIN TE,CD.FIL ;FILENAME?
JRST CLHAC3 ;YES - SEE IF ITS THE ONE
MOVE TA,TB ;NOT AT TOP YET
PUSHJ PP,LNKSET ;UP TO NEXT LEVEL...
JRST CLHAC2 ;LOOP UNTIL WE GET TO FILE
CLHAC3: HRRZ TA,CURFIL ;GET CURRENT FILE ABS. ADDRESS
HRRZ TE,FILLOC ;GET BASE OF FILTAB
SUB TA,TE ;GET CURRENT FILE REL ADDRESS
CAMN TA,TB ;SAME FILE?
PUSHJ PP,CLHE42 ;YES, GIVE ERROR
CLHAC4:
MOVE TA,CURFIL ;RESTORE FILTAB PTR
LDB TA,FI.RMS ;IS IT AN RMS FILE?
CAIE TA,1 ;
JRST CLHAC5 ; NO
CAILE TC,^D10 ;KEY LEN MORE THAN 10 DIGITS?
PUSHJ PP,CLHE43 ; YES - GIVE FATAL DIAG MSG
CLHAC5: ;
MOVE TA,CURFIL ;RESTORE FILTAB PTR AGAIN
POP PP,TB
POP PP,TE
CAIN TB,%US.1C ;1-WORD COMP
CAILE TC,^D10
CAIA ;NO
JRST CLHACX ;OK
DPB TE,FI.CKA## ;STORE REAL KEY
SETOM RELKEY## ;SIGNAL CONVERSION REQUIRED
MOVEI TE,AS.MSC## ;MARK AS MISC. FOR LATER INCR. TO %PARAM
CLHACX: MOVE TC,FI.ACK## ;ACT-KEY PTR
JRST CLNSTO
;REPLACE THE HLDTAB LINKS IN THE FILE STATUS ENTRIES OF A FILE TABLE
; BY DATAB LINKS.
;ENTRY CONDITIONS:
; (TA) ABS ADR OF FILE TABLE.
; (TBLOCK+4) 0 IF THE ITEM IS UNIQUELY DEFINED.
; (TE) DATAB LINK.
CLHERS: MOVE TB, FI.SPT## ;GET POINTER TO FILE STATUS LINKS.
MOVEM TB, TBLOCK
HRREI TB, -10 ;-MAXIMUM NUMBER OF LINKS.
MOVEM TB, TBLOCK+1
HRRZ TB, CURHLD ;CURRENT HLDTAB ADDRESS.
CLHER1: ILDB TC, TBLOCK ;GET A FILE STATUS LINK.
JUMPE TC, CLHER2 ;IF ITS ZERO SKIP IT.
LDB TD, [POINT 3,TC,20] ;GET THE TABLE CODE.
CAIN TD, CD.DAT ;DATAB?
JRST CLHER2 ;YES, SKIP IT.
ADD TC, HLDLOC ;MAKE IT ABSOLUTE.
CAIE TB, (TC) ;IS THIS THE ONE? (IT SHOULD BE.)
JRST CLHER2 ;NO, NEXT LINK.
;FOUND THE LINK - NOW WHAT TO DO WITH IT.
SKIPN TBLOCK+4 ;WAS THE NAME OK?
JRST CLHER4 ;YES, GO CHECK IT OUT.
SETZ TB, ;FLUSH THE LINK.
DPB TB, TBLOCK
JRST CLNHL9 ;GO LOOK AT THE NEXT HLDTAB ENTRY.
CLHER2: AOSGE TBLOCK+1 ;ANY MORE LINKS?
JRST CLHER1 ;YES, GO LOOK AT THE NEXT ONE.
JRST CLNHL9 ;OTHERWISE GO LOOK AT THE NEXT HLDTAB ENTRY.
;COME HERE WHEN WE FIND A GOOD LINK.
CLHER4: DPB TE, TBLOCK ;ASSUME THAT THE DATA IS GOOD.
PUSH PP, TA ;BUT SAVE THE FILE TABLE ADDRESS
; JUST IN CASE IT ISN'T.
HRRI TA, (TE) ;SET UP TO LOOK AT DATAB.
LDB TB, LNKCOD## ;MAKE SURE IT'S DATAB.
CAIE TB, CD.DAT
JRST CLHE23 ;IT ISN'T - COMPLAIN.
ANDI TA, 077777 ;GET OFFSET.
ADD TA, DATLOC ;MAKE IT ABSOLUTE.
;SEE WHERE TO GO NEXT.
MOVE TB, TBLOCK+1
JRST @.+11(TB)
EXP CLHE4A ;DISPLAY.
EXP CLHE4A ;DISPLAY.
EXP CLHER9 ;INDEX.
EXP CLHE4A ;DISPLAY.
EXP CLHER9 ;INDEX.
EXP CLHER9 ;INDEX.
EXP CLHE4A ;DISPLAY.
EXP CLHER9 ;INDEX.
;CHECK THINGS THAT ALL DISPLAY ITEMS MUST HAVE - NO SIGN, DECIMAL PLACES, ETC.
;MACROS TO MAKE LIFE EASIER.
DEFINE AECK1 (FIELD, LOC)<
LDB TB, FIELD'##
JUMPN TB, LOC
>
DEFINE AECK2 (LOC, NUM)<
LOC': MOVEI DW, E.'NUM
JRST CLHE30
>
CLHE4A: AECK1 DA.SGN,CLHE22 ;SIGNED?
AECK1 DA.BWZ,CLHE21 ;BLANK WHEN ZERO?
AECK1 DA.SUB,CLHE20 ;SUBSCRIPTED?
AECK1 DA.EDT,CLHE19 ;EDITED?
AECK1 DA.JST,CLHE18 ;JUSTIFIED?
AECK1 DA.DFS,CLHE17 ;FILE SECTION?
AECK1 DA.LKS,CLHE16 ;LINKAGE SECTION?
AECK1 DA.NDP,CLHE15 ;DECIMAL PLACES?
;NOW CHECK THINGS SPECIFIC TO EACH ITEM.
DEFINE AECK3 (SIZE, RTN)<BYTE (11)SIZE(25)RTN>
MOVE TB, TBLOCK+1 ;BET YOU THOUGHT I FORGOT ABOUT TBLOCK+1.
JRST @.+11(TB)
CLHER5: AECK3 2,CLHE68 ;ALPHANUMERIC OR NUMERIC DISPLAY, 2 CHARS.
AECK3 12,CLHER6 ;NUMERIC DISPLAY, 10 CHARS.
EXP KILL## ;INDEX, CAN'T GET HERE.
EXP CLHE7A ;[1634] NO LONGER CHECK FOR 9 CHAR.
EXP KILL## ;INDEX, CAN'T GET HERE.
EXP KILL## ;INDEX, CAN'T GET HERE.
AECK3 36,CLHER8 ;ALPHANUMERIC DISPLAY, 30 CHARS.
;CHECK FOR NUMERIC DISPLAY.
CLHER6: LDB TC,DA.CLA ;GET CLASS.
CAIE TC,%CL.NU ;NUMERIC?
JRST CLHE14 ;NO.
CLHER7: LDB TC,DA.USG ;GET USAGE.
CAIE TC,%%US ;SKIP IF NO USAGE ASSIGNED.
CAILE TC,%US.DS ; FALL IF NOT SOME KIND OF DISPLAY.
JRST CLHE13 ;IT ISN'T DISPLAY
LDB TC,DA.EXS ;GET ITS SIZE.
LDB TB,[POINT 11,CLHER5+10(TB),10] ;GET THE RIGHT SIZE.
CAIE TB,(TC) ;SAME SIZE?
JRST CLHE12 ;NO.
;EVERYTHING CHECKS OUT.
CLHE7A: LDB TC,DA.EXS ;[1634]GET ITS SIZE
CAILE TC,77 ;[1634]IS IT WITHIN LIMITS
JRST CLHE12 ;[1634]NO
CLHE7E: POP PP,TA ;RESTORE THE STACK.
JRST CLNHL9 ;GO LOOK FOR MORE HLDTAB ITEMS.
;CHECK FOR EITHER NUMERIC OR ALPHANUMERIC
CLHE68: LDB TC,DA.CLA ;GET THE CLASS
CAIN TC,%CL.NU ;NUMERIC?
JRST CLHER7 ;YES.
;NO, TEST FOR ALPHANUMERIC
;CHECK FOR ALPHANUMERIC.
CLHER8: LDB TC,DA.CLA ;GET THE CLASS.
CAIE TC,%CL.AN ;SKIP IF ALPHANUMERIC.
JRST CLHE11 ;NOPE - ERROR.
JRST CLHER7 ;GO LOOK AT USAGE.
;CHECK FOR INDEX.
CLHER9: LDB TC,DA.USG ;GET USAGE.
CAIN TC,%US.IN ;INDEX?
JRST CLHE7E ;YES.
;FALL INTO ERROR CODE..
;COME HERE ON ERRORS.
AECK2 CLHE10,551 ;USAGE MUST BE INDEX.
AECK2 CLHE11,552 ;MUST BE ALPHANUMERIC.
AECK2 CLHE12,553 ;WRONG SIZE.
AECK2 CLHE13,554 ;MUST BE DISPLAY
AECK2 CLHE14,555 ;MUST BE NUMERIC.
AECK2 CLHE15,556 ;CAN'T HAVE DECIMAL PLACES.
AECK2 CLHE16,557 ;CAN'T BE IN LINKAGE SECTION.
AECK2 CLHE17,558 ;CAN'T BE IN FILE SECTION.
AECK2 CLHE18,559 ;CAN'T BE JUSTIFIED.
AECK2 CLHE19,560 ;CAN'T BE EDITED.
AECK2 CLHE20,561 ;CAN'T BE SUBSRCRIPTED.
AECK2 CLHE21,562 ;BLANK WHEN ZERO NOT ALLOWED.
AECK2 CLHE22,563 ;CAN'T BE SIGNED.
AECK2 CLHE23,564 ;IT ISN'T DATAB!!!
;PUT OUT AN ERROR MSG.
CLHE30: HRRZ TA, CURHLD ;GET THE HLDTAB ENTRY.
LDB LN, HL.LN## ;SET UP FOR ERROR.
LDB CP, HL.CP##
PUSHJ PP, FATAL## ;FATAL ERROR.
POP PP, TA ;GET FILE TABLE LOC BACK.
SETZ TB, ;CLEAR THE LINK IN FILTAB.
DPB TB, TBLOCK
JRST CLNHL9 ;AND GO LOOK FOR MORE.
CLHE41: MOVEI DW,E.827
TRNA ;SAME ACTION AS CLHE40
CLHE40: HRRZI DW,E.723
HRRZ TA,CURHLD ;GET THE HLDTAB ENTRY.
LDB LN,HL.LN## ;SET UP FOR ERROR.
LDB CP,HL.CP##
PJRST WARN##
CLHE43: HRRZI DW,E.792 ;RMS REL KEY NOT > 10 DIGITS
TRNA ;
CLHE42: HRRZI DW,E.755 ;RELATIVE KEY IN RECORD
HRRZ TA,CURFIL
LDB LN,FI.LN## ;POINT TO THE "SELECT"
LDB CP,FI.CP##
JRST FATAL##
;MAKE INDEX ENTRY IN DATAB & LINK ITEM INDEXED TO IT
CLHIDX: LDB TB,HL.NAM## ;STASH HLDTAB INFO IN TBLOCK
MOVEM TB,TBLOCK ;NAMTAB LINK OF INDEX
LDB TB,HL.LNK
MOVEM TB,TBLOCK+1 ;DATAB LINK OF INDEXED ITEM
LDB TB,HL.LNC##
MOVEM TB,TBLOCK+2 ;LINE&CHAR POS. OF INDEX
HRRZ TA,TBLOCK ;LOOK FOR ITEM ALREADY IN DATAB
HRRZI TB,CD.DAT
PUSHJ PP,FNDLNK##
JRST CLHID2 ;NONE -- MAKE ONE
HRRZI TA,(TB) ;GET DATAB LINK
HLRM TB,TBLOCK+4 ;SAVE A COPY
LDB TB,DA.IDX## ;IS THIS AN INDEX?
JUMPN TB,CLHID3 ;[770] YES
HRRZI DW,E.297 ;ILLEGAL INDEX
LDB LN,[POINT 13,TBLOCK+2,28]
LDB CP,[POINT 7,TBLOCK+2,35]
PUSHJ PP,FATAL##
MOVEI TB,1 ;[770] GET A DUMMY DATA ITEM
HRRZ TA,CURHLD ;[770] CHANGE NAMTAB LINK OF INDEX ITEM
DPB TB,HL.NAM ;[770] IN HLDTAB TO DATAB LINK
JRST CLNHL9
CLHID2: MOVE TA,[XWD CD.DAT,SZ.DAT] ;MAKE INDEX
PUSHJ PP,GETENT
HLRZM TA,TBLOCK+4 ;SAVE LINK TO INDEX
MOVE TB,TBLOCK ;GET NAMTAB LINK OF INDEX
DPB TB,DA.NAM
HRRZI TB,CD.DAT
DPB TB,[POINT 3,(TA),2]
HRRZI TB,LVL.77
DPB TB,DA.LVL
HRRZI TB,%CL.NU
DPB TB,DA.CLA##
HRRZI TB,5
DPB TB,DA.INS
DPB TB,DA.EXS
SETO TB,
DPB TB,DA.SGN
DPB TB,DA.PIC
DPB TB,DA.IDX ;SET INDEX BIT
HRRZI TB,%US.IN
DPB TB,DA.USG##
MOVE TB,TBLOCK+2 ;SAVE LINE & CHAR POS.
DPB TB,DA.LNC
HRRZ TB,EAS1PC ;ALLOCATE WORD IN AS1FIL FOR INDEX
DPB TB,DA.LOC
HRRZI TB,44
DPB TB,DA.RES
SETO TB,
DPB TB,DA.DEF
AOS EAS1PC
LDB TB,DA.NAM
HRRI TA,(TB)
PUSHJ PP,PUTLNK##
CLHID3: HRRZ TA,CURHLD ;CHANGE NAMTAB LINK OF INDEX ITEM
MOVE TB,TBLOCK+4 ; IN HLDTAB TO DATAB LINK
DPB TB,HL.NAM
JRST CLNHL9
CLHVID: MOVEM TA,TBLOCK+1 ;[152] SAVE STORAGE PTR
SKIPE TBLOCK+4 ;UNDEFINED?
JRST CLHVIX ;YES
PUSHJ PP,CLHSUB ;GET USAGE OF DATA ITEM
CAIE TB,%%US ;USAGE MUST BE DISPLAY
CAILE TB,%US.DS
PUSHJ PP,CLHBAD ;WRONG USAGE
IFE TOPS20,<
CAILE TC,^D17 ;UPTO 17 CHARS FOR A MAGTAPE LABEL
PUSHJ PP,CLHSIZ ;TOO BIG
>
IFN TOPS20,<
CAILE TC,377 ;UPTO 255 CHARS FOR LONG FILE NAME
PUSHJ PP,CLHSIZ ;TOO BIG
>
MOVE TA,TBLOCK+1 ;GET BACK STORAGE PTR
DPB TC,FI.SID## ;SAVE SIZE FOR RUN-TIME
CLHVIX: MOVE TC,FI.VID## ;VAL-OF-ID PTR
JRST CLNSTO
CLHVDW: MOVEM TA,TBLOCK+1 ;[152] SAVE STORAGE PTR
SKIPE TBLOCK+4 ;UNDEFINED?
JRST CLHVDX ;YES
PUSHJ PP,CLHSUB ;GET USAGE OF DATA ITEM
CAIE TB,%%US ;MUST BE DISPLAY
CAILE TB,%US.DS ;SKIP IF IT IS
PUSHJ PP,CLHBAD ;WRONG USAGE
CAIE TC,6 ;6 DIGITS?
PUSHJ PP,CLHSIZ ;NO
CLHVDX: MOVE TC,FI.VDW## ;VAL-OF-DATE-WRITTEN PTR
JRST CLNSTO
CLHVPR: MOVEM TA,TBLOCK+1 ;SAVE STORAGE PTR
SKIPE TBLOCK+4 ;UNDEFINED?
JRST CLHVRX ;YES
PUSHJ PP,CLHSUB ;GET USAGE OF DATA ITEM
CAIE TB,%US.1C ;1-WORD COMP?
PUSHJ PP,CLHBAD ;NO
CAILE TC,^D10 ;10 DIGITS OR LESS?
PUSHJ PP,CLHSIZ ;NO
CLHVRX: MOVE TC,FI.PRT## ;VAL-OF-PROTECTION-CODE PTR
JRST CLNSTO
CLHVPP: MOVEM TA,TBLOCK+1 ;[152] SAVE STORAGE PTR
SKIPE TBLOCK+4 ;UNDEFINED?
JRST CLHVPX ;YES
PUSHJ PP,CLHSUB ;GET USAGE OF DATA ITEM
CAIE TB,%US.1C ;1-WORD COMP?
PUSHJ PP,CLHBAD ;NO
CAILE TC,^D10 ;10 DIGITS OR LESS?
PUSHJ PP,CLHSIZ ;NO
CLHVPX: MOVE TC,FI.VPP## ;VAL-OF-PROJ-PROG PTR
CLNSTO: MOVE TA,TBLOCK+1 ;GET BACK STORAGE PTR
CLNST1: LDB TB,TC ;SEE IF ITEM ALREADY STORED
JUMPE TB,CLNST2
PUSHJ PP,CLHDUP ;YES, DUPLICATE CLAUSE
CLNST2: DPB TE,TC ;NO, STORE ITEM
JRST CLNHL9 ;GO BACK FOR NEXT HLDTAB ENTRY
CLHSUB: MOVEM TA,TBLOCK+1 ;SAVE STORAGE PTR
HRRZ TA,CURHLD ;[162] GET HLDTAB CODE
LDB TC,HL.COD ;[162] TO TC
MOVE TA,TE ;GET ITEM DATAB LINK
ANDI TA,77777 ;MAKE DATAB PTR
ADD TA,DATLOC##
LDB TB,DA.LKS## ;[162] GET LINKAGE SECTION FLAG
CAIE TC,%HL.SY ;[162] IF FLAG ON AND CODE IS SYM-KEY
CAIGE TC,%HL.DP ;[162] ACT-KEY, FIL-LIM, VAL-OF-ID, DW OR PPN
JUMPN TB,CLHLER ;[162] GIVE ERROR MESSAGE
CLHSU2: LDB TB,DA.USG ;[162] GET USAGE
LDB TC,DA.EXS ;& SIZE
POPJ PP,
CLHLER: PUSH PP,TA ;[162] SAVE DATAB PTR
HRRZI DW,E.493 ;[162] NOT ALLOWED IN LINKAGE SECT.
PUSHJ PP,CLHBA1 ;[162] COMPLAIN
POP PP,TA ;[162] RESTORE
JRST CLHSU2 ;[162] CONTINUE
CLHBAD: HRRZI DW,E.373 ;WRONG USAGE
CLHBA1:
PUSH PP,TA ;[164] SAVE DATA-POINTER
HRRZ TA,CURHLD ;HLDTAB ADDR
LDB LN,HL.LN## ;GET LINE POSITION
LDB CP,HL.CP##
PUSHJ PP,FATAL ;GIVE ERROR MESSAGE
MOVEI TE,<CD.DAT>B20+1 ;AIM AT DUMMY DATAB ENTRY
POP PP,TA ;[164] RESTORE DATA-POINTER
POPJ PP,
CLHDUP: HRRZI DW,E.16 ;DUPLICATE CLAUSE MESSAGE
JRST CLHBA1
CLHSIZ: HRRZI DW,E.340 ;WRONG SIZE
JRST CLHBA1
CLE264: HRRZI DW,E.264 ;WRONG CLASS
JRST CLHBA1
CLE275: HRRZI DW,E.275 ;[164] NO SUBSCRIPTING ALLOWED
JRST CLHBA1 ;[164]
CLNFIL:
IFE TOPS20,<
MOVE TA,AS2BUF## ;SET
MOVEM TA,.JBFF## ; UP
OUTBUF AS2,2 ; AS2FIL
>
MOVE TA,FILLOC
CAMN TA,FILNXT##
JRST CLNCON ;CLEAN UP CONTAB LITERALS
HRRZI TA,CD.FIL*1B20+1
CLNC: HRLZM TA,CURFIL##
PUSHJ PP,LNKSET
HRRM TA,CURFIL
LDB TB,FI.DRL ;ANY DATA RECORD?
JUMPN TB,CLNC0 ;YES
LDB TB,FI.RPG## ;NO - REPORT FILE?
JUMPN TB,CLNCRP ;YES
MOVEI TB,<CD.DAT>B20+1 ;NO, AIM AT DUMMY ENTRY
DPB TB,FI.DRL
LDB TB,FI.FDD## ;IS THERE ANY FD?
JUMPE TB,CLNC0 ;NO, THAT'S WHY WE DIDN'T FIND A DATA RECORD.
; DON'T GIVE THIS ERROR AND THAT ONE TOO.
HRRZI DW,E.38 ;?NO DATA RECORD
LDB LN,FI.FLN## ;POINT TO FD
LDB CP,FI.FCP##
PUSHJ PP,FATAL
JRST CLNC0 ;CONTINUE
CLNCRP:
PUSHJ PP,RPWNAM ;MAKE A NAME FOR REPORT RECORD
MOVE TA,[CD.DAT,,SZ.DAT]
PUSHJ PP,GETENT
MOVEI TB,%US.D7 ;DISPLAY-7 USAGE IN CORE
DPB TB,DA.USG
MOVEI TB,^D132 ;RECORD SIZE = 132 CHARS.
DPB TB,DA.INS
DPB TB,DA.EXS
MOVEI TB,^D36 ;BYTE RESIDUE
DPB TB,DA.RES
MOVEI TB,1 ;LEVEL 01
DPB TB,DA.LVL
DPB TB,DA.PIC ;SAY PIC SEEN
DPB TB,DA.DFS## ;DEFINED IN FILE SECTION
DPB TB,DA.DRC## ;DATA RECORD
DPB TB,DA.DEF ;SAY DEFINED
DPB TB,DA.FAK ;SAY FAKE NAME
DPB TB,DA.FAL## ;SET FATHER LINK BIT (FILE IS FATHER)
HLRZ TB,NAMADR ;STORE NAMTAB LINK TO DATA ENTRY
DPB TB,DA.NAM
MOVEI TB,%CL.AN ;ALPHANUMERIC CLASS
DPB TB,DA.CLA
HLRZ TB,CURFIL ;FILE = FATHER LINK
DPB TB,DA.BRO##
HRRZ TB,NAMADR ;PUT LINK TO DATA ENTRY IN NAMTAB
HLRM TA,(TB)
MOVS TC,TA ;LINK FILE TO NEW DATA RECORD
HRRZ TA,CURFIL
DPB TC,FI.DRL
MOVEI TB,^D132 ;RECORD SIZE
DPB TB,FI.MRS##
MOVEI TB,%RM.7B ;ASCII RECORDING MODE
DPB TB,FI.ERM##
DPB TB,FI.IRM##
MOVEI TB,1 ;RECORDING MODE DECLARED
DPB TB,FI.RM2##
LDB TB,FI.LNC## ;GET FILE DEFINITION LINE POSITION
MOVS TA,TC ;GET BACK PTR TO DATAB ENTRY
DPB TB,DA.LNC ;RECORD DEFN POSITION = FILE DEF. POS.
CLNC0: HRRZ TA,CURFIL
;SET DEFAULT ACCESS MODE
; THIS WILL INSURE THAT ALL CODE GENERATION AND PHASE D PROCESSING
;TREATS UNSPECIFIED ACCESS MODE AS IF THE USER HAD SAID "ACCESS MODE
;IS SEQUENTIAL".
LDB TB,FI.FAM## ;FILE ACCESS MODE
CAIE TB,%FAM.U ;UNSPECIFIED?
JRST .+3 ;NO, USE VALUE GIVEN
MOVEI TB,%FAM.S ; DEFAULT TO SEQUENTIAL ALWAYS
DPB TB,FI.FAM##
; NOW CHECK FOR MISSING "ORGANIZATION" CLAUSE. THIS WILL DEFAULT
;TO SEQUENTIAL, UNLESS WE CAN GUESS THAT THE USER MEANT SOMETHING ELSE.
;IF HE SPECIFIED ALTERNATE KEYS WE WILL COMPLAIN AND SET THE ORGANIZATION TO "INDEXED".
LDB TB,FI.ORG ;GET ORGANIZATION
CAIE TB,%%ACC ;UNSPECIFIED?
JRST CLNC0B ;NO, TEST FOR CONFUSED USER
LDB TC,FI.AKS## ;WERE ALTERNATE KEYS SPECIFIED?
JUMPN TC,CLNC0A ;YES, GIVE WARNING & SET TO "INDEXED"
LDB TC,FI.RKY ;DO WE HAVE A RECORD KEY?
JUMPN TC,CLNC0I ;YES, THEN ASSUME "INDEXED"
LDB TC,FI.ACK ;DO WE HAVE A RELATIVE KEY?
JUMPN TC,CLNC0R ;YES, THEN ASSUME "RELATIVE"
LDB TC,FI.FAM ;GET FILE ACCESS MODE
CAIN TC,%FAM.S ;SEQUENTIAL?
JRST CLNC0S ;YES, MAKE ORGANIZATION SEQUENTIAL
MOVEI DW,E.205 ;MUST BE REL OR INDEX ORG
MOVEI TB,%ACC.S ;BUT MAKE IT SEQUENTIAL SINCE WE DON'T KNOW WHICH
JRST CLNC0E
CLNC0B: LDB TC,FI.RKY ;IF WE HAVE A RECORD KEY
CAIE TB,%ACC.I ;THEN ORGANIZATION MUST BE INDEXED
JUMPN TC,CLNC0C ;ERROR
LDB TC,FI.ACK ;SIMILARLY, IF WE HAVE A RELATIVE KEY
CAIE TB,%ACC.R ;THEN ORGANIZATION MUST BE RELATIVE
JUMPN TC,CLNC0D ;ERROR
JRST CLNC1 ;OK
CLNC0C: SKIPA DW,[E.744] ;NOT INDEXED FILE ERROR
CLNC0D: MOVEI DW,E.743 ;NOT RELATIVE FILE ERROR
JRST CLNC0F ;GIVE ERROR ONLY
CLNC0R: MOVEI DW,E.743 ;MUST BE RELATIVE IF RECORD KEY SEEN
MOVEI TB,%ACC.R ;SET IT
JRST CLNC0E
CLNC0A: SKIPA DW,[E.736] ;ALTERNATE KEYS ONLY ALLOWED WITH INDEXED FILES
CLNC0I: MOVEI DW,E.744 ;MUST BE INDEXED IF RECORD KEY SEEN
MOVEI TB,%ACC.I ;SET TO DEFAULT "INDEXED"
CLNC0E: DPB TB,FI.ORG##
CLNC0F: LDB LN,FI.LN## ;POINT TO "SELECT" CLAUSE
LDB CP,FI.CP##
PUSHJ PP,FATAL ;PRESERVES TA
JRST CLNC1
CLNC0S: MOVEI TB,%ACC.S ;SET TO DEFAULT "SEQUENTIAL"
DPB TB,FI.ORG
CLNC1:
LDB TB,FI.NDV## ;NUMBER OF DEVICES
JUMPLE TB,PFL ;NONE
MOVEM TB,NDEV##
SETZM (SAVPTR) ;CLR FLAG
CAIE TB,1 ;ONLY ONE DEVICE NAMED?
JRST CLNC2 ;NO, FORGET THIS STUFF
LDB TC,FI.ORG## ;INDEXED?
CAIE TC,%ACC.I
JRST CLNC2 ;NO
SETOM (SAVPTR) ;YES, SET FLAG
DPB TC,FI.NDV ;SAY 2 DEVICES
CLNC2: LDB TB,FI.VAL##
JUMPE TB,PFL ;LINK IS NULL
HRLZM TB,CURVAL##
HRRZ TA,TB
PUSHJ PP,LNKSET
HRRM TA,CURVAL
PUSHJ PP,GETTAG##
HRRZ TA,CURFIL
DPB CH,FI.VAL
PUSHJ PP,PUTTAG
MOVE TA,CURVAL ;SAVE CURVAL IN CASE WE NEED SAME DEV TWICE
MOVEM TA,1(SAVPTR)
PDEV: PUSHJ PP,PV.SXB
AOSE (SAVPTR) ;INDEXED FILE WITH ONLY ONE DEVICE?
JRST PDEV2 ;NO
MOVE TA,1(SAVPTR) ;YES, REPEAT SAME DEVICE
MOVEM TA,CURVAL
JRST PDEV
PDEV2: SOSLE NDEV
JRST PDEV
HRRZ TA,CURFIL
PFL:
;HERE FOR LINAGE-COUNTER
PLC: LDB TB,FI.LCP##
JUMPE TB,CHID ;NO LINAGE-COUNTER FOR THIS FILE
MOVE TB,[[SIXBIT /LINAGE:COUNTER/],,NAMWRD##]
BLT TB,NAMWRD+2
SETZM NAMWRD+3
SETZM NAMWRD+4 ;SETUP NAME
PUSHJ PP,TRYNAM##
HALT ;MUST BE THERE!
MOVE TB,(TA) ;GET TYPE
HLLZ TA,TA ;ASSUME FIRST TIME
TLO TA,AS.DAT## ;TURN ON DATAB BIT
PUSH PP,TA ;SAVE POINTER TO NAMTAB
TLNN TB,NAMRSV/1000000 ;FIRST TIME = RESERVED WORD
HRRM TB,0(PP) ;NO, SAVE CURRENT DATAB
MOVE TA,[CD.DAT,,SZ.DAT+SZ.DOC+SZ.MSK]
PUSHJ PP,GETENT ;GET SPACE FOR IT
POP PP,(TA) ;SAVE POINTER TO NAMTAB
HLRZ TB,CURFIL ;GET PTR. TO FILTAB
DPB TB,DA.POP
MOVEI TB,%US.1C ;MAKE IT 1-WORD COMP
DPB TB,DA.USG
MOVEI TB,%CL.NU ;AND NUMERIC
DPB TB,DA.CLA
SETO TB,
DPB TB,DA.FAL ;LINK IS TO FATHER
DPB TB,DA.DEF ;DEFINED
MOVEI TB,^D10 ;MAX. SIZE
DPB TB,DA.EXS ;EXTERNAL SIZE
DPB TB,DA.INS ;INTERNAL SIZE
PUSH PP,TA ;SAVE LINK
PUSHJ PP,TRYNAM ;GET NAME LINK AGAIN
JFCL
POP PP,TB
HLRZM TB,(TA) ;CHANGE TO DATAB ENTRY
HRRZ TA,CURFIL
HLRZ TB,TB
DPB TB,FI.LCP ;MAKE FILE POINT TO DATAB
;CHECK VALUE OF ID
CHID: HRRZ TA,CURFIL
LDB TB,FI.VID
JUMPE TB,CHID2 ;NO VALUE-OF-ID
LDB TC,[POINT 3,TB,20]
CAIE TC,CD.VAL
JRST CHID.1 ;NOT A LITERAL
HRLZM TB,CURVAL
HRRZ TA,TB
PUSHJ PP,LNKSET
HRRM TA,CURVAL
PUSHJ PP,GETTAG
HRRZ TA,CURFIL
DPB CH,FI.VID
PUSHJ PP,PUTTAG
IFE TOPS20,<
PUSHJ PP,PV.SXB
>
IFN TOPS20,<
PUSHJ PP,PV.ASC ;PUT OUT FULL ASCII STRING
SKIPE CTRREM## ;IF REM 0 WE NEED EXTRA WORD OF 0 TO FINISH ASCIZ STRING
JRST CHID2 ; ALL SET AS IS
MOVE CH,[AS.OCT,,1] ;SET UP AS OCTAL WORD
PUSHJ PP,PUTAS2
AOS EAS2PC## ;ADVANCE STARTING PC FOR AS2 FILE
HRRZI CH,0 ;STUFF THE BINARY 0
PUSHJ PP,PUTAS2 ;
>
JRST CHID2
CHID.1: CAIE TC,CD.DAT
JRST CHID2
HRRZI TA,(TB)
PUSHJ PP,LNKSET
LDB TB,DA.DEF
JUMPE TB,CHID2 ;[270] NOT DEFINED
LDB TB,DA.USG
CAIE TB,%%US ;CHECK FOR LEGAL DISPLAY USAGE
CAILE TB,%US.DS ;SKIP IF SOME KIND OF DISPLAY..
JRST CHIDE2 ;NO, GIVE ERROR
CHID.3: LDB TB,DA.EXS
IFE TOPS20,<
CAIG TC,^D17 ;UPTO 17 CHARS FOR A MAGTAPE LABEL
JRST CHID2 ;OK, GO CHECK VALUE OF PROJ-PROG
>
IFN TOPS20,<
CAIG TC,377 ;UPTO 255 CHARS FOR LONG FILE NAME
JRST CHID2 ;OK, GO CHECK VALUE OF PROJ-PROG
>
;VALUE-OF-ID WAS NOT A DISPLAY ITEM 9 CHARACTERS IN LENGTH
CHIDE2: HRRZI DW,E.62
PUSHJ PP,FATALE
;CHECK VALUE OF PROJ-PROG
CHID2: HRRZ TA,CURFIL
LDB TB,FI.VPP
JUMPE TB,CHID3 ;NONE SPECIFIED
LDB TC,[POINT 3,TB,20]
CAIE TC,CD.VAL
JRST CHID.5 ;NOT A LITERAL
HRLZM TB,CURVAL
HRRZI TA,(TB)
PUSHJ PP,LNKSET
HRRM TA,CURVAL
CHID.6: PUSHJ PP,GETTAG
HRRZ TA,CURFIL
DPB CH,FI.VPP
PUSHJ PP,PUTTAG
MOVE CH,[AS.XWD##,,1]
PUSHJ PP,PUTAS2##
AOS EAS2PC##
PUSHJ PP,PUTOCT
PUSHJ PP,PUTOCT
JRST CHID3
CHID.5: CAIE TC,CD.DAT
JRST CHID3
HRRZI TA,(TB)
PUSHJ PP,LNKSET
LDB TB,DA.USG
CAIN TB,%US.1C
JRST CHID3
HRRZI DW,E.366 ;?PPN MUST BE 1-WORD COMP
HRRZ TA,CURFIL
LDB LN,FI.LN##
LDB CP,FI.CP## ;[270] MAKE SOURCE CHAR POS EXT
PUSHJ PP,WARN##
JRST CHID.6
;CHECK VALUE OF DATE-WRITTEN
CHID3: HRRZ TA,CURFIL
LDB TB,FI.VDW
JUMPE TB,CHID4 ;NO VALUE-OF-DATE-WRITTEN
LDB TC,[POINT 3,TB,20]
CAIE TC,CD.VAL
JRST CHID4 ;NOT A LITERAL
HRLZM TB,CURVAL
HRRZ TA,TB
PUSHJ PP,LNKSET
HRRM TA,CURVAL
LDB TB,[POINT 7,(TA),6]
CAIN TB,6 ;SKIP IF NOT SIX CHARACTERS
JRST CH2.1
CAILE TB,6 ;IF LESS THAN SIX,
HRRZI TB,6 ;PRETEND IT IS SIX
DPB TB,[POINT 7,(TA),6]
HRRZI DW,E.63
HRRZ TA,CURFIL
LDB LN,FI.LN
LDB CP,FI.CP
PUSHJ PP,WARN
CH2.1: PUSHJ PP,GETTAG
HRRZ TA,CURFIL
DPB CH,FI.VDW
PUSHJ PP,PUTTAG
PUSHJ PP,PV.SXB
;CHECK VALUE OF PROTECTION CODE
CHID4: HRRZ TA,CURFIL
LDB TB,FI.PRT
JUMPE TB,CHID5 ;NO VALUE-OF-PROTECTION-CODE
LDB TC,[POINT 3,TB,20]
CAIE TC,CD.VAL
JRST CH4.2 ;NOT A LITERAL
HRLZM TB,CURVAL
HRRZI TA,(TB)
PUSHJ PP,LNKSET
HRRM TA,CURVAL
CH4.1: PUSHJ PP,GETTAG
HRRZ TA,CURFIL
DPB CH,FI.PRT
PUSHJ PP,PUTTAG
MOVE CH,[AS.XWD,,1] ;SHOULD USE AS.OCT BUT THIS IS EASIER
PUSHJ PP,PUTAS2##
AOS EAS2PC##
SETZ CH,
PUSHJ PP,PUTAS2
PUSHJ PP,PUTOCT
JRST CHID5
CH4.2: CAIE TC,CD.DAT
JRST CHID5
HRRZI TA,(TB)
PUSHJ PP,LNKSET
LDB TB,DA.USG
CAIN TB,%US.1C
JRST CHID5
HRRZI DW,E.366 ;PROTECTION-CODE MUST BE 1-WORD COMP
HRRZ TA,CURFIL
LDB LN,FI.LN##
LDB CP,FI.CP## ;[270] MAKE SOURCE CHAR POS EXT
PUSHJ PP,WARN##
JRST CH4.1
;CHECK FOR PADDING CHARACTER
CHID5: HRRZ TA,CURFIL
LDB TB,FI.PAD##
CAIG TB,777 ;IF BIGGER THAN 7 BITS ITS A NAMTAB LINK
JRST CHDATS ;ZERO OR LITERAL
HRRZ TA,NAMLOC
ADD TA,TB
HRRZ TB,(TA) ;GET LINK
HRRZ TA,CURFIL
DPB TB,FI.PAD ;ASSUME ITS OK
MOVE TA,TB
LDB TB,[POINT 3,TA,20]
CAIE TB,TB.DAT##
JRST CH5.1 ;ITS NOT
PUSHJ PP,LNKSET
LDB TB,DA.INS
SOJN TB,CH5.1 ;MUST BE 1 CHAR.
LDB TB,DA.CLA
CAIE TB,%CL.NU ;AND NON-NUMERIC
JRST CHDATS
CH5.1: MOVEI DW,E.823
LDB LN,DA.LN
LDB CP,DA.CP
PUSHJ PP,FATAL
HRRZ TA,CURFIL
SETZ TB,
DPB TB,FI.PAD ;TO AVOID ERRORS LATER
;CHECK TO INSURE ALL RECORDS FOR THIS FILE ARE < 4096 CHARACTERS
;AND THAT OCCURS DOES NOT APPEAR AT 01 LEVEL
CHDATS: SETZM RUSAGE## ;CLEAR USAGE FLAG
HRRZ TA,CURFIL ;GET ADDRESS OF FILTAB ENTRY
LDB TA,FI.DRL## ;GET RECORD LINK
JUMPE TA,CLNKYS ;IF ZERO--FORGET IT
CHDA.1: PUSHJ PP,LNKSET ;GET RECORD ADDRESS
MOVEM TA,CURDAT ;[1502] SAVE OFFSET
LDB TE,DA.USG ;GET USAGE OF RECORD
CAIE TE,%US.D7 ;DISPLAY-7?
HRRZI TE,%US.D6 ;NO, ASSUME DISPLAY-6
SKIPN RUSAGE ;SEEN 1ST RECORD BEFORE THIS?
MOVEM TE,RUSAGE ;NO, SAVE USAGE OF 1ST
CAMN TE,RUSAGE ;YES, THIS USAGE CONFLICT WITH 1ST RECORD?
JRST CHDA.5 ;[1502] NO
MOVEI DW,E.33 ;YES, ERROR
HRRM TA,CURDAT ;SAVE DATAB PTR
HRRZ TA,CURFIL ;GET FILTAB PTR
LDB LN,FI.LN
LDB CP,FI.CP
PUSHJ PP,FATAL
HRRZ TA,CURDAT ;GET BACK DATAB PTR
CHDA.5: LDB TE,DA.EXS ;[1502] GET EXTERNAL SIZE
CAIG TE,MAXFSS## ;GREATER THAN LARGEST ALLOWED SIZE?
JRST CHDA.4 ;[1502] NO
MOVEI DW,E.322 ;YES
PUSHJ PP,FATALE ; PUT OUT DIAGNOSTIC
JRST CHDA.3 ;[1502]
CHDA.4: HRRZ TA,CURFIL ;[1502]
LDB TD,FI.MRS ;[1502] GET MAX RECORD SIZE
LDB TB,FI.VRS## ;[1605] 'VARYING' SYNTAX?
LDB TC,FI.RCN## ;[1620] 'REC CNT nn TO nn' SYNTAX?
HRRZ TA,CURDAT ;[1502] RESTORE HERE
JUMPG TB,CHDA.3 ;[1605] IF RECORD IS 'VARYING' IGNORE FI.MRS
JUMPN TC,CHDA.3 ;[1620] IF "TO nn" IGNORE IT TOO
CAML TE,TD ;[1502] IS CURRENT 01 LEVEL SMALLER
JRST CHDA.3 ;[1502] THAN MAX FOUND?
MOVEI DW,E.670 ;[1502] YES, GIVE WARNING
LDB LN,DA.LN ;[1502] SET UP LINE NBR
LDB CP,DA.CP ;[1502] AND CHARACTER POSITION
PUSHJ PP,WARN ;[1502]
CHDA.3: LDB TE,DA.OCC## ;OCCURS AT 01 LEVEL?
JUMPE TE,CHDA.2 ;NO
MOVEI DW,E.325 ;YES, FLAG IT
PUSHJ PP,FATALE
CHDA.2: LDB TE,DA.FAL ;IS BROTHER/FATHER LINK
JUMPN TE,CLNKYS ; A FATHER?
LDB TA,DA.BRO ;NO--LOOK AT NEXT RECORD
JUMPN TA,CHDA.1
CLNKYS:
;FOR THE KEY INFO FOR RMS FILES, SET UP A CONSTANT BLOCK UNDER START.:
;THIS BLOCK WILL CONTAIN THE SAME INFO ON KEY POS AND BYTE COUNT THAT
;WAS CONTAINED IN %LIT00 FOR THESE KEYS IN V12B. IT HAS TO BE MOVED TO
;HERE TO ACCOMODATE THE FILE OPEN PROCEDURES FOR SMU FILES.
;FIND OUT IF WE ARE DOING RMS INDEXED OR RELATIVE FILES
HRRZ TA,CURFIL ;GET PTR TO CURRENT FILE TABLE
LDB TB,FI.RMS## ;DOING AN RMS FILE?
JUMPE TB,CLNCUP ; NO
LDB TB,FI.ORG## ;IS IT INDEXED OR RELATIVE?
CAIN TB,%ACC.S ;
JRST CLNCUP ; NO
;INSERT LOCATION OF RMS INDEXED KEY INFO INTO WORD IN FILE TABLE.
PUSHJ PP,GETTAG ;GET A %N TAG
HRRZ TA,CURFIL
DPB CH,FI.RKL## ; AND RECORD IT IN THE FILE TABLE
PUSHJ PP,PUTTAG ;ALSO PUT IT UNDER START.
;GET KEY INFO AND STUFF IT OUT TO BLOCK IN CONSTANT AREA.
PUSHJ PP,KYPTR ;PUT RMS KEY INFO OUT TO AS2FIL
;END OF STUFF FOR STORING RMS INDEXED KEY INFO
CLNCUP: HRRZ TA,CURFIL
LDB TA,FI.NXT##
JUMPN TA,CLNC ;NEXT FILE TABLE
CLNCON: MOVE TA,CONLOC##
CAMN TA,CONNXT##
POPJ PP,
HRRZI TA,CD.CON*1B20+1
HRLZM TA,CURCON##
PUSHJ PP,LNKSET
C0.: HRRM TA,CURCON
LDB TB,CO.NVL
LDB TA,CO.DAT##
LSH TB,1
HRRZM TB,TBLOCK+1
JUMPE TA,C3.
CAIN TA,CD.DAT*1B20+1 ;[644] TEST FOR DUMMY DATAB ENTRY
JRST C3B. ;[1066] [644] WHICH IS SET IF ERROR IN 01 LEVEL
JUMPE TB,C3. ;[454] IF NO LITERAL ENTRIES DUE TO ERROR GO ON
HRLZM TA,CURDAT
PUSHJ PP,LNKSET
HRRM TA,CURDAT
LDB LN,DA.LN ;PREPARE TO POINT TO THE DATA ITEM (NOT
LDB CP,DA.CP ; THE LEVEL 88 ITEM) IF ERRORS FOUND
MOVE TE,[POINT 18,SZ.CON(TA)]
MOVEM TE,PNTS##
C1.: HRRZ TA,CURCON
ILDB TA,PNTS ;GET ADDRESS OF LITTAB ENTRY
ANDI TA,077777 ;JUST GET OFFSET
JUMPE TA,C2. ;?MUST BE NON-ZERO,
; ENTRY IS SCREWED UP, FORGET IT
IORI TA,CD.LIT*1B20 ;LOOK AT LITAB ENTRY
HRLZM TA,CURLIT
PUSHJ PP,LNKSET
HRRM TA,CURLIT ;CURLIT SET UP TO POINT TO LITAB ENTRY
;31-DEC-80 /DAW: There is a check that should be made here at some later
; date. Now, there is one user error that gets through undiagnosed:
; If there is a group item usage INDEX, and a subordinate item has 88 level
; items with value clauses, they were not checked for the correct
; class in COBOLC since the class had not been determined yet at that
; point (see edit 1106 in COBOLC).
; What should be done is to check the consistancy of the item's usage
;now, and if it is not consistant, and a father of the item is usage
;INDEX, then DIAG 241 or 236 should be given and should point to
;the value literal for the each 88 item in error. Note this requires
;that CONTAB or LITAB be expanded to contain the LN and CP of the clause.
PUSHJ PP,ADJUST ;CREATE LITERAL OF PROPER SIZE FOR ITEM
HRRZ TA,CURLIT
LDB TB,LI.FGC
JUMPE TB,C1.5
LDB TC,LI.FCC
HRRZ TA,CURCON
LDB TB,PNTS
ANDI TB,400000
TRO TB,200000
CAIN TC,SPACE.
TRO TB,040000
CAIN TC,ZERO.
TRO TB,20000
CAIN TC,QUOTE.
TRO TB,10000
CAIN TC,HIVAL.
TRO TB,4000
CAIN TC,LOVAL.
TRO TB,2000
DPB TB,PNTS
JRST C2.
C1.5: PUSHJ PP,GETTAG
HRRZ TA,CURCON
LDB TB,PNTS
ANDI TB,7B20
HRRZI TC,(CH)
ANDI TC,077777
IORI TB,(TC)
DPB TB,PNTS
PUSHJ PP,PUTTAG
PUSHJ PP,PUTLIT
C2.: SOSLE TBLOCK+1
JRST C1.
C3.: HRRZ TA,CURCON
LDB TB,CO.NVL##
C3A.: ADDI TA,SZ.CON(TB) ;[1066] NEW LABEL
HRRZ TC,CONNXT
CAIG TA,(TC) ;SKIP IF WE ARE DONE ALL ENTRIES IN CONTAB
JRST C0.
POPJ PP,
;[1066] THIS PREVENTS "?ILL MEM REF" IN PHASE E, BY TELLING
;[1066] IFCGEN THAT THERE ARE NO "VALUE" ITEMS (ACTUALLY THERE
;[1066] ARE, BUT THE CONVERSION CODE ABOVE DID NOT GET EXECUTED
;[1066] SO THE CONTAB ENTRY WOULD BE MESSED UP). NO CODE GENERATION
;[1066] IS THEN ATTEMPTED.
C3B.: HRRZ TA,CURCON ;[1066]
LDB TB,CO.NVL## ;[1066] NUMBER OF WORDS TO FOLLOW
SETZ TC, ;[1066] SET NUMBER OF VALUE ITEMS TO 0
DPB TC,CO.NVL## ;[1066] SO PHASE E KNOWS THIS IS A BOGUS ENTRY
JRST C3A. ;[1066] GO ON TO NEXT CONTAB ENTRY
PUTLIT: HRRZ TA,CURDAT
LDB TB,DA.USG
JRST .+1(TB)
POPJ PP,
JRST PTLDSP ;DISPLAY-6
JRST PTLDSP ;DISPLAY-7
JRST PTLDSP ;DISPLAY-9
JRST PTL1WC ;1-WORD COMP
JRST PTL2WC ;2-WORD COMP
JRST PTLC1 ;COMP-1
JRST PTL1WC ;INDEX
JRST PTLDSP ;COMP-3 (PRETEND IT'S DISPLAY-9)
JRST PTLC2 ;COMP-2
;MAKE SURE THE ABOVE TABLE DOESN'T GET MESSED UP.
N==<%%US>!<%US.D6-1>!<%US.D7-2>!<%US.EB-3>!<%US.1C-4>
N==N!<%US.2C-5>!<%US.C1-6>!<%US.IN-7>!<%US.C3-10>!<%US.C2-11>
IFN N,<
PRINTX %PUTLIT - TABLE IS MESSED UP.
>
PTL1WC: MOVE CH,[XWD 600000+ASCD1,1]
PUSHJ PP,PUTAS2
MOVE CH,VALUE2
AOS EAS2PC
JRST PUTAS2
PTL2WC: MOVE CH,[XWD 600000+ASCD2,2]
PUSHJ PP,PUTAS2
MOVE CH,VALUE1##
AOS EAS2PC
PUSHJ PP,PUTAS2
MOVE CH,VALUE2##
AOS EAS2PC
JRST PUTAS2
PTLC2: MOVE CH,[XWD 600000+ASCF2,2]
PUSHJ PP,PUTAS2
MOVE CH,VALUE1
PUSHJ PP,PUTAS2
MOVE CH,VALUE2
AOS EAS2PC
AOS EAS2PC
JRST PUTAS2
PTLC1: MOVE CH,[XWD 600000+ASCFLT,2]
PUSHJ PP,PUTAS2
MOVE CH,VALUE1
PUSHJ PP,PUTAS2
MOVE CH,VALUE2
AOS EAS2PC
JRST PUTAS2
PTLDSP: SKIPG TC,NCHITM##
POPJ PP,
ADD TC,NCHWRD##
HRRZI TC,-1(TC)
IDIV TC,NCHWRD
MOVE CH, CONVR2##
HRL CH, ASCDS(CH)
HRRI CH,(TC)
TRNA
P2.: AOS EAS2PC
PUSHJ PP,PUTAS2
SETZ CH,
HRRZ TA,CURLIT##
MOVE TE, CONVR2##
HLL TE, LHPTRS(TE)
HRRI TE, CH
P1.: SOSGE NCHITM
JRST P3.
PUSHJ PP,GETCHR
IDPB TC,TE
TLNE TE,760000
JRST P1.
JRST P2.
P3.: LDB TB,[POINT 6,TE,5]
CAIN TB,44
POPJ PP,
AOS EAS2PC
JRST PUTAS2
;THE FOLLOWING TABLE CONTAINS:
; LH THE LEFT HALF OF THE POINTER FOR PUTTING CHARACTERS IN CH.
; RH THE ASSEMBLY CODE FOR THE ITEM.
; INDEX BY CONVR2.
LHPTRS: ASCDS:
POINT 9,AS.EBC## ;COMP-3.
POINT 6,AS.SIX## ;SIXBIT.
POINT 7,AS.ASC## ;ASCII.
POINT 9,AS.EBC## ;EBCDIC.
;PUT ASCII # ON AS2 AS A BINARY CONSTANT
PUTOCT: HRRZ TA,CURVAL
LDB TD,[POINT 14,(TA),13]
MOVEM TD,CTR
HRLI TA,(POINT 7,0,13)
SETZ TC,
PUTOC1: SOJL TD,PUTOC2
ILDB TB,TA
IMULI TC,10
ADDI TC,-60(TB)
JRST PUTOC1
PUTOC2: AOJ TA,
HRRM TA,CURVAL
HRLZI CH,(TC)
HRRI CH,AS.CNB##
JRST PUTAS2
PV.SXB: HRRZ TB,CURVAL
LDB TC,[POINT 14,(TB),13]
MOVEM TC,CTR
HRLI TB,(POINT 7,0,13)
MOVEM TB,PNTR##
ADDI TC,5
IDIVI TC,6
MOVEM TC,TBLOCK+1
HRLZI CH,AS.SIX##
HRR CH,TC
PV.S1: PUSHJ PP,PUTAS2
MOVE TA,[POINT 6,CH]
SETZ CH,
HRRZI TE,6
PV.S2: ILDB TB,PNTR
CAIN TB,":"
HRRZI TB,"-"
CAIN TB,";"
HRRZI TB,"."
SUBI TB,40
IDPB TB,TA
SOSG CTR
JRST PV.S3
SOJG TE,PV.S2
JRST PV.S1
PV.S3: PUSHJ PP,PUTAS2
MOVE TA,CURVAL
LDB TC,VA.SIZ## ;get size of valtab entry
ADDI TC,6 ;4 + 2, 4 to fill out word,
IDIVI TC,5 ; 2 to account for char count
HLRZS TA
ADD TA,TC
HRLZM TA,CURVAL
PUSHJ PP,LNKSET
HRRM TA,CURVAL
MOVE TB,EAS2PC
ADD TB,TBLOCK+1
MOVEM TB,EAS2PC
POPJ PP,
PV.ASC: HRRZ TB,CURVAL
LDB TC,[POINT 14,(TB),13]
MOVEM TC,CTR
HRLI TB,(POINT 7,0,13)
MOVEM TB,PNTR##
ADDI TC,4
IDIVI TC,5
SUBI TB,4 ;KNOCK OFF THE FOUR ADDED FOR ROUNDOFF UP ABOVE
MOVEM TB,CTRREM## ;SAVE REM TO TEST IF NEED N+1TH 0 WORD BELOW VID
MOVEM TC,TBLOCK+1
HRLZI CH,AS.ASC##
HRR CH,TC
PV.A1: PUSHJ PP,PUTAS2
MOVE TA,[POINT 7,CH]
SETZ CH,
HRRZI TE,5
PV.A2: ILDB TB,PNTR
IDPB TB,TA
SOSG CTR
JRST PV.S3
SOJG TE,PV.A2
JRST PV.A1
PV.DEC: HRRZ TB,CURVAL
LDB TC,[POINT 14,(TB),13]
MOVEM TC,CTR
HRLI TB,(POINT 7,0,13)
MOVEM TB,PNTR##
MOVE CH,[AS.D1##,,1]
PUSHJ PP,PUTAS2
MOVE TD,PNTR
PUSHJ PP,GETV2##
MOVE CH,TC
PUSHJ PP,PUTAS2
AOS EAS2PC
POPJ PP,
PVOUT: MOVE CH,[AS.D1,,1]
PUSHJ PP,PUTAS2
SETZ CH,
JRST PUTAS2
PUTTAG: ANDI CH,077777
IORI CH,CD.TAG*1B20
HRLI CH,720000
PUSHJ PP,PUTAS2
MOVE TE,EAS2PC
TRZ TE,1B18
ANDI CH,077777
ADD CH,TAGLOC##
HRRM TE,(CH)
POPJ PP,
;ADJUST NON-NUMERIC LITERALS
ADJUST: SETZM NPADL ;INITIALIZE.
SETZM NPADR
SETZM NCHLIT##
SETZM NCHLI2
SETZM NCHITM
SETZM ITMLOC##
SETZM ITMRES##
SETZM SIGNED
SETZM VALUE1
SETZM VALUE2
SKIPE TA,CURLIT ;POINT TO CURRENT LITERAL
LDB TA,LI.EBC## ;SEE IF IT IS EBCDIC (SYMBOLIC-CHARACTER)
SKIPE TA ;ITS NOT
SKIPA TB,[POINT 9,SZ.LIT(TA)]
MOVE TB,[POINT 7,SZ.LIT(TA)]
MOVEM TB,BYTEPT##
MOVEM TB,BYTEP2##
SKIPN TA,CURDAT
POPJ PP,
LDB LN,DA.LN ;ASSUME THAT WE WILL HAVE AN ERROR.
LDB CP,DA.CP
LDB TB,DA.SSC## ;SEE IF SEPARATE SIGN
MOVEM TB,SEPSGN## ;STORE RESULT
LDB TB,DA.LSC## ;SEE IF LEADING SIGN
MOVEM TB,LDNSGN## ;STORE RESULT
SKIPN TA,CURLIT
POPJ PP,
LDB TB,LI.NLT## ;IF THE LITERAL IS NUMERIC, GO WORRY OVER IT.
JUMPN TB,ADJNUM
;LITERAL IS NON NUMERIC.
SKIPN TA,CURDAT
CPOPJ: POPJ PP,
LDB TB,DA.LOC ;SET LOCATION.
HRRZM TB,ITMLOC
LDB TB,DA.RES## ;SET RESIDUE.
HRRZM TB,ITMRES
LDB TB,DA.EXS ;SET NUMBER OF CHARS IN THE ITEM.
HRRZM TB,NCHITM
SETZ TC, ;[ANS74] IGNORE JUSTIFICATION WHEN
;PUTTING VALUES IN DATA ITEMS
LDB TD,DA.USG
SETO TE,
CAIN TD,%US.D6 ;IS IT DISPLAY-6.
MOVEI TE,1 ;YES.
CAIN TD,%US.D7 ;IS IT DISPLAY-7.
MOVEI TE,2 ;YES.
CAIN TD,%US.EB ;IS IT DISPLAY-9.
MOVEI TE,3 ;YES.
JUMPLE TE,ADJNND ;IF THE ITEM ISN'T DISPLAY, LEAVE.
MOVE TA,CURLIT
LDB TD,LI.EBC## ;IS LITERAL EBCDIC (SYMBOLIC-CHAR)
SKIPE TD ;NO
MOVEI TD,3 ;YES, CHANGE INDEX
ADDI TD,(TE)
MOVEM TD,CONVR2## ;SET THE CONVERSION INDEX.
HLL TE,PADCHS(TE) ;GET THE APPROPRIATE PADD CHAR.
HLRZM TE,PADCHR ;REMEMBER IT.
HRL TE,CHSPWD(TE) ;GET THE NUMBER OF CHARS PER WORD.
HLRZM TE,NCHWRD ;REMEMBER IT.
LDB TD,LI.FGC## ;IF IT IS A FIGURATIVE CONSTANT,
JUMPN TD,AJNN.6 ; GO WORRY OVER IT.
LDB TD,LI.NCH## ;SET THE NUMBER OF CHARS IN THE LITERAL.
HRRZM TD,NCHLIT
CAIN TD,(TB) ;IF THE LITERAL IS THE SAME SIZE
JRST AJNN.X ; AS THE ITEM, GO ON.
CAIL TD,(TB) ;IF THE LITERAL IS LARGER THAN
JRST AJNN.4 ;THE ITEM, GO ON.
SUBI TB,(TD) ;SEE HOW MUCH SMALLER IT IS.
LDB TD,LI.ALL##
SETOM NPADR
JUMPE TD,AJNN.2
JRST AJNN.X
ADJNND: SKIPN TA,CURLIT ;POINT AT THE LITERAL.
POPJ PP,
LDB TB,LI.FGC## ;IF IT ISN'T A FIGURATIVE CONSTANT leave.
JUMPE TB,CPOPJ ;THE ERROR SHOULD HAVE been detected
; BY THE SYNTAX scan.
LDB TB,LI.FCC## ;SEE WHICH ONE IT IS.
JRST ADJNM5 ;GO SEE WHAT TO DO WITH IT.
;LITERAL IS SMALLER THAN THE ITEM.
AJNN.2: HRRZM TB,NPADR## ;PADD ON THE RIGHT.
JRST AJNN.X
;LITERAL IS LARGER THAN THE ITEM.
AJNN.4: HRRZM TB,NCHLIT ;MAKE THE LITERAL THE SAME SIZE AS THE ITEM.
HRRZI DW,E.238 ;COMPLAIN ABOUT THE SIZE.
PUSHJ PP,WARN
JRST AJNN.X
;THE LITERAL IS A FIGURATIVE CONSTANT.
AJNN.6: HRRZM TB,NPADL ;PADD THE WHOLE ITEM WITH IT.
LDB TD,LI.FCC## ;SEE WHICH ONE IT IS.
SETZ TC, ;IF IT ISN'T VALID WE WILL USE NULLS.
SUBI TD,HIVAL.
CAILE TD,5
JRST AJNN.7
IMULI TD,3
SKIPE COLSEQ ;PROGRAM COL. SEQ.?
CAILE TD,3*<LOVAL.-HIVAL.> ;YES, AND EITHER LOW OR HIGH VALUE
JRST AJNN.8 ;NO
ADD TD,CONVR2
HRRZ TC,COHVLV##-1(TD) ;GET RIGHT CHARACTER
JRST AJNN.7
AJNN.8: ADD TD,CONVR2##
HRRZ TC,FIGC-1(TD)
AJNN.7: HRRZM TC,PADCHR##
AJNN.X: PUSHJ PP,ADJALP
MOVE TA,BYTEPT
MOVEM TA,BYTEP2
MOVE TA,NCHLIT
MOVEM TA,NCHLI2##
POPJ PP,
;ROUTINE TO SEE IF IN ITEM IS ALPHABETIC AND IF IT IS, CHECK TO MAKE
; SURE THAT THE LITERAL CONTAINS ONLY ALPHABETIC CHARACTERS.
ADJALP: SKIPN TA, CURDAT ;POINT AT THE ITEM.
POPJ PP, ;IF THERE IS NONE, LEAVE.
LDB TB, DA.CLA## ;GET ITS CLASS.
CAIE TB, %CL.AB ;IS IT ALPHABETIC?
JRST ADJNBR ;[1500] NO, NUMERIC
SETZM TBLOCK
SKIPG TD, NCHLIT ;GET THE NUMBER OF CHARS IN THE
; LITERAL.
JRST ADJAL6 ;IF IT'S ZERO, IT'S PROBABLY A
; FIGURATIVE CONSTANT.
HRRZ TA, CURLIT ;POINT AT THE LITERAL.
MOVE TE, BYTEPT
ADJAL1: ILDB TB, TE ;GET A CHAR.
CAIN TB, " " ;SPACE?
JRST ADJAL2 ;YES.
CAIL TB, "A" ;LETTER?
CAILE TB, "Z"
JRST ADJAL8 ;NO, GO SEE IF IT'S LOWER CASE.
ADJAL2: SOJG TD, ADJAL1 ;IF THERE ARE MORE CHARS, LOOP.
SKIPN TBLOCK ;IF THERE WERE NO NON ALPHABETIC
POPJ PP, ; CHARACTERS, RETURN.
ADJAL4: HRRZI DW, E.298 ;OTHERWISE, COMPLAIN.
PJRST WARN##
;LITERAL IS A FIGURATIVE CONSTANT - MAKE SURE IT IS SPACES.
ADJAL6: MOVE TB, CONVR2## ;GET THE CONVERSION INDEX.
HLRZ TB, PADCHS(TB) ;SEE WHAT A SPACE LOOKS LIKE.
CAMN TB, PADCHR ;DOES THE FIGURATIVE CONSTANT
; LOOK LIKE A SPACE?
POPJ PP, ;YES, ALL IS WELL, RETURN.
MOVEM TB, PADCHR ;MAKE THE FIGURATIVE CONSTANT
; A SPACE.
JRST ADJAL4 ;GO COMPLAIN.
;THERE MAY BE A NON ALPHABETIC CHARACTER IN THE LITERAL.
ADJAL8: CAIL TB, "a" ;IS IT A LOWER CASE LETTER?
CAILE TB, "z"
CAIA ;NO, ERROR.
JRST ADJAL2
SETOM TBLOCK ;REMEMBER THAT WE HAD AN ERROR.
MOVEI TB, " " ;REPLACE THE CHARACTER BY A SPACE.
DPB TB, TE
JRST ADJAL2 ;GO SCAN THE REST OF THE LITERAL.
;VALUE CLAUSE IS FOR A NUMERIC FIELD, SEE IF FIGURATIVE CONSTANT
; AND WARN IF NOT ZERO
ADJNBR: HRRZ TA,CURDAT ;[1500]
LDB TB,DA.CLA ;[1500] GET THE CLASS
CAIE TB,%CL.NUM ;[1500] IF IT'S NOT NUMERIC,
POPJ PP, ;[1500] EXIT
LDB TC,DA.USG ;[1500] STORE OFF ITS USAGE
HRRZ TA,CURLIT ;[1500] GET THE LITERAL'S ADDRESS
LDB TB,LI.FGC ;[1500] GET LITERAL CODE
JUMPE TB,CPOPJ ;[1500] NOT A FIGURATIVE CONSTANT
LDB TB,LI.FCC ;[1500] FIND OUT WHAT KIND OF FIG CONST
CAIN TB,ZERO. ;[1500] IF IT'S A ZERO - OK
POPJ PP, ;[1500] ALLOWED BY ANSI STANDARD
HRRZI DW,E.669 ;[1500] OTHERWISE GIVE WARNING
CAIE TB,HIVAL. ;[1500]
JRST WARN## ;[1500]
HRRZI DW,E.667 ;[1500] HIGH-VALUES DISPLAY MODE
CAILE TC,%US.DS ;[1500]
HRRZI DW,E.668 ;[1500] HIGH-VALUES NON-DISPLAY MODE
JRST WARN## ;[1500]
;TABLE OF FIGURATIVE CONSTANTS.
FIGC: OCT 77 ;HIGH VALUES.
OCT 177
OCT 377
OCT 0 ;LOW VALUES.
OCT 0
OCT 0
EXP '"' ;QUOTES.
OCT 42
OCT 177
EXP ' ' ;SPACES.
EXP " "
OCT 100
OCT 0 ;TALLY (TO MAKE INDEXING INTO THE TABLE EASIER.)
OCT 0
PADCHZ: OCT 360
EXP '0' ;ZEROES.
EXP "0"
OCT 360
;TABLE OF PADD CHARACTERS (LEFT HALF) AND CHARACTERS PER WORD (RIGHT
; HALF). INDEX BY CONVERSION INDEX.
PADCHS: CHSPWD:
XWD 0,4 ;COMP-3.
XWD ' ',6 ;SIXBIT.
XWD " ",5 ;ASCII.
XWD 100,4 ;EBCDIC.
COMMENT \
ROUTINE TO GET A CHARACTER FROM A LITERAL.
CALL:
PUSHJ PP, GETCHR
ENTRY CONDITIONS:
(NPADL) REMAINING NUMBER OF CHARACTERS TO PADD ON THE LEFT.
(NCHLIT) NUMBER OF CHARACTERS REMAINING IN THE LITERAL.
(NCHLI2) NUMBER OF CHARACTERS IN THE LITERAL.
(CURLIT) ADDRESS OF THE LITAB ENTRY CONTAINING THE LITERAL.
(BYTEPT) BYTE POINTER TO THE NEXT CHAR IN THE LITERAL.
(BYTEP2) BYTE POINTER TO THE FIRST CHAR IN THE LITERAL.
(NPADR) IF LESS THAN ZERO "ALL" WAS SPECIFIED FOR THE LITERAL
OTHERWISE RETURN PADD CHARS IF THERE ARE NO
MORE CHARS IN THE LITERAL.
(NCHITM) NUMBER OF CHARACTERS REMAINING IN THE ITEM.
(CONVR2) CONVERSION INDEX:
0 ==> CONVERT ASCII TO COMP-3.
1 ==> CONVERT ASCII TO SIXBIT.
2 ==> NO ASCII CONVERSION.
3 ==> CONVERT ASCII TO EBCDIC.
4 ==> CONVERT EBCDIC TO SIXBIT.
5 ==> CONVERT EBCDIC TO ASCII.
6 ==> NO EBCDIC CONVERSION.
EXIT CONDITIONS:
(TC) = THE CHARACTER.
NOTES:
1. NPADL, BYTEPT, ETC ARE UPDATED BEFORE RETURNING.
2. WHEN CONVERTING TO COMP-3 TWO CHARACTERS FROM THE LITERAL
ARE RETURNED PACKED RIGHT JUSTIFIED IN A NINE BIT BYTE.
3. TA AND TC ARE DESTROYED.
\
GETCHR: SKIPN CONVR2## ;IF THE ITEM IS COMP-3 GO GET TWO
JRST GETCHP ; CHARS FROM THE LITERAL AND RETURN
; ONE NINE BIT BYTE.
SKIPE SEPSGN## ;SEPARATE SIGN
SKIPN LDNSGN## ;AND LEADING
JRST GETCH1 ;NO
GETCH0: MOVE TC,SIGNED ;GET SIGN OF LITERAL
MOVE TC,[EXP "-","+","+"]+1(TC) ;GET RIGHT SIGN
SETZM SIGNED ;SO WE DON'T DO IT AGAIN
SETZM SEPSGN
SETZM LDNSGN
JRST GETCH4 ;CONVERT AND RETURN
;THE ITEM IS DISPLAY.
GETCH1: SOSL NPADL ;ARE WE PADDING ON THE lEFT?
JRST GETCH6 ;YES, GO RETURN A PADD CHAR.
SOSL NCHLIT ;ANY CHARS LEFT IN THE LITERAL?
JRST GETCH2 ;YES, GO GET A CHAR FROM IT.
SKIPL NPADR ;WAS "ALL" SPECIFIED?
JRST GETCH6 ;NO, GO PADD ON THE RIGHT.
;"ALL" WAS SPECIFIED FOR THE LITERAL, REPEAT THE LITERAL.
MOVE TA, BYTEP2 ;POINT AT THE BEGINNING OF THE LITERAL.
MOVEM TA, BYTEPT
SKIPG TA, NCHLI2 ;IF THERE ARE NO CHARS IN THE LITERAL
JRST GETCH6 ; IT MUST BE A FIGURATIVE CONSTANT
; GO RETURN A PADD CHAR.
MOVEM TA, NCHLIT ;SET THE NUMBER OF CHARS IN THE LITERAL.
SOS NCHLIT ;LESS ONE FOR THE ONE WE ARE ABOUT
; TO RETURN.
;GET A CHAR FROM THE LITERAL.
GETCH2: HRRZ TA, CURLIT ;POINT AT THE LITERAL.
ILDB TC, BYTEPT ;GET A CHAR.
SKIPLE NCHITM ;IF NOT LAST CHARACTER
JRST [SKIPE LDNSGN ;CHECK FOR LEADING SIGN
SKIPL SIGNED ;AND NEGATIVE
JRST GETCH4 ;NO
SETZM LDNSGN
SETZM SIGNED
JRST GETCH3] ;MAKE LEADING CHAR NEGATIVE
SKIPE SIGNED ;SIGNED?
SKIPN TA,SEPSGN ;AND SEPARATE CHAR?
JRST .+3 ;NO
MOVE TC,[EXP "-","+","+"]+1(TA) ;GET SIGN
JRST GETCH4 ;AND RETURN IT
SKIPGE SIGNED ;IF THE LITERAL WAS NOT NEGATIVE
SKIPLE NCHITM ; OR THIS IS NOT THE LAST CHAR,
JRST GETCH4 ; GO ON.
;THE LITERAL WAS NEGATIVE AND THIS IS THE LAST CHAR. IMBED A "-" OVERPUNCH.
GETCH3: CAIN TC, "0"
JRST GETCN0 ;OVERPUNCH 0 IS SPECIAL
ADDI TC, "J"-"1"
;CONVERT THE CHAR IF NECESSARY.
GETCH4: MOVE TA, CONVR2## ;GET THE CONVERSION INDEX.
XCT GETCH5(TA) ;CONVERT THE CHAR.
POPJ PP, ;RETURN (COULD ELIMINATE THIS
; INSTR BY CHANGING THE XQT TO
; A JRST BUT IT WOULD PROBABLY
; MAKE THINGS MORE OBSCURE.)
;TABLE TO HANDLE CONVERSIONS - INDEX BY CONVR2.
GETCH5: JRST GETCH7 ;COMP-3, RETURN AN EBCDIC CHAR.
SUBI TC,40 ;SIXBIT, WILL ALWAYS WORK BECAUSE
; WE HAVE ALREADY CHECKED THE LITERAL.
POPJ PP, ;ASCII, NO CONVERSION NECESSARY.
JRST GETC7A ;[1072] EBCDIC.
JRST GETC9S ;EBCDIC - SIXBIT
JRST GETC9A ;EBCDIC - ASCII
POPJ PP, ;EBCDIC - EBCDIC
;RETURN A PADD CHAR.
GETCH6: HRRZ TC, PADCHR ;GET A PADD CHAR.
SKIPE LDNSGN ;REQUIRE LEADING SIGN?
SKIPL SIGNED ;AND NEGATIVE?
JRST .+4 ;NO
SETZM SIGNED
SETZM LDNSGN
JRST GETCN0 ;YES, -0
SKIPLE NCHITM ;IF NOT LAST CHAR.
POPJ PP, ;RETURN
SKIPE SEPSGN ;STILL NEEDING SEPARATE SIGN?
JRST GETCH0 ;YES
SKIPGE SIGNED ;IF THE LITERAL WAS NOT NEGATIVE
SKIPLE NCHITM ;OR THIS IS NOT THE LAST CHAR,
POPJ PP, ; RETURN.
SKIPN CONVR2## ;IF IT'S NOT COMP-3 OR THE
CAIE TC, 371 ; CHAR ISN'T AN EBCDIC 9,
JRST GETCN0 ; RETURN A "-0".
MOVEI TC, 331 ;OTHERWISE, RETURN A "-9".
POPJ PP,
;RETURN AN OVERPUNCHED 0
GETCN0: MOVE TA,CONVR2 ;GET CONVERSION INDEX
MOVE TC,[EXP 320,']',"}",320](TA) ;GET RIGHT 0
POPJ PP,
;CONVERT THE CHARACTER IN TC TO EBCDIC.
GETCH7: PUSH PP, TB ;SAVE TB.
IDIVI TC, 4 ;FORM THE INDICES.
LDB TC, GETCH8(TB) ;CONVERT THE CHAR.
POP PP, TB ;RESTORE TB.
POPJ PP, ;RETURN.
;[1072] Convert character to EBCDIC. If this is the last character,
;[1072] and the item is signed, and literal is positive, overpunch
;[1072] a "+".
GETC7A: IDIVI TC,4 ;[1072] FORM THE INDICES
LDB TC,GETCH8(TB) ;[1072] CONVERT THE CHAR TO EBCDIC.
SKIPN NCHITM ;[1072] IS THIS THE LAST CHARACTER?
SKIPGE SIGNED ;[1072] YES, AND IS LITERAL POSITIVE?
POPJ PP, ;[1072] NO, RETURN
HRRZ TA,CURDAT## ;[1072] IS ITEM SIGNED?
LDB TA,DA.SGN## ;[1072]
JUMPE TA,CPOPJ ;[1072] NO, RETURN POSITIVE DIGIT
TRZ TC,60 ;[1072] OVERPUNCH A "+"
POPJ PP, ;[1072] RETURN
;TABLE OF POINTERS TO THE ASCII TO EBCDIC CONVERSION TABLE - INDEX BY
; THE LOW ORDER TWO BITS OF THE ASCII CHARACTER WITH THE HIGH ORDER FIVE
; BITS IN TC.
GETCH8: POINT 9,ASEBC.##(TC),8
POINT 9,ASEBC.##(TC),17
POINT 9,ASEBC.##(TC),26
POINT 9,ASEBC.##(TC),35
;ROUTINE TO CONVERT AN EBCDIC CHAR IN TC TO ASCII.
GETC9A: ROT TC,-2 ;FORM THE TABLE INDEX.
JUMPL TC,GETC9R ;LEFT OR RIGHT HALF.
HLR TC,EBASC.##(TC) ;LEFT.
CAIA
GETC9R: HRR TC,EBASC.##(TC) ;RIGHT.
TLNN TC,(1B1) ;IS THE CHAR RIGHT JUSTIFIED?
LSH TC,-^D9 ;IT IS NOW.
ANDI TC,177 ;GET RID OF ANY JUNK
POPJ PP, ;RETURN.
;ROUTINE TO CONVERT AN EBCDIC CHAR IN TC TO SIXBIT
GETC9S: PUSHJ PP,GETC9A ;FIRST CONVERT TO ASCII
;THEN TO SIXBIT
CAIL TC,40 ;IS THIS ASCII CHAR CONVERTABLE?
CAILE TC,137 ;IE TO SIXBIT?
JRST ADJAL4 ;NO, WARN USER
ROT TC,-2 ;FORM THE INDEX INTO THE TABLE.
JUMPL TC,GETC9T ;LEFT OR RIGHT HALF?
HLR TC,ASCSX.##(TC) ;LEFT.
CAIA
GETC9T: HRR TC,ASCSX.##(TC) ;RIGHT.
TLNN TC,(1B1) ;IS THE CHAR RIGHT JUSTIFIED?
LSH TC,-^D9 ;IT IS NOW.
TRZ TC,777700 ;GET RID OF STATUS BITS
POPJ PP, ;RETURN.
;COME HERE IF THE ITEM IS COMP-3.
GETCHP: PUSHJ PP, GETCH1 ;GO GET AN EBCDIC CHAR.
SKIPLE NCHITM ;IF THIS IS NOT THE LAST CHAR IN
JRST GETC10 ; THE ITEM, GO ON.
;THIS IS THE LAST CHAR, WE HAVE TO RETURN A SIGN ALSO.
LDB TA, [POINT 4,TC,31] ;GET THE SIGN.
LSH TC, 4 ;POSITION THE DIGIT.
TRO TC, (TA) ;COMBINE THE SIGN AND THE DIGIT.
ANDI TC, 377 ;GET RID OF ANY JUNK.
HRRZ TA, CURDAT## ;SEE IT THE ITEM IS
LDB TA, DA.SGN## ; SIGNED.
JUMPE TA, CPOPJ ;IF IT ISN'T, RETURN.
TRNE TC, 2 ;IF THE LITERAL IS NEGATIVE
; DO NOTHING.
TRZ TC, 3 ;OTHERWISE MAKE THE VALUE
POPJ PP, ; POSITIVE RATHER THAN UNSIGNED.
;RETURN TWO DIGITS IN A NINE BIT BYTE.
GETC10: ANDI TC, 17 ;ISOLATE THE FIRST DIGIT.
PUSH PP, TC ;SAVE IT.
PUSHJ PP, GETCH1 ;GO GET THE SECOND DIGIT.
POP PP, TA ;RESTORE THE FIRST DIGIT.
DPB TA, [POINT 5,TC,31] ;COMBINE THE DIGITS.
POPJ PP, ;RETURN.
ADJNUM: LDB TB,LI.FGC
JUMPN TB,ADJNM5 ;FIGURATIVE CONSTANT
LDB TB,LI.NCH
HRRZM TB,NCHLIT
PUSHJ PP,EXALIT
SKIPN TA,CURDAT
POPJ PP,
LDB TB,DA.USG
CAIN TB,%US.C1
JRST AJUC1 ;COMP-1
CAIN TB,%US.C2
JRST AJUC2 ;COMP-2
LDB TB,DA.INS
SKIPE SEPSGN ;SEPARATE SIGN?
SUBI TB,1 ;YES, 1 LESS DATA CHAR
LDB TC,DA.NDP
LDB TD,DA.DPR
HRRZM TB,NCHITM
SKIPN NINTGD
SKIPE NFRACD##
JRST ADJNM0
HRRZM TB,NPADL
SETZM NCHLIT
SETZM NPADR
JRST ADJNM3
ADJNM0: JUMPN TD,ADJNM2 ;NDP<0
CAIGE TB,(TC)
JRST ADJNM1 ;NDP>INSIZE --- P(>0)9(N)
SUBI TB,(TC)
CAMGE TB,NINTGD## ;INS-NDP>=NINTGD?
JRST AJUE.1 ;NO---NUMBER TOO BIG
SUB TB,NINTGD
MOVEM TB,NPADL
CAMGE TC,NFRACD
JRST AJUE.2 ;NDP<NFRACD --- ERROR
SUB TC,NFRACD
MOVEM TC,NPADR
JRST ADJNM3
ADJNM1: SKIPLE NINTGD
JRST AJUE.1 ;NUMBER TOO BIG
HRRZ TA,CURLIT
SUBI TC,(TB) ;PIC IS P(NDP-INS)9(INS)
ILDB TE,BYTEPT
CAIE TE,"0"
JRST AJUE.3 ;NUMBER TOO BIG
SOJG TC,.-3
SETZM NPADL
HRRZ TA,CURDAT
LDB TC,DA.NDP
MOVE TD,TB
ADD TB,NCHLIT
SUB TB,TC ;INS-NDP+NCHLIT
MOVEM TB,NCHLIT
SUB TD,TB
MOVEM TD,NPADR
JRST ADJNM3
ADJNM2: SKIPN NFRACD
CAML TC,NINTGD
JRST AJUE.3
MOVE TA,CURLIT
MOVE TE,NINTGD
SUB TE,TC ;PIC IS 9(INS)P(NDP)
MOVE TD,BYTEPT
IBP TD
SOJG TE,.-1
REPEAT 0,< ;[FCTC NC124] allow non-zero values
ILDB TE,TD
CAIE TE,"0"
JRST AJUE.3
SOJG TC,.-3
>
HRRZ TA,CURDAT
LDB TC,DA.NDP
MOVE TD,TB
SUB TD,NINTGD
ADD TD,TC
JUMPL TD,AJUE.3 ;VALUE TOO LARGE
MOVEM TD,NPADL ;INS+NDP-NINTGD
SETZM NPADR
SUBI TB,(TD)
MOVEM TB,NCHLIT
ADJNM3: HRRZ TA,CURDAT
LDB TB,DA.SGN##
JUMPN TB,ADJNM4
SKIPN SIGNED##
JRST ADJNM4
HRRZI DW,E.249 ;VALUE SHOULD BE UNSIGNED
PUSHJ PP,AJUC16
SETZM SIGNED
ADJNM4: HRRZ TA, CURDAT## ;POINT AT THE ITEM.
LDB TE, DA.USG## ;GET ITS USAGE.
XCT AJNMDP(TE) ;EITHER GET THE CONVERSION INDEX
; OR DISPATCH TO A CONVERSION ROUTINE.
;CONVERSION INDEX IS IN TE.
AJNM4B: HRR TB, PADCHZ(TE) ;GET THE PADD CHAR.
AJNM4D: HRRZM TB, PADCHR## ;REMEMBER IT.
MOVEM TE, CONVR2## ;REMEMBER THE CONVERSION INDEX.
HRR TB, CHSPWD(TE) ;GET CHAR'S PER WORD.
HRRZM TB, NCHWRD## ;REMEMBER IT.
LDB TB, DA.LOC## ;SET THE LOCATION.
HRRZM TB, ITMLOC##
LDB TB, DA.RES## ;SET THE RESIDUE.
HRRZM TB, ITMRES##
SKIPE SEPSGN ;SEPARATE SIGN?
AOS NCHITM ;YES, ADD SIGN IN
JUMPN TE, CPOPJ ;IF THE ITEM IS NOT COMP-3, RETURN.
;THE ITEM IS COMP-3, CHANGE THE NUMBER OF CHARACTERS IN THE ITEM FROM
; THE NUMBER OF 9'S TO THE NUMBER OF 9 BIT BYTES REQUIRED TO HOLD THE
; ITEM.
MOVE TB, NCHITM## ;NUMBER OF 9'S IN THE PICTURE.
HRRZI TB, 2(TB) ;ADD ONE FOR THE SIGN AND ONE TO
; FORCE ROUNDING UPWARDS.
LSHC TB, -1 ;NUMBER OF 9 BIT BYTES REQUIRED.
MOVEM TB, NCHITM## ;SAVE THE RESULT.
JUMPL TA, CPOPJ ;IF THERE WAS A REMAINDER, WE
AOS NPADL## ; WILL HAVE TO PADD THE LEADING
; CHARACTER POSITION.
POPJ PP, ;RETURN.
;TABLE WHICH EITHER RETURNS THE ITEM'S CONVERSION INDEX OR DISPATCHES
; TO A CONVERSION ROUTINE.
;MAKE SURE IT DOESN'T GET MESSED UP.
N==<%%US>!<%US.D6-1>!<%US.D7-2>!<%US.EB-3>!<%US.1C-4>
N==N!<%US.2C-5>!<%US.C1-6>!<%US.IN-7>!<%US.C3-10>!<%US.C2-11>
IFN N,<
PRINTX %AJNMDP - TABLE IS MESSED UP.
>
AJNMDP: POPJ PP, ;UNKNOWN USAGE.
MOVEI TE, 1 ;DISPLAY-6.
MOVEI TE, 2 ;DISPLAY-7.
MOVEI TE, 3 ;DISPLAY-9.
JRST AJU1WC ;1-WORD COMP.
JRST AJU2WC ;2-WORD COMP.
JRST AJUC1 ;COMP-1.
JRST AJU1WC ;INDEX
SETZ TE, ;COMP-3.
JRST AJUC2 ;COMP-2.
ADJNM5: CAIE TB, HIVAL. ;ONLY HIGH VALUES,
CAIN TB, LOVAL. ; LOW VALUES
JRST .+4 ;[1500] AND
CAIE TB, ZERO. ; ZERO ARE ALLOWED.
JRST AJUE.4
SKIPA ;[1500] HV AND LV ARE SORT OF
PUSHJ PP, ADJNBR ;[1500] ALLOWED
HRRZ TA, CURDAT
LDB TC, DA.INS##
HRRZM TC, NPADR
HRRZM TC, NCHITM
SETZM NINTGD
SETZM NFRACD
CAIN TB, ZERO.
JRST ADJNM4
LDB TE, DA.USG##
JRST @.+1(TE)
EXP CPOPJ
EXP ADJNM4
EXP ADJNM4
EXP ADJNM4
EXP AJCP
EXP AJCP
EXP AJC1
EXP AJCP
EXP AJC3
EXP AJC2
AJCP: CAIE TB, HIVAL.
SKIPA TD, [EXP 1B0]
HRLOI TD, 377777
MOVE TC, TD
JRST AJU1X2
AJC2:
AJC1: CAIE TB, HIVAL.
SKIPA TC, [EXP 1B0+1]
HRLOI TC, 377777
JRST AJU1X2
AJC3: SETZI TE,
CAIE TB, LOVAL.
JRST AJC3D
LDB TB, DA.SGN##
JUMPE TB, AJNM4B
SETOM SIGNED
AJC3D: MOVEI TB, 371
JRST AJNM4D
AJU2WC:
AJU1WC: HRRZ TA,CURLIT
SETZB TD,TC
AJU1W1: SOSGE NCHLIT
JRST AJU1WX
ILDB TE,BYTEPT
CAIL TE,"0"
CAILE TE,"9"
JRST AJU1W1
IMULI TD,12
MULI TC,12
ADD TD,TC
MOVE TC,TB
ADDI TC,-"0"(TE)
TLZN TC,1B18
JRST AJU1W1
AOJA TD,AJU1W1
AJU1WX: SOSGE NPADR
JRST AJ1WX1
IMULI TD,12
MULI TC,12
ADD TD,TC
MOVE TC,TB
TLZN TC,1B18
JRST AJU1WX
AOJA TD,AJU1WX
AJ1WX1: SKIPL SIGNED
JRST AJU1X2
SETCA TD,
MOVNS TC
JUMPN TC,AJU1X2
TLO TC,1B18
AOJA TD,AJU1X2
AJU1X2: DMOVEM TD,VALUE1 ;STORE VALUE1 & VALUE2
POPJ PP,
AJUC2: SKIPN TA,NINTGD
SKIPE NFRACD
SKIPA ;NON-ZERO DIGITS IN SOME PART
POPJ PP,
CAIGE TA,0
SETZ TA,
MOVEM TA,VALUE1 ;EXPONENT
SETZ TA,
SKIPGE SIGNED
HRLZI TA,740000
SETOM SIGNED ;NOTE THAT THIS IS A FLOATING POINT
; NUMBER IN A FUNNY FORMAT.
MOVEM TA,VALUE2
MOVE TA,CURLIT
HRRZI TB,^D18 ;NUMBER OF SIGNIFICANT DIGITS ALLOWED
MOVE TD,[POINT 4,VALUE2,3]
SETZM VALUE2+1 ;CLEAR EXTRA WORDS
SETZM VALUE2+2
JRST AJUC11 ;COMMON CODE
AJUC1: SKIPN TA,NINTGD
SKIPE NFRACD
SKIPA ;NON-ZERO DIGITS IN SOME PART
POPJ PP,
CAIGE TA,0
SETZ TA,
MOVEM TA,VALUE1 ;EXPONENT
SETZ TA,
SKIPGE SIGNED
HRLZI TA,740000
SETOM SIGNED ;NOTE THAT THIS IS A FLOATING POINT
; NUMBER IN A FUNNY FORMAT.
MOVEM TA,VALUE2
MOVE TA,CURLIT
HRRZI TB,^D8 ;NUMBER OF SIGNIFICANT DIGITS ALLOWED
MOVE TD,[POINT 4,VALUE2,3]
AJUC11: ILDB TE,BYTEPT
CAIE TE,"0"
JRST AJC121 ;NON-ZERO DIGIT
SOS VALUE1 ;ZERO HERE IS A ZERO FOLLOWING THE DECIMAL
;POINT --- HENCE, DECREMENT EXPONENT
SOSLE NCHLIT
JRST AJUC11
POPJ PP,
AJUC12: ILDB TE,BYTEPT
AJC121: IDPB TE,TD
SOS TC,NCHLIT
SOJLE TB,AJUC13 ;NO MORE SIGNIFICANT DIGITS ALLOWED
JUMPG TC,AJUC12 ;MORE DIGITS
AJUC13: SKIPG NCHLIT
POPJ PP,
AJUC14: ILDB TE,BYTEPT
CAIE TE,"0"
JRST AJUC15 ;NON-ZERO DIGIT AFTER 8 PLACES USED
SOSLE NCHLIT
JRST AJUC14
POPJ PP,
AJUC15: HRRZ TA,CURDAT
HRRZI DW,E.302 ;TOO MANY DIGITS
AJUC16: LDB LN,DA.LN
LDB CP,DA.CP
JRST WARN
AJUE.1: HRRZI DW,E.245 ;HIGH-PART TRUNCATION
AJUE.E: SETZM NCHITM
SETZM NPADL
SETZM NPADR
SETZM NCHLIT
JRST FATAL
AJUE.2: HRRZI DW,E.246 ;LOW-PART TRUNCATION
JRST AJUE.E
AJUE.3: HRRZI DW,E.248 ;VALUE OUT OF RANGE
JRST AJUE.E
AJUE.4: HRRZI DW,E.298
JRST AJUE.E
FATALE: LDB LN,DA.LN##
LDB CP,DA.CP##
JRST FATAL
EXALIT: SETZM SIGNED
SETZM NLEADZ
SETZM NTRALZ##
SETZM NINTGD
SETZM NFRACD
SKIPN TA,CURLIT
POPJ PP,
LDB TB,LI.NCH
MOVE TE,[POINT 7,SZ.LIT(TA)]
MOVE TD,TE
ILDB TC,TE
CAIN TC,"+"
JRST EXL.1
CAIE TC,"-"
JRST EXL.2
SETOM SIGNED
JRST EXL.3
EXL.1: HRRZI TC,1
HRRZM TC,SIGNED
JRST EXL.3
EXL.2: CAIE TC,"0"
JRST EXL.4
AOS NLEADZ##
EXL.3: SOS NCHLIT
SOJLE TB,CPOPJ
ILDB TC,TE
JRST EXL.2
EXL.4: CAIN TC,"."
JRST EXL.45
IDPB TC,TD
AOS NINTGD
SOJLE TB,CPOPJ
ILDB TC,TE
JRST EXL.4
EXL.45: SOS NCHLIT
EXL.5: SOJLE TB,CPOPJ
ILDB TC,TE
IDPB TC,TD
CAIE TC,"0"
JRST EXL.6
AOS NTRALZ
SOS NCHLIT
JRST EXL.5
EXL.6: AOS TC,NTRALZ
ADDM TC,NFRACD
ADDM TC,NCHLIT
SOS NCHLIT
SETZM NTRALZ
JRST EXL.5
SUBTTL KYPTR -- RMS ROUTINE TO GET PTR TO RECORD KEYS
;WHOLE BUNCH OF CODE IN ANS74
;THIS ROUTINE WAS SNARFED OUT OF IOGEN AND REFURBED AS NOTED BELOW.
;THIS ROUTINE GENERATES THE KEY INFORMATION IN %N UNDER START.
;RETURNS .+1 ALWAYS
KYPTR: MOVE TA,CURFIL
LDB TB,FI.KYE## ;DID WE HAVE ERRORS BEFORE?
CAIE TB,0
POPJ PP, ;YES, RETURN IMMEDIATELY
;PUT THE FOLLOWING KEY INFORMATION IN AS2FIL:
;
; EXP NUMBER OF KEYS
; 2-WORD-KEY-DESCRIPTORS
;
; EACH KEY-DESCRIPTOR HAS THE FOLLOWING FORMAT:
; XWD STARTING BYTE POSITION,,KEY SIZE
; XWD FLAGS,,DATATYPE
; FLAGS ARE:
; 1B0 DUPLICATES ALLOWED
; DATATYPE VALUES ARE:
; 0 SIXBIT
; 1 ASCII
; 2 EBCDIC
;FIRST, FIND NUMBER OF KEYS
LDB TA,FI.ALK## ;GET PTR TO FIRST ALTERNATE KEY
MOVEI TE,1 ;1 KEY SO FAR (THE PRIMARY KEY)
JUMPE TA,KYPTR1 ; JUMP IF THAT'S ALL
;LINK THRU AKTTAB TO COUNT ALTERNATE KEYS
;PTR TO FIRST ENTRY IS IN EACA
ADD TA,AKTLOC## ;TA= ABS ADDR OF ENTRY
HRRZ TA,TA ;CLEAR LEFT HALF
HRRZ TB,AKTNXT## ;TB= PTR TO "NEXT" ENTRY
; (TO TELL WHEN OFF TABLE)
LDB TD,AK.FLK## ;TD= WHICH FILE
KYPTR0: ADDI TE,1 ;COUNT ANOTHER KEY
ADDI TA,SZ.AKT ;LOOK AT NEXT ENTRY
CAML TA,TB ;PAST END OF TABLE?
JRST KYPTR1 ;YES, THAT'S ALL THE KEYS
LDB TC,AK.FLK## ;GET WHICH FILE THIS ENTRY POINTS TO
CAIN TC,(TD) ;SKIP IF LOOKING AT A DIFFERENT FILE NOW
JRST KYPTR0 ;SAME FILE, KEEP COUNTING
;FALL TO NEXT PAGE WHEN TE = NUMBER OF KEYS
;HERE WITH NUMBER OF KEYS IN TE
KYPTR1: MOVEM TE,NMAKYS## ;SAVE NUMBER OF ALTERNATE KEYS + 1
MOVE CH,[AS.OCT,,1] ;PUT OUT HEADER WITH COUNT OF KEYS
PUSHJ PP,PUTAS2
AOS EAS2PC## ;ADVANCE STARTING PC FOR AS2
MOVE CH,NMAKYS##
PUSHJ PP,PUTAS2
;WRITE OUT KEY INFORMATION
;FIRST FOR THE PRIMARY RECORD KEY
HRRZ TA,CURFIL ;FIND PTR TO CURRENT FILE AGAIN
LDB TA,FI.RKY ;GET RECORD KEY PTR
SETZM EFLAGB ;CLEAR FLAGS
PUSHJ PP,KYINFO ;CREATE THE INFO BLOCK
JRST KYIER ;ERROR
MOVE TD,NMAKYS## ;NUMBER OF ALTERNATE KEYS
SOJ TD, ;IN TD
JUMPE TD,KYPTR6 ;JUMP IF NONE TO DO
HRRZ TA,CURFIL ;POINT TO CURRENT FILE
LDB TA,FI.ALK ;GET PTR TO ALTERNATE KEYS
MOVEM TA,CURAKT## ;SAVE REL. ADDR
ADD TA,AKTLOC ;GET ABS PTR
;HERE WITH TA= ABS ADDR OF ENTRY, TD= # ENTRIES LEFT TO DO
KYPTR2: LDB TB,AK.DUP## ;GET "DUPLICATES" FLAG
TRNE TB,1 ;IS IT SET?
MOVX TB,1B0 ;YES, TURN ON BIT
MOVEM TB,EFLAGB ;SETUP FOR "FLAGS"
LDB TA,AK.DLK## ;GET DATAB LINK
PUSHJ PP,KYINFO ;CREATE THE INFO BLOCK
JRST KYIER ;ERROR
SOJLE TD,KYPTR6 ;JUMP IF NO MORE TO DO
MOVEI TA,SZ.AKT ;BUMP TO NEW ENTRY
ADDB TA,CURAKT ;FETCH AND UPDATE REL. LOC
ADD TA,AKTLOC ;GET ABS LOC IN ALTERNATE KEY TABLE
JRST KYPTR2 ;GO BACK FOR MORE KEYS
;HERE IF AN ERROR IF FOUND IN KYINFO. SET FI.KYE TO -1
; TO INDICATE ERROR, AND LEAVE LITERALS IN A GOOD STATE
KYIER: HRRZ TA,CURFIL
SETO TB, ;SET FIELD TO -1
DPB TB,FI.KYE## ;THE NEXT TIME, DON'T TRY TO GEN CODE
;FALL INTO KYPTR6, AS IF WE HAD FINISHED GENERATING ALL THE KEYS
;HERE WHEN DONE PUTTING ALL KEY INFO IN CONSTANT AREA
KYPTR6:
POPJ PP, ;SUCCESSFUL RETURN
SUBTTL KYINFO -- WRITE KEY BLOCK FOR EACH KEY
;
;;CALL: TA/ PTR TO KEY DATANAME
; EFLAGB/ LH = FLAGS TO PASS
;
; PUSHJ PP,KYINFO
; <RETURN HERE IF ERRORS>
; <RETURN HERE IF OK>
;
; THIS ROUTINE CHECKS THE RMS RESTRICTIONS ON KEYS
; PRESERVES TD
KYINFO: JUMPE TA,CPOPJ ;ERROR IF NO LINK
PUSH PP,TD ;PRESERVE AC
MOVEM TA,ETABLB ;USE "B" LOCATIONS FOR TEMP STORAGE
PUSHJ PP,LNKSET ;LOOK AT DATAB ENTRY
LDB TE,DA.ERR## ;ERROR BIT ON?
JUMPN TE,KYINF9 ;YES, RETURN ERROR
;CHECK FOR KEY MODE OF "DISPLAY", AND SAVE MODE IN EMODEB
LDB TE,DA.USG
SUBI TE,1
CAILE TE,DSMODE##
JRST KYINF8 ;GIVE ERROR
MOVEM TE,EMODEB ;SAVE IT
;CHECK FOR KEY SIZE TOO LARGE FOR RMS TO HANDLE
LDB TE,DA.INS## ;GET SIZE OF ITEM
CAILE TE,^D256 ;CHECK RMS LIMIT
JRST KYINF7 ;?TOO BIG, GIVE ERROR
MOVEM TE,ESIZEB ;SAVE SIZE
LDB TE,DA.RES## ;BYTE RESIDUE
HRLM TE,ERESB ;SAVE
;OK, EVERYTHING IS FINE.
; COMPUTE KEY OFFSET (BYTES) AND PUT IN EINCRB
LDB TE,DA.LOC## ;GET START OF THIS KEY
MOVE TD,EMODEB ;GET MODE OF THE DATA ITEM
MOVE TC,BYTE.W##(TD) ;TC= BYTES PER WORD
IMUL TE,TC ;START COMPUTING OFFSET
HLRZ TB,ERESB ;FIND BYTE OFFSET IN WORD..
MOVEI TC,^D36
SUB TC,TB ; (# BITS IN..)
IDIV TC,BYTE.S##(TD) ;DIVIDE BY BYTE SIZE
ADD TE,TC ;ADD IN BYTE OFFSET WITHIN WORD
MOVEM TE,EINCRB ;SAVE BYTE OFFSET INTO THE RECORD
;GENERATE THE TWO-WORD BLOCK
MOVE CH,[AS.OCT,,1] ;PUT OUT SIZE,,BYTE COUNT
PUSHJ PP,PUTAS2
AOS EAS2PC## ;ADVANCE STARTING PTR FOR AS2 FILE
HRLZ CH,EINCRB ;POSITION OF KEY IN THE RECORD
HRR CH,ESIZEB ;KEY SIZE IN BYTES
PUSHJ PP,PUTAS2
MOVE CH,[AS.OCT,,1] ;PUT OUT FLAGS,,DATA TYPE
PUSHJ PP,PUTAS2
AOS EAS2PC## ;ADVANCE STARTING PTR FOR AS2 FILE
HLLZ CH,EFLAGB ;FLAGS
HRR TA,EMODEB ;DATATYPE (0=SIXBIT, 1=ASCII, 2=EBCDIC)
PUSHJ PP,PUTAS2
POP PP,TD ;RESTORE AC
AOS 0(PP) ;GOOD RETURN
POPJ PP,
;ERROR ROUTINES
;SIZE OF KEY TOO LARGE
KYINF7: MOVEI DW,E.628 ;KEY LARGER THAN 256
JRST KYIN8A
;KEY NOT DISPLAY MODE
KYINF8: MOVEI DW,E.627 ;MODE NOT DISPLAY
KYIN8A: LDB LN,DA.LN ;POINT TO DATANAME DEFINITION FOR THIS ERROR
LDB CP,DA.CP ; (IT WILL ONLY HAPPEN ONCE)
PUSHJ PP,FATAL
JRST KYINF9
;HERE IF ERRORS OCCUR IN KYINFO ROUTINE
KYINF9: POP PP,TD ;RESTORE AC
POPJ PP, ;ERROR RETURN
END