.TITLE XVM FORTRAN IV COMPILER, PART 1
/
/
/ FIRST PRINTING, FEBRUARY, 1975
/
/ THE INFORMATION IN THIS DOCUMENT IS SUBJECT TO
/ CHANGE WITHOUT NOTICE AND SHOULD NOT BE CONSTRUED
/ AS A COMMITMENT BY DIGITAL EQUIPMENT CORPORATION.
/ DIGITAL EQUIPMENT CORPORATION ASSUMES NO RESPON-
/ SIBILITY FOR ANY ERRORS THAT MAY APPEAR IN THIS
/ DOCUMENT.
/
/ THE SOFTWARE DESCRIBED IN THIS DOCUMENT IS FUR-
/ NISHED TO THE PURCHASER UNDER A LICENSE FOR USE ON
/ A SINGLE COMPUTER SYSTEM AND CAN BE COPIED (WITH
/ INCLUSION OF DIGITAL'S COPYRIGHT NOTICE) ONLY FOR
/ USE IN SUCH SYSTEM, EXCEPT AS MAY OTHERWISE BE PRO-
/ VIDED IN WRITING BY DIGITAL.
/
/ DIGITAL EQUIPMENT CORPORATION ASSUMES NO RESPONSIBILITY
/ FOR THE USE OR RELIABILITY OF ITS SOFTWARE ON EQUIP-
/ MENT THAT IS NOT SUPPLIED BY DIGITAL.
/
/ COPYRIGHT (C) 1974, 1975 BY DIGITAL EQUIPMENT CORPORATION
/
/
.EJECT
/
/ PART 1 OF TWO PART SOURCE FILE OF FORTRAN IV COMPILER. THE SAME
/ EDIT NUMBER AND SOURCE FILE EXTENSION IS MAINTAINED FOR BOTH PARTS.
/
/
/EDIT #46 4 FEB 74 *TAM-43 THROUGH 38*37-REF*
/
/FORTRAN 4 COMPILER
/ EDIT DATE VERSION PROGRAMMER FIX
/ 050 24-NOV-74 V3A001 R.K. HYATT CORRECTED >0E < PROB - IN PART 2
/
/ 051 24-NOV-74 V3A002 R.K. HYATT CORRECTED NONDETECTION OF
/ MISSING PAREN IN IMPLIED DO LOOPS
/ INCLUDED NEW ERROR MESSAGE >33X<
/
/ 052 24-NOV-74 V3A003 R.K. HYATT CORRECTED NONDETECTION OF GARBAGE
/ AT END OF EXPRESSION IN ASSIGNMENT STATEMENTS
/ INCLUDED NEW ERROR MESSAGE >34X<
/
/ 053 26-NOV-74 V3A004 R.K. HYATT CORRECTED INFINITE LOOPING
/ ON ERROR MESSAGE DUE TO COMMAND SYNTAX ERROR
/
/ 054 27-NOV-74 V3B000 R.K. HYATT CHANGED VERSION NUMBER TO V3B000
/ FOR B UPDATE OF DOS - IN PART TWO
/
/ 055 16-JAN-75 V3B000 R.K. HYATT CORRECTED DOS INIT PROBLEM
/
/ 056 31-JAN-75 V3B001 R.K. HYATT REMERGED DOS AND RSX COMPILERS
/ AND DELETED MODE BITS FROM HIGH ORDER VECTORS BITS
/
/ 057 3-FEB-75 V3B002 R.K.HYATT CORRECTED NONDETECTION OF
/ REDUNDENT EQUIVALENCE STATEMENTS - NEW ERROR
/ MESSAGE >17C< - SPR#15-714
/
/ 058 3-FEB-75 V3B003 R.K. HYATT INSERTED CHECK FOR UNBALANCED - SPR#15-822
/
/ 059 3-FEB-75 V3B004 R.K. HYATT CORRECTIONS FOR IMPROPER
/ EVALUATION OF 'IF5' - SPR#15-822
/
/ 060 11-FEB-75 V3B005 R.K. HYATT CORRECTIONS TO DETECT UNDEFINED
/ FUNCTION DEFENITIONS - SPR#15-E737
/
/ 061 20-FEB-75 V3B006 R.K. HYATT CHANGED 'HELLO' TO XVM 'VERSION' FOR PDP15
/
/ 062 21-MAY-75 R.K. BLACKETT REMOVED ANTIQUE CONDITIONAL ASSEMBLY
/ PARAMETERS IN PREPERATION TO XVM VERSIONS.
/
/ 063 22-MAY-75 V1X000 R.K. BLACKETT CHANGE CODE GENERATED FOR
/ LOGICAL .OR. TO DO A BOOLEAN INCLUSIVE OR.
/
/ 064 22-MAY-75 V1X001 R.K. BLACKETT FIX FORMAT STATEMENT CHECKER
/ TO DETECT MISSING OPENING PAREN
/
/ 065 30-JUL-75 V1X002 R.K. BLACKETT FIX ERROR IN EDIT 062.
/ FOUR LINES WERE ERONEOUSLY DELETED
/ AFTER LABEL 'DDCHK'.
/
/ 066 29-AUG-75 V1X003 R.K. BLACKETT GIVE FORTRAN A "HEADER LINE'
/ AT THE TOP OF EACH LISTING PAGE, AND
/ COUNT LINES/PAGE. ALSO FIXED A BUG
/ SUCH THAT A COMMA IN THE COMMAND STRING
/ WILL NOW GIVE AN ERROR, RATHER THAN
/ SEEK THE WRONG FILE NAME.
/
/ 067 18-SEP-75 V1A000 R.K. BLACKETT ADD 'SIZE =' AND 'XX ERRORS'
/ MESSAGES. ALSO REMOVED BOSS CONDITIONALS
/ AND CHANGED THE HELLO TO 'XVM V1A000'.
/
/ 068 11-NOV-75 V1A000 R.K. BLACKETT FIX HEADER LINE FROM GOING
/ TO -12 WHEN NO LISTING REQUIESTED
/ ALSO, COMPLETE RSX CODE IN HEADER.
/
/ 069 17-NOV-75 V1A000 R.K. BLACKETT PUT IN CONDITIONAL ASSEMBLY
/ PARAMETERS TO ELIMINATE EITHER
/ THE LISTING TOF HEADING LINE, OR
/ END OF COMPILATION SIZE/ERROR
/ COUNT MESSAGE. THIS IS A TEMPORARY
/ SITUATION DUE TO THE RSX VERSION
/ BEING > 8K WITH THESE FEATURES.
/
/ 070 23-DEC-75 V1A000 R.K. BLACKETT PRECEED RSX'S HELLO MESSAGE
/ WITH A LEGAL HEADER WORD PAIR,
/ SINCE SOME RSX HANDLERS (LP FOR
/ EXAMPLE) ARE PICKIER THAN TT.
/
/ 071 27-FEB-76 V1A001 R.K. BLACKETT FIX BUG IN 'SINP00' WHICH
/ CAUSED THE LINE FOLLOWING A COMMENT
/ LINE OF THE FORM 'C [TAB] "' TO BE
/ MARKED IN ERROR >01I<. SPR 9-485.
/
/ 072 12-MAR-76 V1A002 G. A. REID FIX PROBLEM WHICH WOULD SOMETIMES
/ CAUSE ARRAY LENGTHS TO BE INCORRECTLY
/ CALCULATED WHEN THEY WERE USED AS A DUMMY
/ PARAMETER IN A SUBROUTINE. (SPR 15-1093)
/
/ 073 17-MAR-76 V1A003 R. K. BLACKETT FIX A PROBLEM IN THE
/ EXPRESSION ANALYZER SUCH
/ THAT IT MAY NOT ALWAYS DETECT
/ ERRORS OF THE FORM "A=(B)(C)"
/ NOW ISSUES >14S< (TWO ARGS
/ TOGETHER). SPR 1087.
/
/ 074 18-MAR-76 V1A004 G. A. REID FIX SO THAT 18-BIT PARTWORD
/ RESULTS ARE NOT INCORRECTLY
/ TYPED AS DOUBLE INTEGER AND
/ SUBSEQUENTLY CONVERTED IN-
/ ACCURATELY. (SPR 15-1031)
/
/ 075 8-AUG-76 V1A005 G. A. REID CHANGE SO THAT THE RSX VERSIONS
/ WRITE A FORM FEED ON NON-FILE
/ STRUCTURED LISTING DEVICES, I.E.
/ THE LINE PRINTER ET AL. THIS CHANGE
/ WILL PREVENT THE LISTINGS FROM MULTIPLE
/ COMPILATION RUNS FROM BEING JAMMED
/ AGAINST EACH OTHER. THIS WILL WORK
/ PROPERLY WITH XVM/RSX V1B000 AND LATER
/ SYSTEMS.
/
/
.TITLE XVM FORTRAN IV, ASSEMBLY PARAMETERS
/ IF RSX DEFINED MAKE RSX VERSION
/ IF %FPP DEFINED MAKE VERSION TO USE FLOATING HARDWARE
/ IF %ARGOP IS DEFINED IT IS TAKEN AS THE LENGTH OF THE ARG-OP TABLE
/
.EJECT
.IFDEF RSX
/
%NOHDG=0 /(RKB-069) NO HEADING FOR NOW WITH RSX
%NOEOC=0 /(RKB-069) NO END OF COMPILATION MSG, EITHER.
ECLA=641000
/ RSX PARAMETER DEFINITIONS
/
.IFUND DAT2
DAT2=14
.ENDC
.IFUND DAT3
DAT3=15
.ENDC
.IFUND DAT11
DAT11=17
.ENDC
.IFUND DAT12
DAT12=20
.ENDC
.IFUND DAT13
DAT13=21
.ENDC
.ENDC
/
/
/
.IFUND %ARGOP
%ARGOP=101
.ENDC
.IODEV -11,-12,-13
.TITLE XVM FORTRAN IV, MACRO DEFINITIONS
.DEFIN SYN,A
A .DSA 0 /PUT TWO TAGS ON THIS LOCATION
.ENDM
.DEFIN BLK,N
.LOC .+N
.ENDM
.DEFIN OPCOD,A
A@CMD A
.SIXBT +A+
.ENDM
/
/ ERROR MACROS - TWO SETS, BASIC AND EXPANDED
/
.DEFIN ERN,A,B,C
C@A JMS ERRORN
.ASCII + @A+
.LOC .-2
B
.LOC .+1
.ENDM
/
.DEFIN ERS,A,B,C
C@A JMS ERRORS
.ASCII + @A+
.LOC .-2
B
.LOC .+1
.ENDM
/
.DEFIN ERR,A,B,C
C@A .ASCII + @A+
.LOC .-2
JMS ERROR1
.LOC .+1
.ENDM
/
.DEFIN ERX,A,C
C@A JMS ERRORS
.ASCII + @A+
.LOC .-2
SKP
.LOC .+1
.ENDM
/
/ MACROS TO GENERATE FPP INSTRUCTIONS OR SUBROUTINE NAMES
.IFDEF %FPP
.DEFIN FPPIN,A,B
B
.ENDM
.ENDC
.IFUND %FPP
.DEFIN FPPIN,A,B
A
.ENDM
.ENDC
.TITLE
.TITLE ONCE-ONLY INITIALIZATION CODE
/BANK-BIT INITIALIZATION-OVERLAYED
/
BEGIN=.
.IFUND %NOHDG /(RKB-069) DON'T DO THIS IF WE DON'T WANT IT
.IFUND RSX /(RKB-066)
LAC* SC.DATE /(RKB-066) GET THE DATE
LRSS 14 /(RKB-066) POSITION TO MONTH
.ENDC /(RKB-067)
.IFDEF RSX /(RKB-067)
CAL GTDATE /(RKB-067)
LAC GTDATE+2 /(RKB-067)
.ENDC /(RKB-067)
RCL /(RKB-066) EACH ENTRY IN MONTAB IS TWO WORDS LONG
TAD MONTAB /(RKB-066) FIND THIS MONTH
DAC MONTAB /(RKB-066)
LAC* MONTAB /(RKB-066) MOVE THREE CHARACTER MONTH INTO PRINT LINE
DAC TOF+14 /(RKB-066) //
ISZ MONTAB /(RKB-066) //
LAC* MONTAB /(RKB-066) //
DAC TOF+15 /(RKB-066) //
.IFUND RSX /(RKB-067)
LAC* SC.DATE /(RKB-066) GET THE DATE BACK
LRS 6 /(RKB-066) POSITION TO DAY IN 12-17
AND S00077 /(RKB-066) CLEAN IT UP
.ENDC /(RKB-067)
.IFDEF RSX /(RKB-067)
LAC GTDATE+3 /(RKB-067)
.ENDC /(RKB-067)
JMS GT2D /(RKB-066) GET TWO DECIMAL CHARACTERS
DAC TOF+13 /(RKB-066) PUT DAY IN PRINT LINE
.IFUND RSX /(RKB-067)
LAC* SC.DATE /(RKB-066) NOW GO FOR YEAR
AND S00077 /(RKB-066) STRIP IT
AAC 106 /(RKB-066) YEAR IS HELD AS YEARS SINCE 1970
.ENDC /(RKB-067)
.IFDEF RSX /(RKB-067)
LAC GTDATE+4 /(RKB-067)
.ENDC /(RKB-067)
JMS GT2D /(RKB-066) GET TWO DECIAMAL CHARACTERS
LLSS 3 /(RKB-066) POSITION ANSWER
AAC 4 /(RKB-066) PAD WITH BLANK
DAC TOF+16 /(RKB-066) AND PUT YEAR IN PRINT LINE
.IFUND RSX /(RKB-067)
ISZ SC.DATE /(RKB-066) NOW WORD POINTS TO TIME
LAC* SC.DATE /(RKB-066) GET TIME OF DAY
LRSS 14 /(RKB-066) POSITION HOURS
.ENDC /(RKB-067)
.IFDEF RSX /(RKB-067)
LAC GTDATE+5 /(RKB-067)
.ENDC /(RKB-067)
JMS GT2D /(RKB-066) GET 2 CHARACTERS
ALS 3 /(RKB-066) SLIDE IT
AAC 7 /(RKB-066) MAKE SURE ':' PRINTS
DAC TOF+20 /(RKB-066) PUT HOURS IN PRINT LINE
.IFUND RSX /(RKB-067)
LAC* SC.DATE /(RKB-066) GET THE TIME
LRS 6 /(RKB-066) POSITION FOR MINUTES
AND S00077 /(RKB-066) CLEAN IT UP
.ENDC /(RKB-067)
.IFDEF RSX /(RKB-067)
LAC GTDATE+6 /(RKB-067)
.ENDC /(RKB-067)
JMS GT2D /(RKB-066) CONVERT TO ASCII
XOR U00000 /(RKB-066) BUILD IN BOTTOM PART OF ':'
DAC TOF+21 /(RKB-066) AND PUT MINUTES IN PRINT LINE
.ENDC /(RKB-069)
LAC DLNOP
DAC RSTRT
.IFUND RSX
LAC* S00100
AND S70000 /GET BANK BITS
DAC BNKBTS
/
/ONCE-ONLY INITIALIZATION-OVERLAYED
/
OVRLAY CAL+775
1
INIT02
0
LAC* S00103
.ENDC
.IFDEF RSX
CAL PARTDV /READ THE PARAMETERS FROM TDV
LAC PAREV /PICK UP THE EVENT VARIABLE
SPA /IS IT LEGAL?
JMP REQERR /NO -- ILLEGAL TDV REQUEST ERROR
CAL PREA11 /PREALLOCATE INPUT BUFFER
CAL WFEVA /WAIT FOR EVENT VARIABLE
LAC EVA
SMA
JMP .+4
SAD (-6) /-6 LEGAL
SKP
JMS IOERR /OTHER ERROR POSSIBLY NOT ENUF CORE
LAC (DAT11)
JMS SIN520 /READ THE SWITCHES FOR BUFFER ALLOCKATION
BUFAL1 JMS SIN500 /READ CHARS THRU THE 1ST SPACE SINCE TDV...
SAD CHARSP /WON'T STRIP OFF THE EXTRA CHARS. IS IT A SPACE?
JMP BUFAL /YES -- PROCEED TO LOOK FOR SWITCHES
SAD CHARLT /NO -- ALTMODE?
JMP CMDERR /YES -- ERROR
SAD CHARCR /NO -- CARRIAGE RETURN?
JMP CMDERR /YES -- ERROR
JMP BUFAL1 /NO -- IGNORE THE CHAR AND CONTINUE TO LOOK FOR A SPACE.
BUFAL JMS SIN500
SAD CHARLT /ALTMODE?
JMP CMDERR /YES COMMAND ERROR
SAD CHARCR /CRTN?
JMP CMDERR /YES ERRROR
SAD CHARB /B?
JMP CHBB /ALLOCATE A BUFFER FOR IT
SAD CHARL /L?
JMP CHLL /ALLOCATE A BUFFER FOR IT
SAD CHARO /O?
JMP CHLL /SAME AS L
SAD CHARS
JMP CHLL /SAME AS L
SAD ARROW /END OF COMMAND STRING?
JMP CMDEND
JMP BUFAL /NO TRY AGAIN
/
CHBB CAL PREA13
LAC (JMP BUFAL) /ONLY DO IT ONCE
DAC CHBB
CAL WFEVA /WAIT FOR EVENT VARIABLE
BUFEVC LAC EVA /CHECK EVENT VARIABLE
SMA /IS IT LEGAL?
JMP BUFAL /YES GO DECODE AGAIN
SAD (-6) /-6 IS ALSO LEGAL
JMP BUFAL
JMS IOERR /OTHER ERROR POSSIBLY NOT ENUF CORE
LAC (DAT13)
/
CHLL CAL PREA12 /PREALLOCATE LISTING DEVICE
CAL WFEVA
LAC (JMP BUFAL) /ONLY DO IT ONCE
DAC CHLL
JMP BUFEVC /CHECK EVENT VARIABLE
CMDEND CAL PARSIZ /FIND THE PARTITION SIZE
LAC ENDPAR /PICK UP THE END OF AVAILABLE MEMORY
.ENDC
DAC ENDINT
.IFDEF RSX
AND S60000 /GET BANK BITS
DAC BNKBTS /SET IN BANK BITS FLAG
SNA /CHECK FOR ZERO
JMP HELPP /BOOBY TRAPED IF BANK BITS ARE 0 !!!!!!!
.ENDC
.IFUND RSX
N00767 CAL 767 /.INIT INPUT (-11)
1
INIT02
0
LAC .-1
AND S00200
.ENDC
.IFDEF RSX
LAC (DAT11) /ATTACH TO INPUT DEVICE
JMS ATTACH
CAL HINF /DO A HANDLER INFORMATION TO FIND OUT IF DIRECTORY DEVICE
CAL WFEVA /WAIT FOR EVENT VARIABLE
LAC EVA /PICK UP THE EVENT VARIABLE
AND (040000) /MASK OFF THE DIRECTORY BITS
.ENDC
SZA
LAC DLJMP /BULK STORAGE
SNA
LAC DLNOP /NOT BULK STORAGE
DAC EPS1SW /INTO END PASS 1 SWITCH
LAC DLCR
DAC SINBFH+44
CLC
TAD ENDINT
DAC CONTB0
.IFUND RSX
LAC* S00102
.ENDC
.IFDEF RSX
LAC SIZECP /PICK UP THE SIZE OF THE PARTITION INDICATOR
.ENDC
DAC .FFREE
LAC DL155
DAC BINBFH
.IFDEF RSX
JMP STARTI /START UP INIT FINISHED
HELPP CAL HELPM /NOT ENUF CORE
JMS WFEV /WAIT FOR EVENT VARIABLE
LAC C00013 /LUN INCASE OF I/O ERROR
CAL C00008 /EXIT
/
HELPM 2700
EVA
15 /ON LUN 13
2 /IOPS ASCII
HELPMS /BUFFER
HELPMS 6002 /HEADER
0
.ASCII /FOR-PARTITION TOO SMALL/<15>
REQERR CAL REQMS /TDV ERROR
JMS WFEV /WAIT FOR EVENT VARIABLE
LAC C00013 /LUN IN CASE OF I/O ERROR
DAC TITLEA
JMP EXITF
/
REQMS 2700
EVA
15 /LUN 13 TDV OUTPUT DEVICE
2 /ASCII
REQERM /MESSAGE
REQERM 6002 /HEADER
0 /CHECKSUM
.ASCII /FOR-TDV ERR/<15>
.ENDC
.IFUND RSX
JMP INIT02
.ENDC
DL155 15500
DLCR 64000
ENDINT BEGIN
.IFUND RSX
DLNOP JMS SUB990
.ENDC
.IFDEF RSX
DLNOP NOP
.ENDC
DLJMP JMP INIT01
S00102 102
S00103 103
.IFUND %NOHDG /(RKB-069) DOING HEADING STUFF?
.IFUND RSX /(RKB-067)
SC.DATE 147 /(RKB-066) POINTER TO SCOM DATE/TIME WORDS
.ENDC /(RKB-067)
.IFDEF RSX /(RKB-067)
GTDATE 24 /(RKB-067)
0 /(RKB-067)
.BLOCK 6 /(RKB-067)
.ENDC /(RKB-067)
GT2D XX /(RKB-066) SUBROUTINE TO CONVERT TO 2 DECIMAL CHARS
IDIV /(RKB-066) DIVIDE INTO TWO DIGITS
12 /(RKB-066) //
RCL /(RKB-066) WE ALWAYS BUILD FOR THE SECOND WORD OF A PAIR
PAL /(RKB-066) SAVE THE SECOND DIGIT
LLSS 10 /(RKB-066) POSITION FIRST DIGIT
PLA /(RKB-066) RETURN SECOND
XOR (30140) /(RKB-066) MAKE THEM PRINTING ASCII
OMQ /(RKB-066) SMASH THEM ALL TOGETHER
JMP* GT2D /(RKB-066)
MONTAB .-1 /(RKB-066) THE MONTHS NAMES
.ASCII '-JAN-' /(RKB-066)
.ASCII '-FEB-' /(RKB-066)
.ASCII '-MAR-' /(RKB-066)
.ASCII '-APR-' /(RKB-066)
.ASCII '-MAY-' /(RKB-066)
.ASCII '-JUN-' /(RKB-066)
.ASCII '-JUL-' /(RKB-066)
.ASCII '-AUG-' /(RKB-066)
.ASCII '-SEP-' /(RKB-066)
.ASCII '-OCT-' /(RKB-066)
.ASCII '-NOV-' /(RKB-066)
.ASCII '-DEC-' /(RKB-066)
.ENDC /(RKB-069)
.TITLE STORAGE ASSIGNMENT - TEMPORARIES AND ARRAYS
.IFUND RSX
.LOC BEGIN /NOW SET UP PC FOR OVERLAY STORAGE
.ENDC
.IFDEF RSX
/**053** REMOVED OVERLAY BY .LOC RELOCATION
LIST OPR /**050** LIST MUST NOT SKIP WHEN EXECUTED ON COMMAND DECODE
.ENDC
.IFUND RSX
LIST BLK 1 /**055** FIX FOR DOS INIT PROBLEMS
.ENDC
DOTABX BLK 1 /END ADDRESSE OF DO-TABLE
DOTABC BLK 1 /SECOND STRING ADDRESS TABLE
DOTABB BLK 1 /FIRST STRING ADDRESS TABLE
DOTABA BLK 1 /TERMINAL STATEMENT NO. TABLE
FILFLG BLK 1
STRNGB BLK 1 /ADDRESS OF BRANCH AROUND PARAMETERS
SSCTR BLK 1 /SUBSCRIPT COUNTER
FCNRET BLK 1 /SYMTAB ADDRESS OF FUNCTION RETURN
FCNFLG BLK 1 /SUBPROGRAM FLAG - MINUS 1 FOR BLOCK DATA
NAME0 BLK 1 /ARGUMENT MODE
TFAO06 BLK 1 /LOGIC OP MODE ENTRY FLAG (MODE)
TFAO01 BLK 1 /LAST DELIMITER PROCESSED
DOM2 BLK 1
TI BLK 1 /ADDRESS OF I-TH SUBSCRIPT
TRW2 BLK 1
TRW1 BLK 1
EQUCLS BLK 1 /ADDR OF LAST ENTRY IN EQV CLASS LIST
RELADR BLK 1 /ADDRESS RELATIVE TO HEAD OF EQV CLASS
DIFF BLK 1 /DIFFERENCE IN A VARIABLES ADDR IN TWO EQV CLASSES
SUBADJ BLK 1 /ADDRESS LINEUP ADJUSTMENT FACTOR
SUBVAL BLK 1 /RELATIVE ADDRESS WITH RESPECT TO ONE
OLDCLS BLK 1 /NON-ZERO IF WE ARE MERGING TWO EQV CLASSES
COMCLS BLK 1 /NON-ZERO IF THIS EQV CLASS IS IN COMMON
HEDCLS BLK 1 /ADDRESS OF HEAD MEMBER OF EQV CLASS
LSTVAR BLK 1 /ADDR OF LAST VARIABLES LINKAGE WORD
FSTVAR BLK 1 /FLAG INDICATING FIRST CLASS MEMBER
DATAFL BLK 1 /DATA STATEMENT FLAG
TSTRNG BLK 1 /TEMPORARY HOLD FOR STRING ADDRESS
NOP BLK 1 /ADDRESS OF NEXT OPERATOR IN OP TABLE
CTRLSW BLK 1 /FLAG GOVERNING WHETHER CONTINUATION IS ALLOWED
.IFUND RSX
FILE BLK 3 /FILE NAME FROM COMMAND STRING
.ENDC
STRNGA BLK 1 /ADDR OF INSTRUCTION REQUIRING A STRING
PROCAD BLK 1 /ADDRESS OF STATEMENT PROCESSING ROUTINE
TORDER BLK 1 /ORDER NUMBER OF CURRENT STMT
SORDER BLK 1 /ORDER NUMBER OF LAST STATEMENT
LABEL BLK 1 /SYMTAB ADDR OF CURRENT STATEMENT LABEL
LOWRAD BLK 1 /BLOCK DATA SIZE, ALSO EQV CLASS LOW ADDR
EQUSTR BLK 1 /AMOUNT OF NON-COMMON EQUIVALENCED STORAGE
TSMTBN BLK 1 /"STATEMENT FUNCTION" FLAG
SYMTBN BLK 1 /NEXT ENTRY ADDRESS IN SYMBOL TABLE
SYMTB0 BLK 1 /FIRST ADDRESS IN SYMBOL TABLE
SYMTBC BLK 1 /ADDRESS OF CURRENT ENTRY IN SYMTAB
TSMTW7 BLK 1 /TEMP ADDRESS OF WORD 7 OF SYMTAB ENTRY
CONTBN BLK 1 /NEXT ENTRY ADDRESS IN CONSTANT TABLE
OBJBFH BLK 22 /PRINTING BUFFER
OBJB04 BLK 1 /TEMP STORAGE
OBJB03 BLK 1 /"
OBJB02 BLK 1 /"
OBJB01 BLK 1 /"
CODCTR BLK 1 /LOADER CODE COUNTER
WRDCTR BLK 1 /DATA WORD COUNTER
CODEWD BLK 1 /LOADER CODE WORD STORAGE ADDRESS
BINBUF BLK 1 /DATA WORD STORAGE ADDRESS
BINBFH BLK 32 /BINARY OUTPUT BUFFER
TCHAR BLK 1 /TEMPORARY CURRENT CHAR
KOL BLK 1 /TEMP COLUMN COUNTER
TCHCNT BLK 1 /TEMP CHCRACTER COUNTER
TSINBF BLK 1 /TEMPORARY ADDRESS OF NEXT 5 CHARACTERS
TCHBF1 BLK 1 /TEMPORARY CHARACTER BUFFER
TCHBUF BLK 1 /"
BITCTR BLK 1 /SHIFT COUNTER FOR POSITIONING CHARACTER
COL06 BLK 1 /CONTENTS OF CONTINUATION FIELD(COLUMN 6)
UNFNBC BLK 1 /RE--USE LAST CHARACTER FETCHED FLAG
LSTCHR BLK 1 /LAST CHARACTER FETCHED
LEVEL BLK 1 /CURRENT CHAR, HIERARCHY LEVEL IF OP
CHRTYP BLK 1 /TYPE CODE OF CURRENT CHARACTER
XCHAR BLK 1 /ASCII OF CURRENT CHAR
CHAR BLK 1 /INTERNAL CODE FOR CURRENT CHAR
COL BLK 1 /COLUMN COUNTER
CHRCNT BLK 1 /CHARACTER COUNTER (WITHIN BUFFER)
SINBUF BLK 1 /ADDRESS OF NEXT 5 CHARACTERS
CHRBF1 BLK 1 /SECOND WORD OF DOUBLEWORD CHAR BUFFER
CHRBUF BLK 1 /FIRST WORD OF CHAR BUFFER
LINMBR BLK 1 /(RKB-067)
BLK 2 /(RKB-067) STORAGE FOR LINE NUMBER
SINBFH BLK 45 /INPUT BUFFER
/
/
/ TABLES WHICH PRECEDE THE COMPILER IN MEMORY
/ DOTAB DO TABLES
/ SYMTAB SYMBOL TABLE
/ CONTAB CONSTANT TABLE
/
.FFREE 0 /START OF DO + SYMTAB
CONTB0 0
.IFDEF RSX
PC 0
CTLPSW 0
START 0
FORMST 0
.ENDC
.EJECT
/ DESCRIPTION OF VARIABLES DEFINED ELSEWHERE IN THE PROGRAM
/ADDRA1 ADDRESS IN SYMTAB OF ARGUMENT 1
/ADDRA2 ADDRESS IN SYMTAB OF ARGUMENT 2
/ARGI ADDRESS OF CURRENT ENTRY IN ARG TABLE
/ARG1 ADDRESS OF ARGUMENT 1 IN ARG TABLE
/ARG2 ADDRESS OF ARGUMENT 2 IN ARG TABLE
/ARG ARGUMENT DESCRIPTOR WORD
/CHRCTR POSITION NUMBER OF CURRENT SYMBOL IN SYMTAB
/CONTBC ADDRESS OF CURRENT ENTRY IN CONSTANT TABLE
/FAOMOD POINTS TO CURRENT JUMP TABLE
/FLS LOW HALF OF BUFFER FOR PACKING FORMATS AND HOLLERITH CONSTANTS
/FMS HIGH ORDER HALF OF SAME BUFFER
/FMTCNT COUNT OF CHARACTERS REMAINING IN ABOVE BUFFER
/HFLG "HOLLERITH MODE" FLAG FOR FORMAT SCANNER
/IDXNOP VALUE OF NEXT OPERATOR
/IDXPOP VALUE OF PREVIOUS OPERATOR
/IFFLAG ON IF CURRENT STMT IS AN IF STMT
/LEVNOP PRECEDENCE LEVEL OF NEXT OP
/LEVPOP PRECEDENCE LEVEL OF PREVIOUS OP
/LOGIF ON IF LOGICAL IF STMT SEEN
/LS LOW ORDER WORD FOR NUMBER CONVERSION
/MODE MODE TYPE FOR SPECIFICATION STMTS
/MODEA1 MODE OF ARG 1
/MODEA2 MODE OF ARG 2
/MS HIGH ORDER WORD FOR NUMBER CONVERSION
/NAME1 FIRST WORD OF CONCATENATED SYMBOL
/NAME2 SECOND WORD OF SYMBOL
/NUMFLG "NUMBER COLLECTED" FLAG FOR FORMAT SCANNER
/OP OPERATOR DESCRIPTOR WORD
/OPI ADDRESS OF LAST ENTRY IN OPERATOR TABLE
/OPVALU VALUE OF CURRENT OPERATOR
/POP ADDRESS OF PREVIOUS OP IN OP TABLE
/RELOPT RELATIONAL OPERATOR TYPE
/S HIGH ORDER RESULT OF NUMBER CONVERSION
/SHFCTR SHIFT COUNTER
/SIGN ARGUMENT SIGN
/SIGNA1 SIGN OF ARGUMENT 1
/SIGNA2 SIGN OF ARGUMENT 2
/SYMTW2 ADDRESS OF FIRST NAME WORD IN SYMTAB ENTRY
/SYMT2A ADDRESS OF SECOND NAME WORD IN SYMTAB ENTRY
/SYMTW3 ADDRESS OF LENGTH WORD OF SYMTAB ENTRY
/SYMTW4 ADDRESS OF CHAIN WORD OF SYMTAB ENTRY
/SYMTW5 ADDRESS OF DIM1 WORD IN SYMTAB ENTRY
/SYMTW6 ADDRESS OF DIM2 WORD IN SYMTAB ENTRY
/TARGI TEMPORARY HOLD FOR ARGI
/TCTR TEMPORARY COUNTER
/TEMP0 TEMPORARY ADDRESS HOLD
/TFAO04 NUMERIC CONVERSION COMPLETE FLAG
/TFAO05 EXPONENT SIGN
/TLS TEMP HOLD FOR LS
/TMS TEMP HOLD FOR MS
/TOPI TEMP HOLD FOR OPI
/TRELAD TEMPORARY FOR RELATIVE ADDRESS
/TSI NAME OF NEXT INTEGER/LOGICAL TEMPORARY
/TSR NAME OF NEXT REAL/DOUBLE INTEGER TEMPORARY
/TSD NAME OF NEXT DOUBLE PRECISION TEMPORARY
/TSMTBC TEMP HOLD FOR CURRENT SYMTAB ADDRESS
/TSMTW4 TEMP HOLD FOR ADDRESS OF CURRENT CHAIN WORD
/TYPEA1 TYPE OF ARGUMENT 1
/TYPEA2 TYPE OF ARGUMENT 2
.EJECT
/ ARGUMENT/OPERATOR/LEVEL LISTS ... ARG(I), OP(I)
/
/ THE FORMAT OF THE ARG(I) LIST IS....
/ BITS 0-2 IS ARGUMENT TYPE AND BITS 3-17 VARY WITH THE TYPE....
/ 0 ACCUMULATOR B03-04 ACCUMULAYOR MODE B05-17 UNUSED
/ 1 SYMBOLIC B03-17 ADDRESS OF SYMBOL IN SYMBOL TABLE
/ 2 CONSTANT B03-17 ADDRESS OF CONSTANT IN CONSTANT TABL
/ 3 TEMPORARY STORAGE B03-17 ADDRESS OF CREATED SYMBOL IN SYMTAB
/ 4 STRING B03-04 ORIGINAL ARGUMENT MODE
/ B05-17 STRING ADDRESS
/ 5 FUNCTION REFERENCE B03-17 UNUSED
/ 6 SUBSCRIPTED VARIABLE B03-17 UNUSED
/ 7 UNARY OPERATION B03-17 UNUSED
/
/ MODE IS INDICATED AS...
/ 0 INTEGER AND LOGICAL 1 REAL
/ 2 DOUBLE PRECISION 3 DOUBLE INTEGER
/
/ A SYMBOL TABLE ENTRY IS EITHER 3 OR 8 WORDS LONG AND LOOKS LIKE THIS:
/
/ WORD 1: BITS 0-2=SYMBOL TYPE, BITS 3-4=MODE, BITS 5-17=DEFINITION
/ THE VALUES FOR THE SYMBOL TYPE ARE:
/ 0 SCALAR NON-COMMON VARIABLE
/ 1 SCALAR COMMON VARIABLE
/ 2 EXTERNAL FUNCTION
/ 3 DUMMY ARGUMENT (ALSO USED FOR STATEMENT NUMBERS)
/ 4 NON-COMMON ARRAY
/ 5 COMMON ARRAY
/ 6 INTERNAL (STATEMENT) FUNCTION
/ 7 DUMMY ARRAY
/
/ BITS 5-17 CONTAIN THE ACTUAL EXECUTION TIME ADDRESS DURING PASS 2
/ DURING PASS 1 THEY ARE 17777 IF THE SYMBOL HAS NOT BEEN REFERENCED
/ IN AN EXECUTABLE STATEMENT, 17776 OTHERWISE
/
/ WORD 2: FIRST WORD OF SYMBOL NAME -- BIT 0 ON IF 3 WORD SYMBOL
/ BIT 1 ON IF SYMBOL IS A DUMMY ARG USED AS A FUNCTION
/
/ WORD 3: SECOND WORD OF SYMBOL NAME - BIT 0 ON IF MODE="LOGICAL"
/
/ WORD 4: (IF ANY): AMOUNT OF STORAGE USED BY THIS SYMBOL
/
/ WORD 5: (IF ANY): CHAIN POINTER TO NEXT VARIABLE IN EQUIVALENCE BLOCK
/ POINTS TO SELF IF VARIABLE NOT EQUIVALENCED OR IN COMMON
/
/ WORD 6: (IF ANY):FIRST DIMENSION
/ WORD 7: (IF ANY):SECOND DIMENSION
/
/ WORD 8: (IF ANY): OFFSET OF THIS VARIABLE FROM BEGINNING OF THE
/ COMMON OR EQUIVALENCE BLOCK TO WHICH IT BELONGS. FOR ARRAYS, WORD 8
/ CONTAINS THE ADDRESS OF THE ARRAY WHILE WORD 1 CONTAINS THE ADDRESS
/ OF THE ARRAY DESCRIPTOR BLOCK
/
/
/ THE FORMAT OF THE OP(I) LIST IS....
/ BIT 0 INDICATES THE SIGN OF THE CORRESPONDING ARGUMENT (ARG(I))
/ 0 POSITIVE ARGUMENT
/ 1 NEGATED ARGUMENT
/
/ BIT 1 INDICATES THE RELATIVE ORDER OF THE ARGUMENTS WITH RESPECT TO
/ THE OPERATOR....(USED ONLY FOR NON-COMMUTATIBE OPERATIONS)....
/ 0 NORMAL ACCUMULATOR .OP. ARGUMENT
/ 1 REVERSE ARGUMENT .OP. ACCUMULATOR
/
/ BITS 02-11 IS THE HEIRARCHY LEVEL OF THE OPERATOR PLUS THE CURRENT
/ PARENTHESIS NESTING LEVEL
/
/ BITS 12-17 IS THE OPERATOR (ENCODED AS A TRANSLATION TABLE INDEX)
/ OPERATOR HEIRARCHY LEVEL
/ 00 (OCTAL) 00 (OCTAL) TERMINATION
/ 01 01 00 00 =
/ 02 02 02 02 .OR.
/ 03 03 03 03 .AND.
/ 04 04 04 04 .NOT.
/ 05 05 05 05 .LT.
/ 06 06 05 05 .LE.
/ 07 07 05 05 .EQ.
/ 08 10 05 05 .GE.
/ 09 11 05 05 .GT.
/ 10 12 05 05 .NE.
/ 11 13 01 01 .XOR.
/ 12 14 06 06 -
/ 15 17 06 06 +
/ 18 22 07 07 /
/ 21 25 07 07 *
/ 24 30 09 11 UNARY NEGATION
/ 26 32 08 10 **
/ 28 34 10 12 (F FUNCTION OR SUBSCRIPT OPERATOR
/ 30 36 00 00 ,
/ 31 37 00 00 )
/ 32 40 00 00 )F FUNCTION OR SUBSCRIPT CLOSURE
/ 34 42 00 00 (
.EJECT
ARG0 .DSA ARG0+1
.REPT %ARGOP
-1
ARGEND .DSA ARGEND /ARG.-OP. OVFLW. ADD.
OP0 .DSA OP0+1 /OP(I) LIST START
.REPT %ARGOP
-1
EQU0 .DSA EQU0+1
.REPT 20
-1
EQCLSX .DSA EQCLSX /EQUIVALENCE CLASS LIST OVERFLOW ADDRESS
/
/
/ ARRAY DECLARATION SUBSCRIPT STORAGE
T0 0 /WORDS PER ELEMENT
T1 0 /FIRST SUBSCRIPT
T2 0 /SECOND SUBSCRIPT
T3 0 /THIRD SUBSCRIPT
ATX .DSA ATX /LIMIT OF 3 SUBSCRIPTS
AT1 .DSA T1 /ADDRESS OF FIRST SUBSCRIPT
/
/FILE NAME STORAGE
FILE1 0 /FIRST HALF OF PROGRAM NAME SYMBOL
FILE2 0 /SECOND HALF OF PROGRAM NAME SYMBOL
TITLEA 15 /LINE TERMINATING CHAR FOR BATCH
/
/
/ PARENTHESIS LEVEL COUNTING TABLE
/ THE PARENTHESIS COUNTING ENTRY IS PUSHED DOWN EACH TIME A FUNCTION
/ REFERENCE IS ENCOUNTERED. THE ENTRY IS PUSHED UP AT THE TERMINATION
/ OF EACH FUNCTION REFERENCE.
/ THE LEVEL NUMBER IS CONTAINED IN BITS 0-11
/
BASE0 .DSA BASE /INITIAL ENTRY ADDRESS
.REPT 10
BASE -1 /TABLE
BASEMX .DSA BASEMX /END OF TABLE
BASEJ .DSA 0 /ADDRESS OF CURRENT LEVEL COUNTER
/
/
/
/BUFFER POINTERS
/
SINBF0 .DSA SINBFH+2
BINBF0 .DSA BINBFH+1 /ADDRESS (-1) OF BINARY BUFFER
OBJBF0 .DSA OBJBFH+2 /ADDRESS OF OUTPUT BUFFER
.EJECT
/ FILE EXTENSIONS
/
SRCEXT .SIXBT /SRC/
LSTEXT .SIXBT /LST/
BINEXT .SIXBT /BIN/
/
/ PASS1 INITIALIZATION
/
/
INIT02 LAC CTLPSW
SZA
JMP INIT01
RSTRT JMP BEGIN
.IFUND RSX
M1BK .DSA 400000+MESSY1-2
JMS SUB990
M2BK .DSA 400000+MESSY5-2
/ .READ -2 / INPUT COMMAND STRING
CAL 02776
C00008 .DSA 000010
.DSA SINBFH
Z77744 .DSA 777744
/ .WAIT -2
CAL 00776
C00010 .DSA 000012
.ENDC
.IFDEF RSX
LAC (PARSAV-1) /RESTORE SAVE AREA
DAC* C00008
LAC (SINBFH-1)
DAC* C00009
LAW -45
DAC PARCNT
LAC* 10
DAC* 11
ISZ PARCNT
JMP .-3
LAC* 10 /RESTORE POINTERS ALSO
DAC SINBUF
LAC* 10
DAC CHRCNT
LAC* 10
DAC CHRBUF
LAC* 10
DAC CHRBF1
LAC* 10
DAC COL
LAC (SKP) /SET UP TO JUMP OVER SWITCHES
DAC SKPSWC
STARTI=.
.ENDC
.TITLE PASS 1 INITIALIZATION
/
.IFUND RSX
CAL 767 /.INIT -11
1
INM11 INIT02
START 0
.ENDC
LAC CHR1 /INTERNAL FOR CR AND ESC IS 36
DAC CHARCR
LAC CHR2
DAC CHARLT
.IFDEF RSX
LAC (DAT11) /ATTACH TO THE INPUT SOURCE FILE
JMS ATTACH
.ENDC
LAW -32 /INITIALIZE IMPLICIT MODE TABLE (EDIT# 40)
DAC HILET /RESET ALL ENTRIES IN THE IMPLICIT
LAC DACTAB /TYPE TABLE TO THE FORTRAN DEFAULT VALUES
DAC .+2
LAC S10000
XX /I THRU N ARE INTEGERS
ISZ .-1 /ALL OTHER LETTERS ARE REAL
ISZ HILET
JMP .-3 /FIRST SET THE ENTIRE TABLE TO REAL
.REPT 6,1
DZM IMTBL+10 /THEN SET I THRU N TO INTEGER
LAC PASS1 /INITIALIZE....
DAC PASS / PASS SWITCH.
.IFDEF RSX
XCT SKPSWC /SKIP IF NOT FIRST TIME
.ENDC
DAC SYMMAP / NO SYMBOL MAP
.IFDEF RSX
LAC RSXBIN /GET PREVIOUS 'B' SWITCH SETTING, BUT
XCT SKPSWC /SKIP IF NOT THE FIRST TIME
.ENDC
LAC OBSPCL /SPECIAL, POSITIVE NO-OP
DAC OBINRY /OBINRY=+NOP(NO OUTPUT),-NOP(OUTPUT, PASS1) OR SKP
LAC PASS2
DAC F4K
.IFDEF RSX
XCT SKPSWC
.ENDC
DAC OPTSWC /SUBSCRIPT CALCULATION IN-LINE : ON
.IFDEF RSX
XCT SKPSWC /SKIP IF NOT THE FIRST TIME
.ENDC
DAC SLIST /NO SOURCE LIST
.IFDEF RSX
XCT SKPSWC /SKIP IF NOT THE FIRST TIME
.ENDC
DAC LIST /NO LISTING DEVICE
DAC FT2CNG
.IFDEF RSX
XCT SKPSWC /SKIP IF NOT THE FIRST TIME
.ENDC
DAC OLIST /NO OBJECT LIST
LAC EQU0
DAC EQUCLS /EQUIVALENCE CLASS LIST
JMS INDOTB /DO TABLE POINTERS
TAD C00010
DAC DOTABX /DO TABLE END
DAC SYMTB0 / START SYMBOL TABLE
DZM TSMTBN / (PERMANENT SYMTAB)
DAC SYMTBN /SYMBOL TABLE NEXT ENTRY ADDRESS
LAC CONTB0
DAC CONTBN / CONSTANT TABLE NEXT ENTRY ADDRESS
.IFDEF RSX
XCT SKPSWC /SKIP IF NOT FIRST TIME
SKP
JMP CMDA /GO DECODE THE FILE NAME
.ENDC
.IFUND %NOHDG /(RKB-069)
DZM PAGCNT /(RKB-066) ZERO THE PAGE COUNTER
.ENDC /(RKB-069)
.IFUND %NOEOC /(RKB-069)
DZM ERRCNT /(RKB-067) ZERO THE ERROR COUNTER.
.ENDC
JMS SIN520
.IFDEF RSX
INIT13 JMS SIN500 /IGNORE UNTIL THE FIRST SPACE
SAD CHARSP /IS IT A SPACE?
JMP INIT08 /YES DECODE SWITCHES
SAD CHARLT /ALTMODE?
JMP CMDERR /YES COMMAND ERROR
SAD CHARCR /CRTN?
JMP CMDERR /YES COMMAND ERROR
JMP INIT13 /NONE OF ABOVE TRY AGAIN
.ENDC
INIT08 JMS SIN500
SAD CHARCR /CR
JMP CMDERR
SAD CHARLT /ALT MODE
JMP CMDERR
SAD CHARB
JMP CMDB /B...BINARY
SAD CHARL
JMP CMDL / L...LIST SOURCE
.IFDEF RSX
SAD CHARR /CHECK FOR R SWITCH
ISZ VERPNT /SET OUTPUT ON TTY SWITCH
.ENDC
SAD CHARO
JMP CMDO / O...OBJECT LIST
SAD CHARS
JMP CMDS / S...SYMBOL MAP
SAD CHARH / H...NO IN-LINE SUBSCRIPT CALCULATION
JMP CMDH
SAD ARROW
JMP CMDA /_...END OF OPTION LIST
JMP INIT08 / ILLEGAL CHAR...IGNORE
.IFUND RSX
CMDERR JMS SUB990 /ERROR: CR OR ALT MODE BEFORE _
CMDERT-2
LAC* SCOM52
SPA
JMP END999 /RETURN TO MONITOR IF IN BATCH
JMP INIT02
.ENDC
.IFDEF RSX
CMDERR ISZ VERPNT /FORCE PRINTING ON TTY
JMS SUB990
CMDERT-2
LAC C00013 /FORCE TDV TO BE CALLED
DAC TITLEA
JMP EXITF /EXIT FORTRAN
.ENDC
CMDB LAC PASS1
DAC OBINRY / SET BINARY OPTION FLAG
.IFDEF RSX
DAC RSXBIN /SAVE BINARY OPTION FLAG FOR RSX RE-ENTRIES
.ENDC
JMP INIT08
.IFDEF RSX
RSXBIN XOR C00000
.ENDC
CMDH LAC PASS1 /PUT A SKIP AT OPTSWC TO PREVENT IN-LINE
DAC OPTSWC /SUBSCRIPT CALCULATION
JMP INIT08
CMDL LAC PASS1
DAC SLIST / SET SOURCE LIST OPTION FLAG
LSTSET DAC LIST
JMP INIT08
CMDO LAC PASS1
DAC OLIST / SET OBJECT LIST OPTION FLAG
JMP LSTSET
CMDS LAC PASS2
DAC SYMMAP / SET SYMBOL MAP OPTION FLAG
LAC PASS1
JMP LSTSET
.IFDEF RSX
ENDCMR LAC (SINBFH-1) /SET UP TSAVE BUFFER
DAC* C00008
LAC (PARSAV-1)
DAC* C00009
LAW -45 /SAVE ALL 45 WORDS
DAC PARCNT
LAC* 10
DAC* 11
ISZ PARCNT
JMP .-3
LAC SINBUF /SAVE THE POINTERS ALSO
DAC* 11
LAC CHRCNT
DAC* 11
LAC CHRBUF
DAC* 11
LAC CHRBF1
DAC* 11
LAC COL
DAC* 11
LAC S00054 /SET LAST CHARACTER READ TO 54
JMP CMDRTN
/
ENDCMA DZM UNFNBC /SET THE SWITCH TO STOP CHARACTER SCAN
ISZ TCTR /6 CHARACTERS FOUND?
JMP CMDM14 /NO TRY AGAIN
JMP ENDCMR /YES -- SAVE POINTERS
.ENDC
CMDA DAC UNFNBC
.IFDEF RSX
JMS SUB990 /IDENTIFY IF R SWITCH
.DSA 400000+MESSY1-2
.ENDC
DZM TITLEA
JMS SIN530 / SAVE POINTERS FOR OTHER CONVERSION
CLC /FETCH FILE NAME FOR DDT
DAC FILFLG
JMS FVARGO
CMDA1 LAC NAME1
DAC FILE1
LAC NAME2
DAC FILE2
JMS SIN540 / RE-POSITION POINTERS FOR FILE NAME
LAW -6
DAC TCTR / CONVERT NAME TO SIXBIT
DZM MS / FOR FILE SEARCH
DZM LS
CMDM14 LAW -6
DAC TEMP0
JMS DLSHFT
ISZ TEMP0
JMP .-2
JMS FNBCHR
SAD S00054 /CHECK FOR COMMA
.IFUND RSX
JMP CMDERR /(RKB-066) IF YES, ERROR
.ENDC
.IFDEF RSX
JMP ENDCMA /GO SAVE PARAMETERS
.ENDC
SAD C00013 /CR
JMP ENDCML
SAD S00175 /ALT MODE
JMP ENDCML
AND S00077
XOR LS
DAC LS
CMDCNT ISZ TCTR
JMP CMDM14
JMP CMDONE
ENDCML DAC TITLEA /FOR COMMAND BATCHING
DZM UNFNBC
JMP CMDCNT
CMDONE LAC TITLEA /TEST FOR END COMMAND STRING.
SZA
.IFUND RSX
JMP .+10 /FINISHED
.ENDC
.IFDEF RSX
JMP .+12
.ENDC
JMS FNBCHR /FIND TERMINATOR.
.IFDEF RSX
SAD S00054 /CHECK FOR COMMA TERMINATOR
JMP ENDCMR /SAVE THE BUFFER
.ENDC
SAD C00013
SKP
SAD S00175
SKP
.IFUND RSX
JMP .-5
.ENDC
.IFDEF RSX
JMP .-7 /NOT FOUND TRY AGAIN
.ENDC
CMDRTN=.
DAC TITLEA
LAC MS
DAC FILE
LAC LS
DAC FILE+1 / SET UP FILE NAME
LAC LSTEXT
DAC FILE+2 / SET NAME EXTENSION (LST)
LAC CHR3 /INTERNAL FOR CR AND ESC IS 00
DAC CHARCR
LAC CHR4
DAC CHARLT
LAC JMPFT2
DAC FT2CNG
XCT LIST
JMP TRYBIN
.IFUND RSX
CAL+5766 /(RKB-067) SUPPRESS LF ON .CLOSE
1
M3BK INIT02
PC 0 /PROGRAM COUNTER
/ .ENTER -12 / OPEN LISTING FILE
CAL 00766
.DSA 000004
.DSA FILE
.ENDC
.IFDEF RSX
LAC (DAT12) /ATTACH TO OUTPUT LISTING DEVICE
JMS ATTACH
LAC (DAT12) /ENTER ON 12
JMS ENTERR /ENTER FILE
.ENDC
TRYBIN LAC BINEXT
DAC FILE+2 / SET NAME EXTENSION (BIN)
XCT OBINRY
JMP INIT01
.IFUND RSX
CAL+1765
1
INIT02
FORMST 0
/ .ENTER -13 / OPEN BINARY FILE
CAL 00765
.DSA 000004
.DSA FILE
.ENDC
.IFDEF RSX
LAC (DAT13) /ATTACH TO THE OUTPUT BINARY DEVICE
JMS ATTACH
LAC (DAT13) /LOOK FOR AN EXISTING BINARY FILE; IF NONE,
JMS SEEK /'DELETE' IS SET TO KILL BAD BINARY
LAC (DAT13) /ENTER THE BINARY FILE
JMS ENTERR /ENTER FILE
.ENDC
.TITLE PASS 1 / PASS 2 COMMON INITIALIZATION
/
INIT01 JMS INDOTB /INITIALIZE DO TABLE POINTERS
.IFUND RSX
.CLOSE -3 /TYPE CR/LF
.ENDC
.IFDEF RSX
JMS SUB990 /WRITE A CR LF ON THE OUTPUT TTY
.DSA 400000+MESSY7-2
.ENDC
DZM CTLPSW
LAC SRCEXT
DAC FILE+2 / SET NAME EXTENSION (SRC)
.IFUND RSX
/ .SEEK -11,FILE
CAL 00767 / LOCATE INPUT FILE
.DSA 000003
.DSA FILE
.ENDC
.IFUND %NOHDG /(RKB-069)
CLC /(RKB-067)
DAC LINCNT /(RKB-067)
LAC FILE /(RKB-066) PUT FILE NAME IN HEADER
LMQ /(RKB-066)
JMS CV6A /(RKB-066) CONVERT NEXT .SIXBT CHAR TO ASCII
ALSS 13 /(RKB-066) PACK IT TO 5/7
DAC TOF+6 /(RKB-066)
JMS CV6A /(RKB-066) GET CHAR 2
ALSS 4 /(RKB-066) PACK IT
XOR TOF+6 /(RKB-066) WITH CHAR 1
DAC TOF+6 /(RKB-066) //
JMS CV6A /(RKB-066) DO THE THIRD
CLQ!LRSS 3 /(RKB-066) THIS IS THE SPLIT CHAR
XOR TOF+6 /(RKB-066) PUT FIRST 4 BITS WITH OTHER 2 CHARS
DAC TOF+6 /(RKB-066) //
LACQ /(RKB-066) RECAL LOW 3 BITS OF THIRD CHAR
DAC TOF+7 /(RKB-066) PUT IT IN HEADER
LAC FILE+1 /(RKB-066) GET SECOND HALF OF FILE NAME
LMQ /(RKB-066)
JMS CV6A /(RKB-066) CONVERT CHAR 4
ALSS 10 /(RKB-066) POSITION IT
XOR TOF+7 /(RKB-066) COMBINE IT
DAC TOF+7 /(RKB-066) //
JMS CV6A /(RKB-066) DO CHAR 5
RCL /(RKB-066) POSITION IT
XOR TOF+7 /(RKB-066) //
DAC TOF+7 /(RKB-066) //
JMS CV6A /(RKB-066) SIXTH AND FINAL CHAR
ALSS 13 /(RKB-066) SLIDE IT ALL THE WAY OVER
XOR (001012) /(RKB-066) COMBINE WITH A SPACE AND 'S' FOR SRC
DAC TOF+10 /(RKB-066)
.ENDC /(RKB-069)
.IFDEF RSX
CAL SEEK11 /SEEK THE FILE
CAL WFEVA /WAIT FOR EVENT VARIABLE
LAC EVA
SMA /LEGAL?
JMP SKOKA /YES CONTINUE
SAD (-6)
JMP SKOKA /YES
JMS IOERR /NO I/O ERROR
SKOKA LAC (DAT11 /LUN IN CASE OF I/O ERROR
.ENDC
DZM SORDER / STATEMENT ORDERING COUNTER
DZM LINMBR /(RKB-067)
JMS BIN500 /BINARY OUTPUT BUFFER
DZM XCHAR / SOURCE IMAGE REQUIRED
LAC END23+1
DAC BINO06 /OBJECT LISTING BUFFER INITIALIZATION
LAC FCNFLG
SAD K00001
JMP .+4
LAC PC
JMS BINOUT /OUTPUT PROGRAM SIZE FOR EVERYTHING
XOR C00001 /BUT BLOCK DATA SUBPROGRAMS.
DZM PC /RESET PROGRAM COUNTER
DZM FCNFLG /RESET SUBPROGRAM FLAG
DZM FCNRET /AND POINTER TO SYMBOL DEFINED AS RETURN CODE
DZM PROCAD
DZM STAF /RESET TEMPORARY STORAGE LETTER FOR STATEMEMTFUNCTIONS
DZM START /INITIALIZE STARTING ADDRESS
.TITLE STATEMENT INITIALIZATION,RECOGNITION,EXECUTION,TERMINATION
/
CONTRL LAC K00001 /INITIALIZE....
DAC UNFNBC / FETCH NEXT CHARACTER INDICATOR
DZM LOGIF / LOGICAL IF STATEMENT
DZM RWEXPF /ZERO "I/O LIST" FLAG
DZM LOGFLG /INITIALIZE "LOGICAL VARIABLE" FLAG
DZM IMPLFG /ZERO "IMPLICIT STATEMENT" FLAG
DZM LABEL / LABEL FIELD ENTRY
DZM OBJB04 /VECTOR IS (IS NOT) A PARAMETER (OBJ LIST)
DZM DATAFL
DAC IFFLAG / IF STATEMENT
DAC STRNGA /STRING CLEAN-UP REQUIRED
DAC MODE /EXPLICIT MODE TYPING FLAG.
LAC DOTABX /THE ORIGIN OF THE NON-ERASEABLE PORTION
DAC SYMTB0 /OF THE SYMBOL TABLE IS RE-INSTATED.
DZM TSMTBN /TEMPORARY NEXT SYMBOL TABLE ENTRY ADDRESS
/ /A NEW IMAGE IS INPUT IF THE LAST IMAGE
/ /WAS NOT FULLY PROCESSED (LAST CHARACTER
JMS CTRL60 /EXAMINED IS NOT THE STATEMENT TERMINATION
JMS SINPUT /CHARACTER).
JMS SOUTPT /THE CURRENT SOURCE IMAGE IS LISTED BEFORE
JMS FTC500 /PROCESSING OCCURS.
JMP .-3 /CONTINUATION IMAGES FOUND HERE CAN ONLY
JMS SINP00 /EXIST DUE TO AN ERRONEOUS LAST STATEMENT
SKP
CTRL41 JMS SIN530 /THE STARTING COLUMN COUNT IS SAVED TO
DZM TCTR /ALLOW ITS PROPER RETURN (THIS LOGIC IS
DZM OP /USED TO DECODE THE STATEMENT FOLLOWING
CTRL13 LAC CTRLIM /A LOGICAL DO). THE SCAN MODE IS SET TO
CTRL06 DAC FAOMOD /INITIAL AND PROCESSING BEGINS.
DAC CTRLSW /(IMAGE RECOGNITION ALLOWS NO CONTINUATION)
CTRL18 JMS FETCHR
SKP /THE SCAN IS TERMINATED WHEN THE LAST
JMP CTRL19 /CHARACTER HAS BEEN EXAMINED.
SNA /(BLANK CHARACTERS ARE IGNORED.)
JMP CTRL18
TAD FAOMOD /PROCESSING IS DETERMINED BY THE CURRENT
DAC .+1 /SCAN MODE AND THE CURRENT CHARACTER UNDER
JMP* /CONSIDERATION.
.IFUND %NOHDG /(RKB-069)
CV6A XX /(RKB-066) ROUTINE TO CONVERT SIXBIT TO ASCII
LLSS!1000 6 /(RKB-066) GET NEXT CHAR
SNA /(RKB-066) IS IT NULL?
AAC 40 /(RKB-066) YES, MAP IT TO SPACE
AAC 40 /(RKB-066) DO THE CONVERTION
XOR (140) /(RKB-066) //
JMP* CV6A /(RKB-066) THATS IT
.ENDC /(RKB-069)
.EJECT
/SUBROUTINE TO FETCH STATEMENT LABEL
/
CTRL00 SYN ARGI
LAC LOGIF /DO NOT PROCESS THE STATEMENT
SZA /FIELD A SECOND TIME
JMP* CTRL00
JMS SIN520
JMS FETSNO /COLUMNS 1 THRU 5 MAY CONTAIN A STATEMENT
ISZ UNFNBC /LABEL CONSISTING OF 1-5 DECIMAL DIGITS
DAC FETSNO
LAC XCHAR /IF THE STATEMENT NUMBER DID NOT
SAD C00009 /TERMINATE WITH A TAB, THEN WE MUST
JMP CTRL01 /CHECK THE COLUMN COUNTER TO MAKE SURE
LAW -7 /THAT THE NON-DIGIT, NON-SPACE CHARACTER
TAD COL /OCCURRED IN OR AFTER COLUMN SEVEN
ERN 08N,SPA,EN /OTHERWISE ILLEGAL ST. NO.
CTRL01 LAC FETSNO /RESTORE AC
SMA /AC NEGATIVE MEANS NO DIGITS FOUND
JMP CTR01
CLA
JMP CTRL03
CTR01 AND S60000 /WHEN A STATEMENT LABEL IS PRESENT, ITS
SNA /ASSIGNMENT WORD IS EXAMINED TO DETERMINE
JMP CTRL04 /IF THE LABEL HAS PREVIOUSLY BEEN
LAC* SYMTBC /ASSIGNED.
AND S17777 /A PREVIOUS ASSIGNMENT MAY HAVE OCCURED
SAD PC /DURING THIS PASS OR IT MAY HAVE OCCURED
JMP CTRL05 /LAST PASS. THE DEFINITION OF THE LABEL
DAC PC /IS CHECKED AGAINST THE OLD DEFINITION
ERR 01N,16340,EN /AND AN ERROR IS SIGNALLED IF DIFFERENT
JMP CTRL05 /USED MORE THAN ONCE AS A STATEMENT LABEL.
CTRL04 LAC PC /THE LABEL IS DEFINED EQUAL TO THE CURRENT
XOR V60000 /PROGRAM COUNTER IF THIS IS ITS FIRST
DAC* SYMTBC /OCCURANCE IN A LABEL FIELD.
CTRL05 LAC SYMTBC /THE LABEL-NO LABEL FLAG IS SET WITH THE
CTRL03 DAC LABEL /ADDRESS OF THE LABELS ENTRY IN THE SYMTAB
JMS SIN540 /(OR ZERO) TO INDICATE A LABEL (NO LABEL).
JMP* CTRL00
.EJECT
/ SUBROUTINE TO AVOID ILLEGAL MEM REFS
/
FAKE CAL 0
DAC BINBFH+1 /SAVE AC
LAC* FAKE
AND S17777 /(17777
XOR LACCMD /(200000
DAC .+1
XX
.IFUND RSX
AND S60000 /MAKE SURE
JMS TWOCMA /OF LEGAL ADDR.
TAD BNKBTS
SNL
.ENDC
.IFDEF RSX
AND (77777)
TCA /THIS IS THE RIGHT WAY I HOPE !!
TAD ENDPAR
SPA
.ENDC
ISZ FAKE /DO NOT EXECUTE INSTRUCTION
LAC BINBFH+1
JMP* FAKE
.EJECT
/ STATEMENT RECOGNITION DECODING MATRIX
/
/ INITIAL MODE ROW
CTRLIM JMP CTRLIM /TYPE CHARACTER
JMP CTRL11 /01 NUMERIC 0123456789
JMP CTRL12 /02 ALPHABETIC BCJKMNQSUVWYZ
JMP CTRL12 /03 ALPHABETIC ED
JMP CTRL12 /04 ALPHABETIC AEFGHILPXORT
JMP CTRL13 /05 OPERATOR +-
JMP CTRL13 /06 OPERATOR */
JMP CTRL13 /07 PERIOD .
JMP CTRL14 /08 PARENTHESIS (
JMP CTRL15 /09 PARENTHESIS )
JMP CTRL16 /10 DELIMETER ,=
JMP CTRL13 /11 SPACE
JMP CTRL55 /12 QUOTES "$
JMP CTRL13 /13 PARTWD [
JMP CTRL13 /14 MISC :];#@
/
/ SYMBOLIC MODE ROW
CTRLSM JMP CTRLSM /TYPE CHARACTER
JMP CTRL18 /01 NUMERIC 0123456789
JMP CTRL18 /02 ALPHABETIC BCJKMNQSUVWYZ
JMP CTRL18 /03 ALPHABETIC ED
JMP CTRL18 /04 ALPHABETIC AFGHILPXORT
JMP CTRL13 /05 OPERATOR +-
JMP CTRL13 /06 OPERATOR */
JMP CTRL13 /07 PERIOD .
JMP CTRL14 /08 PARENTHESIS (
JMP CTRL15 /09 PARENTHESIS )
JMP CTRL16 /10 DELIMITER ,=
JMP CTRL18 /11 SPACE
JMP CTRL55 /12 QUOTES "$
JMP CTRL13 /13 PARTWD [
JMP CTRL13 /14 MISC :];#@
/
/ NUMERIC MODE ROW
CTRLNM JMP CTRLNM /TYPE CHARACTER
JMP CTRL18 /01 NUMERIC 0123456789
JMP CTRL13 /02 ALPHABETIC BCJKMNQSUVWYZ
JMP CTRL13 /03 ALPHABETIC ED
JMP CTRL19 /04 ALPHABETIC AFGHILPXORT
JMP CTRL13 /05 OPERATOR +-
JMP CTRL13 /06 OPERATOR */
JMP CTRL13 /07 PERIOD .
JMP CTRL14 /08 PARENTHSEIS (
JMP CTRL15 /09 PARENTHESIS )
JMP CTRL16 /10 DELIMETER ,=
JMP CTRL18 /11 SPACE
JMP CTRL55 /12 QUOTES "$
JMP CTRL13 /13 PARTWD [
JMP CTRL13 /14 MISC :];#@
.EJECT
/ NUMERIC CHARACTER IN INITIAL MODE
CTRL11 LAC CTRLNM /THE SCAN CONTINUES IN THE NUMERIC MODE.
JMP CTRL06
/ ALPHABETIC CHARACTER IN INITIAL MODE
CTRL12 LAC CTRLSM /THE SCAN CONTINUES IN THE SYMBOLIC MODE
JMP CTRL06
/ LEFT PARENTHESIS IN ALL MODES
CTRL14 ISZ TCTR /THE PARENTHESIS COUNTER IS UPDATED (+1).
JMP CTRL13 /THE SCAN CONTINUES IN THE INITIAL MODE.
JMP CTRL13
/ RIGHT PARENTHESIS IN ALL MODES
CTRL15 JMS CNSE50 /THE PARENTHESIS COUNTER IS UPDATED (-1).
ERS 19X,<SMA>,EX1 /**058** IF PAREN COUNT GOES NEGITIVE
/TELL THE USER HE'S MESSED UP AND HAS
/TOO MANY RIGHT PARENS
JMP CTRL13 /THE SCAN CONTINUES IN THE INITIAL MODE.
/ DELIMETER IN ALL MODES
CTRL16 LAC CHAR /THE DELIMETER IS EITHER A COMMA OR AN
SAD C00001 /EQUAL SIGN.
JMP CTRL17
/ COMMA IN ALL MODES
LAC TCTR /COMMAS INSIDE PARENTHESIS SEPARATE EITHER
SZA /SUBSCRIPTS OR FUNCTION PARAMETERS.
JMP CTRL13
LAC OP /COMMAS OUTSIDE OF PARENTHESIS SEPARATE
SNA /LIST ITEMS WHEN NO EQUAL SIGN HAS BEEN
JMP CTRL13 /FOUND.
JMS SIN540 /A STATEMENT WITH A COMMA OUTSIDE OF
LAC W00000 /PARENTHESIS AND FOLLOWING AN EQUAL SIGN
JMS CTRL50 /CAN ONLY BE A DO STATEMENT.
ERS 01D,<SAD DOMNE>,ED /ERROR IF OTHERWISE
LAC DOADDR /THE STATEMENT HAS BEEN IDENTIFIED AS A
JMP CTRL21 /DO STATEMENT.
/ EQUAL SIGN IN ALL MODES
CTRL17 LAC TCTR /AN EQUAL SIGN INSIDE PARENTHESIS CAN ONLY
SZA /BE PART OF AN IMPLIED DO WHICH
JMP CTRL19 /CANNOT BE PART OF AN ASSIGNMENT STATEMENT.
ISZ OP /AN EQUAL SIGN OUTSIDE OF PARENTHESIS
JMP CTRL13 /INDICATED A DO OR AN ASSIGNMENT STATEMENT.
.EJECT
/ STATEMENT RECOGNITION WRAP-UP
CTRL19 JMS SIN540 /THE USE OF THE NAME .IF. IS RESERVED FOR
DZM ASSTMT /GETS ISZ'D IF ASSMNT STATEMENT
LAC LOGIF
SZA
JMP CTRL29
CTRL07 LAC Y00000
JMS CTRL50 /BECAUSE A LOGICAL IF STATEMENT MAY
SAD IFMNE /CONTAIN AN ASSIGNMENT STATEMENT, THE
SKP /**59** CHECK IF REALLY PAREN
JMP CTRLXX /**059** THIS IS NECESSARY BECAUSE
LAC S00050 /**059** SOMEBODY DEFINED THE INTERNAL
SAD XCHAR /**59** CODES FOR '5' AND '(' AS THE SAME
JMP CTRL22 /**059** IT'S A '(' - PAREN
CTRLXX NOP /**059** STATEMENT IS FIRST EXAMINED TO DETERMINE
LAC OP /IF IT IS AN IF STATEMENT. OTHERWISE THE
SNA /STATEMENT IS DETERMINED TO BE EITHER AN
JMP CTRL23 /ASSIGNMENT STATEMENT (INCLUDING STATEMENT
CTRL29 LAC OP
SNA
JMP CTRL07
JMS CTRL80 /FUNCTIONS) OR A NON-ASSIGNMENT STATEMENT.
JMS SIN540 /AFTER THE STORAGE ASSIGNMENTS HAVE BEEN
JMS CTRL00 /(FETCH STATEMENT LABEL)
LAC V40000
DAC TORDER /SET ORDER (TENTATIVELY) TO EXECUTABLE STMT
JMS FVARGO /THE ASSIGNMENT
DZM CTRLSW /VARIABLE AND ITS DELIMETER ARE FETCHED.
DAC UNFNBC /RESET "BACKUP CHARACTER" FLAG
DZM PROCAD /INDICATE ASSIGNMENT OR FUNCTION STATEMENT.
SAD C00028 /THE STATEMENT IS IDENTIFIED AS A
LAC* ARG /STATEMENT FUNCTION WHEN THE DELIMITER
AND V00000 /INDICATES A FUNCTION OR SUBSCRIPT AS THE FIRST
SAD U00000 /OPERATOR AND THE FIRST VARIABLE TYPE
JMP STAFCN /IS THAT OF A FUNCTION
JMS SIN540 /EXECUTABLE STATEMENT-
DZM STAF /RE-INITIALIZE TEMPORARY SUFFIX
ISZ ASSTMT /SET TO 1, TESTED IN EXPRSN FOR VALID =
JMS EXPRSN /ASSIGNMENT STATEMENT IS DECODED.
LAW -110 /**052** ARE WE INBOUNDS? LIKE WITHIN
TAD COL /**052** COL. 73??
SMA!CLA /**052** IF NOT FORGET ABOUT THE TEST
JMP STEXIT /**052** WE'RE NOT IN BOUNDS SO GET ON WITH THE WORK
LAC XCHAR /**052** IN BOUNDS - CHECK LAST NON BLANK FOR A C/R
ERS 34X,<SAD C00013>,EX /**052** IF NOT A C/R THEN GIVE AN ERROR
.EJECT
/ STATEMENT PROCESSING COMPLETED (TERMINATED) RETURN
STEXIT LAC TORDER /THE NEW STATEMENT ORDER IS SET BASED ON
DAC SORDER /THE ORDER OF THE LAST STATEMENT.
EREXIT LAC STRNGA /ALL STATEMENT PROCESSORS AND THE ERROR
SMA /ROUTINE EXIT THIS POINT.
JMS STRING /THE CURRENT PROGRAM COUNTER IS STRUNG
/(WHEN NECESSARY) TO A STATEMENT ADDRESS.
DOCLEN LAC DOTABA
SAD .FFREE /IF THERE ARE NO ENTRIES IN THE DO TABLE,
JMP CONTRL /DO NOT SEARCH FOR TERMINATION
TAD K00001 /IF ONE OR MORE DO LOOPS ARE STILL OPEN,
DAC TRW2 /CHECK WHETHER
LAC LABEL /THE LABEL ON THE CURRENT STATEMENT
SNA
JMP CONTRL /(IF THERE IS ONE)
SAD* TRW2 /IS THE TERMINATING LABEL OF THE HIGHEST
JMP DO23 /LEVEL DO LOOP.
DO21 LAC TRW2 /IF NOT, CHECK ALL OTHER DO LOOPS TO SEE
SAD .FFREE /IF THIS IS THE TERMINATING LABEL
JMP CONTRL /OF ANY LOWER LEVEL DO LOOP
TAD K00001
DAC TRW2
LAC* TRW2 /IF IT IS, A DO LOOP NESTING ERROR EXISTS.
SAD LABEL
JMP DO22
JMP DO21 /LOOP FOR ALL CURRENT DO LOOPS
DO23 LAC PROCAD /COMPARE STATEMENT TYPES.
SAD GOTOAD /GO TO
JMP DO24
SAD RETADR /RETURN
JMP DO24
SAD STOPAD /STOP
JMP DO24
SAD PAUSAD /PAUSE
JMP DO24
SAD IFADDR /IF
JMP DO24
JMS DECDTP
LAC* DOTABB /STATEMENT TYPE O.K. -- OUTPUT DO CLEANUP
XOR JMPCMD
JMS RELBIN /OUTPUT THE JUMP BACK INTO THE LOOP
LAC* DOTABC
JMS STRING /AND STRING THE EXIT JUMP
JMP DOCLEN /TEST NEXT LOWER NESTING LEVEL.
DO24 ERN 09D,<DZM LABEL>,ED /ERROR: ILLEGAL TERMINATING STMT
DO22 ERN 02L,<DZM LABEL>,EL /ERROR: ILLEGAL DO NESTING
.EJECT
/ NON-ASSIGNMENT STATEMENT RECOGNITION
CTRL22 LAC IFADDR /THIS STATEMENT HAS BEEN IDENTIFIED AS AN
JMP CTRL21 /IF STATEMENT.
CTRL23 LAC NAME2 /THE STATEMENTS REAL AND READ AND END AND
SAD ENDMNE /ENDFILE MUST BE RECOGNIZED SEPARATELY AS
JMP CTRL37 /THE FIRST 3 CHARACTERS OF EACH PAIR ARE IDENTICAL
IMCTRL SAD REAMNE /(ENTRY HERE FROM "IMPLICIT" STATEMENT)
JMP CTRL36
JMP CTRL38
CTRL36 JMS FNBCHR /WHEN THE FIRST THREE CHARACTERS ARE REA,
SAD S00114 /AN ERROR IS ANNOUNCED IF THE CHARACTER
JMP CTRL40 /IS NEITHER D NOR L
ERS 13I,<SAD S00104>,EI
LAC READAD
JMP CTRL21 /THE ADDRESS OF THE READ OR REAL PROCESSING
CTRL40 LAC REALAD /ROUTINE IS SET ACCORDINGLY.
JMP CTRL21
CTRL37 LAC U00000 /WHEN THE FIRST THREE CHARACTERS ARE END,
JMS CTRL50 /THE NEXT NON-BLANK CHARACTER IS FETCHED.
SNA /IF ITS A CARRIAGE RETURN, THE STATEMENT IS
JMP END /AN END STATEMENT - OTHERWISE WE CHECK FOR
ERS 14I,<SAD C00006>,EI /AN "ENDFILE" STATEMENT.
LAC Y00000
JMS CTRL50 /CHECK THE NEXT 3 CHARACTERS FOR "ILE"
ERS 15I,<SAD ILEMNE>,EI /ERROR: MISSPELLED STATEMENT.
LAC ENDFAD /OTHERWISE THE STATEMENT IS IDENTIFIED AS
JMP CTRL21 /ENDFILE.
CTRL38 LAC PIDTB0 /ALL OTHER
DAC TCTR /NON-ASSIGNMENT STATEMENTS ARE IDENTIFIED
LAC* TCTR /BY THEIR RESPECTIVE NAMES
ERN 01I,<SAD ENDMNE>,EI /RAN OUT OF NAMES - ERROR
AND T77777 /STOP, CALL, ETC.).
SAD NAME2
JMP CTRL24 /THE FIRST THREE CHARACTERS OF THE NAME
LAC TCTR /ARE USED TO OBTAIN A PRELIMINARY
TAD C00002 /IDENTIFICATION OF THE STATEMENT.
JMP CTRL38+1
CTRL24 LAC* TCTR
DAC NAME2 /THE RECOGNITION OF THE FIRST THREE
ISZ TCTR /CHARACTERS IS ENOUGH TO IDENTIFY THE
LAC* TCTR /STATEMENT (ALMOST ALWAYS TRUE). THE
DAC PROCAD /PROCESSOR ADDRESS AND OTHER PERTANENT
LAC PIDTB0 /INFORMATION IS OBTAINED FROM THE PRIMARY
JMS TWOCMA /IDENTIFICATION TABLE.
TAD TCTR /THE RELATIVE POSITION OF THIS ENTRY IS
RCR /CALCULATED SO THAT IT MAY BE USED TO
DAC OP /COMPUTE THE ADDRESS OF THE
LAC CTRL90 /CORRESPONDING ENTRY IN THE SECONDARY
DAC TEMP0 /TABLES.
CTRL31 LAC* TEMP0
TAD OP /THE SECONDARY INDENTIFICATION TABLES ARE
DAC TCTR /SEARCHED WHEN THE STATEMENT NAME CONSISTS
LAC NAME2 /OF MORE THAN THREE CHARACTERS.
AND Y00000 /A SECONDARY TABLE ENTRY CONTAINS THE
SNA /CONCATENATION OF THE NEXT N CHARACTERS
JMP CTRL27 /(N = 1,2,OR 3) OF THE NAME IN BITS 2-17
JMS CTRL50 /AND THE NUMBER OF CHARACTERS TO EXAMINE
/NEXT TIME IN BITS 0-1
/THE STATEMENT IS IDENTIFIED WHEN ALL CHARACTERS
LAC* TCTR /TO DATE HAVE BEEN RECOGNIZED AND THE NUMBER OF
AND T77777 /CHARACTERS TO EXAMINE NEXT TIME IS ZERO.
ERS 02I,<SAD NAME2>,EI /ERROR: CHARACTERS NOT MATCHED
LAC* TCTR
DAC NAME2 /WHEN THE CHARACTERS MATCH, THE NUMBER OF
ISZ TEMP0 /REMAINING CHARACTERS IS FETCHED AND THE
JMP CTRL31 /NEXT SECONDARY TABLE REFERENCED.
CTRL21 DAC PROCAD /STORE DO OR IF PROCESSOR ADDRESSES.
CTRL27 LAC PROCAD
SNA /CHECK FOR "DOUBLE" STATEMENT
JMP DBLEXX /WHICH IS A FUDGE
LAC IMPLFG
SZA!CLL /ARE WE IN AN "IMPLICIT" STATEMENT?
JMP IMPL01 /YES - GO CHECK THE KIND OF STATEMENT WE
LAC PROCAD /FOUND
SAD IMPLAD
SKP /KLUDGE - "IMPLICIT" STMT HAS ORDER 1/2
AND Z00000 /THE SPECIFICATION STATEMENTS MUST BE
RCR /PROCESSED IN A PRESCRIBED MANNER.
DAC TORDER /THEREFORE THE ORDER NUMBER OF THE CURRENT
JMS TWOCMA /STATEMENT IS COMPARED AGAINST THE ORDER
TAD SORDER /OF THE LAST STATEMENT.
ERN 03I,SMA!SZA,EI /ERROR: STATEMENT OUT OF ORDER.
JMS TSTORD /STATEMENTS ARE ORDERED AS FOLLOWS...
JMP CTRL33 / 00 BLOCK DATA, FUNCTION, SUBROUTINE
/ 01 INTEGER, REAL, LOGICAL, DBL PREC, DBL INT.
LAC TORDER / 02 DIMENSION
TAD Z00000 / 03 COMMON
SPA / 04 EQUIVALENCE, EXTERNAL (FLOATS)
JMP CTRL34 / 05 DATA STATEMENT
XCT PASS / 06 STATEMENT FUNCTIONS
/ 07 ALL OTHERS
JMP SEMI00 /CHECK FOR COMMON-DATA ';' OR DIMEN, PASS 2
JMP CTRL34 /STORAGE ASSIGNMENT STATEMENTS ARE NOT
CTRL33 SZA /PROCESSED DURING PASS 2.
JMS CTRL80 /ONLY DATA STATEMENTS AND STORAGE
/ASSIGNMENT STATEMENTS MAY APPEAR IN A
CTRL34 JMS SIN530
JMS CTRL00
JMS TSTORD
SNA
JMS CTRL70
JMS INAOPI /BLOCK DATA SUBPROGRAM.
CLA /APPEAR IN BLOCK DATA SUBPROGRAMS.
JMP* PROCAD
DBLEXX LAC U00000 /"DOUBLE" STATEMENT CAN EITHER BE "DOUBLE INTEGER"
JMS CTRL50 /OR "DOUBLE PRECISION" - GET A CHARACTER AND
JMP CTRL38 /KEEP DECODING THE STATEMENT
SEMI00 LAC TORDER /WANT TO TRAP DIMENSION STATEMENTS IN PASS 2
SAD T00000 /SUCH THAT ADJUSTABLE DIMENSION MAY BE
JMP DIMENS /PROCESSED TO OUTPUT ADJUSTMENT ROUTINES
SAD T40000
JMP SEMI01 /LOOK FOR COMMON SEMICOLON FUDGE
JMP CONTRL /IF NOT A COMMON STMT, FORGET IT
SEMI01 JMS FNBCHR /GET A CHAR
SAD S00073 /IF ITS A SEMICOLON,
JMP SEMI02 /WE'VE FOUND OUR KLUDGE
SAD C00013
JMP CONTRL /AHHH... AN ORDINARY COMMON STATEMENT
JMP SEMI01 /KEEP LOOKING
SEMI02 LAC U40000 /CHANGE THE STATEMENT ORDER
DAC TORDER /TO THAT OF A DATA STATEMENT
LAC FCNFLG /THE SEMICOLON CONSTRUCTION
ERS 11I,<SAD K00001>,EI /IS ONLY GOOD IN A BLOCK DATA
JMP DATA /SUBPROGRAM
T40000 140000
S00073 73
ASSTMT XX
.EJECT
/ PRIMARY STATEMENT IDENTIFICATION TABLE
/ EACH ENTRY IN THIS TABLE CONSISTS OF TWO WORDS. THE FIRST WORD
/ CONTAINS IN BITS 2-17 THE CONCATENATED FORM OF THE FIRST THREE
/ CHARACTERS OF THE NAME. BITS 0-1 CONTAIN THE NUMBER OF CHARACTERS TO
/ BE EXAMINED AGAINST THE FIRST SECONDARY IDENTIFICATION TABLE.
/ THE SECOND WORD CONTAINS IN BITS 3-17 THE ADDRESS OF THE CORRESPONDING
/ STATEMENT PROCESSING ROUTINE. BITS 0-2 CONTAIN A NUMBER INDICATING
/ THE PRESCRIBED ORDER OF APPEARANCE FOR THE STATEMENT.
/
PIDTB0 .DSA .+1
.DSA 620775 /EQU
.DSA 400000+EQUIVA /EQUIVALENCE
.DSA 600020 /P (FUDGE)
DBPRAD .DSA 100000+DBLPRC /DOUBLE PRECISION
.DSA 675012 /SUB
.DSA 000000+SUBROU /SUBROUTINE
.DSA 615165 /DIM
.DSA 200000+DIMENS /DIMENSION
.DSA 607157 /BLO
.DSA 000000+BLOCKD /BLOCK DATA
.DSA 606253 /BAC
.DSA 700000+BACKSP /BACKSPACE
.DSA 600011 /I (FUDGE)
DBINAD .DSA 100000+DBLINT /DOUBLE INTEGER
.DSA 621424 /EXT
.DSA 400000+EXTERN /EXTERNAL
.DSA 612446 /CON
.DSA 700000+CONTIN /CONTINUE
FUNMNE .DSA 624326 /FUN
.DSA 000000+FUNCTI /FUNCTION
.DSA 635130 /IMP
IMPLAD .DSA 000000+IMPLIC /IMPLICIT
.DSA 635204 /INT
INTEAD .DSA 100000+INTEGE /INTEGER
.DSA 646537 /LOG
LOGIAD .DSA 100000+LOGICA /LOGICAL
.DSA 612445 /COM
.DSA 300000+COMMON /COMMON
.DSA 670534 /RET
RETADR .DSA 700000+RETURN /RETURN
.DSA 620563 /ENC
.DSA 700000+ENCODE /ENCODE
.DSA 614713 /DEC
.DSA 700000+DECODE /DECODE
.DSA 615555 /DOU
.DSA 0 /DOUBLE SOMETHING
.DSA 623752 /FOR
.DSA 700000+FORMAT /FORMAT
.DSA 604513 /ASS
.DSA 700000+ASSIGN /ASSIGN
.DSA 670537 /REW
.DSA 700000+REWIND /REWIND
.DSA 511231 /WRI
.DSA 700000+WRITE /WRITE
.DSA 462075 /PAU
PAUSAD .DSA 700000+PAUSE /PAUSE
.DSA 463331 /PRI
.DSA 700000+WRITE /PRINT
.DSA 420604 /ENT
.DSA 700000+ENTRY /ENTRY
.DSA 211364 /CAL
.DSA 700000+CALL /CALL
.DSA 214474 /DAT
DATAAD .DSA 500000+DATA /DATA
.DSA 274757 /STO
STOPAD .DSA 700000+STOP /STOP
.DSA 300370 /TYP
.DSA 700000+WRITE /TYPE
.DSA 227054 /GOT
GOTOAD .DSA 700000+GOTO /GOTO
IFMNE .DSA 034522 /IF(
IFADDR .DSA 700000+IF /IF
ENDMNE .DSA 020564 /END
ILEMNE .DSA 035045 /ILE
ENDFAD .DSA 700000+ENDFIL /ENDFILE
REAMNE .DSA 070511 /REA
REALAD .DSA 100000+REAL /REAL
READAD .DSA 700000+READ /READ
DOMNE .DSA 000257 /DO
DOADDR .DSA 700000+DO /DO
.EJECT
/ SECONDARY STATEMENT IDENTIFICATION TABLES
/
CTRL90 .DSA .+1
.DSA SIDTB1 /FIRST SECONDARY TABLE..CHARACTERS 04-06
.DSA SIDTB2 /SECOND SECONDARY TABLE.CHARACTERS 07-09
.DSA SIDTB3 /THIRD SECONDARY TABLE..CHARACTERS 10-12
/
/ A SECONDARY TABLE ENTRY CONTAINS IN BITS 2-17 THE CONCATENATED FORM
/ OF CHARACTERS N THRU N+2 OF THE NAME AND IN BITS 0-1 THE NUMBER OF
/ CHARACTERS TO BE EXAMINED IN THE FOLLOWING TABLE.
/
SIDTB1=.
.DSA 635661 /IVA EQUIVALENCE
.DSA 670513 /REC DOUBLE PRECISION
.DSA 671355 /ROU SUBROUTINE
.DSA 620603 /ENS DIMENSION
.DSA 612174 /CKD BLOCK DATA
.DSA 643710 /KSP BACKSPACE
.DSA 655245 /NTE DOUBLE INTEGER
.DSA 421036 /ERN EXTERNAL
.DSA 477166 /TIN CONTINUE
CTIMNE .DSA 412751 /CTI FUNCTION
.DSA 446153 /LIC IMPLICIT
.DSA 220135 /EGE INTEGER
.DSA 234271 /ICA LOGICAL
.DSA 051646 /MON COMMON
.DSA 103036 /URN RETURN
.DSA 057145 /ODE ENCODE
.DSA 057145 /ODE DECODE
.DSA 007145 /BLE DOUBLE
.DSA 050574 /MAT FORMAT
.DSA 034546 /IGN ASSIGN
.DSA 035164 /IND REWIND
.DSA 001445 /TE WRITE
.DSA 001375 /SE PAUSE
.DSA 001104 /NT PRINT
.DSA 001351 /RY ENTRY
C00012 .DSA 000014 /L CALL
C00001 .DSA 000001 /A DATA
C00016 .DSA 000020 /P STOP
.DSA 000005 /E TYPE
C00015 .DSA 000017 /O GOTO
/
SIDTB2=.
.DSA 445726 /LEN EQUIVALENCE
.DSA 435501 /ISI DOUBLE PRECISION
.DSA 277166 /TIN SUBROUTINE
.DSA 035246 /ION DIMENSION
.DSA 004541 /ATA BLOCK DATA
.DSA 003275 /ACE BACKSPACE
.DSA 026232 /GER DOUBLE INTEGER
.DSA 000064 /AL EXTERNAL
.DSA 001515 /UE CONTINUE
ONMNE .DSA 001146 /ON FUNCTION
.DSA 000574 /IT IMPLICIT
C00018 .DSA 000022 /R INTEGER
.DSA 000014 /L LOGICAL
/
SIDTB3=.
.DSA 000175 /CE EQUIVALENCE
.DSA 001146 /ON DOUBLE PRECISION
C00005 .DSA 000005 /E SUBROUTINE
/
.EJECT
/ SUBROUTINE TO CONCATENATE N NON-BLANK CHARACTERS
/ CALLING SEQUENCE...
/ LAC N /N IS CONTAINED IN BITS 0 AND 1
/ JMS CTRL50
/
CTRL50 SYN ARG1
DZM NAME2
RCR
CTRL52 DAC NAME1
DAC CTRLSW
SNA
JMP CTRL51
LAC LOGIF
SZA
DZM CTRLSW
CTRL54 JMS FETCHR
JMP CTRL53
CTRL51 LAC NAME2 /WHEN FINISHED, THE CONCATENATED
JMP* CTRL50 /CHARACTERS ARE RETURNED TO THE CALLING PROGRAM
CTRL53 SAD C00011
JMP CTRL54 /ONLY NON-BLANK CHARACTERS FROM THIS IMAGE
JMS CAT /ARE CONCATENATED.
LAC NAME1
TAD Z00000 / N-1 TO N (ALSO TO SWITCH WHICH ALLOWS
JMP CTRL52 / IMAGE CONTINUATION)
/
/ PROCESS " AND ' AND $ DURING STATEMENT SCAN
/
CTRL55 LAC XCHAR
DAC CTRL50 /SAVE OPENING QUOTE
CTRL56 JMS FETCHR
SKP
JMP CTRL19 /LINE DONE
LAC XCHAR
SAD CTRL50
JMP CTRL13 /CLOSE QUOTE - RETURN TO MAIN SCAN
JMP CTRL56 /KEEP LOOKING
.EJECT
/ SUBROUTINE TO TEST FOR STATEMENT TERMINATION CHARACTER
/ CALLING SEQUENCE...
/ JMS CTRL60
/ JMP NO
/ XXX YES
/
CTRL60 SYN RELOPT
LAC XCHAR /THE LAST CHARACTER FETCHED IS EXAMINED
SAD C00013 /TO DETERMINE IF IT IS A CARRIAGE RETURN
ISZ CTRL60 /CHARACTER (LINE TERMINATION CHARACTER).
JMP* CTRL60
/
/
/
/ SUBROUTINE TO DETERMINE IF STATEMENT IS ERRONEOUSLY LABELED
/
CTRL70 SYN ARG2
LAC LABEL
SNA /NO ACTION IS TAKEN IF THE STATEMENT IS
JMP* CTRL70 /NOT LABELED.
ERR 02N,16340,EN /A RECOVERABLE ERROR IS ANNOUNCED
LAC V77777 /IF THE STATEMENT IS LABELED.
DAC* LABEL /THE STATEMENT NUMBER IS FLAGGED AS BEING
DZM LABEL /PERMANENTLY UNDEFINEABLE AND THE NO-LABEL
JMP* CTRL70 /FLAG IS INDICATED FOR THE STATEMENT.
/
/
/
/ SUBROUTINE TO ANNOUNCE AN ERROR WHEN A BLOCK DATA SUBPROGRAM CONTAINS
/ EXECUTABLE STATEMENTS
/
CTRL80 SYN OPI /NO ACTION IS TAKEN WHEN THE CURRENT
LAC FCNFLG /SOURCE PROGRAM IS NOT A BLOCK DATA
ERN 04I,<SAD K00001>,EI /SUBPROGRAM
JMP* CTRL80
.TITLE STORAGE ALLOCATION STATEMENTS
IMPLIC LAC S40000 /IMPLICIT IS OF ORDER 3/2 - I.E.
DAC TORDER /IT COMES AFTER A "SUBROUTINE" STATEMENT
ISZ IMPLFG /BUT BEFORE ANY TYPE STATEMENT
XCT PASS /LIKE THE TYPE STATEMENTS,
JMP CONTRL /IT IS IGNORED ON PASS 2
IMPGRP LAC Y00000 /BEGINNING OF IMPLICIT GROUP: GET THE
JMS CTRL50 /NEXT THREE CHARACTERS
JMP IMCTRL /AND DECODE THE RESULTING ATATEMENT
IMPL01 LAC PROCAD /STATEMENT DECODER COMES HERE WHEN ITS DONE
SAD REALAD
LAC S20000 /DETERMINE IF THE STATEMENT IS A TYPE STATEMENT
SAD INTEAD /AND SET THE MODE ACCORDINGLY
CLA
SAD DBPRAD
LAC S40000
SAD DBINAD
LAC S60000
SAD LOGIAD
CLA!CML
RAR /THE IMPLICIT MODE TABLE CONSISTS OF THE MODE
DAC MODE /SHIFTED RIGHT 1 AND THE LOGICAL FLAG IN THE SIGN
AND SI7777 /NOW TEST IF WE GOT SOMETHING
ERN 08I,SZA,EI /THE STATEMENT WASN'T A TYPE STATEMENT
JMS FNBCHR
ERS 12I,<SAD S00050>,EI /NEXT CHAR BETTER BE (
IMPCMA JMS GETLET /GET A LETTER AND FORM A POINTER
DAC LOLET /SET LOWER LIMIT
DAC HILET /HIGHER LIMIT = LOWER LIMIT
JMS FNBCHR
SAD C00045 /IS IT A RANGE OR A SINGLE VALUE?
JMP IMDASH /A RANGE
IMPCMN LAC HILET /THIS IS WHERE WE SET THE TABLE -
CMA /COMPUTE THE NUMBER OF ENTRIES IN THE RANGE
TAD LOLET
DAC HILET
ERN 21I,SMA,EI /HIGHER LIMIT < LOWER LIMIT - ERROR
LAC MODE
LOLET XX /STORE THE MODE INTO THE TABLE
ISZ LOLET
ISZ HILET
JMP LOLET /AS MANY TIMES AS NECESSARY
LAC XCHAR
SAD S00054 /WAS TERMINATOR A COMMA?
JMP IMPCMA /YES - GET ANOTHER RANGE
ERS 22I,<SAD S00051>,EI /BETTER BE A )
JMS FNBCHR
SAD S00054 /IS THERE ANOTHER GROUP?
JMP IMPGRP /YES
XCT PASS
JMP CRTEST /ONLY REDEFINE VARIABLES DURING PASS 1
LAC SYMTB0 /NOW GO THROUGH THE SYMBOL TABLE
IMPSLP DAC SYMTBC /AND RE-TYPE ALL VARIABLES
SAD SYMTBN /WHICH ARE NOT ALREADY EXPLICITLY TYPED
JMP CRTEST
JMS SETADR
LAC* SYMTW2 /GET THE HIGH ORDER NAME WORD
JMS OBJ560 /EXTRACT THE FIRST CHARACTER
TAD K01600
LAC OBJB01 /OBJB01 CONTAINS FIRST RADIX 50 CHARACTER
SAD C00028 /PERIOD?
JMP IMNEXT /YES - SYSTEM SYMBOL - DON'T TYPE IT
TAD LACTAB
DAC .+1 /INDEX INTO THE TABLE OF IMPLICIT MODES
XX
RCL /DECOMPOSE THE TABLE ENTRY INTO THE MODE
DAC MODE /AND THE "LOGICAL VARIABLE" FLAG
CLA!RAR
DAC LOGFLG
LAC* SYMTW6
SPA /(GAR-072) EXPLICIT TYPE BIT IN SIGN OF SYMTW6
JMP IMNEXT /(GAR-072) DON'T CHANGE IF EXPLICITLY TYPED.
LAC* SYMTBC
AND Z17777 /AND OUT MODE BITS
XOR MODE
/ SNL
/ (GAR-072) ABOVE LINE DELETED.
DAC* SYMTBC /RE-STORE IF NOT EXPLICITLY DEFINED
LAC* SYMT2A
XOR LOGFLG
/ SNL
/ (GAR-072) DELETED ABOVE LINE.
DAC* SYMT2A /SIMILIARLY RESTORE LOGICAL FLAG
LAC MODE /(GAR-072) SET UP TO CHANGE THE ...
JMS SETN /(GAR-072) ELEMENT LENGTH.
DAC* SYMTW3 /(GAR-072) ENTER ELEMENT LENGTH IN SYMBOL TABLE.
IMNEXT JMS SBSE50 /GO TO NEXT ENTRY
JMP IMPSLP /AND LOOP
IMDASH JMS GETLET /RANGE INDICATED - GET UPPER LIMIT
DAC HILET
JMS FNBCHR /GET TERMINATOR
JMP IMPCMN
/
GETLET CAL 0 /SUBROUTINE TO GET A LETTER
JMS FNBCHR
TAD K00133
CLL
TAD C00026 /TEST FOR CHARACTER IN THE RANGE 101-132 OCTAL
ERN 20I,SNL,EI
TAD DACTAB /FORM AN INSTRUCTION
JMP* GETLET
K00133 .DSA 777645
DACTAB DAC IMTBL
LACTAB LAC IMTBL-1
IMTBL .BLOCK 32 /IMPLICIT TABLE - 26 WORDS LONG
HILET 0
S10000 .DSA 10000
IMPLFG .DSA 0
SI7777 .DSA 7777
.EJECT
/ EXTERNAL STATEMENT PROCESSOR
/
EXTERN JMS CTRL80 /EXTERNAL CANNOT APPEAR IN BLOCK DATA SUBR.
EXTE03 JMS FVARGO /THE EXTERNAL STATEMENT IS USED TO DECLARE
LAC* SYMTBC /THE NAMES OF EXTERNAL FUNCTIONS WHICH
AND Z00000 /WILL APPEAR AS FUNCTION PARAMETERS WITHOUT
SAD V00000 /(BY SETTING SPECIAL BIT IN SYMTAB, DUMMY
JMP EXTE02 /VARIABLES CAN BE EXTERNAL)
ERN 01E,SZA,EE /PARAMETER LISTS SO THAT THEY MAY BE
EXTE01 LAC* SYMTBC /DISTINGUISHED FROM SIMPLE VARIABLES.
AND S60000 /GET THE SYMTAB ENTRY FOR THE FUNCTION, SAVE ITS
XOR U17777 /MODE, AND TYPE IT AS A FUNCTION.
DAC* SYMTBC /THE LISTED NAMES CANNOT REPRESENT...
LAC OPVALU / (1) ALREADY DECLARED FUNCTION NAMES
SAD C00030 / (X) DUMMY VARIABLES ARE ALLOWED
JMP EXTE03 / (2) VARIABLES ASSIGNED TO A COMMON BLOCK
LAC SORDER / (3) ARRAYS
DAC TORDER
JMP CRTEST
EXTE02 LAC* SYMTW2 /BIT 1 OF SECOND SYMTAB WORD IS
AND U00000 /SET IF A DUMMY ARG USED AS A FUNCTION
SZA /MUST NOT ALREADY BE SET
JMP EE01E
LAC* SYMTW2 /SET THE SPECIAL BIT
XOR U00000
DAC* SYMTW2
JMP EXTE01
U17777 .DSA 217777 /UNDEFINED EXTERNAL
.EJECT
/ DOUBLE INTEGER STATEMENT PROCESSOR
/
DBLINT TAD S20000 /MODE IS INDICATED BY 3
/
/ DOUBLE PRECESION STATEMENT PROCESSOR
/
DBLPRC TAD S20000 /MODE IS INDICATED BY 2
/
/ REAL STATEMENT PROCESSOR
/
REAL TAD S20000 /MODE IS INDICATED BY 1
/
/ INTEGER STATEMENT PROCESSOR (AND THE OTHER MODE SETTING STATEMENTS)
/
INTEGE SKP!CLL
LOGICA CLA!CLL!CML /LOGICAL=INTEGER BUT SET A FLAG
DAC MODE /MODE IS INDICATED BY 0
CLA!RAR
DAC LOGFGX /SAVE LOGICAL-INTEGER FLAG
JMS SIN530 /SAVE POSITION IN SOURCE IMAGE.
LAC Y00000 /THE WORDS LOGICAL, DOUBLE PRECESION,
JMS CTRL50 /REAL OR INTEGER MAY OR MAY NOT IDENTIFY
XOR Y00000
SAD FUNMNE /THE STATEMENTS BY THE SAME NAMES.
SKP /IF THE FIRST WORD FOLLOWING ANY ONE OF
JMP INTG02 /THESE WORDS IS THE WORD FUNCTION, THE
LAC Y00000 /STATEMENT IS ASSUMED TO BE AN EXPLICITLY
JMS CTRL50 /MODE TYPED FUNCTION STATEMENT.
XOR W00000
SAD CTIMNE /THE GENERAL FORM OF THE STATEMENT IS....
SKP / T FUNCTION NAME(ARG1,ARG2,..,ARGN)
JMP INTG02 /WHERE T IS LOGICAL, DOUBLE PRECESION,
LAC W00000 /REAL OR INTEGER.
JMS CTRL50
SAD ONMNE
JMP TFUNCT /THE MODE-TYPING STATEMENTS ARE
INTG02 JMS SIN540 /PROCESSED BY THE DIMENSION STATEMENT.
.EJECT
/ DIMENSION STATEMENT PROCESSOR - ALSO USED BY TYPE STATEMENTS
/ALLOWS PASS2 PROCESSING OF ARRAYS TO GET ADJUSTABLE DIMENSION
DIMENS JMS FVARGO /GET A VARIABLE NAME
LAC MODE /IF WE ARE IN A DIMENSION STATEMENT (MODE=-1)
SPA /THEN WE SHOULDN'T CHECK FOR MODE REDEFINITION.
JMP DIMN01
XCT PASS /NOR SHOULD WE CHECK FOR MODE REDEFINITION IN
JMP DIMN05-3 /PASS 2
LAC* SYMTW6 /IF VARIABLE MODE ALREADY EXPLICITLY SET, BIT 0
ERN 01V,SPA,EV /OF SYMTW6 WILL BE ON - REPORT AN ERROR.
LAC W00000 /THE EXPLICITLY MODE-TYPED FLAG IS SET SO
DAC* SYMTW6 /THAT AN ERROR CAN BE ANNOUNCED IF THE
LAC* SYMTBC /NAME SHOWS UP ON ANOTHER SPECIFICATION
AND Z17777 /STATEMENT. THE IMPLICIT MODE OF THE NAME
XOR MODE /(BASED ON THE FIRST CHARACTER OF THE NAME) IS
DAC* SYMTBC /OVERRIDDEN AND THE EXPLICIT MODE SUBSTITUTED.
JMS SETN /RECOMPUTE THE ELEMENT LENGTH
DAC* SYMTW3 /AND SAVE IT
LAC* SYMT2A
AND V77777
XOR LOGFGX /THE "LOGICAL FLAG" IN SYMT2A IS PART OF THE MODE
DAC* SYMT2A
LAC OPVALU
SAD C00028 /EITHER SIMPLE VARIABLES OR
JMP DIMN03 /ARRAY DECLARATIONS MAY APPEAR ON A
DIMN05 SAD C00030 /SPECIFICATION STATEMENT. COMMAS ARE USED
JMP DIMENS /TO SEPARATE THE DECLARATIONS.
CRTEST ERN 01X,<JMS CTRL60>,EX /CR TERMINATES, OTHERWISE ERROR
JMP STEXIT
DIMN01 LAC OPVALU /DIMENSION STATEMENTS MAY CONTAIN ONLY
ERS 01C,<SAD C00028>,EC /ARRAY DECLARATIONS.
DIMN03 JMS FEDIMN /THE ARRAY DIMENSIONS ARE OBTAINED AND
JMP DIMN05 /ENTERED INTO THE SYMBOL TABLE.
LOGFLG .DSA 0
LOGFGX .DSA 0
.EJECT
/ COMMON STATEMENT PROCESSOR
/
COMMON JMS FNBCHR /LABELED COMMON IS INDICATED BY ENCLOSING
SAD C00047
JMP COMN01 /THE LABELING NAME IN SLASHES. THE ABSENCE
DZM UNFNBC
COMN03 LAC BLANKC /OF SLASHES INDICATES BLANK COMMON.
DAC NAME1 /BLANK COMMON IS TREATED IN THE SAME
DZM NAME2
JMS SYMBSE /MANNER AS LABELED COMMON AND SO THE
JMP COMN02 /COMPILER ASSIGNS A LABEL TO BLANK COMMON.
COMN01 JMS FNBCHR /TWO SLASHES WITH NO NAME BETWEEN THEM
SAD C00047
JMP COMN03 /ALSO INDICATE BLANK COMMON.
DZM UNFNBC
JMS FVARGO /FETCH THE BLOCK NAME
ERS 02C,<SAD C00018>,EC /NAME MUST END WITH SLASH
COMN02 LAC NAME1
SNA /IF THE DECLARED NAME OF THIS BLOCK HAS
JMP COMN04 /BEEN ENTERED INTO THE SYMBOL TABLE
LAC* SYMTBC /PREVIOUSLY, IT MUST HAVE BEEN USED ONLY
ERS 03C,<SAD K00001>,EC /AS A COMMON BLOCK NAME
LAC* SYMTW7 /CHECK WHETHER THE BLOCK IS EMPTY
SNA
JMP COMN04
JMS TSETAD
LAC* TSMTW4
JMS NTHSYM /CHAIN THE CURRENT BLOCK TO
LAC SYMTW4 /THE EXISTING BLOCK.
DAC LSTVAR
JMP COMN09
COMN04 LAW -1 /WHEN THE NAME IS FIRST
DAC* SYMTBC /ENTERED IT IS FLAGGED AS A COMMON BLOCK
DZM* SYMTW7 /LABEL AND THE BLOCK SIZE IS RESET TO ZERO
JMS TSETAD
COMN09 JMS FVARGO
JMS SYMTYP /THE NAMES OF THE DATA WORDS (ARRAYS)
OBSPCL XOR C00000 /ASSIGNED TO THE COMMON BLOCK MUST
ERX 04C,EC /INITIALLY REPRESENT NON-COMMON VARIABLES
LAC OPVALU /OR ALREADY DECLARED TO BE IN COMMON.
SAD C00028 /ARRAY DECLARATIONS ARE LEGAL ON COMMON
JMS FEDIMN /STATEMENTS.
LAC* TSMTW7 /VARIABLES IN COMMON ARE ASSIGNED RELATIVE
DAC* SYMTW7 /POSITIONS IN COMMON IN THE ORDER OF THEIR
SZA /APPEARANCE. THE FIRST MEMBER OF THE BLOCK
JMP COMN07 /IS INDICATED BY A ZERO BLOCK. IT IS SET
LAC CHRCTR /AS BOTH THE FIRST AND LAST MEMBERS OF THE
DAC* TSMTW4 /BLOCK
LAC SYMTW4
DAC LSTVAR
COMN07 LAC* SYMTW3 /THE SIZE OF THIS VARIABLE (OR ARRAY) IS
TAD* TSMTW7 /ADDED TO THE EXISTING SIZE OF THE COMMON
DAC* TSMTW7 /BLOCK TO WHICH IT IS ASSIGNED
JMS CHAIN /THE VARIABLE (ARRAY) IS ADDED TO THE LIST
LAC* SYMTBC /OF VARIABLES ASSIGNED TO THIS COMMON
XOR T00000 /BLOCK.
DAC* SYMTBC /THE VARIABLE (ARRAY) IS FLAGGED AS A
LAC OPVALU /COMMON VARIABLE (ARRAY).
SAD C00045 /SEMICOLON?
JMP SEMI02 /YES - ITS THE COMMON-DATA KLUDGE
SAD C00030 /NAMES BELONGING TO THE SAME COMMON BLOCK
JMP COMN09 /ARE SEPARATED BY COMMAS. A NEW COMMON
SAD C00018 /BLOCK IS DECLARED WHEN THE LIST OF NAMES
JMP COMN01 /IS DELIMITED BY A SLASH. IF NEITHER OF
JMP CRTEST /THESE DELIMITERS APPEAR, FINI.
.EJECT
/ EQUIVALENCE STATEMENT PROCESSOR
/
EQUIVA JMS FNBCHR /GET CHARACTER
ERS 05C,<SAD S00050>,EC /BETTER BE (
DZM FSTVAR /THE FIRST CLASS MEMBER FLAG IS INITIALIZED
EQUI07 JMS FVORAR /AND A CLASS MEMBER IS OBTAINED.
LAC T0 /THE SUBSCRIPT VALUE OF THE VARIABLE IS THE
/VARIABLES POSITION IN THE ARRAY (SIMPLE
DAC SUBVAL /VARIABLES ARE TREATED AS 1-DIMENSIONAL
LAC FSTVAR /ARRAYS) PLUS THE NUMBER OF MACHINE WORDS
SZA /OCCUPIED BY A SINGLE ELEMENT OF THE ARRAY.
JMP EQUI02 /THE EQUIVALENCE CLASS IS INITIALIZED UPON
LAC OPVALU /ENCOUNTERING THE FIRST VARIABLE
ERS 06C,<SAD C00030>,EC /ERROR: ONLY 1 VAR IN CLASS
DZM OLDCLS
DZM COMCLS /INITIALLY, THE CLASS IS SET UP AS A NEW
LAC CHRCTR /CLASS WITH NO MEMBERS IN ANY COMMON BLOCK.
DAC HEDCLS /THE CURRENT VARIABLE IS NAMED BOTH THE
LAC SYMTW4 /HEAD OF THE EQUIVALENCE CLASS AND THE
DAC LSTVAR /LAST MEMBER ADDED TO THE CLASS. AS THE
LAC SUBVAL /HEAD OF THE CLASS, IT IS ASSIGNED THE
DAC SUBADJ /RELATIVE ADDRESS ZERO AND ITS SUBSCRIPT
EQUI02 LAC SUBVAL /VALUE IS USED AS THE ADJUSTMENT FACTOR TO
JMS TWOCMA /LINE-UP THE RELATIVE ADDRESSES OF THE
TAD SUBADJ /OTHER MEMBERS WITH RESPECT TO ZERO.
DAC RELADR
JMS SYMTYP
XOR T00000 /IS THE VARIABLE IN COMMON?
JMP EQUI04 /NO - ADD VARIABLE TO EQUIVALENCE CLASS
LAC COMCLS /WE WILL MERGE THIS EQUIVALENCE CLASS WITH
ERN 07C,SZA,EC /THE VARIABLE'S COMMON (UNLESS THE
LAC C00001 /CLASS IS ALREADY IN COMMON, IN WHICH CASE AN
DAC COMCLS /ERROR EXISTS.) A COMMON
DAC OLDCLS /BLOCK IS A SPECIAL CASE EQUIVALENCE CLASS.
EQUI01 LAC RELADR
JMS TWOCMA
TAD* SYMTW7 /WHEN THE CURRENT VARIABLE IS A MEMBER OF
DAC DIFF /TWO UNIQUE CLASSES (THE CURRENT CLASS AND
TAD SUBADJ /A PREVIOUS CLASS), THE TWO CLASSES ARE
DAC SUBADJ /MERGED TOGETHER INTO ONE CLASS.
LAC FSTVAR /WHEN THE CURRENT VARIABLE IS THE ONLY
SZA /MEMBER OF THE CURRENT CLASS, THE PREVIOUS
JMP EQUI06 /CLASS IS NAMED THE CURRENT CLASS WITH THE
LAC* SYMTW4 /VARIABLE NAMED BY THE CURRENT VARIABLES
DAC HEDCLS /LINKAGE ADDRESS NAME THE HEAD OF THE
DAC OLDCLS /CURRENT CLASS. FLAGS ARE SET TO INDICATE
DAC FSTVAR /THAT A NEW CLASS HAS NOT BEEN CREATED AND
JMP EQUI07 /THAT THE CLASS CONTAINS MORE THAN ONE
EQUI04 LAC* SYMTW4
SAD CHRCTR
JMP EQUI05
LAC COMCLS
SNA
JMP EQUI01
LAC CHRCTR
DAC FSTVAR
LAC* SYMTW7
JMS TWOCMA
TAD RELADR
DAC DIFF
SKP
EQUI16 JMS NTHSYM
LAC* SYMTW7 /MERGING ANOTHER CLASS INTO A CLASS
TAD DIFF /IN COMMON - ADD IN THE PROPER OFFSET
DAC* SYMTW7
SMA /CHECK THAT THE NEW OFFSET IS NOT
JMP .+4 /NEGATIVE, AS THIS MEANS WE HAVE
ERR 08C,16060,EC /UNDERFLOWED THE COMMON BLOCK
DZM* SYMTW7 /SET OFFSET TO ZERO AND CONTINUE
LAC* SYMTBC
AND Y77777
XOR T00000 /FORCE THE COMMON INDICATOR ON
DAC* SYMTBC /FOR THIS VARIABLE.
LAC* SYMTW4
SAD FSTVAR
JMP EQUI17
JMP EQUI16
EQUI06 JMS TSETAD
LAC HEDCLS /THE PREVIOUS AND CURRENT CLASSES ARE
EQUI12 JMS NTHSYM /MERGED WHEN THE CURRENT CLASS CONTAINS
LAC* SYMTW7 /MORE THAN ONE MEMBER. THE PREVIOUS CLASS
TAD DIFF
DAC* SYMTW7
LAC COMCLS /THESE 7 LINES CORRECT AN EQUIV BUG
SNA
JMP .+5
LAC* SYMTBC
AND Y77777
XOR T00000
DAC* SYMTBC
LAC* SYMTW4 /CALSS ARE FLAGGED AS VARIABLES IN COMMON
SAD TRELAD /ALL RELATIVE ADDRESSES HAVE BEEN ADJUSTED
JMP EQUI11 /WHEN THE LINKAGE ADDRESS POINTS TO THE
SAD HEDCLS /HEAD OF THE CLASS.
JMP EQUI10 /THE CURRENT VARIABLE WILL ALREADY BE A
JMP EQUI12 /MEMBER OF THE CURRENT CLASS IF THE TWO
EQUI11 LAC DIFF /CLASSES HAVE TWO OR MORE MEMBERS IN COMMON
/IF SO, THE RELATIVE ADDRESS OF THE CURRENT
/VARIABLE HAS ALREADY BEEN ADJUSTED (WHEN
ERN 09C,SZA,EC
/**057** THE USER HAS SPECIFIES A REDUNDENT EQUIVALENCE
/**057** WE CAN'T HANDLE THAT SO GIVE HIM AN ERROR
/**057** SINCE WE BREAK THE CHAIN AND THAT RESULTS IN
/**057** MISS ALLOCATION OF CORE
ERX 17C,EC /**057** NEW ERROR 'REDUNDENT EQUIVALENCE'
/THE OTHER VARIABLE COMMON TO BOTH CAUSED
/A MERGE). THEREFORE, AN ERROR IS ANNOUNCED
EQUI10 LAC TRELAD /IF THE CURRENT ADDRESS DIFFERENCE IS NOT
/ZERO (THE RELATIONSHIP BETWEEN THE TWO
DAC OLDCLS /VARIABLES IN BOTH CLASSES IS NOT THE SAME)
JMS NTHSYM /A FLAG IS SET TO INDICATE THE DISOLVMENT
JMP EQUI17 /OF THE CURRENT CLASS.
EQUI05 LAC COMCLS
SNA /A VARIABLE WHICH IS NOT PRESENTLY
JMP EQUI18 /ASSOCIATED WITH ANY OTHER VARIABLES IN AN
LAC RELADR /EQUIVALENCE CLASS OR COMMON BLOCK IS
/SIMPLY ADDED TO THE CURRENT CLASS.
/ERROR: RELATIVE ADDRESS OF A VARIABLE
ERN 10C,SPA,EC /ASSIGNED TO A COMMON BLOCK THROUGH
/AN EQUIVALENCE RELATION UNDERFLOWS.
LAC* SYMTBC
AND Y77777
XOR T00000 /THE VARIABLE ASSIGNED TO A COMMON BLICK IS
DAC* SYMTBC /TYPED AS A VARIABLE IN COMMON.
EQUI18 LAC RELADR /THE VARIABLE'S RELATIVE ADDRESS IS ADDED TO
DAC* SYMTW7 /ITS ENTRY IN THE SYMBOL TABLE.
EQUI17 JMS CHAIN /THE CURRENT EQUIVALENCE CHAIN IS BROKEN
LAC OPVALU /AND THE CURRENT VARIABLE INSERTED
SAD C00030 /A COMMA HERE INDICATES MORE CLASS MEMBERS TO COME
JMP EQUI07
ERS 11C,<SAD C00031>,EC /OTHERWISE ONLY ) IS LEGAL
LAC OLDCLS
SZA
JMP EQUI14 /A NEW ENTRY IS MADE INTO THE LIST OF
LAC EQUCLS /UNIQUE EQUIVALENCE CLASSED IS THE CURRENT
TAD C00001 /CLASS WAS NOT MERGED INTO A PREVIOUS
/CLASS OR COMMON BLOCK.
ERN 01M,<SAD EQCLSX>,EM /ERROR: EQV CLASS LIST FULL
DAC EQUCLS /THE ADDRESS OF THE SYMBOL TABLE ENTRY OF
LAC HEDCLS /THE HEAD OF THE CLASS IS ENTERED INTO THE
DAC* EQUCLS /LIST OF EQUIVALENCE CLASSES.
EQUI14 JMS FNBCHR
SAD S00054 /ANOTHER EQUIVALENCE CLASS IS INDICATED IF
JMP EQUIVA /THE LAST CLASS IS DELIMITED BY A COMMA.
JMP CRTEST /OTHERWISE PROCESSING IS FINISHED.
.EJECT
/ SUBROUTINE TO CLEAN-UP DATA STORAGE ASSIGNMENTS
/
CLENUP SYN TYPEA1 /DATA STORAGE LOCATIONS ARE ASSIGNED AFTER
XCT PASS /THE END STATEMENT IS ENCOUNTERED
JMP CLEN02 /THE ASSIGNMENTS ARE MADE DURING PASS 1
LAC PC /AND THE BINARY INFORMATION IS OUTPUT
DAC START /DURING PASS 2.
DAC EQUSTR /THE AMOUNT OF NON-COMMON EQUIVALENCED
LAC EQUCLS /MEMORY IS INITIALLY SET TO ZERO.
CLEN10 SAD EQU0
JMP CLEN03 /MEMORY ALSO ASSIGNED AT THIS TIME IS USED
LAC* EQUCLS /FOR ARRAY DESCRIPTION WORDS, NON-COMMON
JMS NTHSYM /ARRAY STORAGE, AND TRANSFER VECTORS FOR
LAC* SYMTW4 /SIMPLE VARIABLES IN COMMON.
SMA /EACH EQUIVALENCE CLASS IS EXAMINED BEFORE
JMS SYMTYP /IT IS ADDED TO THE NON-COMMON STORAGE
XOR C00000 /AREA. IF A CLASS HAS ALREADY BEEN ASSIGNED
JMP CLEN04 /TO THE STORAGE AREA (BY VIRTUE OF THE
DZM LOWRAD /CLASS BEING REDUNDANTLY IN THE LIST TWICE
CLEN07 LAC* SYMTW7 /DUE TO A DOUBLE MERGE) OR IF THE CLASS IS
JMS TWOCMA /REALLY A COMMON BLOCK, IT IS BY-PASSED.
TAD LOWRAD
SPA /WHEN A CLASS HAS NOT BEEN ASSIGNED, THE
JMP CLEN05 /MEMBER WITH THE LOWEST RELATIVE ADDRESS
LAC* SYMTW7 /IS FOUND AND IS ASSIGNED THE PROGRAM
DAC LOWRAD /COUNTER AS ITS TRUE ADDRESS.
CLEN05 LAC* SYMTW4
SAD* EQUCLS /RELATIVE ADDRESSES MAY BE NEGATIVE AS
JMP CLEN06 /THEY REFLECT THE VARIABLES RELATIVE
JMS NTHSYM /POSITION IN THE CLASS WITH RESPECT TO THE
JMP CLEN07 /HEAD OF THE CLASS (RELATIVE ADDRESS=ZERO).
CLEN06 JMS NTHSYM
LAC LOWRAD /THE PROGRAM COUNTER IS ADJUSTED BY THE
JMS TWOCMA /LOWEST RELATIVE ADDRESS OF THE CLASS.
TAD PC /THIS RESULTANT VALUE IS USED TO ASSIGN
DAC LOWRAD /LOCATIONS TO THE CLASS MEMBERS.
CLEN09 LAC* SYMTW7
TAD LOWRAD /THE MEMBER WITH THE LOWEST RELATIVE
DAC* SYMTW7 /ADDRESS WILLBE ASSIGNED THE CURRENT
JMS DEFNSM
XOR* SYMTW7
JMS CLEN60 /PROGRAM COUNTER. THE OTHER MEMBERS OF THE
TAD PC /CLASS ARE ASSIGNED STORAGE LOCATIONS
SMA /THAT ARE CONSISTANT WITH THEIR RELATIVE
JMP CLEN08 /POSITIONS IN THE CLASS.
DZM PC /THE PROGRAM COUNTER IS UPDATED IF ITS
JMS INCRPC /COURRENT VALUE IS LESS THAN WHAT IT WOULD
TAD TEMP0 /BE IF IT WAS UPDATED BY THE AMOUNT OF
CLEN08 LAC* SYMTW4 /STORAGE OCCUPIED BY THIS MEMBER
XOR W00000 /THE CURRENT MEMBER IS FLAGGED AS BEING
DAC* SYMTW4 /ASSIGNED
AND V77777
SAD* EQUCLS /ALL MEMBERS OF THIS CLASS HAVE BEEN
JMP CLEN04 /ASSIGNED WHEN THE CURRENT MEMBERS LINKAGE
JMS NTHSYM /ADDRESS POINTS TO THE HEAD OF THE CLASS
JMP CLEN09 /(THE FIRST MEMBER ASSIGNED).
CLEN04 LAC EQUCLS /THE EQUIVALENCE CLASS LIST ADDRESS IS
TAD K00001 /UPDATED AND THE NEXT ENTRY IS EXAMINED
DAC EQUCLS /TO DETERMINE IF ALL THE CLASSES HAVE BEEN
JMP CLEN10 /ASSIGNED MEMORY LOCATIONS.
CLEN03 LAC EQUSTR
JMS TWOCMA /THE AMOUNT OF NON-COMMON DATA STORAGE
TAD PC /REQUIRED BY THE EQUIVALENCE CLASSES IS
DAC EQUSTR /DETERMINED BY SUBTRACTING THE STARTING
LAC START
DAC PC
CLEN02 DZM LOWRAD /THE AMOUNT OF STORAGE REQUIRED FOR THE
LAC PFILE1
DAC SYMTW2
TAD C00001
DAC SYMT2A /SET UP FAKE NAME POINTERS
JMS OSYMBL /OUTPUT THE FILE NAME
LAC W00000
JMS BINOUT
XOR C00019
LAC EQUSTR /MEMBERS OF THE NON-COMMON EQUIVALENCE
SZA /IGNORE ZERO BLOCK
JMS BINOUT /CLASSES IS OUTPUT AS ONE BLOCK OF
XOR C00006 /UNINITIALIZED MEMORY.
LAC SYMTB0
CLENLP DAC SYMTBC
SAD SYMTBN /DONE?
JMP* CLENUP /YUP - EXIT
JMS SETADR
LAC K00001
SAD* SYMTBC /COMMON BLOCK?
JMP CMNBLK /YES - GO OUTPUT IT AND ITS MEMBERS
SAD FCNFLG /ARE WE IN A BLOCK DATA SUBPROGRAM?
JMP CMNCHK /YES - GO CHECK FOR NON-COMMON VARIABLES
LAC* SYMTBC
AND Z00000 /EXTRACT TYPE BITS OF SYMBOL TABLE ENTRY
SAD W00000 /NON-COMMON ARRAY?
JMP CARRAY /YES - OUTPUT STORAGE AND DESCRIPTOR BLOCK
SAD Z00000 /DUMMY ARRAY? IF YES, OUTPUT DES. BLOCK
JMP CADB /(YES) AND DEFINING SYMTAB ENTRY FOR
/IT SUCH THAT ADDRESSING IS TO THE ADB
SAD U00000 /EXTERNAL FUNCTION?
JMP CFUNCT /YES - OUTPUT TRANSFER VECTOR
SNA /NON-COMMON SCALAR?
JMP CSCLAR /YES - RESERVE STORAGE FOR IT
CLENNX JMS SBSE50 /GO TO NEXT SYMTAB ENTRY
JMP CLENLP /AND LOOP
/
CARRAY LAC* SYMTW4 /CHECK THE SIGN BIT OF SYMTW4 - IT IS ONLY
SPA /SET ON BY THE EQUIVALENCE RESOLVER.
JMP CADB /STORAGE ALREADY EXISTS IN EQV. AREA
LAC PC /NO STORAGE EXISTS - SAVE PC FOR USE
DAC* SYMTW7 /IN ARRAY DESCRIPTOR BLOCK
LAC* SYMTW3 /GET LENGTH, CHECK THAT IT IS LESS THAN 8K
TAD K08192 /THIS CHECK USED TO BE DONE WHEN DIMENSIONED -
ERN 03M,SMA,EM /BUT NOW HAVE TO ALLOW COMMON ARRAYS >8K
LAC* SYMTW3 /GET LENGTH
JMS BINOUT /OUTPUT A "BLOCK" COMMAND
XOR C00006
CADB JMS CLEN50 /OUTPUT FIRST 3 WORDS OF ARRAY DESC. BLOCK
JMS VECTOR /OUTPUT POINTER AND DEFINE ARRAY HERE
JMP CLENNX /BACK TO THE SALT MINES
CFUNCT AND* SYMTW2 /AC CONTAINED U00000, REMEMBER?
SZA /BIT 1 OF THE LOW-ORDER NAME WORD IS THE
JMP CLENNX /"DUMMY EXTERNAL" FLAG - IGNORE ENTRY IF ON
JMS DEFNSM
XOR PC /DEFINE SYMBOL HERE
JMS VECBIN /OUTPUT A ZERO WORD
JMS OSYMBL /PUT OUT SYMBOL NAME
LAC* SYMTBC
AND S17777
JMS BINOUT /AND GLOBAL DEFINITION CODE
XOR C00009
JMP CLENNX
/
CSCLAR LAC* SYMTW2 /IF THIS ENTRY HAS MORE THAN 3 WORDS,
CMA
AND* SYMTW4 /CHECK WHETHER IT EXISTS IN EQUIVALENCED
SPA /STORAGE
JMP CLENNX /GUESS IT DOES - IGNORE IT
LAC* SYMTBC
AND S17777 /IF A SYMBOL WAS DEFINED IN THE DECLARATION
SAD S17777 /STATEMENTS, BUT NEVER REFERENCED IN AN EXECUTEABLE
JMP CLENNX /STATEMENT, DON'T DEFINE IT NOW (OR EVER)
JMS DEFNSM
XOR PC /DEFINE THE SYMBOL AS RIGHT HERE
LAC* SYMTBC
JMS SETN /FIND THE NUMBER OF WORDS NECESSARY
JMS BINOUT
XOR C00006 /AND PUT THEM OUT
JMP CLENNX
/
CMNCHK JMS SYMTYP /ONLY VARIABLES IN COMMON ARE ALLOWED
XOR C00000 /IN A BLOCK DATA SUBPROGRAM
JMP CLENNX
ERR 12C,16060,EC /NAUGHTY,NAUGHTY
JMP CLENNX /THE SHOW MUST GO ON
/
CMNBLK JMS TSETAD /SAVE AWAY THE IMPORTANT POINTERS
JMS OSYMBL /OUTPUT THE NAME OF THE BLOCK
LAC* TSMTW7 /IF THE LENGTH IS ALREADY ZERO,
SNA /IGNORE THIS BLOCK AS AN ERROR
JMP CLENNX /WAS DETECTED PROCESSING IT
DZM* TSMTW7 /INITIALIZE THE LENGTH
LAC* TSMTW4 /GET THE FIRST CHAIN POINTER
BLKLLP JMS NTHSYM /GET THE CHAINED SYMBOL
JMS CLEN60 /COMPUTE THE ADDRESS OF THE LAST ELEMENT
TAD* TSMTW7 /(COMPLEMENTED) AND COMPARE IT WITH THE
SMA /EXISTING LENGTH
JMP .+3 /IT FITS WITHIN THE EXISTING LENGTH
LAC TEMP0 /IT DOESN'T FIT - CHANGE THE LENGTH
DAC* TSMTW7
LAC* SYMTW4 /GET THE NEXT CHAIN
SAD* TSMTW4 /HAVE WE COME FULL CIRCLE?
SKP /YUH
JMP BLKLLP /NAW - KEEP LOOPIN
LAC* TSMTW7 /GET THE BLOCK LENGTH
JMS BINOUT
XOR C00012 /OUTPUT IT AS A COMMON BLOCK DEFINITION
LAC* TSMTW4
CMNVLP JMS NTHSYM /NOW GO THROUGH THE ELEMENTS AGAIN
LAC FCNFLG
SAD K00001 /IF WE ARE IN A BLOCK DATA ROUTINE,
JMP BLDCMN /ALL WE ARE INTERESTED IN IS THE DEFINITION
LAC* SYMTBC
SPA /IS THE ELEMENT AN ARRAY?
JMS CLEN50 /YES - OUTPUT THE FIRST 3 WORDS OF THE ADB
JMS VECTOR /OUTPUT AN OFFSET POINTER INTO THE COMMON
LAC* SYMTW7 /BLOCK AND DEFINE THE SYMBOL HERE. THEN
JMS BINOUT /OUTPUT SOME STRANGE LOADER CODES WHICH
XOR C00013 /I TAKE ON FAITH
LAC* SYMTBC
AND S17777
JMS BINOUT /(ANOTHER, EQUALLY STRANGE LOADER CODE)
XOR C00014
SKP
BLDCMN JMS DEFNSM /IN BLOCK DATA SUBRS, ALL WE CARE ABOUT
XOR* SYMTW7 /IS THAT THE DATA STATEMENTS WORK PROPERLY
LAC* SYMTW4
SAD* TSMTW4 /CHECK FOR CIRCUMNAVIGATION
SKP /YUP - ALL DONE
JMP CMNVLP /NOPE - KEEP SAILING
LAC* TSMTW7 /A CUMULATIVE SUM OF ALL COMMON BLOCK
TAD LOWRAD /SIZES IS OBTAINED FOR USE AS THE PROGRAM
DAC LOWRAD /SIZE OF A BLOCK DATA SUBPROGRAM.
LAC TSMTBC
DAC SYMTBC
JMS SETADR /SET UP POINTERS
JMP CLENNX /SO WE CAN ADVANCE TO THE NEXT SYMBOL
.EJECT
/SUBROUTINE TO OUTPUT 5 WORD ARRAY DESCRIPTOR BLOCK (LESS TRANSFER VEC.)
CLEN50 SYN POP /THE ADB IS OUTPUT FOR ALL ARRAYS, ALTHOUGH
LAC* SYMTBC /SYMTAB ENTRIES FOR A DUMMY ARRAY MAY NOT BE
AND S60000 /COMPLETE. WORD 1 CONTAINS THE MODE, RIGHT
LRSS 34 /ADJUSTED, AND THE NUMBER OF DIMENSIONS-1 IN
JMS SUBCT2 /BITS 0,1,2. SUBCT2 COUNTS THE DIMENSIONS, THEN
TAD K00001 /SUBTRACT 1. THE WORD IS OUTPUT AS AN ABSOLUTE
LLS 17
JMS FPPOUT /INSTRUCTION. WORD 2 IS THEN USED FOR SIZE,
LAC* SYMTW3 /ALLOWING EASILY ENOUGH BITS FOR A 128K ARRAY,
JMS FPPOUT /IT PRESENTLY BEING THE LOADERS DECISION AS TO
LAC* SYMTW5 /HOW BIG AN ARRAY CAN BE (EITHER AS PART OF THE
JMS FPPOUT /PROGRAM SIZE OR A COMMON BLOCK). WORD 3
LAC* SYMTW6 /= N*IMAX, WORD 4 = N*IMAX*JMAX, WHERE N IS
JMS FPPOUT /THE NO. WORDS PER ELEMENT FOR THIS MODE
JMP* CLEN50
/
/ SUBROUTINE TO OUTPUT A TRANSFER VECTOR
/
VECTOR SYN ADDRA1
JMS DEFNSM /DEFINE THE SYMBOL
XOR PC /AS THE CURRENT VALUE OF THE PC
LAC* SYMTW7 /TRANSFER VECTORS ARE SHEER ADDRESS
JMS VECBIN /THE TRANSFER VECTOR IS INITIALLY SET TO
JMP* VECTOR /REFERENCE THE ARRAY(VAR) ADDRESS.
/
/
/
/ SUBROUTINE TO DEFINE A SYMBOL
/ CALLING SEQUENCE...
/ JMS DEFNSM
/ XOR DEFINITION
/
DEFNSM SYN ADDRA2
LAC* SYMTBC /THE DEFINITION OF THE SYMBOL IS MERGED
AND Z60000 /INTO THE FIRST WORD OF THE SYMBOL TABLE
XCT* DEFNSM /ENTRY.
DAC* SYMTBC
CLA
JMP* DEFNSM
.EJECT
/ SUBROUTINE TO OBTAIN THE NEGATIVE ADDRESS OF THE FIRST WORD FOLLOWING
/ THE WORDS OCCUPIED BY THIS VARIABLE
/
CLEN60 SYN MODEA1
LAC* SYMTW3 /THE NUMBER OF WORDS OCCUPIED BY THIS
TAD* SYMTW7 /ASSIGNED TO THIS VARIABLE.
DAC TEMP0 /THE POSITIVE ADDRESS IS SAVED AND ITS
JMS TWOCMA /NEGATIVE RETURNED TO THE CALLING PROGRAM.
JMP* CLEN60
/
/
/
/ SUBROUTINE TO INCREMENT PROGRAM COUNTER BY N
/ CALLING SEQUENCE...
/ JMS INCRPC
/ TAD N
/
INCRPC CAL 0
LAC PC
XCT* INCRPC /THE PROGRAM COUNTER IS INCREMENTED BY THE
DAC PC /SPECIFIED AMOUNT AND COMPARED WITH 8191.
TAD K04081
SPA
JMP .+3
LAC PASS1 /PROGRAM EXCEEDS 4K
DAC F4K
LAC PC
TAD K08177
SPA /THE COMPILER.. 8191 IS USED AS A FLAG.)
JMP* INCRPC
DZM PC
ERR 02M,16320,EM /ERROR: PROGRAM SIZE EXCEEDS A CORE BANK
JMP* INCRPC
.EJECT
/ SUBROUTINE TO FETCH VARIABLE ARGUMENT-OPERATOR/DELIMITER PAIR
/
FVARGO SYN NUMFLG
JMS INFAOP
JMS FARGOP /THE NEXT ARGUMENT-OPERATOR PAIR IS
JMS VARTST /OBTAINED. THE ARGUMENT TYPE IS EXAMINED
LAC OPVALU /TO MAKE SURE IT IS A VARIABLE.
JMP* FVARGO
/
/
/
/SUBROUTINE TO SET ADDRESS OF NTH SYMBOL
/CALLING SEQUENCE
/ LAC N
/ JMS NTHSYM
/
NTHSYM SYN SIGNA1
JMS TWOCMA
DAC TCTR
LAC SYMTB0
NTHSM1 DAC SYMTBC
JMS SETADR
ISZ TCTR
SKP
JMP* NTHSYM
JMS SBSE50
JMP NTHSM1
.EJECT
/
/GET DIMENSION DECLARATION SUBSCRIPTS. ALLOWS INTEGER VARIABLE DIMENS
/IF DUMMY ARRAY. IN PASS2, GENERATES CALLS TO ARRAY ADJUSTMENT SUBS.
/3D ARRAYS ONLY.
FARDIM SYN SIGNA2
DZM T2 /INITIALIZE LATTER 2 DIMENSIONS.
DZM T3 /ADJFLG IS INITIALIZED TO ZERO, AND IS
DZM ADJFLG /INCREMENTED IF VALID VARIABLE DIMENSION IS
LAC SYMTBC /FOUND. SAVE PTR TO PRESENT SYMTAB ENTRY,
DAC VARTST /MAY GET CHANGED. BUT IS THIS ISN'T A DUMMY
LAC* VARTST
AND V00000 /ARRAY, A 0 IS SAVED INSTEAD. IT IS USED TO
SAD V00000 /CHECK VALIDITY OF OCCURENCE OF VARIABLE DIMEN
SKP /IF SYMTBC IS LOST FOR NON-DUMMY ARRAY (BY FIARGO)
DZM VARTST /IT WAS AN ERROR ANYWAY.
DZM SSCTR /INITIALIZE COUNT OF SUBSCRIPTS.
LAC AT1 /GET ADDRESS OF DIMENSION HOLDING WORDS.
FARD05 DAC TI /TI GETS BUMPED TO SUCCESSIVELY STORE DIMENS.
JMS FIARGO /GETS ARG, FLAGS ERROR IF NOT INTEGER CONSTANT
LAC ARG /OR VARIABLE. A CONSTANT IS ACCEPTED IN ALL
AND Z00000 /CASES (THIS TEST MODELED AFTER ROUTINE CONTST)
SAD U00000 /OTHERWISE THE ARG MUST BE A DUMMY VARIABLE,
JMP FARD01 /AND WE MUST BE PROCESSING A DUMMY ARRAY.
LAC VARTST /ERROR "VARIABLE DIMENSION IN NON-DUMMY ARRAY"
ERS 12S,<SZA>,ES
LAC* SYMTBC /OCCURENCE OF VARIABLE HAS RESET SYMTAB PTR
AND Z00000 /TO THAT VAR'S ENTRY; MUST BE TYPE DUMMMY
ERS 13S,<SAD V00000>,ES /"VAR DIMEN NOT DUMMY INTEGER"
LAC SYMTBC /WHEN GOOD VAR. DIMEN IS FOUND, ITS POINTER IS
XOR X00000 /IS FLAGGED AND SAVED IN PLACE OF ACTUAL VALUE.
ISZ ADJFLG /ALSO PUT BIT 2 ON, TO INDICATE SYMBOLIC TYPE.
SKP
FARD01 JMS CONTST /TRUE INTEGER CONST. SUBSCRIPT ARRIVES HERE ALSO
DAC* TI
ISZ SSCTR /ACCOUNT FOR ONE MORE SUBSCRIPT. DIMENSIONS
LAC OPVALU /ARE SEPARATED BY COMMAS. THE DIMENSION LIST
SAD C00030 /IS TERMINATED BY A RIGHT PAREN. ERROR NOTED
JMP FARD02
ERS 01S,<SAD C00032>,ES /IF OTHERWISE.
JMS FARGOP /THE PSEUDO-ARGUMENT SUBSCRIPTED VARIABLE AND
LAC VARTST /ITS DELIMITER ARE OBTAINED BEFORE RETURN,
SNA /AND PASS SPECIFIC CLEANUP MUST BE DONE.
JMP* FARDIM /NO CLEANUP DONE IF NOT DUMMY ARRAY.
LAC ADJFLG /ADJFLG IS > 0 IF VARIABLE DIMEN WAS FOUND
/CLEAN UP FOR ADJUSTABLE ARRAY ONLY.
SNA!CLA /1. ENTER WITH CONTST IN AC. IF ZERO, NO VAR-
JMP* FARDIM /IABLE DIMENSIONS
LAC DJMNE
JMS EXP580 /JMS* TO .DJ.
XOR JMSCMD /(PASS1 - ONLY DEFINE .DJ)
LAC VARTST /RESTORE SYMBOL TABLE POINTER
DAC SYMTBC /MAKES SURE OUTPUT ROUTINES WORK
LAC* SYMTBC /2. NOW OUTPUT DIRECT ADDRESS TO ADB WORD 5,
AND S17777 /ADDRESS OF WHOSE SYMBOL TABLE ENTRY WAS
JMS VECBIN /SAVED IN VARTST (INCR. PC IF PASS 1)
/OCCURENCE OF AT LEAST 1 ADJ. DIMEN. REQUIRES PARAMETERS FOR EACH
LAC AT1 /DIMEN. BE OUTPUT, EITHER AS A CONSTANT OR A
FARD09 DAC CHAIN /POINTER TO A DUMMY ARGUMENT.
LAC* CHAIN / CONSTANTS ARE POSITIVE,
SNA /AND ARE OUTPUT AS ABSOLUTE BINARY DATA. IF THEY
JMP FARD07 /COME UP ZERO, IT MEANS THAT THIS IS THE END OF
SPA /THE PARAMETER LIST, MAX = NO. OF DIMENSIONS
JMP .+3 /POINTERS ARE FLAGGED (BIT0=1)
JMS FPPOUT /(ONLY INCREMENTS PC IF PASS1).
JMP .+3
AND V77777 / THE FLAG IS REMOVED, AND A VECTOR IS OUTPUT,
JMS EXP720 /USING SYMTAB ENTRY ADDRESS PASSED IN AC
LAC CHAIN /INCREMENT FOR T2 AND T3.
TAD C00001
SAD ATX /ATX HAS ADDRESS = T3+1
SKP
JMP FARD09
FARD07 LAC T1 /REMOVE POINTER ENTRIES
SPA
DZM T1
LAC T2
SPA
DZM T2
LAC T3
SPA
DZM T3
LAC VARTST /RESET POINTER TO SYMTAB ENTRY TO THAT OF
DAC SYMTBC /THE DUMMY ARRAY.
JMS SETADR /DEFINE THE REST OF THE POINTERS TO THIS ENTRY.
JMP* FARDIM
DJMNE .DSA 127652 /.DJ, RADIX 50
ADJFLG .DSA 0 /0 IF NO ADJ. DIMENS., >0 OTHERWISE
FARD02 LAC TI /CHECK FOR EXCEEDING THREE DIMENSIONS. ATX HOLDS
TAD C00001 /THE ADDRESS OF THE LOCATION FOLLOWING T3.
ERN 02S,<SAD ATX>,ES /("MORE THAN THREE DIMENSIONS DECLARED")
JMP FARD05
.EJECT
/FETCH AND ENTER ARRAY DIMENSIONS INTO SYMBOL TABLE. FOR 3 DIMENS,
/5 WORD ADB, CALL BY REFERENCE, >8K COMMON ARRAY, EAE MULT ROUTINE.
/NO CHECKING OF ARRAY LENGTH MADE CAUSE DONT'T NECESSARILY YET KNOW IF
/IT WILL BE IN A COMMON BLOCK.
FEDIMN SYN LEVPOP
LAC* SYMTW3 / GET NUMBER OF WORDS PER ELEMENT, USE TO CAL-
DAC T0 /CULATE TOTAL ARRAY SIZE.
JMS FARDIM /GO GET DIMENS AND FILL IN BLOCK T1,T2,&T3 WITH
XCT PASS / IF PASS 2, A QUICK EXIT IS TAKEN (ALL FARDIM
JMP FPASS2 /DID WAS GENERATE .DJ OR .DK CALL IF DMY ARY)
LAW -1 /COMPUTE THE APPROPRIATE SYMTAB ENTRIES THAT
TAD AT1 /DESCRIBE THE SIZE OF THIS ARRAY, GOING THROUGH
DAC CONTST /T1,T2,T3 LIST SET UP BY FARDIM. PROPER ACCOUNT
DAC VARTST /MUST BE TAKEN OF THOSE ENTRIES WHICH ARE
FEDNEX LAC* VARTST /ZERO DUE TO DUMMY VARIABLE VS. THOSE ZERO'ED
ISZ CONTST /DUE TO BEING BEYOND NO. OF DIMENS DECLARED.
JMS MULT /CUMULATIVE PRODUCT UP TO N*IMAX*JMAX*KMAX
LAC* CONTST /IS COMPUTED, EACH INTERMEDIATE RESULT BEING
SNA!CLL /SAVED. ANY ZERO PRODUCT SIGNALS DUMMY DIMEN-
CLA!CMA!CML /SION, SINCE CALCULATION IS BEING DONE ONLY FOR
DAC* CONTST /AS MANY DIMENSIONS THAT EXIST. WHEN 0 COMES
LAC CONTST /UP, 777777 IS STORED - SUCH THAT LATER CHECKING
SNL /FOR NO. OF DIMENSIONS WILL WORK. THE POINTER
DAC VARTST /TO PREVIOUS INTERMEDIATE RESULT IS BUMPED
SAD TI /ONLY IF NON-ZERO RESULT. E.G., FOR 'A' REAL,
SKP /A(N,M,5) YIELDS T1=T2=777777, T3=10; OR
JMP FEDNEX /A(N,5,2) YIELDS T1=777777, T2=10, T3=20.
LAC* SYMTBC /ERROR: REDEFINING ARRAY
ERN 04V,<SPA>,EV
XOR W00000 /(400000) THE SYMBOL IS FLAGGED AS AN ARRAY
DAC* SYMTBC
LAC* TI /TI WAS LEFT BY FARDIM TO ADDRESS THE LAST
DAC* SYMTW3 /DIMENSION OF THE ARRAY, WHICH NOW HOLDS THE
DZM* TI /TOTAL SIZE. THE REST OF THE SYMBOL
LAC T1 /TABLE ENTRIES FOR THIS ARRAY ARE DEFINED.
DAC* SYMTW5 /THE FACT THAT THE TRUE SIZE OF A DUMMY ARRAY MAY
LAC T2 /NOT YET BE KNOWN IS OF NO CONCERN, SINCE NO
DAC* SYMTW6 /SPACE IS TO BE ALLOCATED LOCALLY FOR
FPASS2 LAC OPVALU /SUCH AN ARRAY. THE TERMINAL DELIMITER IS
JMP* FEDIMN /RETURNED IN THE AC.
.EJECT
/ SUBROUTINE TO ANNOUNCE AN ERROR IF THE ARGUMENT IS NOT A VARIABLE
/
VARTST SYN HFLG
LAC ARG /THE ARGUMENT TYPE IS ISOLATED AND
AND Z00000 /EXAMINED TO DETERMINE IF IT IS A VARIABLE.
ERS 02V,<SAD T00000>,EV
JMP* VARTST
/
/
/
/ SUBROUTINE TO ANNOUNCE AN ERROR IF AN INTEGER ARGUMENT IS NOT A
/ NON-ZERO POSITIVE CONSTANT.
/
CONTST SYN FMTCNT
LAC S
SMA!SZA!CLA
LAC ARG
AND Z00000 /TEST MODE AND VALUE
ERS 03V,<SAD U00000>,EV /ERROR: NOT INTEGER CONST>0
LAC S
JMP* CONTST
/
/
/
/ SUBROUTINE TO CHAIN CLASS MEMBERS (EQUIVALENCE OR COMMON BLOCK)
/
CHAIN SYN IDXPOP
LAC* LSTVAR /ALL MEMBERS OF THE SAME CLASS ARE CHAINED
DAC FSTVAR /TOGETHER IN A CIRCULAR FASHION. I.E. EACH
LAC* SYMTW4 /MEMBER POINTS TO ANOTHER MEMBER IN TH
DAC* LSTVAR /CLASS AND NO TWO MEMBERS POINT TO THE SAME
LAC FSTVAR /OTHER MEMBER. A ONE MEMBER CLASS POINTS
DAC* SYMTW4 /TO ITSELF. A NEW MEMBER IS ADDED BY
LAC SYMTW4 /BREADING THE CHAIN AT THE LAST MAMBER
DAC LSTVAR /AND INSERTING THE NEW MEMBER BY EXCHANGING
JMP* CHAIN /POINTERS. (NEW NAMES POINT TO SELF.)
.EJECT
/ SUBROUTINE TO FETCH VARIABLE OR ARRAY WITH CONSTANT SUBSCRIPTS
/
FVORAR SYN MODEA2 /THIS SUBROUTINE IS USED BY THE DATA AND
JMS FVARGO /EQUIVALENCE STATEMENT PROCESSORS. LEGAL
LAC* SYMTBC /NAMES ARE SIMPLE VARIABLES OR ARRAY
AND U00000 /ELEMENTS WITH CONSTANT SUBSCRIPTS
ERN 05V,SZA,EV /ERROR: DUMMY VAR OR FUNCTION
DZM SSCTR /USED IN DATA STMT
DZM T0
LAC* SYMTBC /THE NUMBER OF WORDS PER ITEM
JMS SETN /IS OBTAINED FOR USES BOTH INTERNAL AND
DAC MODE /EXTERNAL TO THIS ROUTINE.
LAC OPVALU /THE APPEARANCE OF A SUBSCRIPTED VARIABLE
/NEED NOT INDICATE AN ARRAY ELEMENT. IF
/THE VARIABLE HAS NOT BEEN DECLARED AS AN
SAD C00028 /ARRAY IT IS TREATED AS A ONE-ONLY
JMP FVAR03 /DIMENSION ARRAY.
JMP* FVORAR /EXIT IS QUICK IF THE VARIABLE IS NOT
FVAR03 JMS FARDIM /SUBSCRIPTED AT ALL.
LAC SYMTBC
XOR T00000
DAC ARG
LAC T1 /THE CONSTANTSUBSCRIPTS ARE OBTAINED AND
TAD K00001 /THE ELEMENTS RELATIVE POSITION IN THE
JMS MULT /ARRAY (PSEUDO-ARRAY) IS CALCULATED AS IF
LAC MODE /THE ARRAY WAS ONE-DIMENSIONAL.
DAC T0
LAC SSCTR /A NON-ARRAY VARIABLE MAY BE SINGLY
SAD C00001 /SUBSCRIPTED APPEARING ON AN EQUIVALENCE
JMP FVAR05 /STATEMENT. (A SIMILARILY WRITTEN VARIABLE
LAC* SYMTBC /ON A DATA STATEMENT WOULD BE INTERPRETED
/AS A FUNCTION AND AN ERROR WOULD OCCUR).
/ERROR: MORE THAN 1 DIMENSION INDICATED FOR
ERN 07V,SMA,EV /A NON-ARRAY VARIABLE.
LAC T2
TAD K00001 /THE ELEMENT POSITION IS CALCULATED FOR
JMS MULT /MULTI-DIMENSION ARRAY ELEMENTS AS...
LAC* SYMTW5
TAD T0 / FOR A(I,J,K) DECLARED, AND
DAC T0 / A(M,N,O) STATED
LAC T3
SZA
TAD K00001 / (M-1) + (N-1)*I + (O-1)*I*J
JMS MULT
LAC* SYMTW6 /EACH TERM OF THE POSITION FORMULAE IS
TAD T0 /MULTIPLIED BY THE NUMBER OF WORDS PER
DAC T0 /ELEMENT (TO ACCOUNT FOR DIFFERENT DATA
JMS SUBCNT /MODES). A POSITION OF ZERO IS THE FIRST
FVAR05 LAC* SYMTBC /ELEMENT. MUST HAVE CORRECT NUMBER OF SUBSCRIPTS,
AND Z00000 /(UNLESS # DCL SS = 1), AND THE ELEMENT
XOR X00000 /POSITION CANNOT EXCEED 8191 IF A LOCAL ARRAY,
SNA!CLA /OR 32767 IF A COMMON ARRAY.
LAC K24576 / -24 K
TAD K08192 / -8 K
TAD T0
ERN 04M,SMA,EM
JMP* FVORAR
.TITLE STATEMENT PROCESSORS FOR EXECUTABLE STATEMENTS
/ READ AND WRITE STATEMENT PROCESSORS
/ READ ENTRY = READ WRITE ENTRY = WRITE
WRITE LAC C00002 /WRITE ENTRY -- TWO TO RWFLAG
READ DAC RWFLAG /RWFLG= READ/WRITE INDICATOR
DZM ENCFLG /ZERO ENCODE/DECODE FLAG
JMS FNBCHR
ERS 08V,<SAD S00050>,EV /FIRST CHARACTER MUST BE (
JMS IODEV /FETCH AND RECORD DEVICE NUMBER
LAC ARG /STORE AWAY TEMPORARILY
DAC ARTEM
DZM RWEOFS /INITIALIZE OFFSET AND FLAGS
DZM RWERRS
DZM SYMTMP
DZM RWBIN
LAC XCHAR /GET CHARACTER WHICH TERMINATED DEVICE NUMBER
DZM RWRAN
SAD C00035 /#?
JMP RWRA /YES; RANDOM ACCESS I/O
SAD C00039 /'?
JMP RWRA /YES - RANDOM ACCESS
JMP RWNRAN /NOT RANDOM ACCESS - CHECK FOR COMMA OR RPAR
RWRA LAC C00024 /READ IN EXPRESSION FOR FIRST RECORD #
DAC IFFLAG
LAC PASS1 /ACCEPT , AS 0 LEVEL DELIMITER
DAC EX23X+1
JMS EXPRSN
LAC SNACMD /PUT THINGS BACK TO NORMAL
DAC EX23X+1
LAC MODEA2 /MUST BE INTEGER EXPRESSION
ERN 32V,SZA,EV
LAC C00010 /(OFFSET FOR RANDOM ACESS
DAC RWRAN
LAC XCHAR /GET CHARACTER WHICH TERMINATED RECORD NUMBER
RWNRAN SAD S00051 /RIGHT PAREN?
JMP RWBIN1 /YES - BINARY I/O, NO EXITS
ERS 05I,<SAD S00054>,EI /CHAR BETTER BE COMMA
RWNRA JMS SIN530 /SAVE REGISTERS FOR LOOK AHEAD
LAC Y00000 /GET NEXT 3 CHARACTERS
DZM LOGIF /DO NOT ALLOW CONTINUATION
JMS CTRL50
SAD S20564 /(END IN RADIX 50
JMP RWEOF
SAD S21042 /(ERR IN RADIX 50
JMP RWERR
RWNEIO JMS SIN540 /RESTORE SOURCE IMAGE
LAC SYMTMP /MAKE SURE THAT THIS POINT REACHED ONLY ONCE
ERN 36V,SZA,EV
LAC RWEOFS /HAVE ANY SPECIAL EXITS BEEN INDICATED
TAD RWERRS
ERN 37V,SZA,EV
JMP RWASC1 /BCD I/O
RWEOF LAC DCEOF /GET ADDRESS TO GO TO ON END OF FILE
SKP
RWERR LAC DCERR /GET ADDRESS TO GO TO ON ERROR CONDITION
DAC STORC
JMS FNBCHR /GET OPERATOR
SAD S00075 /=/
SKP
JMP RWNEIO /MUST NOT BE RIGHT AFTER ALL
JMS FDFSNO /GET THE DEFINED ONLY STATEMENT NUMBER
STORC XX /STORE AWAY ADDRESS
LAC XCHAR /TEST OPERATOR FOLLOWING ADDRESS
JMP RWNRAN /BY RE-ENTERING SCAN LOOP
RWBIN1 LAC SYMTMP
SNA
ISZ RWBIN /BIN I/O OFFSET
LAC RWEOFS /DO WE NEED EXPANDED I/O?
TAD RWERRS
SNA
JMP NEXIO /NO
LAC T31442 /OUTPUT JMS* .ZR
JMS EXP580
XOR JMSCMD
LAC RWEOFS /GET EOF EXIT
JMS ADROR0 /OUTPUT IT
NOP
LAC RWERRS
JMS ADROR0 /NOW THE ERROR EXIT
NEXIO NOP
LAC ENCFLG
SZA /IF ENCODE/DECODE FLAG IS ON
JMP NEXIOX /IGNORE ALL THE OTHER FLAGS
LAC RWINIT /OUTPUT I/O INITIALIZER
TAD RWFLAG /BUMP FOR READ OR WRITE
TAD RWBIN /BUMP FOR BINARY I/O
TAD RWRAN /BUMP FOR RANDOM ACCESS
NEXIOX JMS OPOPA2
LAC ARTEM
LAC ENCFLG
SNA /ENCODE/DECODE?
JMP .+3 /NO
LAC ENCVAR /YES - OUTPUT VARIABLE NAME
JMS EXP720
LAC RWBIN
SZA
JMP RW13 /SKIP READING OF FORMAT LABEL IF BIN
LAC SYMTMP /UNSAVE SYMBOL TABLE POINTER
AND V77777
JMS ADROR0 /OUTPUT THE FORMAT POINTER
TAD C00001
RW13 JMS FNBCHR /FETCH FIRST CHARACTER OF THE I/O LIST.
DZM RWDLVL /ZERO IMPLIED DO LEVEL
ISZ RWEXPF /SET FLAG FOR EXPRESSION ANALYZER
JMS CTRL60
JMP RW14 /IF CHAR NOT A CARRIAGE RETURN, THERE IS
LAC RWBIN /IF I/O OPERATION IS A WRITE
TAD RWFLAG /IN BCD MODE GO OUTPUT CLEANUP CODE
ERN 02X,<SAD C00003>,EX /ELSE ERROR
JMP RWENDL
/
ADROR0 SYN LEVNOP /SUBROUTINE TO PUT OUT A RELOCATABLE ADDR OR 0
SNA /IS IT 0?
JMP OUTPT0 /YES - USE FPPOUT
DAC SYMTBC
LAC* SYMTBC /GET SYMTAB ENTRY
SMA /IS IT AN ARRAY?
XCT* ADROR0 /THIS IS EITHER A "NOP" OR A "TAD (1"
AND W17777 /MASK OUT ADDRESS AND ARRAY INDICATOR
JMS VECBIN /OUT WE GO
JMP* ADROR0 /RETURN TO DATA WORD WITH NO ILL EFFECT
OUTPT0 JMS FPPOUT /ZERO IN AC - OUTPUT IT
JMP* ADROR0 /RETURN
/
RWASC1 JMS FNBCHR /GET A CHAR
SAD S00054 /COMMA?
JMP DATDIR /YES - DATA DIRECTED I/O
SAD S00051 /CLOSE PAREN?
JMP DATDIR /YES - D.D I/O
DZM UNFNBC /PUT THE CHARACTER BACK
JMS FETSNO /GET THE FORMAT STATEMENT NUMBER
SMA /POSITIVE RESULT MEANS STATEMENT NUMBER -
JMS CKDFSN /CHECK TO SEE THAT ITS DEFINED (LEAVES AC POS.)
SPA /NEGATIVE RESULT MEANS NON-NUMBER -
JMS FVARGO /FETCH ARRAY NAME
LAC SYMTBC /SAVE THE SYMBOL TABLE ADDRESS
RW44A DAC SYMTMP
LAC XCHAR /TEST OPERATOR
SAD S00054 /IF OPERATOR IS , THEN EXPANDED I/O INDICATED
JMP RWNRA
ERS 01F,<SAD S00051>,EF /BETTER BE CLOSE PAREN
JMP NEXIO /GO TO OUPUT INITIALIZATION CODE
DATDIR LAC W00000
JMP RW44A /SET SYMTMP TO 400000 AS A FAKE VALUE
.EJECT
/ INPUT-OUTPUT LIST PROCESSOR
RW14 DZM UNFNBC /UNFETCH CHAR AND GO TO LIST PROCESSOR
/
RW19 JMS FNBCHR /PEEK AT THE NEXT CHARACTER
SAD S00050 /OPEN PAREN?
JMP RWIMDO /YES - ASSUME BEGINNING OF AN IMPLIED DO
DZM UNFNBC /NO - PUT CHAR BACK
JMS EXPRSN /GET AN EXPRESSION
LAC TYPEA2 /GET TYPE OF RESULT
SAD T00000 /IS IT A VARIABLE?
JMP RW20 /YES - GOOD,GOOD
ERS 03X,<SAD W00000>,EX /ELSE MUST BE A STRING, IE, S.S. VARIABLE
LAC SYMTBX /LAW -MODE WILL NOT BE NEEDED FOR DDIO OUTPUT
TAD C00005 /OF A SUBSCRIPTED ELEMENT OF ANY DIMENSION.
DAC DDSS2 /IN PARTICULAR, FOR OUTPUT OF A SINGLE DIMENSION
LAC* DDSS2 /SUBSCRIPTED VARIABLE. FOR THIS CASE ONLY, DDSS2
DAC DDSS2 /GETS SET TO ZERO, AS SYMTAB ENTYR FOR 2ND DIM
JMP DDCHK /IS ZERO. GO CHECK IF WILL ACTUALLY BE DDIO
RW20 DAC DDSS2 /STASH ARBITRARY NON 0 VALUE, INDICATING IS NOT
LAC* ADDRA2 /A 1 DIM. ARRAY SS ELEMENT REFERENCE. NOW,
SMA /WAS RW20 ENTERED DUE TO SCALAR OR WHOLE ARRAY
JMS MODLAW /REFERENCE? IF SCALAR, MUST OUTPUT LAW -MODE
DDCHK=. /WHOLE ARRAY I/O ROUTINES GET MODE FROM ADB
/AND .SS PASSES IT TO 1 DIM DDIO OUTPUT AND ALL
LAC SYMTMP /(RKB-065) OTHER 2 AND 3 DIM I/O
XOR W00000 /(RKB-065)
SNA /(RKB-065) DATA DIRECTED I/O?
JMP DDLIST /(RKB-065) YES - GENERATE DATA-DIRECTED CALLS
.IFDEF %DDIO /AND .SS PASSES IT TO 1 DIM DDIO OUTPUT AND ALL
LAC SYMTMP /OTHER 2 AND 3 DIM I/O
XOR W00000
SNA /DATA DIRECTED I/O?
JMP DDLIST /YES - GENERATE DATA-DIRECTED CALLS
.ENDC
LAC DDSS2 /WAS THIS A 1 DIM. ARRAY SS ELEMENT REFERENCE?
SNA
JMS MODLAW /YES, OUTPUT LAW -MODE
LAC TYPEA2
SMA!CLA /CHECK FOR ARRAY I/O
LAC* ADDRA2
SMA!CLA
LAC C00002 /NO - SET SCALAR OFFSET
TAD RWBIN /ADD BCD/BINARY OFFSET
TAD RWRAN /ADD RANDOM ACCESS OFFSET
TAD RWABAS /ADD BASE OF I/O TABLE
JMS OPOPA2 /GENERATE PROPER CALL
LAC* ARG2 /WITH PROPER ARG
RWCOMN LAC SIGNA2 /CHECK FOR NO UNARY MINUS STUFF
ERN 24X,SPA,EX
RWCOMA LAC IDXNOP /GET OP WHICH TERMINATED EXPRESSION
SAD C00030 /COMMA?
JMP RW19 /YES - CONTINUE SCANNING
ERN 26X,SZA,EX /BETTER BE A CARRIAGE RETURN
JMP RWENDL /IT WAS - TERMINATE I/O SCAN
DDLIST LAC RWFLAG /IF IS INPUT (RWFLAG=0), AND WAS A 1 DIM
SZA /S.S. ELEMENT REFERENCE, MUST OUTPUT LAW -MODE
JMP .+3 /ELSE THE MODE IS PASSED BY A .SS CALL
SAD DDSS2 /DDSS2 IS ZERO IF I DIM SS ELEMENT REFERENCE
JMS MODLAW
LAC TYPEA2
RCL
SZA!CLA /FORM A RANDOM CONSTANT:
LAC* ADDRA2 /0 IF SCALAR, 1 IF S.S. VARIABLE,
SPA!CLA /4 IF ARRAY
LAC C00002
RAL
TAD RWFLAG /ADD IN READ/WRITE FLAG (0 OR 2)
TAD DDRWSC /ADD IN BASE OF DATA - DIR I/O TABLE
DAC ARG
LAC* ARG /LOAD SUBROUTINE TO CALL
JMS EXP580 /AND CALL IT
XOR JMSCMD
LAC RWFLAG
SNA /DON'T OUTPUT NAME IF INPUT OPERATION
JMP RWOPTR
LAC SYMTBX
DAC SYMTBC /GET POINTER TO VARIABLE NAME
JMS SETADR /SET UP POINTERS TO SYMTAB ENTRY
LAC* SYMTW2
AND V77777
JMS FPPOUT /PRINT FIRST 3 CHARACTERS
LAC* SYMT2A
JMS FPPOUT /AND SECOND 3 CHARACTERS
RWOPTR LAC* ARG2
JMS EXP720 /OUTPUT THE VARIABLE
JMP RWCOMN /CONTINUE WITH LIST
/
RWENDL LAC RWBIN /COMPUTE THE PROPER CLEANUP ROUTINE
TAD RWRAN
TAD RWCNUP
DAC ARG
LAC* ARG /GET NAME OF SUBR TO CALL
JMS EXP580 /GENERATE CALL
XOR JMSCMD
LAC RWDLVL /GET THE DO-LEVEL
ERN 27X,SZA,EX /ERROR IF NON-ZERO
JMP STEXIT /WE'RE THROUGH
/
RWIMDO JMS EXP550 /GENERATE A "JMS STRING"
XOR JMSCMD
DAC* DOTABA /SAVE THE STRING ADDRESS IN THE DO TABLE
JMS INCDTP /BUMP DEPTH TO NEXT LEVEL
ISZ RWDLVL /BUMP LEVEL COUNTER
JMP RW19 /CONTINUE
/
/ THE EXPRESSION ANALYZER GOES HERE IF AN EQUAL SIGN IS ENCOUNTERED
/ WHILE "RWEXPF" IS ON
/
RWEQLS LAC POP /**051** CHECK THE STACK. IF NOT CLEARED THEN INCOMPLETE
ERS 33X,<SAD OP0>,EX /**051** EXPRESSION INCOMPLETE AND ERROR
LAC RWDLVL /**051** GET THE DO-LEVEL
ERN 28X,SNA,EX /BETTER NOT BE ZERO
TAD K00001
DAC RWDLVL /DECREASE IT BY 1
JMS DECDTP /BUMP UP THE DO LEVEL POINTERS
LAC PC
TAD C00004 /GENERATE A "JMP .+4"
XOR JMPCMD
JMS RELBIN
LAC* DOTABA
JMS STRING /DEFINE THE SUBROUTINE WHICH WE CALLED
LAC PC /AT THE BEGINNING OF THE LOOP
DAC* DOTABA
CLA
JMS FPPOUT
JMS DOCODE /GENERATE THE DO LOOP CODE
LAC* DOTABA /IN THE SUBROUTINE, THEN GENERATE
XOR JMPCMD /A RETURN FROM THE SUBRROUTINE
XOR S20000
JMS RELBIN
LAC* DOTABC
JMS STRING /DEFINE THE TERMINATION EXIT FROM THE SUBROUTINE
LAC C00032
DAC TFAO01 /SET LAST DELIMITER SPECIAL
JMS FA2NOP /GET THE NEXT OPERATOR
JMP RWCOMA
/
RWABAS BCDAIO-OPTRAN-1
RWCNUP BCDCLN
RWINIT BCDINT-OPTRAN-1
DDRWSC DDRDSC
RWDLVL .DSA 0 /IMPLIED DO LOOP DEPTH COUNTER
RWEXPF .DSA 0 /"I/O LIST" FLAG FOR EXPRESSION ANALYZER
ARTEM 0 /.DAT SLOT ARGUMENT STORE
RWEOFS 0 /ADDRESS TO GO TO ON EOF
RWERRS 0 /ADDRESS TO GO TO ON ERROR IN I/O
DCEOF DAC RWEOFS
DCERR DAC RWERRS
RWRAN 0 /OFFSET FOR RANDOM ACCESS
SYMTMP 0
RWBIN=FORMST
/
MODLAW CAL /OUTPUT THE ONES COMPLEMENT OF THE MODE, AS A
LAC* SYMTBX /LAW INSTRUCTION. THIS IS DONE FOR SCALAR I/O
AND S60000 /CALLS, AND 1 DIM SS ELEMENT I/O CALLS OTHER
LRSS 15 /THAN DDIO OUTPUT. ALL OTHER SS ELEMENT I/O
CMA /RELIES ON .SS TO PASS THE MODE. WHOLE ARRAY
JMS FPPOUT /I/O GET THE MODE FROM THE ADB.
JMP* MODLAW
DDSS2 CAL /SET TO 0 IS 1 DIM SS ELEMENT I/O, NON-0 OTHERWISE
.EJECT
/BACKSPACE, REWIND, AND ENDFILE STATEMENT PROCESSORS.
/ BACKSPACE ENTRY = BACKSP
/ REWIND ENTRY = REWIND
/ ENDFILE ENTRY = ENDFIL
ENDFIL LAC C00001
REWIND TAD C00001
BACKSP TAD C00035
DAC TRW1 /SAVE OUTPUT OP-VALUE
JMS IODEV /FETCH AND RECORD UNIT NUMBER
LAC TRW1 /OUTPUT SUBROUTINE CALL.
ENDF01 JMS OPOPA2
LAC ARG
JMP CRTEST /EXIT
.EJECT
/ENCODE-DECODE STATEMENT PROCESSOR
ENCODE TAD C00002
DECODE DAC RWFLAG
RCR
TAD DOTGFP /GET A POINTER TO THE CORRECT ROUTINE
DZM RWBIN
DZM RWRAN /ZERO VARIOUS FLAGS FOR THE READ/WRITE PROC
DAC ENCFLG
JMS FNBCHR
ERS 39V,<SAD S00050>,EV /NEXT CHAR BETTER BE (
JMS FIARGO /GET CHARACTER COUNT
LAC ARG
DAC ARTEM /STORE IN READ/WRITE TEMPORARY
LAC OPVALU
ERS 40V,<SAD C00030>,EV /DELIM BETTER BE COMMA
JMS FVARGO /GET ARRAY NAME
LAC ARG
DAC ENCVAR /SAVE IT AWAY
LAC* SYMTBC
ERN 41V,SMA,EV /ARRAY BETTER BE ARRAY
LAC OPVALU
ERS 42V,<SAD C00030>,EV /DELIM BETTER BE COMMA
JMP RWASC1 /NOW GO GET FORMAT AND ERR. CONDITIONS
ENCFLG .DSA 0
ENCVAR .DSA 0
DOTGFP .DSA DOTGF-OPTRAN-1
/
/
/SUBROUTINE TO FETCH DEVICE NUMBER AND OUTPUT IODEV LOADER INFORMATION
IODEV SYN TYPEA2
JMS FIARGO /FETCH DEVICE NUMBER
LAC ARG /TEST ARGUMENT. IF A SYMBOL, DEFINE ALL
AND Z00000 /.DAT SLOTS. IF A CONSTANT, DEFINE
SAD T00000 /ONE .DAT SLOT (=ARG). IF NEITHER,
JMP IODEV2 /ANNOUNCE ERROR.
JMS CONTST
PASS1 SKP
IODEV2 LAC W00000 /ALL SLOTS
JMS BINOUT /OUTPUT IODEV INFO -- LOADER CODE 22.
XOR C00022
JMP* IODEV /EXIT
.EJECT
/DO STATEMENT PROCESSOR
DO JMS FDFSNO /FETCH DEFINED STATEMENT NO.
DAC* DOTABA /STORE SYMTAB ADDRESS IN DO TABLE, WORD A
DZM UNFNBC /UNFETCH CHARACTER.
JMS INAOPI /INITIALIZE ELEMENT LIST.
JMS FA2NOP
LAC IDXNOP /CHECK DELIMITER FOR "="
ERS 04D,<SAD C00001>,ED
JMS DOCODE /GENERATE DO CODE
JMS INCDTP /BUMP DO LEVEL POINTERS
JMP STEXIT /EXIT
.EJECT
/SUBROUTINE TO INITIALIZE DO-TABLE
/
INDOTB SYN IFFLAG /SET DOTABA, DOTABB, AND DOTABC POINTERS
LAC .FFREE /TO THE FIRST ADDRESS OF EACH OF THREE
JMS RSVDTP /CONSECUTIVE TABLES.
JMP* INDOTB
/
/
/SUBROUTINE TO INCREMENT DO-TABLE POINTERS.
/
INCDTP SYN NAME2
LAC DOTABA
TAD C00001
JMS RSVDTP
ERN 01L,<SAD SYMTB0>,EL /CHECK FOR OVERFLOW
JMP* INCDTP /EXIT
/
/
/
/SUBROUTINE TO DECREMENT DO-TABLE POINTERS.
/
DECDTP SYN IDXNOP
CLCCMD CLC
TAD DOTABA
JMS RSVDTP
JMP* DECDTP /EXIT
/
/
/
/SUBROUTINE TO RESOLVE DO-TABLE POINTERS.
/CALLING SEQUENCE -- JMS RSVDTP (DOTABA IN AC)
/
RSVDTP SYN NAME1
DAC DOTABA
TAD C00010
DAC DOTABB
TAD C00010
DAC DOTABC
JMP* RSVDTP
.EJECT
/SUBROUTINE TO OUTPUT DO-CODING
/
DOCODE CAL 0
DZM DOM1
DZM DOM3
JMS INFAOP /RE-INITIALIZE ARG/OP FETCH
LAC MODEA2
SNA /CHECK THAT THE DO VARIABLE (ALREADY SCANNED)
LAC TYPEA2 /IS A SIMPLE INTEGER VARIABLE
ERS 05D,<SAD T00000>,ED
LAC* ARG2
DAC DOI /SAVE DO VARIABLE
JMS FIARGO /GET INTEGER VAR/CONST AND OPERATOR
LAC OPVALU
ERS 06D,<SAD C00030>,ED /OP BETTER BE COMMA
LAC C00004 /GENERATE A LOAD INSTRUCTION
JMS OPOPA2
LAC ARG
JMS FIARGO
LAC ARG
DAC DOM2 /SAVE UPPER LIMIT
LAC OPVALU
SAD C00030
JMP .+3 /STEP EXISTS
ISZ DOM1 /NO STEP - SET STEP POSITIVE
JMP DOGEN /GO GENERATE CODE
JMS FNBCHR /PEEK AT NEXT CHAR
SAD C00045 /IS IT "-"
JMP .+3
ISZ DOM1 /NO - SET " POSITIVE DO" FLAG
DZM UNFNBC /AND UNPEEK THE CHARACTER
JMS FIARGO
LAC ARG /GET THE STEP
DAC DOM3 /SAVE IT AWAY
/
DOGEN LAC RWEXPF
SZA!CLA /THE DO PARAMETERS MUST BE TERMINATED BY A
LAW -37 /CARRIAGE RETURN IF IN A REGULAR DO LOOP
TAD OPVALU /AND BY A RIGHT PAREN IF IN AN IMPLIED
ERN 07D,SZA,ED /DO LOOP
LAC DOM1 /DOM1=0 IF NEG DO, =1 IF POS DO
.IFDEF %PDP9 /NOW CALCULATE THE INITIAL JMP
SZA /"JMP .+3" FOR POS STEP,"JMP .+4" FOR NEG STEP
.ENDC /AND PDP-15, "JMP .+5" FOR NEG STEP
CMA /AND PDP-9 (CAUSE NEED TWO INSTRUCTIONS TO TCA)
TAD C00005
TAD PC
XOR JMPCMD /GENERATE JMP .+N
JMS RELBIN
LAC PC
DAC* DOTABB /SAVE POINTER TO LOOP REENTRY FOR DO CLEANUP
LAC DOM3
SZA /WAS THERE A STEP?
JMP DOWINC /YES - COMPILE DO WITH STEP
LAC C00004
JMS OPOPA2 /LAC I
LAC DOI
JMS EXP730 /IAC ( TAD 1 ON PDP9)
JMP DOSTOR
/
DOWINC LAC C00004
JMS OPOPA2
LAC DOM3 /LAC M3
LAC DOM1
SNA
JMS EXP570 /TCA IF NEGATIVE STEP
LAC C00015
JMS OPOPA2 /TAD I
LAC DOI
DOSTOR LAC C00008
JMS OPOPA2 /DAC I
LAC DOI
JMS EXPKFF /TCA
LAC C00015
JMS OPOPA2 /TAD M2
LAC DOM2
LAC DOM1
SMA!SZA!CLA
LAC S00600 /GENERATE "SPA" IF POSITIVE STEP,
TAD .-2 /"SMA SZA" IF NEGATIVE STEP
JMS ABSBIN
JMS EXP550 /JMP OUT
XOR JMPCMD
DAC* DOTABC /SAVE ADDRESS OF JUMPOUT
JMP* DOCODE
.EJECT
/FORMAT STATEMENT PROCESSOR
FORMAT DZM SYMTBC
JMS EXP550 /OUTPUT BRANCH AROUND FORMAT STORAGE AND
XOR JMPCMD / SET FLAG FOR COMPLETING STRING.
DAC STRNGA
LAC LABEL /IF NO LABEL, ANNOUNCE ERROR.
ERN 04N,SNA,EN /ERROR: NO STATEMENT NUMBER
DZM HFLG /INITIALIZE HOLLERITH FLAG.
DZM NUMFLG /INITIALIZE NUMERIC FLAG.
LAW -5 /INITIALIZE FORMAT OUTPUT PACKER.
DAC FMTCNT
DZM FPCNT /INITIALIZE PAREN COUNT.
RW60 JMS FMTFCH /FETCH CHARACTER.
RW61 SAD S00054
JMP RW70 /IF COMMA.
SAD S00051
JMP RW71 /IF RIGHT PAREN.
RW62 SAD C00047
JMP RW60 /IF SLASH
SAD C00034
JMP RW85 /IF "
SAD C00036
JMP RW85 /IF $
SAD C00039
JMP RW85 /IF '
SAD S00124
JMP RW81 /IF T
RW63 SAD C00045
JMP RW72 /IF MINUS SIGN.
RW635 SAD S00050
JMP RW75 /IF LEFT PAREN.
JMS NUMCHK
JMP RW636 /IF NUMBER.
SAD S00120
JMP RW77 /IF P
SAD S00110
JMP RW78 /IF H
SAD S00130
JMP RW80 /IF X
SAD S00111
JMP RW81 /IF I
SAD S00114
JMP RW81 /IF L
SAD S00101
JMP RW81 /IF A
SAD S00122
JMP RW81 /IF R
SAD S00117
JMP RW81 /IF O
RW64 JMS NUMCHK
JMP RW65 /IF NUMBER
RW65 SAD S00104
JMP RW82 /IF D
SAD S00105
JMP RW82 /IF E
SAD S00106
JMP RW82 /IF F
SAD S00107
JMP RW82 /IF G
RW66 ERS 02F,<JMS NUMCHK>,EF /GET WIDTH - ERROR IF NOT THERE
LAC LS
ERN 03F,SNA,EF /ERROR: FIELD WIDTH IS 0
DZM NUMFLG /RESET NUMERIC FLAG AND CHECK XCHAR FOR
LAC XCHAR / A PERIOD.
SAD C00046
JMP RW68 /IF PERIOD, CONVERSION MUST BE FLOATING.
LAC FLOATF /IS CONVERSION D, E, F, OR G.
ERN 04F,SZA,EF /ERROR: ILLEGAL W IN NSW.D
LAC XCHAR / NO, GET NEXT CONVERSION.
JMP RW61
RW68 LAC FLOATF /IS CONVERSION D, E, F, OR G.
ERN 05F,SNA,EF /ERROR: ILLEGAL W IN NSW.D
JMS FMTFCH / YES, GET D-VALUE.
ERS 06F,<JMS NUMCHK>,EF /GET D-VALUE - ERROR IF MISSING
DZM NUMFLG
JMP RW61 /GET NEXT CONVERSION.
/NUMBER WAS FOUND; PAREN COUNT MUST BE AT LEAST ONE
RW636 LAC FPCNT /MUST
SNA /MAKE EXPLICIT CHECK TO PREVENT CONDITION OF A
JMP EF07F /NUMBER PRECEEDING THE FIRST LEFT PAREN OF
LAC XCHAR /THE FORMAT STATEMENT. RECOVER NEXT CHARACTER,
JMP RW635 /AND GET NEXT CONVERSION
/COMMA PROCESSOR.
RW70 LAC FPCNT /CHECK PAREN COUNT.
ERN 07F,SPA!SNA,EF /ERROR: MISSING LEFT PAREN
JMS FMTFCH
JMP RW62
/RIGHT PAREN PROCESSOR.
RW71 CLC /DECREMENT PAREN COUNT.
TAD FPCNT
DAC FPCNT
SPA /(RKB-064) CHECK PAREN COUNT --
JMP EF07F /(RKB-064) ERROR IF MINUS (MISSING LEFT PAREN)
SZA /(RKB-064)
JMP RW60 /(RKB-064) GET NEXT CONVERSION IF PLUS
JMP RW83 /(RKB-064) TRY TO EXIT IF ZERO.
/MINUS SIGN PROCESSOR.
RW72 JMS FMTFCH /FETCH NEGATIVE SCALE FACTOR
ERS 08F,<JMS NUMCHK>,EF /GET NUMBER - ERROR IF MISSING
RW73 DZM NUMFLG
ERS 09F,<SAD S00120>,EF /ERROR: P MISSING
JMS FMTFCH /FETCH NEXT CHARACTER.
JMP RW64 /REENTER SKIP CHAIN.
/LEFT PAREN PROCESSOR.
RW75 ISZ FPCNT /BUMP PAREN COUNT.
JMS FMTFCH /FETCH NEXT CHARACTER.
JMP RW62 /REENTER SKIP CHAIN.
/P PROCESSOR
RW77 LAC NUMFLG /IS P PRECEDED BY A NUMBER.
ERN 10F,SNA,EF /ERROR: NO NUMBER BEFORE P
JMS FMTFCH /FETCH NEXT CHAR
JMP RW64 /RE-ENTER SKIP CHAIN
/H PROCESSOR
RW78 LAC NUMFLG /IS H PRECEDED BY A NUMBER.
SZA
LAC LS /IF SO, TEST FOR NUMBER >0
DZM NUMFLG
ERN 12F,SNA,EF /ERROR: ZERO PRECEDING H
JMS TWOCMA / NO, FETCH AND SKIP (LS) CHARACTERS.
DAC LS
DAC HFLG /SET HOLLERITH FLAG.
RW79 JMS FMTFCH
ISZ LS
JMP RW79
DZM HFLG /RESET HOLLERITH FLAG.
JMP RW60 /REENTER SKIP CHAIN AT TOP.
/X PROCESSOR
RW80 LAC NUMFLG /IS X PRECEDED BY A NUMBER.
SZA /IF SO,
LAC LS /MAKE SURE ITS NON-ZERO
DZM NUMFLG
ERN 13F,SNA,EF /ERROR: BAD NUMBER BEFORE X
JMP RW60 / NO, REENTER SKIP CHAIN AT TOP.
/" AND $ PROCESSORS
/
RW85 DAC LS
DAC HFLG /PASS BLANKS
RW86 JMS FMTFCH
SAD LS
SKP
JMP RW86 /LOOP UNTIL CLOSE QUOTE
DZM HFLG
JMP RW60
/T,I,L,A PROCESSORS.
RW81 DZM FLOATF /SET FLAG TO NON-FLOATING.
JMP RW825 /REENTER SKIP CHAIN.
/D,E,F,G PROCESSORS.
RW82 CLC /SET FLAG TO FLOATING.
DAC FLOATF
RW825 JMS FMTFCH
JMP RW66 /REENTER SKIPCHAIN
/EXIT CHECKS.
RW83 JMS FMTFIL /FILL MS/LS WITH BLANKS IF NECESSARY.
JMS FMTOUT / NECESSARY -- OUTPUT LAST WORD PAIR.
JMS FNBCHR /FETCH NEXT CHARACTER (SHOULD BE A C/R).
JMP CRTEST /EXIT
/
/SUBROUTINE TO FETCH, TEST, PACK, AND OUTPUT A FORMAT CHARACTER.
FMTFCH SYN TARGI
LAC HFLG /TEST HOLLERITH FLAG. IF SET, FETCH CHAR-
SNA /ACTER. IF NOT SET, FETCH NON-BLANK
JMP FMTFC0 /CHARACTER.
JMS FETCHR
LAC XCHAR
SKP
FMTFC0 JMS FNBCHR
JMS FMTPAK /PACK XCHAR IN MS/LS.
JMS FMTOUT /IF MS/LS FULL, OUTPUT 2 OBJECT WORDS.
JMS CTRL60 /TEST IF CHARACTER WAS CARRIAGE RETURN
JMP* FMTFCH /NO - EXIT WITH CHARACTER IN AC
ERX 15F,EF /ERROR: TOO MANY LEFT PARENTHESES
.EJECT
/SUBROUTINE TO SHIFT MS/LS LEFT 7 AND MERGE CHARACTER.
/ CALLING SEQUENCE -- LAC CHARACTER (ASCII-7)
/ JMS FMTPAK
/ JMP MS/LS FULL (5 CHARACTERS PACKED)
/ XXX MS/LS NOT FULL (1-4 CHARACTERS PACKED)
/ INITIALIZATION -- SET FMTCNT TO -5.
FMTPAK SYN OP
AND S00177
DAC TRW1 /SAVE CHARACTER TO BE PACKED.
LAW -7 /INITIALIZE SHIFT-CONNT.
DAC TRW2
FMTPK1 JMS DSHL /SHIFT MS/LS 7 LEFT OPEN.
ISZ TRW2
JMP FMTPK1
LAC FLS /MERGE IN SAVED CHARACTER.
XOR TRW1
DAC FLS
ISZ FMTCNT /CHECK IF 5 CHARACTERS HAVE BEEN PACKED.
JMP FMTPK2 /NO, BUMP RETURN ADDRESS AND EXIT.
JMS DSHL /YES, LEFT JUSTIFY MS/LS AND REINITIAL-
LAW -5 /IZE CHARACTER COUNTER.
DAC FMTCNT
JMP* FMTPAK /EXIT FOR MS/LS FULL.
FMTPK2 ISZ FMTPAK /EXIT FOR MS/LS NOT FULL.
JMP* FMTPAK
/
/
/SUBROUTINE TO FILL MS/LS WITH BLANK CHARACTERS
/ CALLING SEQUENCE
/ JMS FMTFIL
/ JMP (FILL REQUIRED AND WAS EXECUTED)
/ XXX (FILL NOT REQUIRED -- NO CHANGE)
FMTFIL SYN OPVALU
LAW -5 /IF MS/LS ALREADY CONTAINS 5 CHARACTERS,
SAD FMTCNT /BUMP RETURN ADDRESS AND EXIT WITH
JMP FMTFL2 /MS/LS UNCHANGED.
FMTFL1 LAC S00040 /IF MS/LS IS PARTIALLY FULL, PACK BLANKS
JMS FMTPAK /UNTIL IT IS FULL, THEN EXIT.
JMP* FMTFIL
JMP FMTFL1
FMTFL2 ISZ FMTFIL
JMP* FMTFIL
/
/
/SUBROUTINE TO OUTPUT M/S
/
FMTOUT SYN TOPI
LAC FMS /OUTPUT MS
JMS FPPOUT
LAC FLS /OUTPUT LS
JMS FPPOUT
JMP* FMTOUT /EXIT
.EJECT
/SUBROUTINE TO CHECK FOR A NUMBER AND COMPLETE ITS CONVERSION.
/ CALLING SEQUENCE -- LAC CHARACTER (ASCII-7)
/ JMS NUMCHK
/ JMP YES
NUMCHK SYN ARG
JMS NUMTST /IS CHARACTER A NUMBER.
JMP NUMCH3 /NO, BUMP RETURN ADDRESS AND EXIT.
ISZ NUMFLG /YES - SET FLAG
NUMCH1 DAC LS /SAVE VALUE OF NUMBER
NUMCH2 JMS FMTFCH /FETCH NEXT CHARACTER.
JMS NUMTST /IS IT A NUMBER.
JMP* NUMCHK /NO, EXIT WITH NEXT (XCHAR) IN AC.
DAC TRW1 /YES - SAVE VALUE
LAC LS
RTL
TAD LS /MULTIPLY LS BY 10.
RAL
TAD TRW1 /ADD IN NEW DIGIT
JMP NUMCH1 /UPDATE VALUE AND LOOP
NUMCH3 ISZ NUMCHK /EXIT HERE IF 1ST CHARACTER NON-NUMERIC.
JMP* NUMCHK /EXIT WITH CURRENT XCHAR IN AC.
/
/
/SUBROUTINE TO TEST FOR A NUMBER
/ CALLING SEQUENCE -- LAC CHARACTER
/ JMS NUMTST
/ JMP NO
NUMTST SYN SIGN
TAD Z77706 /IS CHARACTER LESS THEN OR EQUAL TO NINE
CLL!CML /BUT GREATER THAN OR EQUAL TO ZERO?
TAD C00010
SZL /LINK ON IF VALID NUMBER
LAC XCHAR /RELOAD CHAR IF INVALID
SNL
ISZ NUMTST /SKIP RETURN IF VALID
JMP* NUMTST
/
/SUBROUTINE TO SHIFT FMS/FLS LEFT ONE OPEN.
/
DSHL SYN CHRCTR
LAC FLS
RCL
DAC FLS
LAC FMS
RAL
DAC FMS
JMP* DSHL
.EJECT
/ ASSIGNMENT STATEMENT PROCESSOR
/ ASSIGN K TO I
/
ASSIGN JMS FDFSNO /GET A STATEMENT NUMBER
LAC SYMTBC
DAC S /FORM A PSEUDO - CONSTANT WITH THE
LAC Y00000 /SYMBOL TABLE ADDRESS OF THE STATEMENT NUMBER
DAC NAME0 /AS THE VALUE AND "RELOCATABLE" AS THE TYPE
JMS CONSSE /ENTER IT IN THE CONSTANT TABLE
DAC SYMTBC
LAC XCHAR / WAS TERMINATING CHAR A -T-
ERS 06I,<SAD S00124>,EI /ERROR: NO T
JMS FNBCHR / CHECK FOR -O-
ERS 07I,<SAD S00117>,EI /ERROR: NO O
JMS SYMBIN /OUTPUT "LAC (STNO"
XOR LACCMD
JMS FIARGO /FETCH INTEGER ARGUMENT, OP
JMS VARTST /ARGUMENT MUST BE A VARIABLE
LAC C00008 /SET STORE INSTRUCTION
JMP ENDF01 /OUTPUT INSTRUCTION AND EXIT
.EJECT
/ GOTO STATEMENT PROCESSOR
/
GOTO CLC
DAC RWFLAG /INITIALIZE FLAG FOR LIST PROCESSING
JMS FNBCHR
SAD S00050 /IS CHAR AN OPEN PARENS (?
JMP GOTO01 / YES, IS ((), THIS IS COMPUTED GOTO
DZM UNFNBC / NO, UNFETCH AND TEST LAST CHAR FOR A-Z
JMS AIF500 /GET STATEMENT NUMBER OR VARIABLE AND OUTPUT JUMP
SAD S00054 /WAS TERMINATOR COMMA?
SKP /YES - ASSIGNED GOTO
JMP CRTEST /NO - BETTER BE CR
LAC SYMTBC
ERN 24I,SMA,EI /COMMA ILLEGAL AFTER STATEMENT NUMBER
JMS FNBCHR
ERS 07X,<SAD S00050>,EX /NEXT CHAR BETTER BE (
DZM RWFLAG /ZERO FLAG AND FALL THROUGH COMPUTED GOTO CODE
/
/ COMPUTED GOTO
/ GOTO (S1,S2,S3,..SN), V
GOTO01 JMS INAOPI /INITIALIZE INTEGER ARG, OP
GOTO02 JMS FDFSNO /FETCH DEFINED STATEMENT NO.
DAC OP
JMS ENTER /ENTER ARG IN LIST
LAC XCHAR /TEST LAST CHAR FOR COMMA (,)
SAD S00054 / (EXT 54)
JMP GOTO02 / YES, IS COMMA, CYCLE BACK FOR NEXT STMNT
ERS 04X,<SAD S00051>,EX /NOT COMMA, BETTER BE )
JMS FNBCHR /FETCH NEXT NON-BLANK CHARACTER
ISZ RWFLAG /IF RWFLAG IS NOT -1, THIS IS AN ASSIGNED GOTO STMT
JMP CRTEST /AND ALL WE WANTED WAS TO ERROR-CHECK, SO GOODBYE
ERS 05X,<SAD S00054>,EX /BETTER BE COMMA
JMS FIARGO /FETCH INTEGER ARG, OP
JMS VARTST /ARGUMENT MUST BE A VARIABLE
LAC C00004 /SET INDEX VALVE FOR INTEGER LOAD (LAC)
JMS OPOPA2 /OUTPUT PREVIOUS OP, ARG2 (LAC V)
LAC ARG
LAC CGOMNE /SET CAT .GO
JMS EXP580 /OUTPUT INSTRUCTION (JMS+ .GO)
XOR JMSCMD
LAC ARGI /DETERMINE NO OF STATEMENT NOS. IN LIST (N)
JMS TWOCMA
TAD ARG0 / MOW HAVE (-N)
DAC TARGI /SAVE FOR JUMP COUNTER
JMS FPPOUT /OUTPUT (-N)
JMS INAOPI
GOTO06 ISZ OPI
LAC* OPI
JMS JMPBIN /OUTPUT JUMP TO STATEMENT NUMBER
ISZ TARGI /DO THIS THE CORRECT NUMBER OF TIMES
JMP GOTO06
JMP CRTEST /SO LONG
.EJECT
/ SUBROUTINE TO OUTPUT A JUMP
/ CALLING SEQUENCE - LOAD AC WITH POINTER INTO SYMBOL TABLE
/ (SIGN 0 IF ST. NO., 1 IF ASSIGNED VARIABLE)
/ JMS JMPBIN
/
JMPBIN CAL 0
DAC SYMTBC
SPA /STATEMENT NUMBER?
JMP JMPSYM /NO
JMS SYMBIN /YES - OUTPUT "JMP STNO"
XOR JMPCMD
JMP* JMPBIN /RETURN
JMPSYM LAC* SYMTBC /VARIABLE --
AND T00000 /CHECK FOR DUMMY OR COMMON VARIABLE
SNA
JMP JMPVAR /NEITHER - A SIMPLE JMP* WILL DO
LAC PASS1 /OUTPUT THE FOLLOWING SEQUENCE
JMS ABSBIN / SKP (MIGHT BE IN IF STMT)
LAC PC
TAD C00004 / JMP .+4
XOR JMPCMD
JMS RELBIN / LAC* VAR
JMS SYMBIN
XOR LACICM / DAC TEMP
CLA
JMS STORET / JMP* TEMP
DAC SYMTBC
JMPVAR JMS SYMBIN
XOR JMPICM /OUTPUT A JUMP INDIRECT THROUGH CURRENT SYMTBC
JMP* JMPBIN /RETURN
LACICM LAC* 0
.EJECT
/ CONTINUE STATEMENT PROCESSOR
/
CONTIN JMS FNBCHR /GET LAST CHARACTER
JMP CRTEST /EXIT AND TEST FOR C/R IN XCHAR
/ PAUSE STATEMENT PROCESSOR
/
PAUSE LAC JMSCMD /SET UP FOR JMS* .PA INSTRUCTION
DAC POP / HOLD -JMS-
LAC PAMNE / GET .PA
JMP STOP01
/ STOP STATEMENT PROCESSOR
/
STOP LAC JMPCMD /SET UP FOR JMP* .ST INSTRUCTION
DAC POP / HOLD -JMP-
LAC STMNE / GET .ST
STOP01 DAC ARG2 / HOLD .PA OR .ST
DZM UNFNBC /WE ARE GOING TO FALSELY INSERT A "#"
JMS INFAOP /INTO THE INPUT CHARACTER STREAM SO THAT THE
LAC CHAROC /NEXT NUMBER (IF ANY) WILL BE TAKEN AS OCTAL
DAC LSTCHR
JMS FIARGO /FETCH AN INTEGER
LAC C00004
JMS OPOPA2
LAC ARG /GENERATE "LAC (CONSTANT"
LAC ARG2 /GET .PA OR .ST
JMS EXP580 /BUILD AND OUTPUT JMS* .PA OR JMP* .ST
XOR POP / (JMS OR JMP)
JMP CRTEST /STATEMENT EXIT
.EJECT
/ DATA STATEMENT PROCESSOR
/
DATA LAW -1
DAC DATAFL
JMS CTRL70 /CATCH STMT LABEL FOR CONTINUE ERROR.
DATA25 JMS INAOPI /INITIALIZE ARG(I) AND OP(I) LISTS
DATA01 JMS FVORAR /FETCH SIMPLE OR SUBSCRIPTED VARIABLE, OP
CLL
JMS SYMTYP /IS VARIABLE COMMON
XOR T00000
CML /LINK IS COMPLEMENTED IF VAR NOT IN COMMON
LAW -1
SAD FCNFLG /LINK COMPLEMENTED AGAIN IF IN BLOCK DATA
CML
ERN 16C,SNL,EC /WRONG COMBINATION YIELDS ERROR
LAC* ARG
SMA /ARRAY?
JMP DATA1B /NO
LAC SSCTR
SZA /SUBSCRIPTS?
JMP DATA1A /YES - TREAT NORMALLY
LAC W00000
DAC T0 /SET T0 TO STRANGE NEGATIVE NUMBER
SKP
DATA1A JMS SUBCNT /CHECK NUMBER OF SUBSCRIPTS
DATA1B JMS ENTER /ENTER ARG, OP IN ARG(I), OP(I) LISTS
LAC T0 /PLACE SUBSRIPT VALUE
DAC* OPI / IN OP(I)
LAC OPVALU /IS OPERATOR A COMMA (,)
SAD C00030
JMP DATA01 / YES, CYCLE BACK FOR NEXT VARIABLE
ERS 10X,<SAD C00018>,EX /BETTER BE A SLASH
JMS EXP540 /MOVE ARG(I) TO TARG(I)
JMS INAOPI /RE-INITIALIZE THE LIST
DZM TFAO01
LAW -1
DAC ARGCTR /INITIALIZE REPEAT FLAG
LAC C00030
DAC OPVALU /INITIALIZE LAST OP TO A COMMA
DATA02 ISZ ARGI
ISZ OPI /GET NEXT VARIABLE FROM VARIABLE LIST
DATA03 ISZ ARGCTR /ARE WE REPEATING?
JMP DATA05 /YES - KEEP OLD VARIABLE
LAW -1
DAC ARGCTR /RE-INITIALIZE COUNTER
LAC OPVALU
ERS 11V,<SAD C00030>,EV /MAKE SURE LAST CHAR SCANNED IS ,
DATA04 LAC C00001 /IF HOLLERITH CONSTANT IS GOTTEN, THIS IS RESET TO
DAC HOLCON /-5 TO 0, CORRESPONDING TO 0 TO 5 CHARACTERS PACKED
JMS FARGOP /GET ARG AND OP
LAC ARG
AND Z00000
ERS 09V,<SAD U00000>,EV /MAKE SURE ARG IS A CONSTANT
LAC OPVALU /IF OP IS *, GO STORE REPEAT FACTOR
SAD C00021 /ALSO SET -1 INTO DATA22. IT IS ISZ'D
JMP DATA16 /EACH TIME HAVE TO CONVERT INTEGER CONSTANT
LAW -1 /TO D.I. VARIABLE; ALLOWING THIS CONVERSION
DAC DATA22 /ONLY ONCE IN A REPEAT CYCLE.
DATA05 LAC* ARGI /GET ARGUMENT DESCRIPTION WORD (I)
JMS SETA2 /BUST ARGUMENT
JMS SETADR / TO GENERATE VARIABLE ADDRESSES
LAC HOLCON /IF HOLCON IS STILL 1, THEN NO HOLLERITH INFORMATION
SAD C00001 /WAS ENCOUNTERED. ELSE CHECK IF ONLY 1 OR TWO
JMP DATA26 /CHARACTERS WERE PACKED. ADDING 2 TO HOLCON
TAD C00002 /LEAVES IT NEGATIVE IF ONLY 1 OR 2 CHARS WERE
SPA!CLL /PACKED, FOR WHICH CASE THE LINK IS SET.
STL
LAC MODEA2 /GET THE MODE OF THE VARIABLE
DAC NAME0 /MAKE THE MODE OF THE CONSTANT MATCH IT
AND S60000 /NOW, IF IT IS AN INTEGER, WONT ALLOW MORE THAN
SZA /2 CHARS. SKIPS IF IS INTEGER.
JMP DATA26 /NOT INTEGER, WE ARE SAFE (ULTIMATE 5 CHAR LIMIT)
ERS 02H,SZL,EH /IF LINK IS OFF, TOO MANY CHARS
DATA26 LAC NAME0 /CHECK IF MODE OF VARIABLE IS MODE OF CONSTANT
RTL /(THIS IS FORCED FOR HOLLERITH CODE)
AND V00000
DAC MODEA1 /SHIFT BITS 3,4 INTO BITS 1,2 FOR OUTPUT
LAC MODEA2
SAD NAME0 /VARIABLE AND CONSTANT MODES SHOULD AGREE
JMP DATA06
TAD MODEA1 /ONLY EXCEPTION BEING WHEN VAR IS DBL INTEGER
ERS 38V,<SAD S60000>,EV /AND CONSTANT IS INTEGER
ISZ DATA22 /INITIALLY = -1, ALLOWING CONVERSION OF
JMP DATA06+2 /INTEGER TO DOUBLE INTEGER ONLY FIRST
LAC S /TIME THROUGH. THIS PREVENTS REPEAT COUNT
DAC NAME1 /SEQUENCE FROM CONVERTING MORE THAN ONCE
SPA!CLA /IN A SEQUENCE
CMA
DAC S
JMP .+3
DATA06 LAC MODEA1 /IF THE MODE OF THE VARIABLE IS
SAD V00000 /DOUBLE INTEGER, MAKE IT REAL TO PACIFY THE
LAC T00000 /LOADER (WHICH THINKS MODE 3 IS LOGICAL)
DAC MODEA1
LAC S /OUTPUT FIRST DATA WORD
JMS BINOUT /WITH
XOR C00015 /LOADER CODE 15
LAC MODEA1 /IF MODE OF CONSTANT IS INTEGER OR LOGICAL,
SNA / SKIP OUTPUT OF SECOND DATA WORD
JMP DATA08
LAC NAME1 /OUTPUT SECOND DATA WORD
JMS BINOUT / WITH
XOR C00016 / LOADER CODE 16
LAC MODEA1 /IF MODE OF CONSTANT IS REAL,
SAD T00000
JMP DATA08 / SKIP OUTPUT OF THIRD DATA WORD
LAC NAME2 /OUTPUT THIRD DATA WORD
JMS BINOUT / WITH
XOR C00017 / LOADER CODE 17
DATA08 LAC* SYMTBC /GET SYMBOL DESCRIPTION
AND Z00000
SAD W00000 /CHECK FOR A NON-COMMON ARRAY
JMP DATA09 /YES - USE POINTER FROM ARRAY DESCRIPTOR BLOCK
LAC* SYMTBC / NO, GET ARG DESCRIPTION WORD (WORD 1)
AND S17777 / KEEP ADDRESS OF VARIABLE
JMP DATA12
DATA09 LAC* SYMTW7 /GET ADDRESS OF ARRAY
DATA12 TAD* OPI / ADD SUBSCRIPT VALUE (0 IF NOT ARRAY)
TAD MODEA1 /ADD MODE BITS IN BITS 1,2
AND V77777 /AND OUT SIGN BIT, IF ARRAY KLUDGE
JMS BINOUT /OUTPUT DEFINITION WORD
XOR C00018 /WITH LOADER CODE 18
LAC MODEA2
JMS SETN
TAD* OPI
DAC* OPI /BUMP SUBSCRIPT BY ARGUMENT LENGTH
XOR W00000 /CHANGE SIGN BIT
SMA /IF THIS IS ARRAY KLUDGE, CHECK WHETHER
SAD* SYMTW3 /WE HAVE EXHAUSTED THE ARRAY
SKP /NO ARRAY OR ARRAY EXHAUSTED - GET NEXT ARG
JMP DATA03 /NOT EXHAUSTED YET - GET NEXT CONSTANT
LAC ARGI
SAD TARGI /IF CURRENT ARG PTR IS AT END OF LIST
JMP DATA21 /THEN WE ARE FINISHED
JMP DATA02 /OTHERWISE BUMP POINTERS AND CONTINUE
DATA16 LAC NAME0
SNA
ISZ ARGCTR
ERX 15C,EC /CURRENT REPEAT CTR MUST BE 0 AND REPEAT FACTOR
JMS CONTST /MUST BE A POSITIVE NON-ZERO INTEGER.
JMS TWOCMA
DAC ARGCTR /STORE INTEGER (NEGATED) AS NEW REPEAT COUNT
JMP DATA04 /AND GO GET SOME DATA TO REPEAT
DATA21 LAC C00018 /END OF LIST HAS BEEN REACHED -
SAD OPVALU /CHECK THAT NEXT INPUT CHARACTER IS A SLASH
ISZ ARGCTR /AND THAT THE REPEAT SWITCH IS OFF
ERX 12V,EV /OTHERWISE ERROR
JMS FNBCHR /GET NEXT NON-BLANK CHAR
SAD S00054 / IS IT A COMMA
JMP DATA25 /YES, REINITIALIZE FOR NEW SET OF VARIABLES
JMP CRTEST /NO, TEST FOR C/R AND EXIT
HOLCON XX
DATA22 XX
.EJECT
/ IF STATEMENT PROCESSOR
/
IF LAC C00024 /THE IF INDICATOR IS SET AS AN OPEN
DAC IFFLAG /PARENTHESIS FOR EXPRESSION DECODING.
JMS EXPRSN /THE IF EXPRESSION IS DECODED AND THE
LAC OPVALU /NECESSARY CODE IS GENERATED SO THAT THE
/RESULT WILL BE LEFT IN THE ACCUMULATOR
ERS 11X,<SAD C00031>,EX /ERROR: NO CLOSE PAREN
JMS SIN530 /SAVE COLUMN POINTERS
ISZ CTRLSW /INHIBIT READING CONTINUATION CARDS
IFLP JMS FETCHR /GET A CHARACTAR
SKP /NORMAL CHARACTER
JMP LGCLIF /END OF LINE REACHED - ASSUME LOGICAL IF
TAD K00005
SMA /CHECK IF CHAR IS ALPHANUMERIC
SAD C00006 /OR BLANK
JMP IFLP /IT IS - KEEP LOOKING
LAC XCHAR /IF FIRST NON-ALPHANUMERIC, NON-BLANK CHARACTER
SAD S00054 /IS NOT A COMMA,
SKP
JMP LGCLIF /ITS A LOGICAL IF STMT
JMS FNBCHR /IF COMMA, WE MUST STILL CHECK THAT THE NEXT CHAR
SAD S00050 /IS A RIGHT PAREN
JMP LGCLIF /IF IT IS, THIS IS A LOGICAL IF STMT
JMS SIN540 /ARITHMETIC IF - RESTORE POINTERS
DZM CTRLSW /RE-ENABLE CONTINUATIONS
/
/ARITHMETIC IF STATEMENT WRAP-UP
/
DZM LOGIF
.IFUND %FPP
JMS GTINAC /GET A TESTABLE RESULT INTO THE AC
.ENDC
.IFDEF %FPP
.ENDC
LAC OSSTM1 /SET UP TRANSFER VECTOR FOR STORING ADRESSES
DAC OSSTMP
JMS AIKF50 /GET ADRESS 1
ERS 12X,<SAD S00054>,EX
JMS AIKF50 /GET ADDRESS 2
ERS 13X,<SAD S00054>,EX
JMS AIKF50 /GET ADDRESS 3
.IFDEF %FPP
LAC MODEA2 /IS EXPRESSION INTEGER?
SNA
JMP AIF14 /YES; USE HARDWARE AC
LAC JMP.1 /NO; USE FAC OF FPP
SAD JMP.2 /ARE FIRST TWO ADDRESSES IDENTICAL
JMP AIFR10 /YES USE SHORTCUT METHOD
SAD JMP.3 /ARE FIRST AND THIRD ADDRESS SAME?
JMP AIFR12 /YES; USE ANOTHER SHORTCUT METHOD
LAC FPPSPA /OUTPUT SKIP ON FAC POSITIVE
JMS FPPOUT
LAC JMP.1 /MAKE SURE OBJECT CODE LISTING IS RIGHT
DAC SYMTBC
LAC* SYMTBC
AND S17777
JMS VECBIN
LAC JMP.2 /ARE SECOND AND THIRD ADDRESSES SAME
SAD JMP.3
JMP AIF13 /YES; OUTPUT SIMPLE JMP
AIFR12 LAC FPPSNA /OUTPUT SKIP ON NONZERO FAC
JMS FPPOUT
LAC JMP.2 /MAKE SURE OBJECT LISTING RIGHT
DAC SYMTBC
LAC* SYMTBC
AND S17777
JMS VECBIN
JMP AIF13
AIFR10 LAC FSPANA
JMP AIFR12+1
FPPSPA 716602 /BMA
FPPSNA 716601 /BZA
FSPANA 716603 /BLE
AIF14=.
.ENDC
LAC JMP.1 /IS ADDRESS 1 THE SAME AS 2
SAD JMP.2 /NO
JMP AIF10 /YES
SAD JMP.3 /ADDRESS 3? NO
JMP AIF12
LAC SPACMD /OUTPUT A SPA INSTRUCTION
JMS ABSBIN
LAC JMP.1 /SET UP TO LOOK LIKE ADDRESS JUST READ
JMS JMPBIN /OUTPUT FIRST JMP(1)
LAC JMP.2 /IS ADDRESS 2 THE SAME AS 3
SAD JMP.3 /NO
JMP AIF13 /YES
AIF12 LAC SNACMD /OUTPUT A SNA INSTRUCTION
JMS ABSBIN
LAC JMP.2 /SET UP TO OUTPUT JMP (2)
JMS JMPBIN
AIF13 LAC JMP.3 /SET UP TO OUTPUT JMP (3)
JMS JMPBIN
JMP CRTEST /TEST FOR CARRIAGE RETURN TERMINATOR
AIF10 LAC SPASNA /OUTPUT SPA!SNA COMMAND
JMP AIF12+1
.EJECT
/ LOGICAL IF STATEMENT WRAP-UP
/
LGCLIF JMS SIN540 /RESTORE CHAR POINTERS
DZM CTRLSW /RE-ENABLE CONTINUATION CARDS
LAC LOGIF /ARE WE ALREADY IN A LOGICAL IF?
ERN 09I,SZA,EI /YES - ERROR
JMS GTINAC /GET A TESTABLE RESULT INTO THE AC
ISZ LOGIF /GENERATE: (EXPRESSION RESULT IN AC)
LAC SNACMD
JMS ABSBIN / SNA
JMS EXP550 / JMP AA FALSE EXIT
XOR JMPCMD / . TRUE EXIT (STATEMENT)
DAC STRNGA / .
CLC / AA NEXT STATEMENT
DAC IFFLAG /SET IFFLAG OFF SO PAREN CHECKS WILL BE VALID
JMP CTRL41 /(SEE EX15X ERROR CHECK)
.EJECT
/ SUBROUTINE TO OUTPUT A BRANCH INSTRUCTION TO A STATEMENT LABEL
/
AIF500 SYN LOGIF
JMS FSNOAV /THE DEFINED-ONLY STATEMENT NUMBER IS
JMS JMPBIN /FETCHED AND OUTPUT AS A BRANCH
LAC XCHAR /INSTRUCTION.
JMP* AIF500
/
/
/ SUBROUTINE TO GET A STATEMENT LABEL
/STORES IN JMP.1 TO JMP.3 THE THREE LABELS FOR A ARITHMETIC IF
/THE QUANTITIES STORED ARE NOT THE TAGS BUT THE ADDRESSES OF THE
/TAGS IN THE SYMBOL TABLE.
/
OSSTM1 DAC JMP.1 /INSTRUCTION TO STORE IN JUMP TABLE
JMP.1 0
JMP.2 0
JMP.3 0
/
AIKF50 CAL 0
JMS FSNOAV /FETCH DEFINED ONLY STATEMENT LABEL
OSSTMP XX /STORE IT IN THE JUMP TABLE
ISZ OSSTMP
LAC XCHAR /LEAVE WITH OPERATOR IN AC
JMP* AIKF50
/
/
/ SUBROUTINE TO FETCH DEFINED-ONLY STATEMENT NUMBER
/
FDFSNO SYN FPCNT
JMS FETSNO /THE CALLING PROGRAM REQUIRES THAT A
ERN 05N,SPA,EN /DEFINED STATEMENT NUMBER BE PRESENT
JMS CKDFSN /CHECK THAT STMT NO IS DEFINED
LAC SYMTBC /THE SYMTAB ADDRESS IS RETURNED TO THE
JMP* FDFSNO /CALLING PROGRAM
.EJECT
/ SUBROUTINE TO CHECK HAT STMT NUMBER IS DEFINED
/
CKDFSN CAL 0 /SUBROUTINE TO CHECK THAT ST. NO. IS DEFINED
AND S60000 /ENTER WITH SYMBOL TABLE WORD 1 IN AC
XCT PASS /RETURN IF THIS IS PASS 1 OR IF THE MODE
SAD S60000 /BITS OF THE SYMBOL ARE NOT 60000 (UNDEF. ST. NO.)
JMP* CKDFSN
ERX 03N,EN /ERROR: UNDEFINED STMT NO. ON PASS 2
/
/ SUBROUTINE TO FETCH DEFINED STMT NUMBER OR ASSIGNED GOTO VARIABLE
/
FSNOAV CAL 0 /SUBROUTINE TO FETCH DEFINED STMT NO. OR ASS. VAR.
JMS FETSNO
SPA /STATEMENT NUMBER?
JMP FSOOPS /NO
JMS CKDFSN /CHECK DEFINITION
LAC SYMTBC
JMP* FSNOAV /RETURN WITH SYMTAB POINTER IN AC
FSOOPS JMS FIARGO /FETCH SIMPLE INTEGER
JMS VARTST /VARIABLE
LAC SYMTBC
XOR W00000 /RETURN WITH SYMTAB POINTER IN AC
JMP* FSNOAV /AND SIGN BIT ON
.TITLE FUNCTION AND SUBROUTINE STATEMENT PROCESSORS
/ STATEMENT FUNCTION STATEMENT PROCESSOR
/
STAFCN LAC SORDER /STATEMENT FUNCTIONS MUST PRECEDE EXECUTABLE CODE
ERN 16I,<SAD V40000>,EI /WHICH HAS A STMT ORDER OF SEVEN.
LAC V00000 /STATEMENT FUNCTIONS HAVE AN IMPLIED
DAC TORDER /STATEMENT ORDER OF SIX.
JMS EXP550 /STRING A JUMP
XOR JMPCMD /AROUND THE FUNCTION BODY
DAC STRNGA /AND SAVE THE STRING ADDRESS FOR STMT CLEANUP
XCT PASS
JMP SFCN01 /STATEMENT FUNCTION NAMES CANNOT BE
/EXPLICITLY TYPED AS EXTERNAL FUNCTIONS
LAC* SYMTBC
AND S60000
XOR PC
XOR Y00000 /STATEMENT FUNCTIONS ARE DIFFERENTIATED
DAC* SYMTBC /FROM EXTERNAL FUNCTIONS.
SFCN01 JMS CTRL70 /STATEMENT FUNCTIONS CANNOT BE LABELED.
/THE DUMMY ARGUMENTS LISTED ARE VALID ONLY
JMS SUBR60 /FOR THIS STATEMENT AND MAY DUPLICATE
ISZ TSMTBN /PREVIOUSLY DECLARED NAMES. THE AREA IN
JMS SUBR50 /FRONT OF THE SYMBOL TABLE IS USED TO
LAC XCHAR /TEMPORARILY CONTAIN THESE ERASABLE VARIABLES
ERS 04E,<SAD S00075>,EE /CHECK FOR = SIGN
LAC C00001 /THE PROPER NEXT ENTRY ADDRESS IS RESET
DAC IFFLAG /SO THAT NON-DUMMY VARIABLES IN THE
DZM TSMTBN /EXPRESSION MAY BE ENTERED PERMANENTLY.
LAC STAF
TAD S03100
DAC STAF
LAC TSMTBC
DAC SUBR40 /SAVE POINTER TO FUNCTION DEFINITION
JMS EXPRSN /THE BODY OF THE FUNCTION IS DECODED AND
LAC* SUBR40 /GET THE MODE OF THE FUNCTION
AND S60000 /FROM ITS SYMBOL TABLE ENTRY
JMS EXP740
LAC SUBR40 /AFTER CONVERTING THE RESULT, GET THE ENTRY
DAC SYMTBC /POINT ADDRESS FROM THE SYMBOL TABLE
JMS SYMBIN /AND GENERATE A RETURN JUMP
XOR JMPICM /THE SUBROUTINE IS CLOSED WHEN THE EXIT
JMP STEXIT /INSTRUCTION IS OUTPUT.
STAF 0 /STATEMENT FUNCTION TEMPORARY STORAGE SUFFIX
S03100 3100 /A--
.EJECT
/ T FUNCTION STATEMENT PROCESSOR
/
TFUNCT LAC SORDER /WE CAME HERE FROM THE TYPE STMT PROCESSOR
ERN 17I,SZA,EI /ERROR: FUNCTION STMT NOT FIRST IN PROGRAM
/
/
/ SUBROUTINE/FUNCTION STATEMENT PROCESSOR
/
FUNCTI LAC S20000 /A FUNCTION IS DIFFERENTIATED FROM A
SUBROU XOR JMPICM /SUBROUTINE IN THAT A FUNCTION MUST RETURN
DAC FCNFLG /A VALUE IN THE ACCUMULATOR TO THE CALLING
DZM TORDER
LAC PASS2 /PUT A NOP INTO ENTFLG SO SUBR50
DAC ENTFLG /WILL KNOW THIS IS SUBROU OR FUNCTI
JMS FVARGO /PROGRAM. THE SUBPROGRAM NAME IS FETCHED
XCT PASS
JMP FUN002 /MODE SET IF PASS 2
LAC MODE
SPA /THE MODE-TYPE IS EXPLICITLY SET WHEN
FUN002 LAC* SYMTBC /THIS IS A T FUNCTION STATEMENT
AND S77777 /THE NAME IS ENTERED AS A SIMPLE VARIABLE
DAC* SYMTBC /WITH THE USE FLAG RESET.
XCT PASS /**060** CHECK FOR UNDEFINED FUNCTION ON PASS 2
SKP /**060** IT'S PASS 2
JMP FUN003 /**060** NO CHECK
AND S17777 /**060** ONLY NEED ADDRESS BITS
SAD S17777 /**060**IF ADDRESS EQUALS 17777, FUNCTION IS
SKP /**060**NOT DEFINED
JMP FUN003 /**060**
LAC FCNFLG /**060** TEST IF SUBROUTINE OR FUNCTION, IF FUNCTION
ERS 10E,<SAD JMPICM>,EE /**060** THEN ERROR
FUN003=. /**060** NO ERROR CONTINUE
LAC MODE
CMA
AND W00000 /IF THE FUNCTION WAS EXPLICITLY TYPED
DAC* SYMTW6 /SET THE "EXPLICITLY TYPED" BIT ON
JMS SUBR40 /COMPILE THE CODE FOR THE STATEMENT
LAC FNCMNE /DEFINE THE QUANTITY ".EX" AS THE
JMS EXP580 /ADDRESS OF THE RETURN CODE FOR THE SUBROUTINE
JMP .+1 /FANCY, FANCY!
LAC SYMTBC /SAVE THE SYMBOL TABLE POINTER SO THAT THE
DAC FCNRET /"END" STATEMENT PROCESSOR CAN DEFINE .EX
ISZ TORDER /ONLY ONE SUBR,FUNCT OR BLOCKDATA IS ALLOWED
JMP CRTEST
.EJECT
ENTRY LAC FCNFLG /AN ENTRY STATEMENT IS ONLY LEGAL
AND Z40000 /INSIDE A SUBROUTINE OR FUNCTION
ERS 03E,<SAD JMPCMD>,EE
JMS EXP550 /GENERATE A JUMP AROUND
XOR JMPCMD /THIS STATEMENT
DAC STRNGA /SAVE STRING ADDRESS FOR STATEMENT CLEANUP RTN
JMS FVARGO /GET ENTRY NAME
LAC NAME1
ERN 02E,SZA,EE /ENTRY NAME MUST BE UNIQUE
LAC PASS1 /PUT A SKP INTO ENTFLG, SO SUBR50 WILL
DAC ENTFLG /KNOW ITS AN ENTRY STATEMENT.
LAC PC
DAC* SYMTBC /STORE ENTRY ADDRESS AWAY TEMPORARILY
JMS SUBR40 /COMPILE THE CODE FOR THE ENTRY
LAC TSMTBC
DAC SYMTBC /RESTORE SYMTBC FOR LISTING
JMS SYMBIN /GENERATE LAC ENTRYNAME
XOR LACCMD / DAC SUBROUTINENAME
LAC S17777
DAC* SYMTBC /SET ENTRY POINT UNDEFINED FOR UNIQUENESS TEST
LAC DACCMD /OUTPUT A "DAC 0" SINCE SUBROUTINE ENTRY IS
JMS RELBIN /AT 0 (RELOCATABLE)
JMP CRTEST
.EJECT
/ SUBROUTINE TO OUTPUT CODE FOR "FUNCTION","SUBROUTINE", AND "ENTRY" STMTS
/
SUBR40 CAL 0
JMS OSYMBL /PUT OUT THE NAME
LAC PC /AS A GLOBAL AND DEFINE IT
JMS BINOUT /WITH THE CURRENT LOCATION COUNTER
XOR C00010
JMS SUBR60 /GENERATE THE SUBROUTINE ENTRY CODE
LAC OPVALU /ANY ARGUMENTS?
SAD C00028
JMS SUBR50 /YES - COLLECT THEM
JMP* SUBR40
/
/
/
/ SUBROUTINE TO GENERATE A SUBROUTINE ENTRY
/
SUBR60 SYN FLOATF
DZM STRNGB
JMS TSETAD /THE SYMBOL TABLE POINTERS ARE PRESERVED
LAC PC /THE SUBROUTINE ENTRY POINT IS OUTPUT AS
JMS VECBIN /A SELF-REFERENCING TRANSFER VECTOR.
LAC OPVALU
SAD C00028 /A SUBROUTINE SUBPROGRAM MAY BE WRITTEN
JMP SUBR51 /WITHOUT AN ARGUMENT LIST.
LAC FCNFLG
ERS 05E,<SAD JMPICM>,EE /ARG LIST NOT INDICATED
JMP* SUBR60
SUBR51 LAC GETARG
JMS EXP580 / THE SUBROUTINE ENTRY CODE IS...
XOR JMSCMD
JMS EXP550 / ENTRY .DSA ENTRY
XOR JMPCMD / JMS* .G GET ARGUMENTS
DAC STRNGB / JMP A(N)+1
JMP* SUBR60
.EJECT
/ SUBROUTINE TO FETCH DUMMY ARGUMENTS
/
SUBR50 SYN RWFLAG
SUBR55 JMS FVARGO / . . .
LAC NAME1
SNA /IS ARGUMENT NAME UNIQUE?
JMP SUBR52 /YES - GO OUTPUT POINTER
LAC* SYMTBC /THERE ARE FOUR POSSIBILITIES HERE -
AND S17777 /1) THE VARIABLE HAS BEEN TYPED BUT NOT USED
SAD S17777 /2) THE VARIABLE IS DEFINED AS THE CURRENT LOCATION
JMP SUBR52 / (I.E. WE ARE IN PASS2)
SAD PC /TSMTBC ADDRESS THE ENTRY, FUNC, OR SUBR NAME
JMP SUBR52 /SYMTAB ENTRY. IN PASS 1 MUST GET NEG RESULT
CMA /AT THIS STAGE AS (3) THE VAR. WAS PREVIOUSLY
TAD* TSMTBC /DEFINED AS DUMMY. AT END OF PASS1, DUMMY ARRAYS
SMA /ARE REDEFINED AT END OF PROGRAM. CHECK 3 STILL
JMP SUBRYY
XCT PASS
XCT ENTFLG /POSITIVE RESULT OF CMA; TAD* TSMTBC IS OK.
JMP SUBRYY / JMPS IF PASS1 OR IF NOT ENTRY
LAC* SYMTBC
SPA!CLA /POSITIVE IF NOT ARRAY; IF IS ARRAY
SUBRYY LAC* SYMTBC /CHECK IF IS DUMMY
AND V00000
ERS 14V,<SAD V00000>,EV
LAC* SYMTBC /IF THE ARGUMENT WAS VALIDLY PREVIOUSLY DEFINED
AND S17777 /THEN OUTPUT A POINTER TO THE PREVIOUS
XOR W00000 /DEFINITION WITH THE SIGN BIT ON
JMS VECBIN
JMP SUBR53 /REJOIN OTHER CODE
SUBR52 LAC TSMTBN
SZA
JMP .+3 /STATEMENT FUNCTION.
XCT PASS
JMP SUBR56
LAC* SYMTBC /ALL ARGS IN THE LIST ARE TYPED AS
AND W77777
XOR V00000 /DUMMY VARIABLES AND ASSIGNED THE VALUE OF
DAC* SYMTBC /THE CURRENT LOCATION COUNTER.
SUBR56 JMS DEFNSM
XOR PC
JMS VECBIN /THE ARGUMENT LIST IS OUTPUT AS A LIST OF
SUBR53 LAC OPVALU /SELF-REFERENCING TRANSFER VECTORS.
SAD C00031 /ARGUMENT LIST TERMINATED BY
JMP SUBR54 /CLOSE PARENTHESIS
ERS 03S,<SAD C00030>,ES /ONLY OTHER LEGAL CHAR IS ,
JMP SUBR55
SUBR54 LAC STRNGB /STRING JUMP ROUND
JMS STRING /ARGUMENT LIST
JMS FNBCHR
JMP* SUBR50
.EJECT
/ BLOCK DATA STATEMENT PROCESSOR
/
BLOCKD LAC K00001 /THE SUBPROGRAM FLAG IS SET TO INDICATE
DAC FCNFLG /A BLOCK DATA SUBPROGRAM.
LAC LOWRAD /THE BLOCK DATA DECLARATION IS OUTPUT AS
JMS BINOUT /THE CUMULATIVE SIZE OF THE DECLARED
XOR C00011 /COMMON BLOCKS
ISZ TORDER /ONLY ONE SUBR,FUNCT, OR BLOCKDATA ALLOWED IN A PGM
XCT PASS /IF WE ARE IN PASS 2,
JMS CLENUP /OUTPUT COMMON DEFINITIONS NOW.
JMP CONTIN /FROM BEING ACCEPTED.
.EJECT
/ RETURN STATEMENT PROCESSOR
/
RETURN LAC FCNRET /A "RETURN" STATEMENT IS ONLY LEGAL
ERN 10I,SNA,EI /IF WE ARE IN A SUBROUTINE OR FUNCTION
JMS FNBCHR /LOOK A CHARACTER AHEAD
DZM UNFNBC
SAD C00013 /IS THE CHARACTER A CARRIAGE RETURN?
JMP RETRNX /YES - NORMAL SUBROUTINE RETURN
MRETRN JMS FVARGO /MULTIPLE RETURN - GET THE RETURN TARGET
DZM UNFNBC
LAC* SYMTBC
AND Z60000 /MAKE SURE THAT IT IS A SIMPLE INTEGER ARGUMENT
ERS 26I,<SAD V00000>,EI /ERROR: ILLEGAL RETURN ADDRESS
JMS SYMBIN /GENERATE LAC* ARGUMENT
XOR LACICM / DAC SUBROUTINENAME
LAC DACCMD / FOLLOWED BY A NORMAL RETURN SEQUENCE
JMS RELBIN
RETRNX LAC FCNRET /GENERATE A JUMP
JMS JMPBIN /TO THE COMMON RETURN CODE AT THE END OF THE PGM
JMP CONTIN
.EJECT
/ CALL STATEMENT PROCESSOR
/
CALL JMS FA2NOP /THE NAME OF THE SUBROUTINE BEING CALLED
JMS VARTST /IS FETCHED AND ENTERED INTO THE ARG(I);
LAC* SYMTBC /OP(I) LISTS
AND Z00000
SAD U00000 /IS THE NAME A FUNCTION?
JMP CALL03
SAD V00000 /IS THE NAME A DUMMY ARG?
JMP CALL01
LAC NAME1 /CHECK FOR REDEFINITION OF AN
ERN 06E,SZA,EE /EXISTING VARIABLE
CALL02 LAC* SYMTBC
AND S77777
XOR U00000 /THE NAME IS TYPED AS A FUNCTION NAME IF
DAC* SYMTBC /THIS IS ITS FIRST APPEARANCE.
CALL03 LAC OPVALU
SAD C00028 /A SUBROUTINE MAY BE CALLED WITH OR
JMP CALL06 /WITHOUT SPECIFYING A PARAMETER LIST.
JMS SYMBIN /A SIMPLE "JMS* SUBR" IS GENERATED WHEN
XOR JMSICM /NO PARAMETER LIST IS SPECIFIED
JMP CRTEST /THE EXPRESSION DECODING ROUTINE IS USED
CALL06 LAC CALL05 /TO GENERATE THE SUBROUTINE CALL WITH
DAC EXPRSN /FORMAL PARAMETERS.
JMP EXP011
CALL05 .DSA CRTEST
CALL01 LAC U00000
XOR* SYMTW2
DAC* SYMTW2
JMP CALL02
JMSICM JMS* 0
.TITLE END STATEMENT PROCESSOR
/
END LAC K00001
DAC PROCAD /SET UP PROCAD FOR ERROR ROUTINE
JMS CTRL70 /END STATEMENTS CANNOT BE LABELED
LAC FCNFLG
SAD K00001
JMP ENDBLK /BLOCK DATA SUBPROGRAM
SNA /MAIN PROGRAM?
JMP END04 /YES
LAC PC /NO - DEFINE ".EX" HERE
XOR V00000
DAC* FCNRET
LAC FCNFLG
SAD JMPICM /IF THIS IS A SUBROUTINE,
JMP END02 /OUTPUT A "RETURN"
LAC ARG0
DAC ARG2
LAC SYMTB0
XOR T00000
DAC* ARG2 /THE FUNCTION SUBPROGRAM EXIT CONSISTS
JMS SETA2 /OF A LOAD COMMAND WITH THE FUNCTION NAME
JMS EXP590 /AS THE ARGUMENT.
TAD C00004 /THIS IS FOLLOWED BY A BRANCH RETURN TO
END02 LAC JMPICM /THE CALLING PROGRAM (INDIRECT VIA ENTRY).
JMS RELBIN
JMP ENDSP1
END04 LAC CLACMD /GENERATE A "STOP 0" AT THE END
JMS ABSBIN /OF A MAIN PROGRAM
LAC STMNE /TO PREVENT USERS FROM KILLING THEMSELVES
JMS EXP580 /BY STUPIDITY
XOR JMPCMD
LAC PC
DAC START /SET THE STARTING ADDRESS HERE FOR A MAIN PROGRAM
.IFDEF %FPP
LAC T31422 /OUTPUT A CALL TO .ZB
JMS EXP580
XOR JMSCMD
.ENDC
LAC FNCMNE+1 /IS OUTPUT IF THIS
JMS EXP580 /IS A MAIN-BODY
XOR JMSCMD /PROGRAM CONTAINING I-O STATEMENTS
LAC JMPCMD /A JUMP IS NOW OUTPUT TO THE BEGINNING
JMS RELBIN /OF THE PROGRAM (RELOCATABLE LOCATION 0)
ENDSP1 JMS CLENUP /ASSIGN VARIABLE STORAGE NOW
LAC CONTB0
DAC TCTR
END09 SAD CONTBN
JMP END13
LAC* TCTR /DECLARED AND CREATED CONSTANTS ARE
AND Z60000 /ASSIGNED MEMORY LOCATIONS IMMEDIATELY
XOR PC /FOLLOWING THE PROGRAM BODY.
DAC* TCTR
RAL /CHECK FOR THE SPECIAL CONSTANT
SPA!RAR /GENERATED BY THE @N CONSTRUCTION
JMP RELCON /AND OUTPUT THEM AS RELOCATABLE CONSTANTS
JMS SETN /THE CONSTANTS ARE OUTPUT AS THEY ARE
JMS TWOCMA /ASSIGNED.
DAC TEMP0
END10 JMS CNSE50
LAC* TCTR
JMS FPPOUT
ISZ TEMP0
JMP END10
END11 JMS CNSE50
JMP END09
RELCON JMS CNSE50
LAC* TCTR /LOW ORDER WORD IS ADDRESS
DAC SYMTBC /OF SYMBOL TABLE ENTRY FOR STATEMENT NUMBER
LAC* SYMTBC /FROM THAT ENTRY WE GET THE ADDRESS
AND S17777
JMS VECBIN
JMP END11
END13 LAC DOTABA
ERS 04L,<SAD .FFREE>,EL /ERROR: BACKWARD DO LOOP
JMP PASS
ENDBLK XCT PASS
SKP
JMS CLENUP /CLEAN UP ON PASS 1 ONLY
PASS SKP
JMP END12 / END OF COMPILATION
/
/ PASS 2 INITIALIZATION
/
LAC PASS2 /INITIALIZE...
DAC PASS / PASS FLAG
.IFUND RSX
CAL+767
6
.ENDC
.IFDEF RSX
LAC (DAT11) /CLOSE THE INPUT FILE AT END OF PASS1
JMS CLOSEL
.ENDC
JMS SUB990
.DSA 400000+MESSY4-2
EPS1SW XX /DON'T WAIT FOR ^P.
.IFUND RSX
.DSA 100000+MESSY3-2
Z77000 777000
DAC CTLPSW
JMP . /WAIT FOR ^P
.ENDC
.IFDEF RSX
CNTPLP CAL WRCP /WRITE ^P ON TTY
CAL WFEVA /WAIT FOR EVENT VARIABLE
CAL REACP /READ A LINE
CAL WFEVA /WAIT FOR EVENT VARIABLE
LAC EVA /PICK UP THE EVENT VARIABLE
SPA
JMP EXITF /BAD EVENT VARIABLE EXIT
LAC SINBFH+2 /PICK UP THE FIRST WORD
AND (774000) /MASK OFF THE FIRST CHARACTER
SAD (100000) /IS IT ^P?
JMP INIT01 /YES RESTART
SAD (104000) /IS IT ^Q?
JMP EXITF /YES EXIT
JMP CNTPLP /NEITHER TRY AGAIN
/
WRCP 2700 /WRITE ^P
EVA /EVENT VARIABLE ADDRESS
DAT3 /LUN
2 /DATA MODE
MESSY3-2 /LINE BUFFER ADDRESS
/
REACP 2600 /READ FROM TTY
EVA /EVENT VARIABLE ADDRESS
DAT2 /LUN
2 /MODE
SINBFH /BUFFER ADDRESS
5 /MAX WORD COUNT
/
.ENDC
.EJECT
/ END OF COMPILATION
/
END12=.
LAC PASS2
DAC BINO06
LAC SYMTB0
END23 DAC SYMTBC
JMS OBJ500 /INITIALIZE SYMBOL TABLE OUTPUT LINE
LAC SYMTBC /*** END23+1 IS REFERENCED IN INIT01 ***
SAD SYMTBN
JMP END22
JMS SETADR
JMS SIN530
JMS OSYMBL /EACH SYMBOL IS OUTPUT AS AN INTERNAL
LAC* SYMTBC /SYMBOL FOR DDT. THE USER MUST MAINTAIN
AND S17777 /SOME DISCRETION WHEN IT COMES TO THE USE
SAD S17777 /OF SYMBOLS WHICH THE COMPILER DOES NOT
SKP /DEFINE (BECAUSE THEY ARE NOT REFERENCED)
JMS BINOUT
XOR C00019
LAW -1
SAD* SYMTBC
JMP .+5
JMS SYMTYP /THE SYMBOL TABLE IS PRINTED WITH FOUR
XOR U00000 /SYMBOLS AND THEIR DEFINITIONS PER LINE.
LAC K00010
TAD K00006 /COMMON SECTIONS ARE INDICATED BY A SLASH,
TAD C00048 /EXTERNAL NAMES AND STATEMENT FUNCTIONS
JMS OBJ510 /BY AN ASTERISK BEFORE
JMS OBJ630 /THE SYMBOL AND ITS DEFINITION.
JMS OBJ550
JMS OBJ630
LAC* SYMTBC
AND Z00000
SAD Y00000
JMP END50
LAC* SYMTBC
SPA
LAC* SYMTW7
SKP
END50 LAC* SYMTBC
JMS OBJ640 /FORMAT SYMBOL DEFINITION.
JMS OBJ630 /FORMAT A SPACE
SYMMAP SKP
JMS OBJ520 /OUTPUT SYMBOL BUFFER
JMS SBSE50
JMP END23
END22 LAC START
JMS BINOUT /OUTPUT END CODE WITH STARTING ADDRESS OF
XOR C00023 /PROGRAM UNIT AS THE DATA WORD
.IFUND %NOEOC /(RKB-069) DO WE WANT END OF COMP. MSGS?
LAC ERRCNT /(RKB-067) READY FOR SIZE AND ERRS MSG
SZA /(RKB-067) HAVE ANY ERRORS OCCURRED?
JMP END24 /(RKB-067) YES
LAC (PGMSIZ) /(RKB-067) NO, JUST TO 'SIZE =' PART
DAC SINBUF /(RKB-067)
LAW -5 /(RKB-067) CONVERT 5 CHARS
DAC CHRCNT /(RKB-067)
LAC PC /(RKB-067) CONVERT PC TO ASCII
JMS OBJ540 /(RKB-067) CONVERT ROUTINE
LAW -5 /(RKB-067)**ARG TO OBJ540
JMS SUB990 /(RKB-067) TYPE IT
.DSA SIZMSG+400000 /(RKB-067) SUPRESS IF IN BOSS
LAC .-1 /(RKB-067) AND FORWARD MSG TO PRINTER
JMP END25 /(RKB-067) GO
END24 LAC (ERRMSG+2) /(RKB-067) DO ERROR COUNT MSG
JMS SUB980 /(RKB-067) CONVERT ERROR COUNT TO DECIMAL
LAC ERRCNT /(RKB-067) **ARG TO SUB980
JMS SUB990 /(RKB-067) OK, TYPE IT
.DSA ERRMSG+400000 /(RKB-067) SUPRESS IF BOSS
LAC .-1 /(RKB-067) GET MSG ADDR FOR PRINTING
END25 AND S77777 /(RKB-067) STUFF RIGHT MSG ADDR IN PRINT CALL
DAC END26 /(RKB-067) WITHOUT SUPPRESS BIT
.IFUND RSX /(RKB-067)
LAC S02766 /(RKB-267) SET OUTPUT TO .DAT -12
.ENDC /(RKB-067)
.IFDEF RSX /(RKB-067)
LAC (DAT12) /(RKB-067) SET OUTPUT TO LUN16
.ENDC /(RKB-067)
XCT LIST /(RKB-067) SKIP IF LISTING DEVICE IS NOT TTY.
JMP F4K /(RKB-067)
DAC S990CL /(RKB-067) STUFF UNIT IN I/O.
JMS SUB990 /(RKB-067) PRINT IT
END26 .DSA .-. /(RKB-067)
.ENDC /(RKB-069)
F4K XX
JMP .+3
JMS SUB990
.DSA MESSY2-2
.IFUND RSX
.WAIT -3
/ .CLOSE -11 /NOW IS THE TIME TO CLOSE ALL FILES
CAL 00767
.DSA 000006
/ .CLOSE -12
XCT LIST
JMP .+3
CAL 00766
.DSA 000006
/ .CL0SE -13
LAC OBINRY /WAS BINARY
SMA /OPENED?
JMP NJOPND /NO
XCT OBINRY /DID WE GET AN ERROR?
JMP COMPER /YES
CAL 00765 /NO-CLOSE FILE
6
JMP NJOPND
COMPER CAL 765 /ERROR-KILL FILE
1
INIT02
0
.ENDC
.IFDEF RSX
EXITF LAC (DAT11) /CLOSE INPUT LUN
JMS CLOSEL
XCT LIST /DON'T CLOSE THE LISTING LUN IF NO LISTING WAS PRINTED
JMP .+3
LAC (DAT12)
JMS CLOSEL /CLOSE LISTING OUTPUT DEVICE
LAC OBINRY /CHECK IF A BINARY FILE WAS OPEN
SMA
JMP EXITR /NO - DON'T CLOSE AT ALL
LAC (DAT13) /YES - GET BINARY FILE LUN
XCT OBINRY /WERE THERE COMPILATION ERRORS?
CMA /YES
JMS CLOSEL /NO
XCT DELETE /SKIP TO DELETE BAD BINARY WHEN NO ORIGINAL
JMP .+3 /BINARY
XCT OBINRY /SKP IF NO ERRORS, AVOID DELETE
JMS DELBIN
/
EXITR LAC (DAT11) /DETACH FROM INPUT LUN
JMS DETACH
LAC (DAT12) /DETACH FROM LISTING LUN
JMS DETACH
LAC (DAT13) /DETACH FROM BINARY FILE
JMS DETACH
LAC TITLEA /CHECK THE LAST CHARACTER
SAD S00054 /IS IT A ,?
JMP INIT02 /YES RESTART
SAD C00013 /IS IT A CARRTN?
CAL REQTDV /YES REQUEST TDV
.ENDC
.IFUND RSX
NJOPND LAC TITLEA
SAD C00013
JMP INIT02 /ALLOW BATCH PROCESSING OF SOURCE PROGRAMS.
.ENDC
.IFUND RSX
/ .EXIT
END999 CAL 0
C00013 .DSA 000015
.ENDC
.IFDEF RSX
CAL C00008 /EXIT TASK
.ENDC
PFILE1 .DSA FILE1
/
.EOT