.TITLE	WATRAN
/
/   5 AUG 74 (JAS) CATCH CONTINUATION LINES WITH GARBAGE IN COL'S 1-5
/   7 JUN 74 (JAF, JAS) CONTINUE BLOCK DATA IMPLEMENTATION; REMOVE '.EBREL'
/   6 MAR 74 (PDH) IMPLEMENT LOGICAL, COMPLEX,CHARACTER FUNCTIONS
/   1 MAR 74 (MKH, JAF, JAS) MORE HOLLERITH FIXES;CONTINUATION ERROR FIX
/  22 FEB 74 (MKH,JAF,JAS) ..*NH.. , FIX WARNING RETURN
/   8 FEB 74 (PDH,JAF) BEGIN BLOCK DATA IMPLEMENTATION AND ADD
/			ARITHMETIC STATEMENT FUNCTIONS
/  17 SEP 73 (PDH) CHANGE DEVICE NUMBER REFERENCES TO SYMBOLIC
/  11 SEP 73 (PDH) ANNOUNCE ERROR COUNT ON TTY; TEST FOR PDP-15
/   7 SEP 73 (PDH) 'ASSIGN','LOGICAL FUNCTION','COMPLEX FUNCTION': ERRST5
/		   TURN OFF BINARY IF ERRORS; MOVE 'HOOK'
/  31 AUG 73 (JAS&PDH) FIX HANG UP WITH SOME NUMERIC SOURCE FILE NAMES
/   1 AUG 73 (JAS) MAKE SYMBOL TABLE COME OUT IN CORRECT SEQUENCE
/  30 JUL 73 (PDH) CORRECT CHANGED ERROR HANDLING STRATEGY
/  27 JUL 73 (JAS) CHANGE ERROR ANNOUNCING STRATEGY
/   3 JUL 73 (PDH) $TRACEON & $TRACEOFF
/  22 JUN 73 (PDH) .GLOBL ERRCP2
/
/  NOTE:  THE STARTING ADDRESS OF WATRAN IS '.START' (AAAAA%=.START)
/
	.IODEV	TTI,TTO,DKI,LP,DKO
/
/ IN WATRAN
/   ADDRESSES:
	.GLOBL BOX,CHI,CHIEND,ERRORS,ERRCP2,LIST,LIST1,NXTSPC,RETRN
	.GLOBL	BASE0,BASE,BASE2,BASE3,MODES,D,D1,JOINCK,.START
	.GLOBL	%ERCNT,AAAAA%
/   SUBROUTINES:
	.GLOBL	SETPT2,HIERAR,STLINE,INSERT,PROCES,ERROR,WARN
	.GLOBL	CMPARE,TESOUT,HOOK
/   SWITCHES:
	.GLOBL	EQSWT,EQSWL,MODESW,STATSW,EQUVSW
	.GLOBL	BLOWN,%ISSUE,BINSW,TRACSW,LST
/
/ IN IDENT -
/   ADDRESSES:
	.GLOBL	BASE1,DTSTAT,DTSTOR,IFSTAT,ERSW,OVERS
	.GLOBL	SYMPRT,EXITSW,KIND,FORMBX
	.GLOBL	ARITH,ASSGN,CALLS,CHARAC,.CONT,COMMN,COMPLX
	.GLOBL	DATA,DBCPLX,DBLINT,DBLREL,DIMEN,DO,END,EQUIV
	.GLOBL	EXTRNL,FORMAT,FUNCT,.GOTO,IFBRAC
	.GLOBL	INTGR,LOGIC,.PAUSE,PRINT.,PUNCH.,READBR,READ.
	.GLOBL	REAL,RETR,STOP,SUBR,TRACON,TRACOFF,WRITEB
	.GLOBL	LOGICF,INTF,DINTF,REALF,DREALF,CMPLXF,CHARF
	.GLOBL	ENDFIL,BLDATA
/   SUBROUTINES:
	.GLOBL	SHOVE,PULL,CLENUP,EQUCLN,WDSIZE,ARYSIZ,ENDDO,REPACK
/   SWITCHES:
	.GLOBL	CMNSWH,ENDSW,TYPESW,IFSW,IFSTOR,DIMCNT
/
/ IN SEARCH -
/   ADDRESSES:
	.GLOBL FLTFLG,IMPLCT,IMPLC,IMPLIC,INDEX,IND
	.GLOBL VANTED,VANT1
/
/ IN CALCP
/    ADDRESSES:
	.GLOBL DTNEXT,OTNEXT,TBPOSN,OPLACE
	.GLOBL DTABLE,OTABLE,PTABLE,PTEND,PSIZE
/   SUBROUTINES:
	.GLOBL CALCP,GETOTB
/
/ IN GEARS -
/   SUBROUTINES:
	.GLOBL G.MOVE,G.CMPR,G.INIT,G.STSF,G.STUF,G.STPK
	.GLOBL G.UNPK,NUMS,G.CVRT,G.SCAN
	.GLOBL G.STPC,G.PACK
/
/ IN BIN1 -
/   ADDRESSES:
	.GLOBL BINAME,BINAM1,LOCCNT
/   SUBROUTINES:
	.GLOBL	ITEM4,ITEMIN,NAMEIT,OPENER,OPENPG,PROGPT
/
/ IN APPEND -
/   ADDRESSES:
	.GLOBL	START,PNAME,PNAM1,PNAM2,MNAME
/
/ IN EXPRES -
/   ADDRESSES:
	.GLOBL	ARGCHN,ARGCNT,ASFNUM,ASFOFF
/   SUBROUTINES:
	.GLOBL	CLRACC,CLRSUB
/
/SET UP VARIABLE NUMBER OF INPUT BUFFER AREAS ACCORDING TO
/ THE VALUE OF 'NUMB' AND INITIALIZE .
NUMB=6
BUFFER	.BLOCK 50
	.BLOCK 50
	.BLOCK 50
	.BLOCK 50
	.BLOCK 50
	.BLOCK 50
