Trailing-Edge
-
PDP-10 Archives
-
BB-H506E-SM
-
cobol/source/cleanc.mac
There are 20 other files named cleanc.mac in the archive. Click here to see a list.
; UPD ID= 3443 on 3/9/81 at 8:41 PM by NIXON
TITLE CLEANC FOR COBOL V12C
SUBTTL CLEANUP AFTER PHASE C W.NEELY/CAM
SEARCH COPYRT
SALL
COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1974, 1985
;ALL RIGHTS RESERVED.
;
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
;ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
SEARCH P
%%P==:%%P
ISAM==:ISAM
RPW==:RPW
;EDITS
;NAME DATE
;
;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
;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
;SMI 27-OCT-82 [1427] 68274 Gives warning SHOULD BE UNSIGNED INTEGER
; when data item is an unsigned integer.
;SMI 15-OCT-82 [1417] FIX 68274 CONVERSION OF WRITE
;DMN 12-MAR-82 [1340] 68274 converter does not flag JUSTIFIED clause
; in VALUE
;JEH 02-FEB-82 [1335] Declare DATAB entries for all indexes if
; REPORT SECTION is scanned for their use by REPORT
; WRITER stmts
;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
IFN RPW,<EXTERN RPTSRT,RPTRPT,RPTNEW,RPTRHT,RPTNHT,RPTCIT,RPTCID,RPTNID,RPTFIN>
EXTERN TEMLOC,CURTEM,HL.CID,HL.RD ; [415]
%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:
PUSH PP,TA ;[1417]
MOVE TA,FILLOC ;[1417] GET LOCATION OF FILE ENTRY
CAMN TA,FILNXT ;[1417] ANY FILTAB ENTRIES ?
JRST CLNAC2 ;[1417] NO
HRRZI TA,SZ.DEV ;[1417] SET UP ABSOLUTE ADDRESS TO FILTAB
ADDM TA,FILTBL## ;[1417]
HRRZI TA,CD.FIL*1B20+1 ;[1417]
CLNACC: HRLZM TA,CURFIL ;[1417]
PUSHJ PP,LNKSET ;[1417]
HRRM TA,CURFIL ;[1417]
LDB TB,FI.ACC ;[1417] GET FILE ACCESS MODE
CAIE TB,%%ACC ;[1417] ACCESS SPECIFIED ?
JRST CLNAC1 ;[1417] YES
HRRZI TB,%ACC.S ;[1417] NO, ASSUME SEQUENTIAL
DPB TB,FI.ACC ;[1417] STORE ACCESS MODE
CLNAC1: LDB TA,FI.NXT ;[1417] GET NEXT FILTAB ENTRY
JUMPN TA,CLNACC ;[1417] FINISHED ?
CLNAC2: POP PP,TA ;[1417] YES
IFN ANS74,<
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 INDEXES,
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
IFN RPW,<
SKIPE BLDIX ;[1335] IF JUST BUILDING INDEXES,
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]
SKIPA ; [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
JRST CLHLFL ;5: STORE LOW FILE-LIMIT DATAB LINK
JRST CLHHFL ;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
IFN RPW,<
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)
>
IFE RPW,<REPEAT 4,<0>>
IFN ISAM,<
JRST CLHSKY ;15: STORE SYMBOLIC KEY DATAB LINK
JRST CLHRKY ;16: STORE RECORD KEY DATAB LINK
>
IFE ISAM,<REPEAT 2,<0>>
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)
IFN ISAM&ANS74,<JRST CLHAKY> ;23: STORE ALTERNATE KEY LINK
IFE ISAM&ANS74,<0>
; 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,5 ;ROUND UP + STANDARD # OF HALFWORDS
LSH TB,-1 ;DIVIDED BY 2
ADDM TB,CURHLD ;AIM AT NEXT HLDTAB ENTRY
JRST CLNHLD
IFN RPW,<
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 NEST 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
RPTST1: LDB TB,TC ; [415] SEE IF ALREADY STORED
SKIPE TB ; [415]
PUSHJ PP,CLHDUP ; [415] YES GIVE DUPLICATE ERROR
DPB TE,TC ; [415] STORE THE NEW ITEM
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,5 ; [415] GO FIND NEXT HLDTAB
LSH TB,-1 ; [415] 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
IFN RPW,<
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: PUSHJ PP,CLNHLQ ; [415] PICK UP ANY QUALIFIERS
SUB TA,FILLOC ;NOT FILTAB REF. BUT RPWTAB
ADD TA,RPWLOC
PUSH PP,TE ;SAVE AC'S
PUSH PP,TA ;SAVE RPWTAB PTR
HRRZI TA,(TE) ;MAKE PTR TO DATA ITEM
PUSHJ PP,LNKSET##
LDB TB,DA.RPW ;GET LINK TO CORRESP RPW ITEM
HRRZ TA,RPWLOC ;MAKE PTR TO RPWTAB ENTRY
ADDI TA,(TB)
LDB TB,RW.TYP## ;MUST BE TYPE DETAIL
CAIE TB,%RG.DE
PUSHJ PP,CLHUPE ;IT'S NOT
SETO TB, ;SET REFERENCED-BY-SUM-UPON BIT
DPB TB,RW.RSU##
POP PP,TA ;GET BACK AC'S
POP PP,TE
MOVE TC,RW.UPN## ;GET PTR TO UPON CLAUSE LINK
JRST RPTST1 ; [415] PUT LINK IN RPWTAB 'UPON'
CLHUPE: HRRZI DW,E.364 ;?SUM UPON MUST REF. TYPE DETAIL
JRST CLHBA1
;MAKE A SUM COUNTER FOR DATAB ITEM
CLHSCT: SKIPGE RPWERR ; [335] FATAL REPORT GENERATOR ERROR
JRST RPTDOE ; [415] CANT GO ON
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 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: LDB TB,DA.RDS## ;GET SOURCE FOR DETAIL BIT
JUMPE TB,SUMCKE ;NOT ON
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,
>;END IFN RPW
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
IFN ANS74,<
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:>
IFN ANS68,<
LDB TB,DA.USG ;[164] GET USAGE
CAIE TB,%US.1C ;[164] LEGAL ONLY IF 1-WORD COMP
CAIN TB,%US.IN ;[164] OR INDEXED
CAIA ;[164] OK
PUSHJ PP,CLE347 ;[164] ERROR
>
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
IFN ISAM,<
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
IFN ANS74,<
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,CP; 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
>;END IFN ANS74
>;END IFN ISAM
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
IFN ANS68,<
MOVE TA,CURFIL ;RESTORE FILTAB PTR
CAIE TB,%US.1C ;1-WORD COMP?
PUSHJ PP,CLHBAD ;NO
CAILE TC,^D10 ;10 DIGITS OR LESS?
PUSHJ PP,CLHSIZ ;NO
>
IFN ANS74!FT68274,<
PUSH PP,TE
IFN FT68274,< ;[1427]
PUSHJ PP,CLHSUB ;[1427] GET USAGE OF DATA ITEM
> ;[1427]
LDB TE,DA.SGN ;SEE IF SIGNED
LDB TA,DA.NDP ;OR NOT INTEGER
SKIPN TE
SKIPE TA
PUSHJ PP,CLHE40 ;SHOULD BE UNSIGNED INTEGER
POP PP,TE
MOVE TA,CURFIL ;RESTORE FILTAB PTR
>
IFN ANS74,<
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:
IFN ANS68,<
AECK3 2,CLHER6 ;NUMERIC DISPLAY, 2 CHARS.
>
IFN ANS74,<
AECK3 2,CLHE68 ;ALPHANUMERIC OR NUMERIC DISPLAY, 2 CHARS.
>
AECK3 12,CLHER6 ;NUMERIC DISPLAY, 10 CHARS.
EXP KILL## ;INDEX, CAN'T GET HERE.
AECK3 11,CLHER8 ;ALPHANUMERIC DISPLAY, 9 CHARS.
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.
CLHE7E: POP PP,TA ;RESTORE THE STACK.
JRST CLNHL9 ;GO LOOK FOR MORE HLDTAB ITEMS.
IFN ANS74,<
;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.
IFN ANS74!FT68274,<
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##
>
;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
CAIE TC,^D9 ;9 CHARS?
PUSHJ PP,CLHSIZ ;NO
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
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
CLHLFL: SKIPE TBLOCK+4 ;UNDEFINED?
JRST CLHLFX ;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
MOVE TA,TBLOCK+1 ;GET BACK STORAGE PTR
CLHLFX: HRLM TE,(TA) ;STORE DATAB LINK
JRST CLNHL9 ;GO BACK FOR NEXT HLDTAB ENTRY
CLHHFL: SKIPE TBLOCK+4 ;UNDEFINED?
JRST CLHHFX ;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
MOVE TA,TBLOCK+1 ;GET BACK STORAGE PTR
CLHHFX: HRRM TE,(TA) ;STORE DATAB LINK
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,15 ;[162] IF FLAG ON AND CODE IS SYM-KEY
CAIG TC,6 ;[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]
IFN ANS68,<
CLE347: HRRZI DW,E.347 ;[164] DEPEND ITEM MUST BE COMP
JRST CLHBA1 ;[164]
>
CLNFIL: 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
IFN RPW,<
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:
IFN RPW,<
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
IFN ANS74,< ;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,DI UNLESS WE CAN GUESS THAT THE USER MEANT SOMETHING ELSE.
;HE SPECIFIED ALTERNATE KEYS WE WILL COMPLAIN AND SET THE ORGANIZATION TO "INDEXED".
LDB TB,FI.ORG ;GET ORGANIZATION
CAIE TB,%%ACC ;UNSPECIFIED?
JRST CLNC1 ;NO, SKIP THIS
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
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.ACC##
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:
>;END IFN ANS74
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
IFN ANS68, LDB TC,FI.ACC## ;INDEXED?
IFN ANS74, LDB TC,FI.ORG##
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: SETZ TA,
PUSHJ PP,PUTVAL
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:
IFN ANS68,<
LDB TB,FI.NFL##
JUMPLE TB,CHID ;NO FILE LIMITS
ASH TB,1
MOVEM TB,CFLM##
ADDI TA,SZ.FIL
HRLI TA,442200
MOVEM TA,PNTS##
PFL1: ILDB TA,PNTS
SETZ TE,
JUMPE TA,PFCNT
LDB TB,[POINT 3,TA,20]
CAIE TB,CD.VAL
JRST PFC1
PUSHJ PP,GETTAG
MOVEM CH,TBLOCK+12
PUSHJ PP,PUTTAG
HRLZM TA,CURVAL
PUSHJ PP,LNKSET
HRRM TA,CURVAL
HRRZI TA,1
PUSHJ PP,PUTVAL
MOVE TE,TBLOCK+12
PFCNT: DPB TE,PNTS
PFC1: SOSLE CFLM
JRST PFL1
>
IFN ANS74,<
;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
>
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
SETZ TA,
PUSHJ PP,PUTVAL
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
CAIN TB,^D9 ;MUST BE NINE CHARACTERS
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
HRLZI CH,AS.XWD##
HRRI CH,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
CHID3: HRRZ TA,CURFIL
LDB TB,FI.VDW
JUMPE TB,CHDATS ;NO VALUE-OF-DATE-WRITTEN
LDB TC,[POINT 3,TB,20]
CAIE TC,CD.VAL
JRST CHDATS ;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
SETZ TA,
PUSHJ PP,PUTVAL
;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,CLNCUP ;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
HRRZ TA,CURDAT ;[1502] RESTORE HERE
CAML TE,TD ;[1502] IS CURRENT 01 LEVEL SMALLER
JRST CHDA.3 ;[1502] THAN MAX FOUND?
MOVEI DW,E.660 ;[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,CLNCUP ; A FATHER?
LDB TA,DA.BRO ;NO--LOOK AT NEXT RECORD
JUMPN TA,CHDA.1
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
HRLI TA,440700
ILDB TD,TA
MOVEM TD,CTR
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
PUTVAL: JUMPL TA,PVOUT
CAILE TA,1
JRST PVOUT
HRLZI TB,440700
HRR TB,CURVAL
MOVEM TB,PNTR##
ILDB TC,PNTR
MOVEM TC,CTR
JRST .+1(TA)
JRST PV.SXB
MOVE CH,[XWD 610000,1]
PUSHJ PP,PUTAS2
MOVE TD,PNTR
PUSHJ PP,GETV2##
MOVE CH,TC
PUSHJ PP,PUTAS2
AOS EAS2PC
POPJ PP,
PV.SXB: ADDI TC,5
IDIVI TC,6
MOVEM TC,TBLOCK+1
HRLZI CH,620000
HRR CH,TC
PV.1: PUSHJ PP,PUTAS2
MOVE TA,[POINT 6,CH]
SETZ CH,
HRRZI TE,6
PV.2: ILDB TB,PNTR
CAIN TB,":"
HRRZI TB,"-"
CAIN TB,";"
HRRZI TB,"."
SUBI TB,40
IDPB TB,TA
SOSG CTR
JRST PV.3
SOJG TE,PV.2
JRST PV.1
PV.3: PUSHJ PP,PUTAS2
MOVE TA,CURVAL
LDB TC,[POINT 7,(TA),6]
ADDI TC,5
IDIVI TC,5
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,
PVOUT: MOVE CH,[XWD 610000,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
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
IFN ANS74,<
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
IFN FT68274,<
LDB TC,DA.JST ;[1340]
MOVEI DW,E.768 ;[1340]
SKIPE TC ;[1340] SKIP IF NO "JUSTIFIED" CLAUSE
PUSHJ PP,WARN ;[1340] OTHERWISE WARN USER OF DIFFERENCE
>
IFN ANS68, LDB TC,DA.JST##
IFN ANS74, 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.
MOVEM TE,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.
SKIPN TA,CURLIT
POPJ PP,
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.1
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.
;ALL WAS SPECIFIED AND THE LITERAL IS SMALLER THAN THE ITEM.
; (TC) = 1 IF THE ITEM IS JUSTIFIED RIGHT
; 0 OTHERWISE.
AJNN.1: JUMPE TC, AJNN.X ;IF THE ITEM IS NOT JUSTIFIED
; RIGHT, GO ON.
PUSHJ PP, ADJALP ;GO SEE IF THE ITEM IS ALPHABETIC.
MOVE TB, NCHLIT ;NUMBER OF CHARS IN THE LITERAL.
MOVEM TB, NCHLI2 ;NUMBER OF CHARS IN THE 2ND THROUGH
; NTH REPITITIONS OF THE LITERAL.
MOVE TC, NCHITM ;NUMBER OF CHARS IN THE ITEM.
IDIVI TC, (TB) ;(TB) = # OF CHARS IN THE FIRST
; REPITITION OF THE LITERAL.
MOVE TC, BYTEPT ;BYTE POINTER TO THE LITERAL.
MOVEM TC, BYTEP2 ;BYTE POINTER FOR 2ND THROUGH
; NTH REPITITIONS OF THE LITERAL
JUMPE TB, CPOPJ ;IF THERE ARE NO CHARS IN THE FIRST
; REPITITION, LEAVE.
EXCH TB, NCHLIT
SUB TB, NCHLIT ;(TB) = # OF CHARS TO SKIP THE
; FIRST TIME.
IBP TC ;SKIP OVER SOME CHARS.
SOJG TB, .-1
MOVEM TC, BYTEPT ;BYTE POINTER FOR FIRST REPITITION
; OF THE LITERAL.
POPJ PP, ;RETURN.
;LITERAL IS SMALLER THAN THE ITEM AND ALL WAS NOT SPECIFIED.
AJNN.2: JUMPE TC,AJNN.3 ;IF THE LITERAL SHOULD BE RIGHT
HRRZM TB,NPADL## ; JUSTIFIED, PADD ON THE LEFT.
JRST AJNN.X
AJNN.3: HRRZM TB,NPADR## ;OTHERWISE, 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.
JUMPE TC,AJNN.5 ;IF THE LITERAL SHOULD BE RIGHT
SUBI TD,(TB) ; JUSTIFIED SKIP SOME CHARACTERS
IBP BYTEPT ; SO THAT IT WILL BE TRUNCATED
SOJG TD,.-1 ; ON THE LEFT.
AJNN.5: 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.
IFN ANS68,<
CAIE TD,TALLY-HIVAL. ;SPECIAL CASE TALLY (SEE TABLE "FIGC".)
>
CAILE TD,5
JRST AJNN.7
IMULI TD,3
IFN ANS74,<
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.657 ;[1500] OTHERWISE GIVE WARNING
CAIE TB,HIVAL. ;[1500]
JRST WARN## ;[1500]
HRRZI DW,E.655 ;[1500] HIGH-VALUES DISPLAY MODE
CAILE TC,%US.DS ;[1500]
HRRZI DW,E.656 ;[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 TO COMP-3.
1 ==> CONVERT TO SIXBIT.
2 ==> NO CONVERSION.
3 ==> CONVERT TO EBCDIC.
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 GETCH9 ; CHARS FROM THE LITERAL AND RETURN
; ONE NINE BIT BYTE.
IFN ANS74,<
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.
IFN ANS74,<
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.
;RETURN A PADD CHAR.
GETCH6: HRRZ TC, PADCHR ;GET A PADD CHAR.
IFN ANS74,<
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
;COME HERE IF THE ITEM IS COMP-3.
GETCH9: 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
IFN ANS74,<
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##
IFN ANS74,<
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: MOVEM TD,VALUE1
MOVEM TC,VALUE2
POPJ PP,
AJUC2: JFCL ;SAME AS COMP-1 FOR 12B
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
END