/
/ THE FOLLOWING IS A MACRO FOR GENERATING CODING TO
/ SET UP THE ADDRESSING OF THE ROTARY INPUT/OUTPUT BUFFERS
	.DEFIN SETUP1,ADRESS,SIZE
	LAC	(ADRESS!600000	/ SIGNIFY BUFFERS AS FREE
	DAC	TRAPTR
	DAC	REDPTR
	DAC	POINTR
	DAC	TEMP
SET1	TAD	(SIZE
	DAC*	TEMP	/ INSERT ADDRESS OF NEXT FILE
	DAC	TEMP	/ RESET POINTER TO NEXT FILE
	SAD	(NUMB-1*SIZE+ADRESS!600000
	SKP
	JMP	SET1
	LAC	(ADRESS!600000	/ GET START ADDRESS
	DAC*	TEMP	/ LAST BUFFER POINTS TO FIRST
	TAD	(1	/ SET UP POINTERS FOR ERROR SECTION
	DAC	THERE
	TAD	(3
	DAC	HDR
	.ENDM
/
/
/
/
/ THIS SUBROUTINE SLOUFFS OFF INPUT LINES ,BY MARKING THEM AS  
/ HAVING BEEN PROCESSED AND RESETS THE PROPER POINTERS.
SETPT1	XX
	LAC*	TRAPTR
	XOR	(200000	/ ALLOW PRINTING, (2 XOR 1 = 3)
	DAC*	TRAPTR
	DAC	TRAPTR	/ RESET TO TRANSFER NEXT FILE
	TAD	(1
	DAC	THERE	/ FOR ERROR ROUTINES
	LAC*	TRAPTR
	DAC	REF	/ RETURN FROM ERROR BUFFERS TO NEXT BUFFER YET
	JMP*	SETPT1
/
/ THIS SUBROUTINE RELEASES THE INPUT LINES AFTER PROCESSING AND
/ RESETS THE ERROR & PROCESSING POINTERS.
SETPT2	XX
	LAC*	PROPTR	/ LINE IS FINISHED PROCESSING
	XOR	(200000	/ (2 XOR 1 = 3)
	DAC*	PROPTR
	LAC	TRAPTR
	TAD	(1
	DAC	THERE
	LAC*	TRAPTR
	DAC	REF
	JMP*	SETPT2
/
/
/ THIS SUBROUTINE LOOKS AFTER STATEMENT ORDER AND STATEMENT NUMBERS
/  IF PREVIOUS STATEMENT HAS A NUMBER WHICH IS A 'DO' LOOP
/  TERMINATOR THEN IT CLEANS UP THE END OF THE 'DO' LOOP.
/  IF THIS STATEMENT HAS A NUMBER IT CONVERTS IT TO OCTAL
/ AND ENTERS IT IN THE SYMBOL TABLE.
/  ENTRY IS - HIERARCHY ORDER # ! STATEMENT # CODE
HIERAR	XX
	XOR	(LAW
	DAC	BOXIT
	AND	(7000
	DAC	NEWNUM
	CMA
	TAD	OLDNUM
	SPA		/ IS NEW # > OR = OLD #
	JMP	TESTIF	/ YES, ORDER IS OKAY
ERRSP4	JMS	ERRORS
	.SIXBT	'SP4'
/
/ TEST FOR THE FORM 'IF(...) STATEMENT' & CHECK IF STATEMENT 
/ IS LEGAL.
TESTIF	JMS	TESTIN	/ PROD INPUT
	JMS	TESOUT	/ PROD OUTPUT
	LAC*	IFSW
	SMA
	JMP	ORDOKY	/ NOT IN AN IF STATEMENT
	LAC	BOXIT	/ GET BITS BACK
	AND	(ILGIF
	SNA
	JMP	ORDOKY	/ STATEMENT AFTER 'IF' IS LEGAL
ERRIF0	JMS	ERRORS	/ STATEMENT INVALID AFTER LOGICAL 'IF' STATEMENT
	.SIXBT	'IF0'
ERRBD2	JMS	ERRORS		/ ILLEGAL STATEMENT IN BLOCK DATA
	.SIXBT	'BD2'
/
/
ORDOKY	LAC	OLDNUM	/ GET OLD NUMBER
	SAD	(H5
	JMP	STATE2	/ IF OLD # = H5 , NEW # MUST = H5
	SAD	(H4
	JMP	WASEQU	/ LAST STATEMENT WAS EQUIVALENCE
	SAD	(H3
	JMP	WASSPC	/ LAST STATEMENT WAS SPECIFICATION
	SAD	(H2
	JMP	WASSUB	/ LAST STATEMENT WAS IMPLICIT
	SAD	(H1
	JMP	WASSUB	/ LAST STATEMENT WAS SUBROUTINE OR FUNCTION
/
/ OLD NUMBER = H0, THUS WE ARE AT START OF PROGRAM
	LAC	NEWNUM	/ GET NEW NUMBER
	SAD	(H1
	JMP	ITSSUB	/ SUBROUTINE OR FUNCTION OR BLOCK DATA
/ MUST BE A MAINLINE PROGRAM, THUS FILE NAME BECOMES THE PROGRAM NAME
/ CHECK IF WE ALREADY HAD A MAINLINE PROGRAM
	LAC*	ENDSW
	SNA		/ IF ENDSW IS SET THEN WE HAD A PROGRAM ALREADY
	JMP	FMAIN	/ / OKAY, 1ST PROGRAM
ERRSR0	JMS	ERROR	/ ERROR - MISSING SUBROUTINE STATEMENT
	.SIXBT	'SR0'
	JMP	CARYON	/ GO PROCESS REST OF PROGRAM
/ THIS IS A MAINLINE PROGRAM , FOR SURE NOW
FMAIN	LAC	(MAINK
	DAC*	KIND	/ MARK AS A MAINLINE PROGRAM
	DZM*	BINAM1	/ ZERO EXTENSION IN CASE OF <3 CHARS
	LAC	BINAME
	JMS*	G.STSF	/ SET UP FOR PACKING BUFFER
	LAC	(DUMB
	DAC	CHANSW	/ SHORT CIRCUIT INTERNAL CODE CONVERTER
	LAC*	(.SCOM+2	/ WORK AREA ADDRESS
	DAC*	(AUTO11	/ SET TO EXTRACT SIXBIT CODE
	SKP
DUMB	JMS*	G.STUF	/ INSERT IN BUFFER
	LAC*	AUTO11
	SAD	(ENDST	/ IS IT END OF NAME
	SKP		/ YES, SKIP
	JMP	PILED	/ NO. GO CONVERT CHAR TO INTERNAL CODE
/
	LAC	(SCAN
	DAC	CHANSW	/ REMOVE SHORT CIRCUIT
	JMP	CARYON
/ SUBROUTINE OR FUNCTION NAME BECOMES PROGRAM NAME
/ IF THIS SUBROUTINE WAS NOT PRECEDED BY A MAINLINE
ITSSUB	LAC	PNAME	/ TRANSFER NAME FOR GLOBLING ANYWAY
	JMS*	G.STPC	/ AND PUT ASCII SUBROUTINE NAME IN PNAME
	LAC*	VANTED
	DAC*	BINAME
	JMS	BREAK	/ CONVERT 3 CHARS TO ASCII
	LAC*	VANT1
	DAC*	BINAM1
	JMS	BREAK	/ CONVERT 2ND 3 CHARS TO ASCII
CARYON	JMS*	OPENPG	/ PUNCH OUT NEW PROGRAM INFO
	DZM*	ENDSW	/ RESET FOR THIS PROGRAM
	LAC	NEWNUM	/ CHECK FOR HO TO H5 TRANSITION
	JMP	CHKJN
/
/ PREVIOUS STATEMENT WAS AN IMPLICIT STATEMENT OR
/ PREVIOUS STATEMENT WAS A SUBROUTINE OR FUNCTION STATEMENT
WASSUB	LAC	NEWNUM	/ GET NEW NUMBER
	SAD	(H1	/ IS NEW NUMBER H1
	JMP	ERRSP4	/ ERROR. TWO SUBROUTINE STATEMENTS
CHKJN	SAD	(H5	/ IS IT  A H1 TO H5 TRANSITION
	JMP	FINASS	/ YES. DO CLEAN UP
	JMP	STATE	/ NO. GO PROCESS STATEMENT NUMBER
/
/ PREVIOUS STATEMENT WAS A SPECIFICATION STATEMENT
WASSPC	LAC	NEWNUM	/ GET NEW NUMBER
	SAD	(H3	/ IS THIS A SPEC STATEMENT ALSO?
	JMP	STATE2	/ YES.
	SAD	(H4
	JMP	ITSH4
	JMS*	CLENUP	/ TRANSITION H3 TO H5, COMMON CLENUP
	JMP	FINASS	/ GO ASSIGN ADDRESSES
ITSH4	JMS*	CLENUP	/ TRANSTION H3 TO H4, COMMON CLEANUP
	JMP	STATE
/
/ PREVIOUS STATEMENT WAS AN EQUIVALENCE STATEMENT
WASEQU	LAC	NEWNUM	/ GET NEW NUMBER
	SAD	(H4
	JMP	STATE2	/ ANOTHER EQUIVALENCE, CONTINUE
FINASS	JMS*	EQUCLN	/ GO PROCESS NEST TABLE & ASSIGN ADDRESSES
/
/ THIS SECTION TESTS FOR LACK OF A STATEMENT NUMBER FOR THOSE
/  STATEMENTS WHICH MUST HAVE THEM.
STATE	LAC	NEWNUM
	DAC	OLDNUM
/
/  CHECK IF IN BLOCK DATA & IF STATEMENT IS LEGAL
/
STATE2	LAC	BOXIT
	AND	(BDLEGL
	SZA
	JMP	BDSET		/ STATEMENT OK
	LAC*	KIND		/ STATEMENT NOT LEGAL IN BLOCK DATA.
	SAD	(BLOCKD		/ ARE WE IN IT?
	JMP	ERRBD2
BDSET	LAC*	IFSW	/ IF IFSW IS SET THEN WE ARE PROCESSING
	SPA		/ THE CONDITIONAL STATEMENT.DON'T UNWIND DO
	JMP*	HIERAR	/ LOOPS NOW IF IF STATEMENT ENDED A DO.
	LAC	DOTERM	/ DID PREVIOUS STATEMENT TERMINATE A 'DO' LOOP
	SZA		/ IF SO, IT CONTAINS THE DO COUNT
	JMS*	ENDDO	/ GO CLEAN UP AFTER A 'DO' LOOP
/
	LAC*	LOCCNT
	DAC	SAVIT	/ SAVE ADDRESS OF START OF STATEMENT
/ IF THE ERROR CODES ARE DESIRED, THEN MUST PUNCH OUT FOR EXECUTABLE
/ STATEMENTS ONLY
	LAC	BOXIT	/ YES.
	AND	(.EXC
	SNA		/ IS STATEMENT EXECUTABLE
	JMP	NOTRCE	/NO. NO TRACE ON THIS LINE ANYWAY
/ THE STATEMENT IS EXECUTABLE
	DZM*	DTSTOR	/ MARK A EXEC. STAT HAS OCCURRED SINCE LAST INTERNAL
/ CHECK IF ERROR CODES ARE REQUIRED
	LAC	TRACSW
	SZA
	JMP	NOTRCE
/ PUNCH OUT STATEMENT OPCODE
	LAC	(STCNT*M
	XOR	LINE	/ ADD LINE COUNT
	JMS*	ITEM4
/ CARRY ON WITH THE WORK
NOTRCE	DZM	DOTERM	/ RESET DO INDICATOR
	ISZ	STATNM	/ DOES THIS STATEMENT HAVE A STATEMENT NUMBER
	JMP	NONUMB	/ NO
	DZM	COUNT
	LAC	NOSAVE	/ GET 1ST HALF OF STATEMENT #.
	LRS	13	/ GET CONTENTS OF 1ST COLUMN
	JMS	GRIND	/ PROCESS IT
	LAC	NOSAVE
	LRS	4	/ GET CONTENTS OF 2ND COLUMN
	JMS	GRIND	/ PROCESS IT
	LAC	NOSAVE+1
	LMQ
	LAC	NOSAVE
	LLS	3	/ GET CONTENTS OF 3RD COLUMN
	JMS	GRIND	/ PROCESS IT
	LAC	NOSAVE+1
	LRS	10	/ GET CONTENTS OF 4TH COLUMN
	JMS	GRIND	/ PROCESS IT
	LAC	NOSAVE+1
	RAR		/ GET CONTENTS OF 5TH COLUMN
	JMS	GRIND	/ PROCESS IT
	LAC	COUNT	/ GET BINARY #
	DAC*	VANTED	/ STORE IN VANTED
	DZM*	VANT1	/ ZERO 2ND WORD
	LAC	(STNUM	/ SIGNIFIES WE ARE PASSING STATEMENT #
	JMS*	CALCP	/ INSERT IN SYMBOL TABLE
/
/
/  CHECK IF WE HAVE TWO STATEMENT NUMBERS THE SAME.
	LAC*	TBPOSN
	DAC	COUNT
	TAD	(2
	DAC	TEMP	/ POINTS AT DO COUNT IF IT EXISTS
	LAC*	COUNT	/ GET CONTROL BITS FROM TABLE
	AND	(NON.EX!.EXC!FORM
	SZA
	JMP	ERRST3	/ ERROR - TWO STATEMENT NUMBERS THE SAME
	LAC*	COUNT
	AND	(DO.S
	SNA!CLA		/ DOES STATEMENT NUMBER TERMINATE A 'DO' LOOP
	JMP	NOTDOO	/ NO
	LAW	-1	/ YES. SET UP DO COUNT
	TAD*	TEMP
	CMA
NOTDOO	DAC	DOTERM	/ IS EITHER 0 OR NEG DO COUNT
	LAC	BOXIT	/ GET NEW CONTROL BITS
	AND	(77
	JMS*	SHOVE	/ INSERT IN DTABLE
	AND	(.EXC
	SZA
	DZM	STATSW
	LAC*	OPLACE
	DAC	TEMP	/ POINTS TO OTABLE
	DAC*	FORMBX	/ STORE FOR POSSIBLE FORMAT USE
	LAC	SAVIT	/ GET LOCATION COUNTER
	DAC*	TEMP	/ INSERT LOCATION COUNTER IN OTABLE
	JMP*	HIERAR
SAVIT	0
/
/ THE FOLLOWING CONVERTS THE ASCII NUMBERS TO A BINARY COUNT
GRIND	XX
	AND	(000177
	SAD	(040	/ IS IT BLANK ?
	JMP*	GRIND	/ YES. THUS IGNORE IT & GET NEXT CHAR.
	TAD	(-71	/ ADD MINUS ASCII NINE
	SMA!SZA		/ IS IT .LE. NINE ?
	JMP	ERRST1	/ NO. THEN ERROR ,NON NUMERIC
	TAD	(11
	SPA		/ IS IT .GE. ZERO
	JMP	ERRST1	/ NO. NON NUMERIC
	DAC	TEMP1	/ STORE IT
	CLL
	LAC	COUNT
	MUL
	.DSA	12
	LACQ
	TAD	TEMP1
	DAC	COUNT
	JMP*	GRIND
/
ERRST1	JMS	ERROR	/ NON-NUMERIC CHAR IN STATEMENT # FIELD
	.SIXBT	'ST1'
	JMP*	HIERAR
ERRST3	JMS	ERROR	/ MULTIPLY DEFINED STATEMENT NUMBERS
	.SIXBT	'ST3'
	JMP*	HIERAR	/ GO PROCESS THE REST OF THE STATEMENT
/
/ THIS SUBROUTINE TAKES 3 INTERNAL CODE CHARACTERS FROM THE
/ AC AND BREAKS THEM UP AND CONVERTS TO ASCII CODE FOR PACKING
/ BY G.PACK
BREAK	XX
	DAC	TEMP	/ STORE CHARACTERS
	LRS	14
	JMS	CCHK	/ CHECK FOR BLANKS ON NAMES LESS THAN 6 CHARACTERS
	LAC	TEMP
	LRS	6
	JMS	CCHK
	LAC	TEMP
	JMS	CCHK
	JMP*	BREAK
/
/ THIS SUBROUTINE CHECKS FOR BLANKS(NULLS) AFTER SHORT SUBROUTINE NAMES
CCHK	XX
	AND	(77
	SNA		/ IS CHAR NULL
	LAC	(SPACE	/ YES. INSERT SPACE
	JMS*	REPACK	/ GO CONVERT AND PACK IT
	JMP*	CCHK
/
/
/ STATEMENT DOESN'T HAVE A STATEMENT NUMBER, CHECK IF IT SHOULD
NONUMB	LAC	STATSW	/ NO !!!!!
	SNA		/ WAS PREVIOUS STAT A TRANSFER STAT
	JMP	NOERRS
WRNST4	JMS	WARN	/ SHOULD HAVE A STATEMENT NUMBER
	.SIXBT	'ST4'
	DZM	STATSW	/ CANCEL STATSW, SO ERROR IS ISSUED ONLY ONCE
NOERRS	LAC	BOXIT
	AND	(77
	SAD	(FORM	/ IS IT A FORMAT STATEMENT
	SKP
	JMP*	HIERAR	/ NO
ERRFM2	JMS	ERROR	/ YES. SHOULD'VE HAD A STATEMENT NUMBER
	.SIXBT	'FM2'
	JMP*	HIERAR
/
/ DEVICE WAS NOT FILE ORIENTED, PRINT MESSAGE AND RETURN
DEVERR	.WRITE	TTO,2,MESERR,34
	.CLOSE	TTO
	.EXIT
/ ERROR MESSAGE
MESERR	7002; 0; .ASCII '.DAT -13 NOT FILE-ORIENTED'<15>
	.LOC	.-1	/PRECEEDING MESSAGE ONLY 27 CHARACTERS
/
/
/ INITIALIZE AT THE START OF A JOB
LINEC		/ LINE COUNT FOR LISTING NUMBERS
LINE		/ LINE COUNT FOR EXECUTION LINE ERRORS
/
/ STORAGE LOCATIONS TO BE INITIALIZED AT START OF JOB.
LINE1		/ LINE COUNT BETWEEN STATEMENT NUMBERS
DOTERM		/ IF .NE.0, LAST STAT. ENDED DO LOOP,CONTAINS DO COUNT
STATSW
STATNM
OLDNUM
NEWNUM
BINSW		/ INDICATES IF A BINARY MODULE IS TO BE PRODUCED
TRACSW		/ INDICATES IF A TRACE IS REQUIRED, RESET AT START OF FILE
LST	.DSA	064000	/IF LISTING REQ'D-064000, ELSE 000000 .
NOSAVE	.ASCII '00000'	/ STATEMENT # = 00000 AT START OF PROGRAM
SSET	.ASCII '00000'	/ TO RESET NOSAVE FOR MULTIPLE COMPILES
/
/ THE FOLLOWING ARE THE SYMBOL TABLE SIZES WHICH MAY READILY BE ALTERED
PTSIZE	.DSA	0	/ SIZE OF PTABLE CHANGED ACCORDING TO CORE SIZE
CHISZE	.DSA	0	/ SIZE OF CHI TABLE CHANGED ACCORDING TO CORE SIZE
WKAREA	.DSA	50	/ SIZE OF WORK AREA BELOW CHI
BASE0			/ LOWEST FREE ADDRESS (.SCOM+2)
BASE			/ MARKS START OF GENERAL WORK AREA
/BASE1			/IN IDENT, ADDRESS OF START OF DATA STORAGE
BASE2			/ MARKS END OF DATA, START OF DO TABLES
BASE3			/ MARKS END OF DO TABLES, START OF WORK AREA
/
/
/
MONITR	4002; 0; .ASCII 'WATRAN V1A'<15>
STRING	2002
%ERCNT;	.ASCII	'>'<175>
	.LOC	.-1
/
.START	.INIT	DKI,0,.START
AAAAA%=.START		/FUDGE IN CASE WE HAVE TO LOAD FROM A LIBRARY.
/
/ CALCULATE THE SIZE OF THE SYMBOL TABLES
	LAC*	(.SCOM+3
	CMA!STL
	TAD*	(.SCOM+2	/ GIVES SIZE OF FREE CORE (SETS LINK)
	LRS	3	/ DIVIDE BY 8
	TAD	(-144	/ A FUDGE FOR 16K VERSIONS TO MAKE IT REASONABLE
	DAC	PTSIZE
	CMA
	RCR
	DAC	CHISZE	/ SIZE OF CHI TABLE
/
/ THE FOLLOWING SECTION HANDLES THE INTERPRETION OF
/ THE CONTROL STRING FROM .DAT -2
ORDERS	LAC	(201011	/ ASCII '  I' IN CASE OF NO LISTING
	DAC	ERRSTA+10	/ REMOVE CARRIAGE RETURN
	DZM	LST
	DZM	D
	DZM	D1
	DZM	BINSW	/ RESET BINARY SWITCH
	DZM	TRACSW	/ RESET ERROR CODE INDICATER
	DZM	%ISSUE		/CLEAR 'WE HAVE ISSUED AN ERROR' SWITCH
	DZM	%ERCNT		/ZERO ERROR/WARNING COUNTER
	DZM*	SYMPRT	/ RESET SYMBOL TABLE REQUEST
/   WRITE OUT 'WATRAN V1A'
	.INIT	TTO,1,.START
	.WRITE	TTO,2,MONITR,4
	.WRITE	TTO,2,STRING,0
/   READ COMMAND STRING INTO BUFFER
/
	.READ	TTI,2,BUFFER+4,34
	.WAIT	TTI
/
	LAC	(BUFFER+4+2-1	/ INITIALIZE 5/7 ASCII
	JMS*	G.STPK	/ PACKING ROUTINE
	LAC	(D	/ INITIALIZE 6-BIT
	JMS*	G.STSF	/ PACKING ROUTINE G.STUF
/
NXTCHR	JMS*	G.UNPK	/ UNPACK A CHARACTER
	AND	(77
TRYLET	SAD	ELL	/ IS IT 'L',FOR LISTING
	JMP	ITSL	/ YES
	SAD	BEE	/ IS IT 'B', FOR BINARY
	JMP	ITSB	/ YES
	SAD	ESS	/ IS IT 'S', FOR SYMBOL TABLE
	JMP	ITSS	/ YES
	SAD	ENN	/ IS IT 'N', FOR NO ERROR TRACEBACK
	JMP	ITSEN	/ YES.
	JMP	PWHAT	/ NONE OF THE ABOVE
/
/
ITSL	LAC	(064000
	DAC	LST	/ CAUSE LISTING
	LAC	ERRSTA+10
	AND	(003777
	XOR	LST
	DAC	ERRSTA+10
	JMP	CHKCMA
/
ITSB	ISZ	BINSW	/ MARK TO GENERATE A BINARY MODULE
	JMP	CHKCMA
/
ITSS	ISZ*	SYMPRT	/ MARK FOR SYMBOL TABLE
	JMP	CHKCMA
/
ITSEN	ISZ	TRACSW	/ MARK TRACE BACK AS NOT REQUIRED
/
CHKCMA	JMS*	G.UNPK	/ GET NEXT CHARACTER
	AND	(77	/ TRIM TO 6 BITS
	SAD	CMMA	/ IS IT ','
	JMP	NXTCHR
	SAD	ASSGNS	/ IS IT '_'
	JMP	FILNAM	/ YES
	JMP	TRYLET	/ MUST BE ANOTHER LETTER
/
PWHAT	LAC	(WHAT
NOGOOD	DAC	WROTE+2	/ INSERT ERROR ADDRESS
	.WAIT	TTO
WROTE	.WRITE	TTO,2,WHAT,2
	JMP	ORDERS
WHAT	3002; 0; .ASCII 'WHAT ?'<15>
	.LOC	.-1
TOLONG	5002; 0; .ASCII 'FILE NAME TOO LONG'<15>
NOFILE	4002; 0; .ASCII 'FILE NOT FOUND'<15>
/
FILNAM	LAW	-7
	DAC	COUNT
	LAC	SRC
	DAC	D2	/ INSERT EXENSION SRC
	LAC*	(.SCOM+2	/ USE WORK AREA FOR STORAGE
	DAC*	(AUTO11
	SKP
ACHAR	JMS*	G.STUF
	JMS*	G.UNPK
	SAD	CARAGE
	JMP	OPENIT
	SAD	ALTMOD
	JMP	STEXIT
	DAC*	AUTO11	/ SAVE FOR CONVERSION TO INTERNAL CODE
/ THE NEXT CHARACTERS ARE THE FILE NAME PACK THEM IN THE 'D' FILE
	ISZ	COUNT	/ HAVE WE 7 CHARS WITHOUT A CARRIAGE OR
	JMP	ACHAR	/ NO.	ALTMODE (OR COMMA)
	LAC	(TOLONG
	JMP	NOGOOD
/
/ STORAGE FOR THE INPUT SOURCE FILE NAME, THE BINARY OUTPUT FILE NAME,
/ AND THE LISTING FILE NAME. THE EXTENSION IS CHANGED FOR EACH PURPOSE.
D	.DSA	0	/ FIRST THREE CHARS
D1	.DSA	0	/ SECOND THREE CHARS
D2	.SIXBT 'SRC'	/ EXTENSION - SOURCE
/
/
STEXIT	LAW	-1
	DAC*	EXITSW
OPENIT	LAC	(ENDST
	DAC*	AUTO11	/ INSERT END OF NAME INDICATOR
	.INIT	TTO,1,.START
	LAC	(D	/ INSERT ADDRESS TO SET
	DAC	CHECK+2	/ FILE INDICATOR BITS TO ZERO
CHECK	.FSTAT	DKI,D
	SZA		/ IF AC=0, FILE NOT FOUND
	JMP	SEEK
	LAC	CHECK+2
	AND	(700000	/ GET INDICATOR BITS
	SNA		/ IF A FILE ORIENTED DEVICE, GIVE ERROR
	JMP	SETBUF	/ INPUT NOT FILE ORIENTED
	LAC	(NOFILE	/ FILE NOT FOUND
	JMP	NOGOOD
/
SEEK	.SEEK	DKI,D
/
/
/ OPEN THE LISTING FILE UNDER THE FILE NAME  (NOTE: A LISTING DEVICE IS
/ ALWAYS NEEDED TO LIST THE ERROR MESSAGES)
SETBUF	.INIT	LP,1,.START	/ INITIALIZE LISTING DEVICE
	LAC	LSN	/ GET EXTENSION 'LST'
	DAC	D2
	.ENTER	LP,D	/ OPEN LISTING FILE
/ OPEN THE BINARY OUTPUT FILE IF NECESSARY
	LAC	BINSW
	SNA
	JMP	NOBIN	/ NO BINARY FILE, STILL MUST SET UP BUFFERS
	.INIT	DKO,1,.START
	LAC	BIN	/ GET EXTENSION 'BIN'
	DAC	D2
	LAC	(D
	DAC	FSTAT+2	/ RESET FSTAT BITS
/ CHECK IF .DAT SLOT -13 IS FILE ORIENTED
FSTAT	.FSTAT	DKO,D
	LAC	FSTAT+2	/ ARE BITS 0-2 NON-ZERO
	AND	(700000
	SNA
	JMP	DEVERR	/ NON-FILE ORIENTED
	.ENTER	DKO,D	/ OPEN BINARY FILE
NOBIN	JMS*	OPENER	/ SET UP THE BINARY OUTPUT BUFFERS
/
	DZM*	HDR	/ RESETS EOM BITS IF CONSECUTIVE COMPILE
/ SET UP THE ROTARY INPUT FILE POINTERS
	SETUP1 BUFFER,50
	ISZ	SW1	/INDICATE START OF PROGRAM TO BE READ IN
	ISZ	SW2	/ INDICATE NO PRINTING YET
	DZM	EOMSW	/ REMOVE END OF FILE SWITCH IF SET.
	DZM	EOMRD	/ REMOVE EOF ON READ IF SET
	DZM*	ENDSW	/ REMOVE THE END SWITCH INDICATOR
	LAW	-1
	DAC*	START	/ INITIALIZE START ADDRESS 
	DZM*	LOCCNT	/ ZERO LOCATION COUNTER
	DZM	LINE	/ RESET LINE COUNTERS
	DZM	LINEC
	JMS	TESTIN	/ INITATE INPUT
/ SET UP FOR MAINLINE PROGRAMS. (MUST BE DONE HERE IN CASE OF AN
/ ERROR ON THE 1ST CARD). IF PROGRAM IS A SUBROUTINE, IT WILL BE
/ OVERWRITTEN.
	LAW	-3
	JMS*	G.MOVE
	TAD	MNAME
	TAD	PNAME	/ ASSIGN 'MAIN/L' AS PROGRAM NAME
/
	LAC*	(.SCOM+2	/ LOWEST FREE ADDRESS
	DAC	BASE0
	DAC	BASE
/
/ NOW DO SETUP OF TABLES ETC. WHEN SUBPROGRAMS ARE BEING COMPILED
/ WITH A MAINLINE, THEY RETURN TO HERE.
JOINCK	LAC	BASE
	JMS*	PROGPT	/ SET UP POINTERS FOR SAVING PROGRAM INFO
	DAC	BASE	/ RESET BASE TO PROTECT LOCATIONS
	DAC*	BASE1
	DAC	BASE2
	DAC	BASE3
	TAD	CHISZE
	DAC*	DTABLE	/ START OF DTABLE
	DAC*	DTNEXT
/
	LAC*	(.SCOM+3	/ GET HIGHEST FREE ADDRESS
	DAC*	PTEND
	TAD	PTSIZE
	DAC*	PTABLE
	TAD	(-1
	DAC*	OTABLE
	TAD	(-15	/ ACCOUNT FOR 6 FREE ENTRIES AT THE FIRST
	DAC*	OTNEXT	/ OTNEXT POINTS TO 2ND WORD OF NEXT ENTRY
	LAC	PTSIZE
	CMA
	DAC*	PSIZE
/
	LAW	-6
	JMS*	G.INIT
	TAD	(LINE1
	CLA		/ TO ZERO.
/
	LAC	SSET	/ RESET STATEMENT NUMBER STORAGE
	DAC	NOSAVE
	LAC	SSET+1
	DAC	NOSAVE+1
/
	DZM*	ARGCHN
	DZM*	ARGCNT
	LAC	(440000	/ INTERNAL STATEMENT NUMBERS FOR DATA
	DAC*	DTSTAT
	LAC	(400000	/ INTERNAL STATEMENT NUMBERS FOR FORMAT
	DAC*	IFSTAT
/
	LAW	-14	/ INITIALIZE AREAS IN IDENT
	JMS*	G.INIT
	TAD	CMNSWH
	CLA
/
	JMS*	CLRACC	/ CLEAR TEMP & SUBSCRIPT ACC'S IN EXPRES.
/
	LAC	PTSIZE
	JMS*	G.INIT	/ INITIALIZE PTABLE
	TAD*	PTABLE	/ PTABLE IS A .GLOBL POINTER
	LAC	(5	/ TO '5'.
/
	LAC*	PTEND
	DAC	TEMP
	LAC	(7
	DAC*	TEMP
/
	LAC*	OTABLE
	CMA
	TAD*	DTABLE
	JMS*	G.INIT	/ INITIALIZE DTABLE & OTABLE (TEMPORARILY)
	TAD*	DTABLE
	CLA		/ TO ZERO.
/
	LAW	-33	/ 27 DECIMAL
	JMS*	G.INIT	/ INITIALIZE IMPLICIT TABLE IN 'SEARCH'
	TAD	IMPLCT
	LAC	(REALM	/ FIRST ALL TO REAL MODE
	LAW	-6
	JMS*	G.INIT	/ INITIALIZE INTEGERS NOW
	TAD	IMPLC
	LAC	(SINTGM	/ TO INTEGER MODE
/
	DZM	BLOWN	/ RESET ERROR PROGRAM INDICATOR
	DZM*	ASFNUM		/INITIALIZE STATEMENT FUNCTION COUNTER
	DZM*	ASFOFF
/
/
/ WAIT UNTIL THE 1ST NON-COMMENT CARD IS READ IN. THROW THE COMMENT
/ CARDS AWAY.
NEWSTA	JMS	TRACHK
	JMS	PHIPNT
	LAC	PHI1	/ GET 1ST COLUMN
	SAD	CEE	/ IS IT COMMENT
	SKP
	JMP	NXTSTA	/ NO
	JMS	SETPT1	/ YES IT IS COMMENT. THROW IT AWAY
	JMP	NEWSTA	/ GO GET NEXT STATEMENT
/
/ RETURN HERE FOR EACH NEW STATEMENT
NXTSTA	ISZ	LINE	/ INCREMENT LINE COUNT
	ISZ	LINE1
	DZM	STATNM		/ ZERO 'STATEMENT NUMBER PRESENT' INDICATOR
	JMS	STLINE	/ PERFORM STATEMENT INITIALIZATION
	DZM	EQSWT
	DZM	COMASW	/ MUST BE INITIALIZED HERE
	JMP	TESTST	/ GO TEST FOR A STATEMENT NUMBER
/
/ THIS SUBROUTINE PERFORMS THE INITIALIZATION FOR A NEW STATEMENT
STLINE	XX
	LAC	BASE3	/ GET NEXT FREE ADDRESS ABOVE DO TABLES
	TAD	WKAREA	/ ADD SIZE OF WORK AREA
	DAC	CHI	/ START ADDRESS FOR CHI TABLE
	DAC	LIST
	LAC	(STATST*1000+STATST
	DAC*	CHI
/ INITIALIZE SYNTAX SCANNING SWITCHES
	LAW	-11
	JMS*	G.INIT
	TAD	(BCOUNT	/ STARTING HERE
	CLA		/ WITH ZERO.
/
	LAC	(SCAN
	DAC	CHANSW	/ RESET HOLLERITH SCANNING SWITCH
	LAC	(EQSWT
	DAC	Z11
/ INITIALIZE SPECIFICATION SWITCHES IN SUBPROGRAM 'IDENT'
	LAW	-6
	JMS*	G.INIT
	TAD	TYPESW	/ START HERE
	CLA		/ TO ZERO.
/
	LAW	-1
	DAC	LIST+1	/ PACKING INDICATOR SIGNIFIES LEFT HALF
	DAC	BRACK2	/ LOGICAL IF SWITCH
/
/ MARK SUBSCRIPT ACCUMULATORS AS FREE SO THEY MAY BE REUSED.
	JMS*	CLRSUB
/
/ CHECK TO SEE IF THE OTABLE AND DTABLE HAVE CLASHED.
	LAC*	DTNEXT
	CMA
	TAD*	OTNEXT
	SMA
	JMP*	STLINE
ERRCP2	JMS	ERROR	/ ERROR - OTABLE AND DTABLE HAVE CRASHED
	.SIXBT	'CP2'
	JMP*	STLINE
/
/
/
/
/ CHECK IF STATEMENT HAS A STATEMENT NUMBER
TESTST	LAC*	PHIONE
	SAD	SPACES	/ IS IT SPACES OR A NUMBER ?
	JMP	SECHAF
	DAC	NOSAVE	 / IT IS NUMBER , STORE IT.
	LAC*	PHITWO
	DAC	NOSAVE+1
	JMP	MARK1
/
SECHAF	LAC*	PHITWO
	SAD	SPACES+1	/ IS IT SPACES OR A NUMBER ?
	JMP	TRANA
	DAC	NOSAVE+1	 / IT IS NUMBER , STORE IT.
	LAC*	PHIONE
	DAC	NOSAVE
MARK1	CLC
	DAC	STATNM	/ MARK AS HAVING A STATEMENT NUMBER
	DZM	LINE1	/ RESET LINE COUNT FOR ERROR ROUTINE
/
TRANA	ISZ	PHICNT		/IS BUFFER EMPTY ?
	JMP*	HFILA		/NO
/
/TRANSFER OF LINE IS FINISHED WHEN THIS SECTION IS REACHED. WE MUST
/  RESET POINTER 'TRAPTR' AND CHECK IF NEXT LINE IS CONTINUATION.
NXTLNE	LAC	TRAPTR	/TRANSFER OF THIS LINE IS FINISHED,
	DAC	PROPTR	/ AIM PROCESSING POINTER AT IT.
/
	LAC*	TRAPTR	/RESET TRANSFER POINTER TO NEXT FILE
	DAC	TRAPTR
/
	JMS	TRACHK	/ RETURN WHEN NEXT FILE IS READY FOR TRANSFER
	JMS	PHIPNT	/ SET IT UP TO PERFORM CHECKS
/
	LAC	PHI1	/ PICK UP 1ST COLUMN AND BEGIN CHECKING:
	SAD	CEE		/IS IT COMMENT CARD ?
	JMP	PROCES		/YES. OKAY TO PROCESS LAST ONE
	LAC	PHI6	/GET CONTINUATION COLUMN
	SAD	BLANK		/IS IT NEW STATEMENT ?
	JMP	PROCES		/YES. PROCEED TO PROCESS
	SAD	ZRO		/IS IT NEW STATEMENT ?
	JMP	PROCES		/YES. PROCEED TO PROCESS
	JMS	SETPT2	/ ITS CONTINUATION. LET PREVIOUS ONE PRINT
	LAC*	PHIONE		/ GET COLUMNS 1-2.5
	SAD	SPACES		/ CHECK FOR SPACES (THEY SHOULD BE!)
	SKP
	JMP	WRNST6
	LAC*	PHITWO		/ GET COLUMNS 2.5-5
	SAD	SPACES+1	/ SHOULD ALSO BE SPACES HERE
	JMP	TRANA
WRNST6	JMS	WARN
	.SIXBT	'ST6'		/ COL'S 1-5 OF CONTINUATION CARD NOT BLANK
	JMP	TRANA	/ GO APPEND CONTINUE LINE TO PREVIOUS LINE
/
ASTRIK	.SIXBT <0><0>'*'
DOLLAR	.SIXBT <0><0>'$'
BEE	.SIXBT <0><0>'B'
CEE	.SIXBT <0><0>'C'
ELL	.SIXBT <0><0>'L'
ESS	.SIXBT <0><0>'S'
ENN	.SIXBT <0><0>'N'
BLANK	.SIXBT <0><0>' '
ZRO	.SIXBT <0><0>'0'
ASSGNS	.SIXBT <0><0>'_'
ALTMOD	.DSA	175	/ ASCII ALTMODE
CARAGE	.SIXBT <0><0><215>
CMMA	.SIXBT <0><0>','
NULL	.SIXBT <0><0><0>
SPACES	.ASCII '     '
SRC	.SIXBT 'SRC'
BIN	.SIXBT	'BIN'
LSN	.SIXBT	'LST'
/
/
/
ARORDO	SAD	COMASW	/ IS EITHER ARITHMETIC
	JMP*	DO	/ OR 'DO'
	JMP*	ARITH
/
/
PROCES	LAC	(ENDST	/PLACE END OF STATEMENT INDICATOR
	DAC	BOX
	JMS	INSERT	/IN CHI.
	LAC	HCOUNT	/ GET HOLLERITH COUNT
	SZA		/ IF NON-ZERO, HOLLERITH COUNT NOT FINISHED
	JMP	ERRHO1
	LAC	BCOUNT	/ GET PARENTHESES COUNT
	SZA!SMA		/ IF > ZERO, MORE ( THAN )
	JMS	ERRPC0	/ ERROR, MORE ( THAN )
	LAC	LIST
	TAD	(1
	DAC	CHIEND	/ POINT TO END OF CHI TABLE
/
/
/  THIS SECTION PERFORMS A CONSECUTIVE SCAN OF THE SPECS
/  TABLE CHECKING THEM AGAINST THE CHI TABLE IN AN ATTEMPT TO
/  FIND A MATCH. ONCE FOUND IT BRANCHES TO THE 'IDENT' SUBPROGRAM
/  TO TAKE THE APPROPIATE ACTION.
/
	LAC	EQSWT
	SZA
	JMP	ARORDO
	LAC	(SPECS-1
	DAC	NXTSPC	/ START ADDRESS IN 'NXTSPC'
/
AGAIN	LAC	NXTSPC	/ ADDRESS OF NEXT SPEC
	DAC*	(AUTO10	/ LOAD AUTO-INDEX REGISTER.
	LAC	CHI
	DAC*	(AUTO11	/ LOAD AUTO-INDEX REGISTER.
	JMS	CMPARE
	JMP	AGAIN
/
ERRST5	JMS	ERRORS	/ UNDECODABLE STATEMENT
	.SIXBT	'ST5'
FULWRD	SKP		/ RETURN+3, MATCH ON FULL WORD
HAFWRD	JMP	HALFWD	/ RETURN+4, MATCH ON HALF WORD
	LAC*	AUTO11	/ DUMMY INSTR TO INDEX REGISTER TO NEXT WORD
	LAC*	(AUTO11	/ GET ADDRESS
	DAC*	INDEX	/ SET INDEX TO POINT AT NEXT WORD IN CHI
	CLC
	DAC*	IND	/ IND _ -1, SIGNIFIES NEXT CHAR ON LEFT
	XCT*	AUTO10	/ EXECUTE EXIT TO IDENT SUBPROGRAM
/
HALFWD	LAC*	(AUTO11	/ REGISTER POINTS AT CORRECT WORD
	DAC*	INDEX	/ INDEX _ ADDRESS
	DZM*	IND	/ IND _ 0,SIGNIFIES NEXT CHAR ON RIGHT
	XCT*	AUTO10
/
/
/
/  STORE BRANCH ADDRESS FOR 'IF'
/
CHKIF	XX
	ISZ*	IFSW	/ WAS A LOGICAL IF JUST COMPILED
	JMP*	CHKIF
	LAC*	IFSTOR
	DAC	TEMP
	LAC*	LOCCNT
	DAC*	TEMP
	JMP*	CHKIF
/
/  ALL ROUTINES RE-ENTER HERE UNDER NORMAL CONDITIONS.  IF AN ERROR
/  IN CONTINUATION, IT RETURNS TO 'SETASP'.
/
RETRN	JMS	CHKIF
	JMS	SETPT2	/ LAST STATEMENT IS PROCESSED, RELEASE IT.
TESTDC	LAC	PHI1
	SAD	CEE	/ WAS LAST CARD A COMMENT CARD
	SKP
	JMP	NXTSTA	/ OKAY TO TRANSFER
SETASP	JMS	SETPT1	/ IT IS A COMMENT CARD,OR CONTINUATION
	JMS	TRACHK		/STATEMENT WITH AN ERROR.  SET AS 
	JMS	PHIPNT		/BEING PROCESSED AND
	JMP	TESTDC		/LOOK AT NEXT STATEMENT.
	.EJECT
/
/
/ SINCE A LINE MAY NOT BE PROCESSED UNTIL THE FOLLOWING LINE
/ IS CHECKED FOR A CONTINUATION CARD, THIS SUBORUTINE WAITS UNTIL
/ THE NEXT CARD IS READ IN OR UNTIL AN EOM OR EOF IS FOUND IN THE
/ THE NEXT LINE HEADER WORDS. IT THEN ALLOWS THE LAST LINE TO BE
/ PROCESSED AND THEN ALLOWS PRINTING TO CATCH UP AND TERMINATE.
/
TRACHK	XX
NOTRDY	JMS	TESTIN	/ PROD INPUT
PROOUT	JMS	TESOUT	/ PROD OUTPUT
	LAC	EOMSW
	SNA		/ HAS PROCESSING FOUND AN EOF
	JMP	NOPE	/NO.
	LAC*	ENDSW	/ YES.
	SZA		/ HAS AN 'END' STATEMENT BEEN PROCESSED?
	JMP	PROOUT	/ YES. LOOP TILL PRINTING ENDS
WRNEN1	JMS	WARN	/ NO. ISSUE ERROR
	.SIXBT	'EN1'
	JMP	PROCES	/ GO PROCESS THE GENERATED 'END' STATEMENT
/ CHECK IF THE FILE IS READY FOR TRANSFER. (IE IS THE NEXT FILE READ)
NOPE	LAC*	TRAPTR
	AND	(700000
	SAD	(100000	/ IS NEXT FILE FINISHED READ?
	SKP		/ YES
	JMP	NOTRDY	/ NO. GO PROD INPUT AND OUTPUT
/ THE NEXT FILE HAS BEEN READ, CHECK IF IT CONTAINS AN EOF
	LAC	TRAPTR
	TAD	(4
	DAC	TEMP
	LAC*	TEMP
	AND	(017
	SAD	(5	/ IS IT 'EOF'
	ISZ	EOMSW	/ MARK THAT PROCESSING HAS FOUND AN EOF
	JMP*	TRACHK
	.EJECT
/
/ THIS ROUTINE CHECKS FOR END OF FILES ON INPUT AND RESETS THE BUFFERS
/ AFTER A LINE IS FINISHED READING IN.
TESTIN	XX
	LAC	EOMRD
	SZA		/ HAS READING FOUND AN EOF PREVIOUSLY?
	JMP*	TESTIN	/ YES.
	.WAITR	DKI,BUSY
	LAC*	HDR
	AND	(000017
	SAD	(000006	/ARE 'EOM' BITS SET IN HEADER WORD ?
	JMP	HAVEOM
	SAD	(000005	/ OR ARE 'EOF' BITS SET
	JMP	HAVEOM	/ YES.
/ NOT END OF FILE, CHECK IF A LINE IS TO BE MARKED AS READ IN.
	LAC	SW1
	SZA		/WAS READING UNDERWAY?
	JMP	NOREAD	/NO.
	ISZ	SW1	/ YES.
	LAC*	LASTRD	/ RESET TO READING FINISHED!
	AND	(077777
	XOR	(100000	/ INDICATE LINE IS READY FOR ACTION
	DAC*	LASTRD
/ MOVE THE HEADER WORDS TWO WORDS UP IN THE BUFFER AND RESET THEM
/ TO ALLOW TO INSERT EITHER 5 SPACES OR A LINE COUNT ON EACH LINE.
	LAC*	HDR	/ GET HEADER WORD
	TAD	(1000	/ INCREMENT WORD PAIR COUNT
	DAC*	SWAP
	LAC*	WORD1	/ GET 1ST WORD OF FILE
	AND	(774000	/ ISOLATE 1ST COLUMN OF CARD
	SAD	(414000	/ IT CHARACTER 'C'
	JMP	USESPC	/ YES. ITS CONTINUATION CARD. INSERT SPACES
	LAC*	WORD3	/ GET 3RD WORD
	AND	(774000	/ ISOLATE 6TH COLUMN OF CARD
	SAD	(300000	/ IS CHARACTER '0'
	JMP	NOTCON	/ YES. LINE IS NOT CONTINUATION
	SAD	(200000	/ IS CHARACTER ' '
	JMP	NOTCON	/ YES. LINE IS NOT CONTINUATION
/ THE LINE IS EITHER A COMMENT OR CONTINUATION CARD. INSERT SPACES
USESPC	LAC	SPACES
	DAC*	HDR
	ISZ	HDR
	LAC	SPACES+1
	DAC*	HDR
	JMP	RESETH	/ CARRY ON
/ THE LINE IS NOT A COMMENT OR CONTINUATION LINE. COUNT THE LINE AND
/ INSERT THE LINE COUNT IN THE FILE
NOTCON	ISZ	LINEC	/ COUNT THE LINE
	LAC	HDR	/ ADDRESS OF WHERE TO INSERT COUNT
	JMS*	G.STPC	/ SET UP PACKING ROUTINE
	LAC	(6-4
	DAC*	NUMS	/ SET TO CONVERT 4 CHARACTERS
	CLL		/ SET TO NOT PRINT LEADING ZEROS
	LAC	LINEC	/ GET THE COUNT
	JMS*	G.CVRT	/ CONVERT AND PACK
	LAC	(40	/ INSERT A ASCII SPACE
	JMS*	G.PACK
RESETH	LAC	SWAP	/ GET NEW HEADER POSITION
	DAC	HDR	/ AND RESET HDR IN CASE NEXT FILE IS NOT FREE
/ NOW CHECK IF NEXT FILE IS FREE
NOREAD	LAC*	REDPTR	/ GET NEXT BUFFER TO BE READ INTO.
	AND	(600000
	XOR	(600000
	SZA		/IS BUFFER FREE?
	JMP*	TESTIN	/NO. RETURN.
	LAC	REDPTR	/YES.
	DAC	LASTRD	/ MARK AS LAST BUFFER READ INTO
	TAD	(2
	DAC	SWAP
	TAD	(2
	DAC	HDR	/ POINTS TO HEADER WORD
	DAC	REED+2
	TAD	(2
	DAC	WORD1	/ POINTS TO 1ST WORD OF FILE
	TAD	(2
	DAC	WORD3	/ POINTS TO 3RD WORD OF FILE
REED	.READ	DKI,2,REED,36
	DZM	SW1
	LAC*	REDPTR	/ RESET 'REDPTR' TO NEXT BUFFER
	AND	(077777
	DAC	REDPTR
BUSY	JMP*	TESTIN
SWAP
WORD1
WORD3
/
/ WE HAVE FOUND A RECORD WITH THE EOM OR EOF BITS SET, MARK THE
/ RECORD AS BEING READY FOR TRANSFER. ALSO MOVE THE '      END' INTO THE 
/ EOF RECORD IN CASE AN 'END' STATEMENT IS MISSING
HAVEOM	LAC	LASTRD
	JMS	PUTEND
	ISZ	EOMRD
	JMP*	TESTIN
	.EJECT
/
/ THE FOLLOWING SUBROUTINE HANDLES OUTPUT OF THE SOURCE LINES
/ AND CORRESPONDING ERROR MESSAGES. IT UPDATES THE FILE POINTERS 
/ AS NECESSARY. WHEN AN EOM OR EOF IS ENCOUNTERED OUTPUT IS FINISHED
/ AND IT BRANCHES TO CLOSE THE FILE.
TESOUT	XX
	.WAITR LP,OCCUPY	/ IS OUTPUT DEVICE BUSY?
	LAC	SW2
	SZA		/ WAS PRINTING UNDERWAY?
	JMP	TSJOIN	/ NO. GO CHECK IF FILE IS READY
/PRINTING WAS UNDERWAY, THUS THE FILE BITS MUST BE RESET
	LAC	POINTR
	TAD	(1
	DAC	SPOT		/POINT TO ERROR INDICATOR
	TAD	(7
	DAC	OWORD3		/ POINT TO COLUMNS 6,7,8
	LAC*	SPOT		/DO WE HAVE AN ERROR IN THIS LINE?
	SZA
	JMP	HAVERR
	LAC*	POINTR	/ THUS LAST LINE HAS BEEN PRINTED.
	AND	(300000
	SAD	(300000	/ IS PROCESSING FINISHED?
	SKP
	JMP*	TESOUT	/ NO. GO DO SOMETHING ELSE.
	LAC*	POINTR	/ YES. NOW BOTH PROCESSING AND PRINTING ARE DONE
	XOR	(500000
	DAC*	POINTR	/ MARK FILE AS FREE, 5 XOR 3 = 6
	DAC	POINTR
	LAC	UNDEC
	DAC*	OWORD3		/ CLOBBER PREVIOUS STATEMENT
/ CHECK IF THE FILE IS READY FOR PRINTING
TSJOIN	LAC*	POINTR
	SPA
	JMP	UNABLE	/ NO IT IS NOT READY.
/ FILE IS READY, PRINT IT
	DZM	SW2	/ INDICATE PRINTING IS BEING DONE
	LAC	POINTR	/ GET BUFFER ADDRESS
	TAD	(2
	DAC	HDR2
	DAC	WRIT+2	/ SET UP .WRITE
/ CHECK IF THE EOF BITS ARE SET
RECHK	LAC*	HDR2
	AND	(000017
	SAD	(000005	/ ARE 'EOF' BITS SET
	JMP	CHKEND
/ NOT END OF FILE, CONTINUE PRINTING
	LAC	LST	/ IS LISTING REQ'D ? IE LST=/=0
	SNA
	JMP*	TESOUT	/ NOT REQUIRED.  RETURN.
WRIT	.WRITE LP,2,WRIT,36
OCCUPY	JMP*	TESOUT
/
/ THE FILE IS NOT READY FOR PRINTING
UNABLE	ISZ	SW2
	JMP*	TESOUT
/
/ WE HAVE FOUND A EOF OR EOM. IF 'ENDSW' IS NOT SET THEN THE 
/ PROGRAM WAS MISSING AN END STATEMENT, AND IS NOW POINTED AT
/ THE FIRST ONE GENERATED.
CHKEND	LAC*	ENDSW
	SZA
	JMP*	ENDFIL	/ HAD AN END STATEMENT
	LAC*	HDR2
	AND	(777770
	XOR	(000002	/ REPLACE THE EOF BITS
	DAC*	HDR2
	LAC*	POINTR
	JMS	PUTEND	/ GENERATE A SECOND END IN THE NEXT FILE
	JMP	RECHK	/ WITH AN EOF (JUST A HANDY ROUTINE WITH AN EOF)
/
/ SUBROUTINE TO INSERT AN END STATEMENT WITH AN EOF
PUTEND	XX
	DAC	T1
	TAD	(2
	DAC	T2	/ POINTS AT HEADER WORD
	LAC*	T1	/ GET FILE BITS
	AND	(077777
	XOR	(100000	/ MARK AS FINISHED READ
	DAC*	T1
	LAW	-10
	JMS*	G.MOVE
	TAD	(END.
	TAD	T2
	JMP*	PUTEND
T1;T2;OWORD3
UNDEC	.ASCII	' '<15> ; .LOC .-1
/
END.	EN.-.*400+5
	0
	.ASCII	'     '
	.ASCII	'      END'<215>
EN.=.
	.EJECT
/
/
/INITIALIZE POINTERS TO NEXT BUFFER AREA
/
PHIPNT	XX
	LAC	TRAPTR	/ADDRESS OF BUFFER
	TAD	(6
	DAC	PHIONE	/ADDRESS OF IST CHARACTER
	TAD	(1
	DAC	PHITWO	/ADDRESS OF 4TH CHARACTER
	TAD	(1
	DAC	PHITRE	/ADDRESS OF 6TH CHARACTER
	AND	(077777	/ TO KEEP PDP-15 HAPPY
	DAC*	(AUTO15	/AUTO-REGISTER
/
	LAC	(PHENTR	/ INITIALIZE CHARACTER
	DAC	HFILA	/EXTRACTION ROUTINE
	LAC*	PHITRE	/AT COLUMN 7 (CHAR. 8)
	DAC	NUM3
	RTR
	RTR
	DAC	NUM2
/
	LRS	7
	AND	(000077	/CONTINUATION COLUMN TO .SIXBT
	DAC	PHI6
	LAC*	PHIONE
	LRS	13
	AND	(000077	/FIRST COLUMN TO .SIXBT
	DAC	PHI1
/ SET COUNTER TO PICK UP ONLY COLUMNS 7 TO 72, IE 66 CHARACTERS
	.DEC
	LAW	-67	/ 1'S COMPLIMENT
	.OCT
	DAC	PHICNT
	JMP*	PHIPNT
/
/
/ STORAGE LOCATIONS FOR TRANSFER SECTION
PHI1;PHI6;PHIONE;PHITWO;PHITRE;PHICNT;NUM2;NUM3
/
/
/THIS SECTION REMOVES BLANKS, TRANSFERS STATEMENT TO AREAS 'CHI'
/FOR PROCESSING,
/
PHLOOP	LAC*	AUTO15	/OBTAIN FIRST 2.5 LETTERS
	DAC	NUM3	/PART OF THIRD LETTER
	RTR
	RTR
	DAC	NUM2	/2ND LETTER
	LRS	7	/OBTAIN 1ST LETTER
	JMS	HFILA	/MARK RETURN POINT
/
PHENTR	LAC	NUM2	/OBTAIN 2ND  LETTER
	JMS	HFILA	/MARK RETURN POINT
/
PHFIRT	LAC*	AUTO15	/OBTAIN 2ND 2.5 LETTERS
	LMQ		/SAVE HALF OF 3RD LETTER
	RAR
	DAC	NUM2	/SAVE 4TH & 5TH LETTERS
	LAC	NUM3	/GET REST OF 3RD LETTER
	LLS	3	/3RD LETTER NOW OBTAINED
	JMS	HFILA	/MARK RETURN POINT
/
	LAC	NUM2
	LRS	7	/OBTAIN 4TH LETTER
	JMS	HFILA	/MARK RETURN POINT
/
	LAC	NUM2	/OBTAIN 5TH LETTER
	JMS	HFILA	/MARK RETURN POINT
	JMP	PHLOOP
/
HFILA	.DSA	PHENTR
	AND	(0177
	SAD	NULL
	JMP	TRANA
	SAD	CARAGE
	JMP	NXTLNE
	DAC	CHAR
	JMP	PILED
/
/
BOXIT
CHAR
TRAPTR;PROPTR;POINTR;REDPTR;LASTRD;THERE;REF;SPOT;HDR2
TEMP
SW1	.DSA 1	/ INDICATES THERE IS NO FILE TO BE RESET
SW2	.DSA 1	/ INDICATES NO PRINTING
EOMSW	.DSA 0	/ NO EOM BIT YET
EOMRD	.DSA 0	/ INDICATES READ HAS FOUND EOF
HDR	.DSA HDR	/ ALLOWS DZM* HDR ON 1ST COMPILE (SETBUF+3)
/
/ THE DEFINITION OF THE INTERNAL CHARACTER SET IS RECORDED
/  ON A PARAMETER TAPE.
/
/
/HERE LIES THE TABLE FOR ASCII TO FORTRAN COMPILER CODES
/
/
TABLE	ILLEG*1000+AA		/@ , A
	BB*1000+CC		/B , C
	DD*1000+EE
	FF*1000+GG
	HH*1000+II
	JJ*1000+KK
	LL*1000+MM
	NN*1000+OO
	PP*1000+QQ
	RR*1000+SS
	TT*1000+UU
	VV*1000+WW
	XXX*1000+YY		/X , Y
	ZZ*1000+ILLEG		/Z , [
	ILLEG*1000+ILLEG	/\ , ]
	ARROW*1000+ILLEG	/^ , _
	SPACE*1000+OR		/  , !
	ILLEG*1000+ILLEG	/" , #
	DLR*1000+ILLEG		/$ , %
	AMPER*1000+APOST	/& , '
	OPEN*1000+CLOSE		/( , )
	STAR*1000+PLUS		/* , +
	COMMA*1000+MINUS	/, , -
	POINT*1000+SLASH	/. , /
	ZERO*1000+ONE		/0 , 1
	TWO*1000+THREE
	FOUR*1000+FIVE
	SIX*1000+SEVEN
	EIGHT*1000+NINE		/8 , 9
	ILLEG*1000+ILLEG	/: , ;
	LESS*1000+REPLAC	/< , =
	GREAT*1000+ILLEG	/> , ?
/
/CONVERT 6 BIT CHARACTER TO INTERNAL 7 BIT CODE
/
PILED	AND	(077	/ TRIM TO 6 BITS
	CLL!RAR		/DIVIDE BY 2. LINK POINTS HALF WORD
	TAD	(TABLE	/CALC. TABLE ENTRY ADDRESS
	DAC	BOX		/STORE ADDRESS IN MEMORY
	LAC*	BOX		/AND PICK UP TWO NEW ALPHA CODES
	SNL		/IS DESIRED CHAR.IN IST HALF WORD
	LRS	11		/YES. SHIFT OVER WORD
	AND	MASK		/CLEAN OFF TOP HALF
	DAC	BOX		/BEHOLD THE DESIRED CODE!
	JMP*	CHANSW	/ENTER PROCESSING ROUTINE
BOX
MASK	.DSA 000777
/CHANSW NORMALLY CONTAINS THE ADDRESS SCAN, BUT IT IS ALTERED
/UNDER SPECIAL CONDITIONS SUCH AS DURING COLLECTION OF HOLLERITH
/CONSTANTS. NORMALLY LOADED BY EXECUTING JMS CHANSW. INITIAL
/SETTING IT TO SCAN
/
/
/
CHANSW	.DSA	SCAN	/INITIAL ADDRESS
HENTRY	JMS	INSERT
	JMP	TRANA
/
/
/
/
/THIS ROUTINE LOADS THE CHARACTERS,TWO PER WORD INTO CHI, AND CHECKS FOR
/ CHI TABLE OVERFLOW. AT THE START OF A STATEMENT:
/LIST	.DSA	CHI
	.DSA 777777
/ CHI	STATST*1000+STATST
/
INSERT	XX
	LAC	BOX	/PICKS UP CHARACTER
	ISZ	LIST+1	/WHICH HALF WORD
	JMP	HALF2	/RIGHT HALF
/
/INSERT CHARACTER INTO LEFT HALF WORD
	ISZ	LIST	/INDEX ADDRESS
	ALSS	11	/MOVE CHAR TO LEFT HALF.
	DAC*	LIST	/STORE CHARACTER
	LAC	LIST
	TAD	(1	/ CHECK ONE PAST CURRENT LIST
	SAD*	DTABLE	/ SO 1ST WORD OF DTABLE IS NOT DESTROYED.
	SKP
	JMP*	INSERT
ERRCP0	JMS	ERROR
	.SIXBT	'CP0'
	JMS	CHKIF		/IN CASE OF EXCEEDINGLY LONG 'IF'
	JMP	SETASP
/
HALF2	TAD*	LIST
	DAC*	LIST	/ADD RIGHT HAND CHARACTER
	CLA!CMA
	DAC	LIST+1	/INDICATE RIGHT HALF LOADED
	JMP*	INSERT
/
CHI;CHIEND;LIST;LIST1
/ STORAGE LOCATIONS FOR SCAN SECTION
/
BCOUNT;HCOUNT;BRACKS;EQSWL;MARK;PINIT;PI3;PNTCNT;ERRORC
/
/
Z11	.DSA EQSWT
BRACK2;COMASW;EQSWT
/
CNT2;COUNT
XLIST	.BLOCK 2
/
/
ERRHO1	JMS	ERRORS	/ ERROR 'END OF STATEMENT BEFORE END OF HOLLERITH
	.SIXBT	'HO1'
/
/ENTER HERE FOR "NH" TYPE HOLLERITH CONSTANTS. CONVERT THEM 
/ TO '-----------------' MODE .
/
HTYPE	JMS	NOTE	/RECORD CURRENT STATUS
	DZM	HCOUNT	/WILL DEVELOP -N IN 1'S COMPLEMENT
	LAC	PONTR	/ADDRESS OF POWERS OF 10
	DAC*	(AUTO10	/TABLE. STORE IN AUTO-INDEX REGISTER
LOOP	JMS	BACK1	/PICKUP CHARACTER.
	TAD	(-NINE	/AC_0 FOR CHAR.= 9
	SMA!SZA		/IS IT ALPHA OR DIGIT
	JMP	MAYBEH	/NO. HAVE FOUND OPERATOR.
	TAD	(11		/RECOVER DECIMAL VALUES.
	SPA!STL		/IS IT DIGIT SET SIGN NEG.
	JMP	NOTDIG	/NO. ALPHA OR OPERATORS
	DAC	MULTPY
	LAC*	AUTO10	/GET MULTIPLER.
	SAD	PONTR	/IS IT DEND OF TABLE
	JMP	NOTNH		/YES. NOT A H=MULTIPLER.
	MULS		/MULTIPLY DIGIT BY
MULTPY	XX		/POWER OF TEN
	LACQ
	ADD	HCOUNT		/ASSEMBLE TOTAL NUMBER (NEG)
	DAC	HCOUNT
	JMP	LOOP		/GO GET NEXT DIGIT.
TABLE1		1
		12	/DECIMAL 10
		144	/DECIMAL 100
		1750	/DECIMAL 1000
PONTR		TABLE1-1		/END OF TABLE MARKER
/
MAYBEH	LAC	HCOUNT
	SNA
	JMP	NOTNH
	LAC	BOX
	SAD	(STAR		/LOOKS LIKE '*NH' ?
	JMP	NOTNH		/YES.  MAY BE LIKE 'REAL*4 HARRY'
	ISZ	HCOUNT		/CONVERT TO 2'S COMPLEMENT
	JMP	ISITH
	JMP	NOTNH	/NB!  FOR: 0H HOLLERITHS CHANGE THIS LINE
/
NOTDIG	TAD	(ZERO-AA
	SPA
	JMP	MAYBEH
	LAC	BOX	/GET CURRENT CHARACTER
	SAD	(XXX	/IS IT AN X
	SKP
/**			/OTHER CHARACTER CHECKS CAN BE ADDED AT THIS POINT
	JMP	NOTNH	/NO - NOT HOLLERITH STRING
	LAC	LIST
	DAC	XLIST		/SAVE CURRENT PLACE IN CHI
	LAC	LIST+1
	DAC	XLIST+1
	LAC	XBOX
	DAC	XBOX
ANOTHR	DZM	SET	/KEEPS TRACK OF 3X SETS
NUMBR	JMS	BACK1	/GET PREVIOUS CHARACTER FROM CHI
	TAD	(-NINE
	SMA!SZA
	JMP	CONT	/NOT A NUMBER OR ALPHABETIC OR LEGAL OPERATOR
	TAD	(NINE-DLR
	SPA
	JMP	CONT	/MAYBE AN X,COMMA,OR SLASH
	ISZ	SET	/FOUND A NUMBER
	JMP	NUMBR
/
CONT	LAC	SET	/DID WE HAVE A SET
	SNA
	JMP	NOTNH	/NO - WASN'T A HOLLERITH
	LAC	BOX
	SAD	(XXX	/DO WE HAVE THE BEGINNINGS OF ANOTHER SET
	JMP	ANOTHR	/YES SEE IF NUMBER PRECEEDS
	LAC	XLIST		/NO.  RESET TO 'NNH' PLACE IN CHI
	DAC	LIST
	LAC	XLIST+1
	DAC	LIST+1
	LAC	XBOX
	DAC	BOX
	JMP	MAYBEH
/
XBOX;SET
/
/
NOTNH	JMS	RESET		/RESET CHI POINTERS
	DZM	HCOUNT		/ZERO POSSIBLE FALSE COUNT
	JMP	CHANSW+1	/WAS JUST LETTER 'H'
/
ISITH	DZM	MARK	/ 0 INDICATES AS 3HABC, NOT 'ABC'
	JMS	CLEARS	/RESET TO IGNORE NNH
	JMS	INSERT	/RESTORE LAST CHAR TO LIST
	LAC	(APOST
	SAD	BOX	/WAS LAST CHAR AN ' ?
	JMP	APTIE3	/YES
APTIE1	DAC	BOX	/NO. PREPARE AN ' FOR LIST
	JMP	APTIE5
/
/
APTIE2	LAC	MARK
	SZA		/WAS LAST H-TYPE AN 3HABC
	JMP	APTIE4	/NO.
	JMS	RESET	/YES. RESTORE ' TO LIST
	DAC	MARK	/'APOST' INDICATES 'ABC',NOT 3HABC
APTIE3	LAC	(COMMA
	DAC	BOX
	JMS	INSERT	/INSERT COMMA IN LIST
WRNHO0	JMS	WARN	/ TWO HOLLERITH STRINGS TOGETHER WITHOUT DELIMITER
	.SIXBT	'HO0'
	LAC	(APOST
	JMP	APTIE1
APTIE4	JMS	CLEARS	/DELETE THE '
	LAC	CHAR	/AND INSERT SIXBT FORM
	JMP	APTIE1
/
/
/ENTER HERE WHEN '-------' IS FOUND
/
APTYPE	DZM	HCOUNT	/SET UP FOR INFINITE COUNT.
	JMS	NOTE	/RECORD STATUS
	JMS	BACK1	/GET PREVIOUS CHARACTER
	SAD	(APOST	/WAS IT ' ?
	JMP	APTIE2	/YES
	JMS	RESET	/NO. RESTORE
	DAC	MARK	/APOST INDICATES 'ABC', NOT 3HABC
/
APTIE5	JMS	CHANSW	/STORE THE ' .
/
/SUBSEQUENT CHARACTERS PROCESSED FROM NEXT INSTRUCTION
/
	SAD	MARK	/ENDING ' FOR 'ABC'
	JMP	NORMAL	/YES
	LAC	CHAR	/NO. SET UP SIXBT CODE
	DAC	BOX
	ISZ	HCOUNT	/LAST CHAR. OF STRING ?
	JMP	HENTRY	/NO. STORE IT
/
	JMS	INSERT	/YES. STORE CHAR
	LAC	(APOST
	DAC	BOX
NORMAL	DZM	HCOUNT	/ RESET FOR '  ' TYPE TO AVOID ERROR
	JMS	CHANSW	/ INSERT CLOSING ' .
/
/MAIN BODY OF SCAN FOLLOWS.MUST FOLLOW (NORMAL) TO GET CHANSW
/SET CORRECTLY AT END OF HOLLERITH CONSTANTS
/
/SORT OUT SPECIAL ACTION CODES AND TAKE ACTION
SCAN	SAD	(SPACE
	JMP	TRANA	/ IGNORE SPACES
	SAD	(REPLAC	/ IS IT = ?
	JMP	EQUALC	/YES
	ISZ	BRACKS	/HAS (...)JUST OCCURRED?
	JMP	SCANIF	/NO!
	LAC	(EQSWL	/SET UP FOR IF(...)A=B
	DAC	Z11
	LAC	BOX	/RECOVER CHAR.
SCANIF	SAD	(APOST	/IS IT ' ?
	JMP	APTYPE	/YES
	SAD	(HH	/IS IT  H?
	JMP	HTYPE	/YES
	SAD	(CLOSE	/ ) ?
	JMP	BDECMT	/YES
	SAD	(COMMA	/ , ?
	JMP	DOCHK	/YES
	SAD	(STAR	/ * ?
	JMP	EXPCHK	/YES
	SAD	(POINT	/IS IT . ?
	JMP	POINTC	/YES
	SAD	(OPEN	/IS IT ( ?
	ISZ	BCOUNT	/YES,COUNT IT
/
	XOR	(ILLEG	/IS IT ILLEGAL CHAR
	SZA
	JMP	CHANSW+1	/NO STORE IT
ERRCC0	JMS	ERROR	/ ERROR. CHARACTER VALID ONLY IN HOLLERITH
	.SIXBT	'CC0'
	JMP	HENTRY
/
/BCOUNT IS ZERO AT THE START OF STATEMENT. INCREMENT BY
/ONE FOR EVERY (, DECREMENT BY ONE FOR EVERY ). FIRST TIME
/IT GOES TO ZERO ADJUST TO PICK UP POSSIBLE STATEMENT
/AFTER LOGICAL IF.
/
BDECMT	CLC		/PUT -1 IN AC
	TAD	BCOUNT	/ADD COUNT
	DAC	BCOUNT	/STORE RESULT
	SZA!SMA!RAL	/SKIP IF ZERO OR NEG,SAVE SIGN
	JMP	HENTRY	/STORE ) IN LIST
/
	ISZ	BRACK2	/IS THIS FIRST (...)
	JMP	CHKPC0	/NO CHECK IF ERROR
/
	LAW	-1	/ -1 TO AC
	DAC	BRACKS	/SET SWITCH FOR EQUAL SIGN CONTROL
/
CHKPC0	SZL
	JMS	ERRPC0	/ ERROR MORE ) THAN (
	JMP	HENTRY
/
/ ERROR SUBROUTINE
ERRPC0	XX
	JMS	ERROR	/ COMPLAIN. MORE ) THAN ( OR MORE ( THAN )
	.SIXBT	'PC0'
	DZM	BCOUNT
	JMP*	ERRPC0
/
/ENTER HERE WHEN = IS FOUND. WE ARE INTERESTED IN EQUAL SIGNS
/NOT ENCLOSED IN BRACKETS. THESE INDICATE EITHER DO OR
/ARITHMETIC STATEMENTS
/
EQUALC	LAC	BCOUNT	/PICK UP BRACKET COUNT
	SZA!CLA!CLL!CML	/IS IT ZERO , L=1,AC=0
	JMP	HENTRY	/NO.  INSIDE (...)
	RAL		/SET AC = 1
	DAC*	Z11	/MARKS THAT =  OCCURRED
	DZM	BRACKS	/TURN OFF LOGICAL IF SWITCHES
	DZM	BRACK2
	JMP	HENTRY	/ADD = TO LIST
/
/ENTER HERE WHEN COMMA IS FOUND.THE SEQUENCE = -----,
/INDICATES A DO LOOP
DOCHK	LAC	BCOUNT	/PICK UP BRACKET COUNT
	SZA		/IS IT ZERO
	JMP	HENTRY	/NO.  INSIDE (---)
	LAC	EQSWT
	TAD	EQSWL
	DAC	COMASW	 /RECORD =-----,  SEQUENCE
	JMP	HENTRY
/
/ENTER HERE WHEN  * IS FOUND. CONVERT  ** TO ^
/
EXPCHK	JMS	NOTE	/RECORD POINTERS
	JMS	BACK1	/GET LAST CHAR
	XOR	(STAR
	SZA		/WAS IT A *
	JMP	NOTNH	/NO
	LAC	(ARROW
EXPTIE	DAC	BOX
	JMS	CLEARS	/CLEAR RIGHT-HALF WORD, IF NECESSARY.
	JMP	HENTRY	/STORE ^ IN LIST
/
/ENTER HERE WHEN A PERIOD IS FOUND. CHECK FOR LOGIC CODE
/
POINTC	ISZ	PNTCNT	/FIRST PERIOD ?
	JMP	PNTC2	/YES	
/
	LAC	XLIST
	CMA
	TAD	LIST
	TAD	(-2
	SZA!SMA		/HAVE MORE THAN 6 CHAR. GONE BY ?
	JMP	PNTC2	/YES. MARK PRESENT POINT AS FIRST
	JMS	NOTE	/NO. STORE POSITION & COMMENCE CHECK
	LAC	(FRST	/FOR LOGICAL CODE
	DAC	STOREG
/
/
	DZM	COUNT	/ INITIALIZE WORD COUNT
NEXT	JMS	BACK1	/ GET LAST CHARACTER
	SAD	(POINT	/IS IT A 'POINT'
	JMP	COMPAR	/YES ,COMPARE AGAINST CODES
	JMP*	STOREG	/NO, STORE IT
/
/ THIS CODING PLACES CHARS FROM THE AC INTO LOGSTR TWO PER WORD
/ IT IS ENTERED BY A JMP* STOREG
STOREG	.DSA	FRST
	JMP	NEXT
/
FRST	DAC	LOGSTR
	JMS	STOREG
SECND	CLQ
	LLS+11
	XOR	LOGSTR
	DAC	LOGSTR
	ISZ	COUNT
	JMS	STOREG
THRE	DAC	LOGSTR+1
	ISZ	COUNT	/ WE ARE NOW USING SECOND WORD
	JMS	STOREG
FORE	CLQ
	LLS+11
	XOR	LOGSTR+1
	DAC	LOGSTR+1
	JMS	STOREG
FIVER	DAC	LOGSTR+2
	ISZ	COUNT
	JMS	STOREG
SIXER	JMP	OUT	/ THERE IS NO SIX CHAR LOGIC CODE
/
/
/ THE FOLLOWING IS A LIST OF LEGAL LOGIC OPERATORS FOR TESTING
LGOPS1	OO*1000+RR	/ OR
	LL*1000+TT	/ LT
	GG*1000+TT	/ GT
	LL*1000+EE	/ LE
	GG*1000+EE	/ GE
	EE*1000+QQ	/ EQ
	NN*1000+EE	/ NE
	.DSA	-1	/ END OF TABLE INDICATOR
/
LGOPS2	NN*1000+DD	/ AND
	       AA
	OO*1000+TT	/ NOT
	        NN
	UU*1000+EE	/ TRUE
	TT*1000+RR
	.DSA	-1	/ END OF TABLE INDICATOR
/
LGOPS3	SS*1000+EE	/ FALSE
	AA*1000+LL
	        FF
	.DSA	-1	/ END OF TABLE INDICATOR
/
/ STORAGE FOR SUSPECTED LOGICAL VARIABLES WHILE TESTING
LOGSTR	.BLOCK 3
/
OPADD		/ POINTER TO INTERNAL CODE TABLE
/ THIS TABLE HAS A ONE TO ONE RATIO TO THE ABOVE TABLE AND
/  CONTAINS THE INTERNAL CODE FOR THEM.
OPVAL1	.DSA	OR
	.DSA	LESS
	.DSA	GREAT
	.DSA	LE
	.DSA	GE
	.DSA	EQ
	.DSA	NE
/
OPVAL2	.DSA	AND.
	.DSA	NOT
	.DSA	TRUE
/
OPVAL3	.DSA	FALSE
/
/ THE FOLLOWING CODING CHECKS THE CONTENTS OF LOGSTR WITH THE
/ ABOVE TABLE
COMPAR	LAC	COUNT
	SNA!SPA
	JMP	OUT	/ THERE ARE NO CHARS PRESENT
	SAD	(1
	JMP	ONEWRD	/ THERE IS ONE WORD TO CHECK
	SAD	(2
	JMP	TWOWRD	/ THERE ARE TWO WORDS TO CHECK
	JMP	TREWRD	/ THERE ARE TWO WORDS TO CHECK
/
ONEWRD	LAC	(LGOPS1-1	/ LOAD AUTO-INDEX REGISTER
	DAC*	(AUTO10
	LAC	(OPVAL1	/ SET POINTER TO INTERNAL CODE TABLE
	DAC	OPADD
AGAIN1	LAC*	AUTO10	/ GET COMPARISION MODE
	SPA		/ IS IT END OF TABLE
	JMP	OUT	/ YES, NO MATCH
	SAD	LOGSTR	/ NO, DO THEY MATCH
	JMP	PNTC6	/ YES
	ISZ	OPADD	/ NO, TRY NEXT ONE
	JMP	AGAIN1
/
TWOWRD	LAC	(LGOPS2-1	/ LOAD AUTO-INDEX
	DAC*	(AUTO10
	LAC	(OPVAL2
	DAC	OPADD
AGAIN2	LAC*	AUTO10
	SPA
	JMP	OUT	/ END OF TABLE
	SAD	LOGSTR	/ DO THEY MATCH
	JMP	TRYSND	/ YES, GO TRY SECOND WORD
	LAC*	AUTO10	/ NO MATCH,DUMMY INCREMENT OF AUTO-INDEX
	ISZ	OPADD	/ POINT TO NEXT INTERNAL CODE
	JMP	AGAIN2	/ TRY AGAIN
TRYSND	LAC*	AUTO10	/ FIRST WORD MATCHES, GET SECOND WORD
	SAD	LOGSTR+1 / DO THEY MATCH
	JMP	PNTC6	/ YES
	ISZ	OPADD	/ NO
	JMP	AGAIN2
/
TREWRD	LAC	(LGOPS3-1	/ LOAD AUTO-INDEX REGISTER
	DAC*	(AUTO10
	LAC	(LOGSTR-1
	DAC*	(AUTO11
	LAC	(OPVAL3
	DAC	OPADD
	LAW	-3	/ WE HAVE 3 WORDS TO CHECK
	DAC	COUNT
AGAIN3	LAC*	AUTO10
	SAD*	AUTO11	/ DO THEY MATCH?
	SKP
	JMP	OUT	/ NO
	ISZ	COUNT	/ DO WE HAVE THREE MATCHES ?
	JMP	AGAIN3	/ NOT YET TRY FOR ONE MORE.
	JMP	PNTC6	/ YES, GO INSERT INT. CODE
/
/ IF NO MATCHES RESET POINTERS & CONTINUE
OUT	JMS	RESET	/ NO MATCHES,NOT LOGICAL,RESET & CONTINUE
PNTC2	LAC	LIST	/ MARK THIS AS THE NEXT FIRST POINT
	DAC	XLIST	/ SAVE ALL THE POINTERS TO THIS CHAR
	LAC	LIST+1
	DAC	XLIST+1
	LAW	-1
	DAC	PNTCNT	/ MARK AS 1ST POINT
	JMP	HENTRY	/ RETURN TO MAIN SEQUENCE & STORE POINT
/
/ THIS SECTION IS ENTERED WHEN A MATCH OCCURS. THE .LOGICAL.
/ IS REMOVED AND THE INTERNAL CODE IS INSERTED IN ITS PLACE
PNTC6	LAC	XLIST	/ GET POINTERS TO 1ST POINT
	DAC	LIST	/ & SET ALL POINTERS BACK TO IT
	LAC	XLIST+1
	DAC	LIST+1
	LAC*	OPADD	/ POINTS AT CORRECT INTERNAL CODE
	JMP	EXPTIE	/ RETURN TO MAIN SEQUENCE
/
/
/
/
/
/
/
/
/
/THIS ROUTINE STEPS THE CHI POINTER BACK ONE CHARACTER AND
/ PLACES THE CHARACTER IN 'BOX' AND THE AC. THE LIST IS NOT ALTERED.
/
/ IF LAST CHAR. IN LEFT HALF WORD,(LIST+1)=000000
/ IF LAST CHAR. IN RIGHT HALF WORD,(LIST+1)=777777
/
BACK1	XX
	LAC*	LIST	/PICK UP TWO CHARACTERS
	ISZ	LIST+1	/WHICH ONE ?
	JMP	BACK0	/LEFT HALF WORD
/LAST CHAR IS IN RIGHT HALF WORD. (LIST+1) NOW POINTS TO LEFT
/ HALF WORD. EXCELLENT!
	AND	(777	/WIPE OUT LEFT HALF WORD
	DAC	BOX
	JMP*	BACK1
/
BACK0	LRSS	11	/GET LEFT HALF WORD
	DAC	BOX
	CLA!CMA		/AC=777777
	DAC	LIST+1	/MARKS RIGHT HALF AS LAST
	TAD	LIST	/DECREMENT POINTER
	DAC	LIST
	LAC	BOX
	JMP*	BACK1
/
/
/ SAVE ALL POINTERS AND INDICATORS TO THE PRESENT POSITION AS
/ WE BACKTRACK. IF FALSE ALARM WE CAN CONTINUE EASILY.
/
NOTE	XX
	LAC	LIST+1	/SAVE RIGHT-LEFT INDICATOR
	DAC	NLIST+1
	LAC	LIST	/SAVE LIST POINTER
	DAC	NLIST
	LAC	BOX	/SAVE PRESENT CHARACTER
	DAC	NBOX
	JMP*	NOTE
/
NBOX
NLIST	.BLOCK 2
/
/RESET LIST POINTERS
/
RESET	XX
	LAC	NLIST+1
	DAC	LIST+1
	LAC	NLIST
	DAC	LIST
	LAC	NBOX
	DAC	BOX
	JMP*	RESET
/
/ FIX LIST SO LOADING MAY COMMENCE
/
/
CLEARS	XX
	LAC	LIST+1	/LOAD INDICATOR
	SAD	(777777	/IS RIGHT-HALF WORD INDICATED.
	JMP*	CLEARS	/RETURN.
	LAC*	LIST	/PICK UP CURRENT WORD
	AND	(777000	/AND MAKE ROOM FOR RIGHT HALF
	DAC*	LIST
	JMP*	CLEARS
/
/
/***************************************************************
/THIS SECTION CONTAINS THE STATEMENT DESCRIPTORS FOR STATEMENT
/ IDENTIFICATION.
SPECS	.DSA	3
	II*1000+FF	/ IF(
	OPEN*1000
	JMP*	IFBRAC
/
	.DSA	4
	GG*1000+OO	/ GO TO , AND GO TO (
	TT*1000+OO
	JMP*	.GOTO
/
	.DSA	6
	FF*1000+OO	/FORMAT
	RR*1000+MM
	AA*1000+TT
	JMP*	FORMAT
/
	.DSA	5
	RR*1000+EE	/ READ(
	AA*1000+DD
	OPEN*1000
	JMP*	READBR
/
	.DSA	4
	RR*1000+EE	/ READ
	AA*1000+DD
	JMP*	READ.
/
	.DSA	5
	PP*1000+UU	/ PUNCH
	NN*1000+CC
	HH*1000
	JMP*	PUNCH.
/
	.DSA	6
	WW*1000+RR	/WRITE(
	II*1000+TT
	EE*1000+OPEN
	JMP*	WRITEB
/
	.DSA	4
	CC*1000+AA	/ CALL
	LL*1000+LL
	JMP*	CALLS
/
	.DSA	10
	CC*1000+OO	/ CONTINUE
	NN*1000+TT
	II*1000+NN
	UU*1000+EE
	JMP*	.CONT
/
	.DSA	3
	EE*1000+NN	/ END
	DD*1000
	JMP*	END
/
	.DSA	4
	DD*1000+AA	/ DATA
	TT*1000+AA
	JMP*	DATA
/
	11
	BB*1000+LL	/ BLOCK DATA
	OO*1000+CC
	KK*1000+DD
	AA*1000+TT
	AA*1000
	JMP*	BLDATA
/
	.DSA	5
	PP*1000+RR	/PRINT
	II*1000+NN
	TT*1000
	JMP*	PRINT.
/
	.DSA	6
	RR*1000+EE	/ RETURN
	TT*1000+UU
	RR*1000+NN
	JMP*	RETR
/
	.DSA	5
	PP*1000+AA	/ PAUSE
	UU*1000+SS
	EE*1000
	JMP*	.PAUSE
/
	.DSA	6
	AA*1000+SS	/ ASSIGN
	SS*1000+II
	GG*1000+NN
	JMP*	(ERRST5		/TO BE REMOVED WHEN 'ASSIGN' IMPLEMENTED
/**	JMP*	ASSGN
/
	.DSA	4
	SS*1000+TT	/ STOP
	OO*1000+PP
	JMP*	STOP
/
	.DSA	11
	DD*1000+II	/ DIMENSION
	MM*1000+EE
	NN*1000+SS
	II*1000+OO
	NN*1000
	JMP*	DIMEN
/
	.DSA	6
	CC*1000+OO	/ COMMON
	MM*1000+MM
	OO*1000+NN
	JMP*	COMMN
/
	.DSA	13
	EE*1000+QQ	/ EQUIVALENCE
	UU*1000+II
	VV*1000+AA
	LL*1000+EE
	NN*1000+CC
	EE*1000
	JMP*	EQUIV
/
	10
	DLR*1000+TT		/ $TRACEON
	RR*1000+AA
	CC*1000+EE
	OO*1000+NN
	JMP*	TRACON
/
	11
	DLR*1000+TT		/ $TRACEOFF
	RR*1000+AA
	CC*1000+EE
	OO*1000+FF
	FF*1000
	JMP*	TRACOFF
/
	.DSA	12
	SS*1000+UU	/ SUBROUTINE
	BB*1000+RR
	OO*1000+UU
	TT*1000+II
	NN*1000+EE
	JMP*	SUBR
/
	.DSA	10
	FF*1000+UU	/ FUNCTION
	NN*1000+CC
	TT*1000+II
	OO*1000+NN
	JMP*	FUNCT
/
	.DSA	14
	RR*1000+EE	/ REAL FUNCTION
	AA*1000+LL
	FF*1000+UU
	NN*1000+CC
	TT*1000+II
	OO*1000+NN
	JMP*	REALF
/
	.DSA	17
	II*1000+NN	/ INTEGER FUNCTION
	TT*1000+EE
	GG*1000+EE
	RR*1000+FF
	UU*1000+NN
	CC*1000+TT
	II*1000+OO
	NN*1000
	JMP*	INTF
/
	.DSA	25
	DD*1000+OO	/ DOUBLE INTEGER FUNCTION
	UU*1000+BB
	LL*1000+EE
	II*1000+NN
	TT*1000+EE
	GG*1000+EE
	RR*1000+FF
	UU*1000+NN
	CC*1000+TT
	II*1000+OO
	NN*1000
	JMP*	DINTF
/
	.DSA	17
	LL*1000+OO	/ LOGICAL FUNCTION
	GG*1000+II
	CC*1000+AA
	LL*1000+FF
	UU*1000+NN
	CC*1000+TT
	II*1000+OO
	NN*1000
	JMP*	LOGICF
/
/
	.DSA	27
	DD*1000+OO	/ DOUBLE PRECISION FUNCTION
	UU*1000+BB
	LL*1000+EE
	PP*1000+RR
	EE*1000+CC
	II*1000+SS
	II*1000+OO
	NN*1000+FF
	UU*1000+NN
	CC*1000+TT
	II*1000+OO
	NN*1000
	JMP*	DREALF
/
	.DSA	17
	CC*1000+OO	/ COMPLEX FUNCTION
	MM*1000+PP
	LL*1000+EE
	XXX*1000+FF
	UU*1000+NN
	CC*1000+TT
	II*1000+OO
	NN*1000
	JMP*	CMPLXF
/
	21
	CC*1000+HH		/CHARACTER FUNCTION
	AA*1000+RR
	AA*1000+CC
	TT*1000+EE
	RR*1000+FF
	UU*1000+NN
	CC*1000+TT
	II*1000+OO
	NN*1000
	JMP*	CHARF
/
	.DSA	10
	II*1000+MM	/ IMPLICIT
	PP*1000+LL
	II*1000+CC
	II*1000+TT
	JMP*	IMPLIC
/
	.DSA	10
	EE*1000+XXX	 / EXTERNAL
	TT*1000+EE
	RR*1000+NN
	AA*1000+LL
	JMP*	EXTRNL
/
MODES	.DSA	11
	LL*1000+OO	/ LOGICAL*4
	GG*1000+II
	CC*1000+AA
	LL*1000+STAR
	FOUR*1000
	JMP*	LOGIC
/
	.DSA	11
	LL*1000+OO	/ LOGICAL*2
	GG*1000+II
	CC*1000+AA
	LL*1000+STAR
	TWO*1000
	JMP*	LOGIC
/
	.DSA	7
	LL*1000+OO	/ LOGICAL
	GG*1000+II
	CC*1000+AA
	LL*1000
	JMP*	LOGIC
/
	.DSA	11
	II*1000+NN	/ INTEGER*4
	TT*1000+EE
	GG*1000+EE
	RR*1000+STAR
	FOUR*1000
	JMP*	DBLINT
/
	.DSA	11
	II*1000+NN	/ INTEGER*2
	TT*1000+EE
	GG*1000+EE
	RR*1000+STAR
	TWO*1000
	JMP*	INTGR
/
	.DSA	7
	II*1000+NN	/ INTEGER
	TT*1000+EE
	GG*1000+EE
	RR*1000
	JMP*	INTGR
/
	.DSA	6
	RR*1000+EE	/ REAL*8
	AA*1000+LL
	STAR*1000+EIGHT
	JMP*	DBLREL
/
	.DSA	6
	RR*1000+EE	/ REAL*4
	AA*1000+LL
	STAR*1000+FOUR
	JMP*	REAL
/
	.DSA	4
	RR*1000+EE	/ REAL
	AA*1000+LL
	JMP*	REAL
/
	.DSA	12
	CC*1000+OO	/ COMPLEX*16
	MM*1000+PP
	LL*1000+EE
	XXX*1000+STAR
	ONE*1000+SIX
	JMP*	DBCPLX
/
	.DSA	11
	CC*1000+OO	/ COMPLEX*8
	MM*1000+PP
	LL*1000+EE
	XXX*1000+STAR
	EIGHT*1000
	JMP*	COMPLX
/
	.DSA	7
	CC*1000+OO	/ COMPLEX
	MM*1000+PP
	LL*1000+EE
	XXX*1000
	JMP*	COMPLX
/
	15
	DD*1000+OO
	UU*1000+BB
	LL*1000+EE
	II*1000+NN
	TT*1000+EE
	GG*1000+EE
	RR*1000
	JMP*	DBLINT
/
	.DSA	17
	DD*1000+OO	/ DOUBLE PRECISION
	UU*1000+BB
	LL*1000+EE
	PP*1000+RR
	EE*1000+CC
	II*1000+SS
	II*1000+OO
	NN*1000
	JMP*	DBLREL
/
	.DSA	11
	CC*1000+HH	/ CHARACTER
	AA*1000+RR
	AA*1000+CC
	TT*1000+EE
	RR*1000
	JMP*	CHARAC
/
	.DSA	-1	/END OF TABLE INDICATOR.
/
/
TOTAL;NXTSPC;SAVCNT;KOUNT
/
/ THIS SUBROUTINE COMPARES THE CONTENTS OF ANY REGISTERS
/  WITH THE ABOVE SPECIFICATION DESCRIPTORS.
/IF NO MATCH OCCURS IT EXITS TO THE NORMAL RETURN ADDRESS+1
/IF A MATCH OCCURS ON A FULL WORD IT EXITS TO NORMAL RETURN ADDRESS+3
/ IF A MATCH OCCURS ON A HALF WORD IT EXITS TO NORMAL RETURN ADDRESS+4
CMPARE	XX
	LAC*	AUTO10		/ GET CHAR COUNT
	SPA			/ IS IT END OF TABLE ?
	JMP	ENDTAB		/ YES
	DAC	SAVCNT		/SAVE IT.
	TAD	(2+2+1
	RCR			/GET # OF WHOLE WORDS IN SPEC
	TAD	NXTSPC		/ADD PREVIOUS SPEC ADDRESS
	DAC	NXTSPC		/TO GET NEXT SPEC ADDRESS.
/
/THIS SECTION SETS UP NEG WORD COUNT & HALF WORD INDICATOR
	LAC	SAVCNT		/GET CHAR COUNT.
	RCR			/ L_1 IF HALF WORD&DIVIDE BY 2
	CMA
	TAD	(1
	DAC	KOUNT		/STORE IT
/
/ THIS SECTION COMPARES 'CHI' AGAINST SPECS.
TEST	LAC*	AUTO11	/GET WORD FROM CHI
	SAD*	AUTO10	/COMPARE WITH WORD IN SPEC.
	SKP
	JMP*	CMPARE	/WORDS NOT SAME. TRY NEXT SPEC
	ISZ	KOUNT	/IS WORD COUNT FINISHED?
	JMP	TEST	/NO. CONTINUE
	SZL		/YES. DOES HALF WORD EXIST?
	JMP	HAFWD	/YES. CHECK IT.
	LAC	(3
	JMP	SETXIT
/
HAFWD	LAC*	AUTO11	/GET HALF-WORD FROM CHI
	AND	(777000	/CLEAR RIGHT HALF.
	SAD*	AUTO10	/COMPARE?
	SKP
	JMP*	CMPARE	/NO MATCH. TRY AGAIN
	LAC	(4	/ NORMAL RETURN + 4
SETXIT	TAD	CMPARE
	DAC	CMPARE
	JMP*	CMPARE
/
/
ENDTAB	ISZ	CMPARE
	JMP*	CMPARE
	.EJECT
/
/
/*************************************************************
/***************************************************************
/
/THIS SECTION CONTAINS THE ERROR BUFFERS WHICH ARE HOOKED INTO THE
/ MAIN I/O-SECTION TO ISSUE THE ERRORS AFTER THE APPROPIATE LINE.
/THE SECTION IS ENTERED WITH A SIXBIT CODE IN THE AC WHICH IS THEN
/ CONVERTED TO 5/7 ASCII AND STUFFED INTO THE ERROR MESSAGE.
/  AN ABREVIATED ERROR MESSAGE IS ISSUED IF A PROGRAM
/ LISTING IS REQ'D, ELSE A FULL MESSAGE GIVING THE STATEMENT NUMBER
/ AND THE LINE COUNT WHERE THE ERROR OCCURRED.
/
BLOWN
/
/ THE FOLLOWING MACRO COPIES THE SEQUENCE '****ERROR' OR
/   THE SEQUENCE '**WARNING' INTO THE ERROR STATEMENT BEFORE
/   IT IS TRANSFERRED TO THE ERROR BUFFER.
	.DEFIN LOADS,ERR
	JMS	HOOK		/WAIT FOR PRINTING TO CATCH UP
	LAC	ERR
	DAC	ERRSTA+2
	LAC	ERR+1
	DAC	ERRSTA+3
	LAC	ERR+2
	DAC	ERRSTA+4
	LAC	ERR+3
	DAC	ERRSTA+5
	.ENDM
/
ERR	.ASCII '****ERROR '
WRN	.ASCII '**WARNING '
/
/SUBROUTINE TO LOAD ERROR MESSAGE
LDERR	XX
	LOADS	ERR
	ISZ	BLOWN		/MARK PROGRAM AS HAVING AN ERROR
	DZM	BINSW		/NO MORE BINARY AFTER ERROR DETECTED
	JMP*	LDERR
/
/
ERRORS	XX
	JMS	LDERR
	LAC*	ERRORS	/ GET SIXBIT ERROR DESCRIPTOR
	JMS	ISSUE
	JMP	RETRN
/
ERROR	XX
	JMS	LDERR
	LAC*	ERROR	/ GET SIXBIT ERROR DESCRIPTOR
	ISZ	ERROR	/ SKIP OVER DESCRIPTOR
	JMS	ISSUE
	JMP*	ERROR
/
WARN	XX
	LOADS	WRN
	LAC*	ERSW		/SAVE STATUS OF 'ERSW'
	DAC	TEMP1
	DZM*	ERSW		/WANT TO RETURN NORMALLY FROM WARNING
	LAC*	WARN	/ GET SIXBIT WARNING DESCRIPTOR
	ISZ	WARN	/ SKIP OVER DESCRIPTOR
	JMS	ISSUE
	LAC	TEMP1
	DAC*	ERSW		/RESTORE 'ERSW'
	JMP*	WARN
/
REFER
TEMP1
/
ISSUE	XX
%ISSUE=ISSUE
	ISZ	%ERCNT		/COUNT ALL ERRORS & WARNINGS
	LMQ
	DAC	REFER
	LAC	(ERRSTA+6	/ START OF STORAGE
	JMS*	G.STPC	/ INITIALIZE G.PACK ROUTINE
	LAW	1
	LLS	6
	JMS*	G.PACK
	LAC	REFER
	LRS	6
	AND	(000077
	XOR	(000100	/ CONVERT SIXBIT TO ASCII
	JMS*	G.PACK
	LAC	REFER
	AND	(000077
	TAD	(-60
	SPA!CLL		/ IS IT NUMERIC OR ALPHABETIC
	STL		/ ITS ALPHABETIC,SET LINK
	LAC	REFER
	AND	(000077
	SZL
	XOR	(000100
	JMS*	G.PACK
	LAC	NOSAVE	/STORE LAST STATEMENT NO.,
	DAC	ERRSTA+16 / IN ERROR MESSAGE.
	LAC	NOSAVE+1
	DAC	ERRSTA+17
/
	LAC	(ERRSTA+22	/ START OF STORAGE
	JMS*	G.STPC	/ INITIALIZE G.PACK ROUTINE
	LAC	(6-5
	DAC*	NUMS	/ CONVERT ONLY 5 DIGITS
	LAC	LINE1
	CLL		/ PRINT LEADING ZEROS
	JMS*	G.CVRT	/ CONVERT LINE COUNT TO ASCII
/
/ GET THE NAME OF THE PROGRAM WE ARE COMPILING AND STICK IT IN
/ THE ERROR MESSAGE
	LAC*	PNAME
	DAC	ERRSTA+30
	LAC*	PNAM1
	DAC	ERRSTA+31
	LAC*	PNAM2
	XOR	(000320
	DAC	ERRSTA+32
/
WRITS	.WRITE	LP,2,ERRSTA,0	/WRITE OUT THE ERROR
	ISZ*	ERSW
	JMP*	ISSUE		/NORMAL EXIT
	JMP*	OVERS		/EXIT FOR DATA IN
/
/  THIS SUBROUTINE PUTS A HOOK IN THE CURRENT BUFFER BEING
/  PROCESSED AND ALLOWS PRINTING TO CATCH UP.
/  RETURNS TO 'HAVERR'.
/
HOOK	XX
	ISZ*	THERE		/MARK LINE AS HAVING ERROR
	JMS	TESOUT		/ALLOW PRINTING
	JMP	.-1
HAVERR	DZM*	THERE		/REMOVE ERROR INDICATOR
	.WAIT	LP		/IN CASE OF MULTIPLE ERRORS
	JMP*	HOOK
/
ERRSTA	.DSA ERRFIN-.*400+2
	0		/ZEROED BY BULK STORAGE LISTING DEVICES!!
	.ASCII '****ERROR @@@@@  IN STATEMENT @@@@@'
	.ASCII <0>' + '<0>'@@@@@ LINES IN @@@@@@'<215>
ERRFIN	ERRSTA
/
	.END	.START