.TITLE	CC100
	.IDENT	/X01/
 
	.NLIST	BEX
	.ENABL	LC
 
;
; C COMPILER
; EXTERNAL DEFINITIONS
;
; VERSION X01
;
; DAVID G. CONROY	14-NOV-77
;
 
	.GLOBL	CC100
	.GLOBL	FRETLB
	.GLOBL	FSYMBL
	.GLOBL	CANDT
	.GLOBL	CANDT1
	.GLOBL	DUPDIM
	.GLOBL	ERROR
	.GLOBL	WARN
	.GLOBL	NERRS
	.GLOBL	CLASS
	.GLOBL	TYPE
	.GLOBL	DIMP
	.GLOBL	DOPE
	.GLOBL	OFFSET
	.GLOBL	MOFSET
	.GLOBL	PARMS
	.GLOBL	PARPTR
	.GLOBL	NXTREG
	.GLOBL	DECLST
 
	.MCALL	CALL
	.MCALL	CALLR
	.MCALL	RETURN
 
;
; GLOBAL DATA
;
 
FSYMBL:	.BLKW	1		;SYMBOL NODE OF CURRENT FUNCTION
FRETLB:	.BLKW	1		;FUNCTION RETURN LABEL
CLASS:	.BLKW	1		;DECLARATION CLASS
TYPE:	.BLKW	1		;DECLARATION TYPE
DIMP:	.BLKW	1		;DECLARATION DIMP
DOPE:	.BLKW	1		;DECLARATION DOPE
OFFSET:	.BLKW	1		;DECLARATION OFFSET
MOFSET:	.BLKW	1		;DECLARATION MAX OFFSET
NXTREG:	.BLKW	1		;DECLARATION NEXT REGISTER
PARPTR:	.BLKW	1		;FORMAL PARAMETER POINTER
PARMS:	.BLKW	20.		;FORMAL PARAMETER BUFFER
PARMSE:	.BLKW	0		;END MARK
 
;
; LOCAL DATA
;
 
ANINT:	.WORD	0		;DUMMY SYMBOL NODE FOR CSINIT
	.BYTE	0		;CLASS
	.BYTE	TY.INT		;TYPE
	.WORD	0		;DIMP
	.WORD	0		;DOPE
 
ATYPE:	.BLKW	1		;SAVE FOR TYPE IN DEFINE
ACLASS:	.BLKW	1		;SAVE FOR CLASS IN DEFINE
DOPEPT:	.BLKW	1		;FOR BUILDING STRUCT DOPE LIST
LONGF:	.BLKW	1		;'LONG' FLAG
SHORTF:	.BLKW	1		;'SHORT' FLAG
USIGNF:	.BLKW	1		;'UNSIGNED' FLAG
UNION:	.BLKW	1		;DECLARING A UNION FLAG
AF:	.BLKB	1		;ARRAY FLAG
FF:	.BLKB	1		;FUNCTION FLAG
RF:	.BLKB	1		;REDEFINITION FLAG
MBUF:	.BLKB	100		;MESSAGE FORMAT BUFFER (ERROR/WARN)
 
;
; DIAGNOSTICS
;
 
ERR01:	.ASCIZ	"Class must be external or static"
ERR02:	.ASCIZ	"External syntax"
ERR03:	.ASCIZ	"Compound statement required"
ERR04:	.ASCIZ	"Too many class specifiers"
ERR05:	.ASCIZ	"Too many type specifiers"
ERR06:	.ASCIZ	"Misplaced 'long', 'short' or 'unsigned'"
ERR07:	.ASCIZ	"Declaration syntax"
ERR08:	.ASCIZ	"Declaration semantically forbidden"
ERR09:	.ASCIZ	"Structure offset redeclaration"
ERR10:	.ASCIZ	"Redeclaration"
ERR11:	.ASCIZ	"Formal parameter required"
ERR12:	.ASCIZ	"Argument semantically forbidden"
ERR13:	.ASCIZ	"Zero length row"
ERR14:	.ASCIZ	"Too many initialisers"
ERR15:	.ASCIZ	"Constant initialiser required"
ERR16:	.ASCIZ	"Too many structure initialisers"
ERR17:	.ASCIZ	"Cannot initialise union or automatic aggregate"
 
	.EVEN
	.PAGE
;+
; ** CC100 - PHASE 1 MAINLINE
;
; THIS IS MAINLINE OF THE PARSER. WHEN CALLED FROM THE ROOT, SFDB IS
; OPEN AND CONTAINS THE EXPANDED SOURCE, PUT THERE BY CC000. IT MUST
; BE REWOUND BEFORE USE. IFDB IS OPEN AND IS USED  FOR  INTERMEDIATE
; LANGUAGE.
;
; CC100 FIRST CALLS KWINIT TO PUT THE RESERVED WORDS IN THE   SYMBOL
; TABLE, THEN LOOPS AROUND (UNTIL EOF) COMPILING EXTERNALS. WHEN THE
; END OF THE SOURCE IS REACHED, THE GLOBAL RECORDS ARE OUTPUT TO THE
; INTERMEDIATE FILE, AND CONTROL RETURNS TO THE ROOT.
;
; SOURCE ERRORS ARE ACCUMULATED IN THE GLOBAL CELL NERRS. THIS  CELL
; IS CHECKED BY THE ROOT; PHASE 2 IS NOT CALLED IF THERE WERE ERRORS
; IN PHASE 1. TOO BAD TO ALL YOU SLOBS WITH UNIX 5 PROGRAMMES.
;-
 
CC100:	MOV	#SFDB,R0	;REWIND THE SOURCE
	CLR	R1		;
	MOV	#1,R2		;
	CLR	R3		;
	CALL	.POINT		;
 
	CALL	KWINIT		;INITIALISE SYMBOL TABLE
	CALL	PREC		;SET CORRECT PSECTION
	CALL	ADVANC		;GET FIRST TOKEN 
 
10$:	CMP	LEX1,#OP.EOF	;AT END OF FILE
	BEQ	20$		;YES
	CALL	EXDEFN		;COMPILE AN EXTERNAL
	BR	10$		;
 
20$:	CALLR	GLOBS		;PUT OUT THE 'G' DIRECTIVES
 
;+
; ** EXDEFN - COMPILE AN EXTERNAL DECLARATION
;
; THIS ROUTINE COMPILES A SINGLE EXTERNAL DECLARATION, BE  IT A  DATA
; DECLARATION OR A FUNCTION DECLARATION. IT JUST RETURNS ON SEMICOLON
; (NULL DECLARATION) AND EOF.
;
; THERE IS SOME PDP-11 SPECIFIC CODE HERE.  ALL  OF IT HAS TO DO WITH
; WORD ALLIGNMENT, IN THE DISGUISE OF CALLS TO ALLIGN.
;
; USES:
;	ALL
;-
 
EXDEFN:	CMP	LEX1,#OP.EOF	;END OF FILE
	BEQ	10$		;YES
 
	CMP	LEX1,#OP.SEM	;NULL DECLARATION
	BNE	15$		;NO
	CALL	SCAN		;SKIP IT
10$:	JMP	70$		;AND RETURN
 
15$:	CLR	FSYMBL		;SET NOT IN FUNCTION
	CALL	CANDT		;GET CLASS AND TYPE
	TST	CLASS		;IF NO CLASS
	BNE	20$		;MAKE IT
	MOV	#CL.GBD,CLASS	;SYMDEF

20$:	TST	TYPE		;IF NO TYPE
	BNE	22$		;MAKE
	MOV	#TY.INT,TYPE	;INT
 
22$:	MOV	CLASS,R0	;GET CLASS 
	CMP	R0,#CL.TYP	;TYPEDEF
	BEQ	24$		;YES

	CMP	R0,#CL.SIN	;STATIC (INTERNAL)
	BNE	23$		;NO
	MOV	#CL.SEX,CLASS	;YES, SET STATIC (EXTERNAL)
	BR	24$		;

23$:	CMP	R0,#CL.GBD	;CLASS
	BEQ	24$		;MUST
	CMP	R0,#CL.GBR	;BE
	BEQ	24$		;EXTERNAL
	MOV	#ERR01,R0	;OR ITS
	CALL	ERROR		;AN ERROR
	MOV	#CL.GBD,CLASS	;FORCE SYMDEF
 
24$:	CMP	LEX1,#OP.SEM	;IF ONLY A TYPE
	BNE	25$		;THEN
	CALL	SCAN		;SKIP THE SEMICOLON
	BR	70$		;AND RETURN
 
25$:	CALL	GDECLR		;GET A DECLARATOR
	BCS	50$		;ERROR
	CALL	DEFINE		;DECLARE IT
 
	CMP	CLASS,#CL.GBR	;IS THIS A GLOBL REFERENCE
	BEQ	26$		;YES
	CMP	CLASS,#CL.TYP	;HOW ABOUT A TYPEDEF
	BNE	27$		;NO
26$:	CALL	SCAN		;IF SO, NO BODY IS ALLOWED
	BR	41$		;GO CHECK FOR DELIMITER
 
27$:	MOVB	#'D,R0		;PUT OUT 'D' RECORD
	CALL	CODC		;
	MOVB	#' ,R0		;
	CALL	CODC		;
	MOV	R5,R0		;
	ADD	#S.NAME,R0	;
	CALL	CODSTR		;
	CALL	CODNL		;
 
	MOV	S.DIMP(R5),R0	;IF THE DECLARATOR IS A FUNCTION
	BEQ	30$		;NO
	CMP	D.TYPE(R0),#DT.FUN ;PERHAPS
	BNE	30$		;NO
	MOV	R5,FSYMBL	;SAVE POINTER TO FUNCTION NAME
	CALL	CFUNC		;COMPILE IT
	BR	70$		;RETURN
 
30$:	CALL	SCAN		;IF THE NEXT TOKEN IS ',' OR ';'
	CMP	R0,#OP.CMA	;
	BEQ	32$		;
	CMP	R0,#OP.SEM	;
	BNE	34$		;
32$:	CALL	SLENG		;ALLOCATE BSS
	CALL	BREC		;
	BR	40$		;
 
34$:	CMP	R0,#OP.ASG	;IS IT AN '=' (7TH EDITION)
	BNE	36$		;NO
	CALL	SCAN		;EAT IT

36$:	MOV	#1,R4		;OTHERWISE DO
	CALL	CINIT		;INITIALISERS (FLEX)
 
40$:	CALL	ALLIGN		;ALLIGN EVEN
	MOV	LEX0,R0		;PICK UP DELIMITER TOKEN
41$:	CMP	R0,#OP.CMA	;IF COMMA
	BEQ	24$		;GO GET THE NEXT DECLARATOR
	CMP	R0,#OP.SEM	;IF SEMICOLON
	BEQ	70$		;RETURN
 
50$:	MOV	#ERR02,R0	;SYNTAX ERROR
	CALL	ERROR		;
 
	MOV	LEX0,R0		;SKIP OVER BAD INPUT
60$:	CMP	R0,#OP.LBR	;IF OPEN BRACE
	BNE	65$		;THEN
	MOV	R5,FSYMBL	;SAVE POINTER TO FUNCTION NAME
	MOV	#1,R5		;COMPILE A FUNCTION
	CALL	STATE		;STATEMENT
	BR	70$		;RETURN
 
65$:	CALL	ESCAN		;GET NEXT TOKEN
	CMP	R0,#OP.SEM	;IF SEMICOLON
	BEQ	70$		;OR
	CMP	R0,#OP.EOF	;END OF FILE
	BNE	60$		;JUST
 
70$:	RETURN			;RETURN
 
;+
; ** CFUNC - COMPILE A FUNCTION
;
; THIS ROUTINE IS CALLED BY EXDEFN TO COMPILE A FUNCTION. ON ENTRY THE
; FUNCTION DECLARATOR HAS BEEN COMPLETELY READ IN. THE ARGUMENTS  HAVE
; ALL BEEN DECLARED AS CL.ARG AND TY.INT (DEFINE CHECKS FOR THIS  TYPE
; AND PERMITS REDECLARATION). 
;
; FSYMBL CONTAINS THE POINTER TO THE SYMBOL TABLE NODE OF THE FUNCTION
; NAME. THIS IS USED TO OUTPUT THE NAME IN THE 'N' DIRECTIVE AND (NOTE
; BENE) TO OBTAIN THE RETURN TYPE OF THE FUNCTION SO THE RETURN STATE-
; MENT CAN PERFORM THE REQUIRED TYPE CONVERSIONS.
;
; USES:
;	ALL
;-
 
CFUNC:	MOV	#4,NXTREG	;START REGISTER ALLOCATION

10$:	CALL	CANDT		;GET CLASS AND TYPE
	MOV	CLASS,R0	;IF NO CLASS OR
	BIS	TYPE,R0		;TYPE
	BEQ	60$		;ASSUME NO DECLARATION

	TST	TYPE		;IS THERE A TYPE
	BNE	20$		;YES
	MOV	#TY.INT,TYPE	;NO, MAKE IT INT

20$:	MOV	CLASS,R0	;GET CLASS
	BEQ	40$		;NONE SPECIFIED (CL.DEF)
	CMP	R0,#CL.REG	;REGISTER
	BNE	30$		;NO, ERROR
	MOV	#CL.DRG,CLASS	;SET DEFINED REGISTER ARGUMENT
	BR	50$		;

30$:	MOV	#ERR04,R0	;COMPLAIN
	CALL	ERROR		;
40$:	MOV	#CL.DEF,CLASS	;SET DEFAULT CLASS

50$:	CALL	DECLST		;COMPILE A LIST OF DECLS
	BR	10$		;
 
60$:	CMP	LEX1,#OP.LBR	;MUST BE A LEFT BRACE
	BEQ	70$		;
	MOV	#ERR03,R0	;OR
	CALL	ERROR		;ITS AN ERROR
 
70$:	CALL	GENLAB		;SET UP FUNCTION
	MOV	R0,FRETLB	;RETURN LABEL
	MOV	#1,R5		;COMPILE A STATEMENT
	CALL	STATE		;
	MOV	FRETLB,R0	;PUT OUT THE
	CALL	LREC		;RETURN LABEL
	MOVB	#'X,R0		;AND THE RETURN OPERATOR
	CALL	CODC		;
	CALL	CODNL		;
 
	CALL	ULABS		;CHECK FOR UNDEFINED LABELS
	CALLR	PURGE		;CLEAR OUT SYMBOL TABLE
 
;+
; ** CINIT - COMPILE INITIALISERS
;
; C INITIALISERS ARE SCREWY. I THINK THIS DOES WHAT THE MEMO FROM DMR
; SAYS. HOWEVER, THE MEMO IS FAR FROM CLEAR.
;
; INPUTS:
;	R4=FLEX FLAG (1 MEANS FLEX OK)
;	R5=SYMBOL TABLE NODE
;	LEX0=FIRST TOKEN OF THE INITIALISER
;
; OUTPUTS:
;	LEX0=TOKEN THAT DELIMITED THE INITIALISER
;
; USES:
;	R0, R1
;-
 
FLEX	=	14		;FLEX FLAG (R4)
BRACE	=	6		;BRACE FLAG
ODIMP	=	4		;OLD DIMP FOR ARRAYS
NEL	=	2		;NUMBER OF ELEMENTS
WIDTH	=	0		;WIDTH OF AN ELEMENT
 
CINIT:	MOV	R5,-(SP)	;SAVE ARGUMENTS AND REGISTERS
	MOV	R4,-(SP)	;
	MOV	R3,-(SP)	;
	MOV	R2,-(SP)	;
	SUB	#10,SP		;GET SPACE FOR LOCALS
 
;
; CANNOT INITIALISE AUTOMATIC AGGREGATES.
;

	CMPB	S.CLAS(R5),#CL.AUT ;AUTO
	BNE	2$		;NO
	MOV	S.DIMP(R5),R0	;GET POINTER TO DIMENSIONS
	BEQ	1$		;BR IF SCALAR
	CMP	D.TYPE(R0),#DT.ARY ;IS IT AN ARRAY
	BEQ	3$		;YES, ERROR
	BR	4$		;

1$:	CMPB	S.TYPE(R5),#TY.UST ;STRUCT OR UNION
	BHIS	3$		;YES, ERROR
	BR	4$		;

;
; CANNOT INITIALISE UNIONS.
;

2$:	CMPB	S.TYPE(R5),#TY.UUN ;IS IT AN UNDEFINED UNION
	BEQ	2500$		;YES
	CMPB	S.TYPE(R5),#TY.UNI ;NO, IS IT A (DEFINED) UNION
	BNE	4$		;NO
2500$:	MOV	S.DIMP(R5),R0	;MIGHT BE POINTER TO UNION
	BEQ	3$		;NO
	CMP	D.TYPE(R0),#DT.ARY ;WELL
	BNE	4$		;OK

3$:	MOV	#ERR17,R0	;COMPLAIN
	CALL	ERROR		;

;
; IF THE ITEM BEING INITIALISED IS AN ARRAY, ADJUST THE DIMENSIONS TO
; REMOVE THE TOP LEVEL "ARRAY OF".
;
 
4$:	CALL	SLENG		;GET SIZE OF THE THING
	MOV	R0,WIDTH(SP)	;SAVE IT
 
	MOV	S.DIMP(R5),R0	;GET THE DIMP OF THE SYMBOL
	MOV	R0,ODIMP(SP)	;SAVE IN CASE OF ARRAY
	BEQ	10$		;SCALAR
	CMP	D.TYPE(R0),#DT.ARY ;IS IT AN ARRAY
	BNE	10$		;NO
 
	MOV	(R0),S.DIMP(R5)	;UNDO ONE LEVEL OF 'ARRAY OF'
	TST	WIDTH(SP)	;LOOK FOR 0 LENGTH ROWS
	BNE	20$
	TST	FLEX(SP)
	BNE	20$		;OK IF UNDER A FLEX BOUND
	MOV	#ERR13,R0	;ERROR
	CALL	ERROR
	BR	20$
 
10$:	CLR	FLEX(SP)	;IF NOT ARRAY, NO FLEX ALLOWED
 
;
; COMPUTE THE NUMBER OF ELEMENTS AND THE PER ELEMENT SIZE.
;
 
20$:	CALL	SLENG		;GET THE LENGTH NOW (ARRAYS HAVE CHANGED)
	MOV	R0,R2		;
	MOV	WIDTH(SP),R1	;WIDTH/NEW WIDTH = NUMBER OF ELEMENTS
	CLR	R0		;
	MOV	R2,-(SP)	;
	CALL	$DIVR0		;
	TST	(SP)+		;
	MOV	R0,NEL(SP)	;
 
	MOV	WIDTH(SP),R1	;WIDTH/NEL = ELEMENT SIZE (WIDTH)
	CLR	R0		;
	MOV	NEL(SP),-(SP)	;
	CALL	$DIVR0		;
	TST	(SP)+		;
	MOV	R0,WIDTH(SP)	;
 
;
; SET BRACE FLAG IF THE NEXT TOKEN IS A BRACE AND WE HAVE SOMETHING
; OTHER THAN A SCALAR STRUCTURE (OR UNION).
;
 
	CLR	BRACE(SP)	;NOT IN A BRACE
	CMP	LEX0,#OP.LBR	;IS THE NEXT TOKEN A BRACE
	BNE	25$		;NO
	TST	ODIMP(SP)	;TEST IF SCALAR
	BNE	24$		;NOT SCALAR
	CMPB	S.TYPE(R5),#TY.UST ;SCALAR, CHECK FOR STRUCT (OR UNION)
	BHIS	25$		;BR IF STRUCT (OR UNION)
24$:	INC	BRACE(SP)	;SET THE BRACE FLAG AND
	CALL	SCAN		;SKIP THE BRACE
 
;
; THIS IS THE MAIN LOOP FOR READING IN THE INITIALISERS.  THROUGHOUT
; THIS SECTION, R3 CONTAINS THE NUMBER OF INITIALISERS READ.
;
 
25$:	CLR	R3		;START AT ZERO
 
30$:	MOV	LEX0,R0		;WHAT IS COMING UP
	CMP	R0,#OP.RBR	;DUCK OUT IF
	BEQ	130$		;OPEN BRACE
 
	TST	S.DIMP(R5)	;IF THE ITEM IS A
	BNE	35$		;SCALAR STRUCTURE (OR UNION)
	CMPB	S.TYPE(R5),#TY.UST ;
	BLO	35$		;THEN
	CALL	CSINIT		;USE SPECIAL ROUTINE
	BR	120$		;
 
35$:	CMP	R0,#OP.LBR	;IF THE NEXT TOKEN IS A BRACE
	BNE	37$		;
	MOV	S.DIMP(R5),R0	;AND THE ITEM IS AN ARRAY
	BEQ	37$		;
	CMP	D.TYPE(R0),#DT.ARY ;
	BNE	37$		;
	CLR	R4		;CALL CINIT TO DO IT (RECURSIVELY)
	CALL	CINIT		;
	BR	120$		;
 
37$:	CMP	R0,#OP.CST	;CHARACTER STRING
	BNE	90$		;NO
	TST	S.DIMP(R5)	;TEST IF DOING BYTES
	BNE	60$		;NO
	CMPB	S.TYPE(R5),#TY.CHR ;PERHAPS
	BNE	60$		;NO
	MOV	#'",R1		;TAKE THE STRING APART
40$:	CALL	MAPCH		;
	BCS	50$		;END
	CALL	HREC		;AND PUT IT OUT BYTE AT A TIME
	INC	R3		;COUNT 1 THING
	BR	40$		;
50$:	CALL	ADVANC		;START UP THE SCANNER AGAIN
	CALL	SCAN		;
	BR	130$		;DONE THIS ITEM
 
60$:	CALL	GETSTR		;NOT INITIALISING BYTES
	CALL	IREC		;WE GET A POINTER
	CALL	SCAN		;
	BR	120$		;
 
90$:	MOV	R5,-(SP)	;SAVE THE SYMBOL POINTER
	CALL	CLRTRE		;CLEAR OLD TREE
	INC	INITFG		;MAKE ',' AND ':' SPECIAL
	CALL	EXPR		;
	CLR	INITFG		;NOT SPECIAL ANY MORE
 
	MOV	#ES.OP,R2	;GET A TREE NODE
	CALL	TREESP		;
	MOV	#OP.CVR,(R2)	;TO PASS THE SYMBOL TYPE IN
	MOV	R5,E.LOP(R2)	;LEFT TREE IS FROM EXPR
	MOV	(SP),R5		;THEN RECOVER THE SYMBOL AND
	MOVB	S.TYPE(R5),E.TYPE(R2) ;FILL IN THE NODE
	MOV	S.DIMP(R5),E.DIMP(R2) ;
	MOV	S.DOPE(R5),R5	;
	BEQ	92$		;
	MOV	S.SSIZ(R5),E.SSIZ(R2) ;
 
92$:	MOVB	#'K,R0		;OUTPUT THE TREE
	CALL	CODC		;
	CALL	CODNL		;
	MOV	R2,R5		;
	CALL	OUTREE		;
	MOV	(SP)+,R5	;RECOVER SYMBOL POINTER
 
120$:	INC	R3		;COUNT UP AN ITEM
 
	MOV	LEX0,R0		;GET DELIMITER
	CMP	R0,#OP.CMA	;COMMA
	BNE	130$		;NO, STOP
	TST	FLEX(SP)	;IF FLEX ALWAYS CONTINUE
	BNE	125$		;
	CMP	R3,NEL(SP)	;OTHERWISE CONTINUE IF MORE
	BHIS	130$		;ARE NEEDED
 
125$:	CALL	SCAN		;GET NEXT TOKEN AND
	BR	30$		;GO FOR MORE
 
130$:	CMP	R0,#OP.RBR	;IF THE NEXT TOKEN IS A RIGHT BRACE
	BNE	140$		;
	TST	BRACE(SP)	;AND THE BRACE FLAG IS SET
	BEQ	140$		;THEN
	CALL	SCAN		;EAT UP THE BRACE
 
;
; IF TOO FEW INITIALISERS, ALLOCATE MORE STORAGE.
; IF TOO MANY INITIALISERS, AND THE BOUNDS ARE FLEXABLE, INCREMENT THE
; SIZE FOR THE BENEFIT OF SIZEOF.
;
 
140$:	CMP	R3,NEL(SP)	;COMPARE WHAT WE GOT TO WHAT WE NEEDED
	BEQ	160$		;EXACT
	BHI	150$		;TOO MANY
 
	MOV	NEL(SP),R1	;PUT OUT A 'B' FOR THE REST
	SUB	R3,R1		;
	MOV	WIDTH(SP),-(SP)	;
	CALL	$MULR1		;
	TST	(SP)+		;
	MOV	R1,R0		;
	CALL	BREC		;
	BR	160$		;
 
150$:	TST	FLEX(SP)	;IS TOO MANY OK
	BEQ	155$		;NO
	MOV	ODIMP(SP),R0	;YES, FIDDLE THE DIMP
	MOV	R3,D.BOUN(R0)	;
	BR	160$		;
 
155$:	MOV	#ERR14,R0	;TOO MANY INITIALISERS
	CALL	ERROR		;
 
160$:	MOV	ODIMP(SP),S.DIMP(R5) ;REPLACE THE DIMENSIONS
 
	ADD	#10,SP		;RETURN
	MOV	(SP)+,R2	;
	MOV	(SP)+,R3	;
	MOV	(SP)+,R4	;
	MOV	(SP)+,R5	;
	RETURN			;
 
;+
; ** CSINIT - COMPILE STRUCTURE INITIALISERS
;
; THIS ROUTINE IS CALLED BY CINIT TO INITIALISE A STRUCTURE. IT USES
; THE DOPE LIST (POINTED TO BY THE S.DOPE FIELD OF THE SYMBOL  TABLE
; ENTRY) TO GET THE TYPES RIGHT.
;
; THIS ROUTINE ALSO GETS CALLED ON UNIONS. INITIALISATION  OF UNIONS
; IS FORBIDDEN. WE JUST PRETEND THAT THE UNION IS A STRUCT TO  AVOID
; HAVING TO RESYNC AFTER THE (BAD) INITIALISOR. DON'T WORRY, 'CINIT'
; PUTS OUT A DIAGNOSTIC.
;
; INPUTS:
;	R5=SYMBOL TABLE POINTER
;	LEX0=FIRST TOKEN OF THE INITIALISER
;
; OUTPUTS:
;	LEX0=THE TOKEN THAT STOPPED THE SCAN
;
; USES:
;	R0, R1
;-
 
CSINIT:	MOV	R5,-(SP)	;SAVE THINGS
	MOV	R4,-(SP)	;
	MOV	R3,-(SP)	;
	MOV	R2,-(SP)	;
 
	MOV	S.DOPE(R5),R3	;POINT AT THE DOPE ENTRIES
	ADD	#S.MEMB,R3	;FOR THE STRUCT
 
	CLR	R2		;BRACE FLAG
	CMP	LEX0,#OP.LBR	;IS THE NEXT TOKEN A BRACE
	BNE	10$		;NO
	CALL	SCAN		;YES, EAT IT UP AND
	INC	R2		;SET BRACE FLAG
 
10$:	CMP	LEX0,#OP.RBR	;RIGHT BRACE NEXT
	BEQ	40$		;YES, DONE
 
	TST	(R3)		;IS THERE ANOTHER ELEMENT
	BNE	20$		;YES
	MOV	#ERR16,R0	;NO, GIVE ERROR
	CALL	ERROR		;
	MOV	#ANINT,R5	;AND POINT AT
	BR	30$		;DUMMY SYMBOL NODE
 
20$:	MOV	(R3)+,R5	;GET THE ELEMENT
	BIT	#SF.RUP,S.FLAG(R5) ;IF ALLIGNMENT IS INDICATED
	BEQ	30$		;THEN
	CALL	ALLIGN		;PUT OUT 'A' ITEM
 
30$:	CLR	R4		;NOT FLEX
	CALL	CINIT		;DO THE ITEM
 
	CMP	LEX0,#OP.CMA	;IS THE NEXT TOKEN A COMMA
	BNE	40$		;NO, THE DECLARATION ENDS
	TST	(R3)		;ANY MORE ENTRIES IN THE DOPE
	BNE	35$		;YES, GET ANOTHER
	TST	R2		;WAITING FOR A BRACE
	BEQ	40$		;NO, QUIT
35$:	CALL	SCAN		;SKIP OVER THE ','
	BR	10$		;AND GO FOR MORE
 
40$:	TST	R2		;EAT TRAILING RIGHT BRACE
	BEQ	50$		;IF THE
	CMP	LEX0,#OP.RBR	;INITIALISER WAS
	BNE	50$		;ENCLOSED
	CALL	SCAN		;IN BRACES
 
50$:	CLR	R1		;PUT OUT PADDING TO THE END OF THE
60$:	MOV	(R3)+,R5	;STRUCT
	BEQ	70$		;FOUND THE END
	CALL	SLENG		;ACCUMULATE
	ADD	R0,R1		;THE
	BR	60$		;MEMBERS
70$:	MOV	R1,R0		;PUT OUT A BSS FOR THE SPACE
	BEQ	80$		;UNLESS
	CALL	BREC		;THE SIZE IS ZERO
80$:	CALL	ALLIGN		;FORCE ALLIGN
 
	MOV	(SP)+,R2	;AND RETURN
	MOV	(SP)+,R3	;
	MOV	(SP)+,R4	;
	MOV	(SP)+,R5	;
	RETURN			;
 
;+
; ** ALLIGN - PUT OUT AN 'A' RECORD
;
; THIS ROUTINE IS CALLED FROM ALL OVER CINIT AND CSINIT TO PUT OUT AN
; 'A' DIRECTIVE WHENEVER WORD ALLIGNMENT IS REQUIRED.
;
; USES:
;	R0
;-
 
ALLIGN:	MOVB	#'A,R0		;GET OPCODE
	CALL	CODC		;PUT IT OUT
	CALLR	CODNL		;
 
;+
; ** CANDT  - GET CLASS AND TYPE
; ** CANDT1 - GET CLASS AND TYPE (ALTERNATE ENTRY)
;
; THESE ROUTINES ARE USED TO PARSE THE CLASS AND TYPE KEYWORDS AT THE
; START OF A DECLARATION. THE TYPE AN CLASS INFORMATION IS STORED  IN
; THE EXTERNAL VARIABLES CLASS, TYPE AND DOPE (DOPE IS ONLY SET  WHEN
; THE TYPE IS STRUCT OR UNION).
;
; THE EXTERNAL VARIABLE DIMP IS SET FROM THE BASE DIMENSION LIST.  IN
; ALL NORMAL CASES THIS WILL BE NULL. HOWEVER A TYPEDEF MAY HAVE  NON
; NULL DIMENSIONS.
;
; THE CLASS AND TYPE ARE PRESET TO ZERO. THE CALLER MAY USE THIS AS A
; FLAG TO PERFORM A DEFAULT CLASS AND TYPE ASSIGNMENT.
;
; THE ALTERNATE ENTRY CANDT1 IS JUST LIKE CANDT EXCEPT THAT THE CLASS
; IS NOT PRESET; IT IS USED FOR COMPILING FUNCTION ARGUMENT LISTS AND
; STRUCTURES.
;
; USES:
;	R0, R1
;-
 
CANDT:	CLR	CLASS		;SET THINGS UNDEFINED
CANDT1:	CLR	TYPE		;
	CLR	DIMP		;
	CLR	DOPE		;
 
	CLR	LONGF		;'LONG' FLAG
	CLR	SHORTF		;'SHORT' FLAG
	CLR	USIGNF		;'UNSIGNED' FLAG
 
;
; THIS IS THE MAIN LOOP. PEEK AHEAD IN THE INPUT,  LOOKING FOR CLASS
; AND TYPE KEYWORDS. SET THE CLASS OR TYPE IF ONE IS FOUND. UNSIGNED
; LONG AND SHORT JUST SET FLAGS (AND GET RESOLVED TO TYPES LATER).
;
; STRUCTS AND UNIONS HAVE THEIR OWN ROUTINE. THE SAVE AND RESTORE OF
; THE 'UNION' FLAG IS KLUDGY.
;
 
10$:	MOV	LEX1,R0		;GET PEEK TOKEN
	MOV	#30$,R1		;LOOK IT UP IN THE TABLE
20$:	CMP	R0,(R1)+	;
	BEQ	25$		;HIT
	ADD	#4,R1		;
	CMP	R1,#40$		;
	BLO	20$		;BR IF MORE
	BR	100$		;END OF CLASSES AND TYPES
 
25$:	JMP	@(R1)+		;POINTS R1 AT THE VALUE
 
;
; TRANSFER TABLE.
;
 
30$:	.WORD	OP.AUT,	60$,	CL.AUT
	.WORD	OP.STA,	60$,	CL.SIN
	.WORD	OP.EXT,	60$,	CL.GBR
	.WORD	OP.REG,	60$,	CL.REG
	.WORD	OP.TYP,	60$,	CL.TYP
	.WORD	OP.INT,	80$,	TY.INT
	.WORD	OP.CHR,	80$,	TY.CHR
	.WORD	OP.FLT,	80$,	TY.FLT
	.WORD	OP.DBL,	80$,	TY.DBL
	.WORD	OP.LNG,	50$,	LONGF
	.WORD	OP.SHO,	50$,	SHORTF
	.WORD	OP.UNS,	50$,	USIGNF
	.WORD	OP.STR,	70$,	0
	.WORD	OP.UNI,	70$,	1
	.WORD	OP.ID,	75$,	0
40$:				;END OF THE TABLE
 
50$:	INC	@(R1)+		;SET FLAG ON ADJECTIVE
	BR	90$		;
 
60$:	TST	CLASS		;CLASS SPEC, DO WE HAVE ONE
	BEQ	65$		;NO
	MOV	#ERR04,R0	;YES, COMPLAIN
	CALL	ERROR		;
65$:	MOV	(R1),CLASS	;SET CLASS
	BR	90$		;
 
70$:	MOV	UNION,-(SP)	;SAVE UNION FLAG
	MOV	(R1),UNION	;SET UNION FLAG IF 'UNION'
	CALL	SUDCL		;DECLARE STRUCT OR UNION
	MOV	(SP)+,UNION	;RESTORE UNION FLAG
	BR	10$		;
 
75$:	MOV	VAL1,R1		;GET SYMBOL POINTER
	CMPB	S.CLAS(R1),#CL.TYP ;IS IT A TYPEDEF
	BNE	100$		;NO, DUCK
	TST	TYPE		;HAVE A TYPE ALREADY
	BEQ	76$		;NO
	MOV	#ERR05,R0	;COMPLAIN
	CALL	ERROR		;
76$:	MOVB	S.TYPE(R1),TYPE	;COPY TYPE
	MOV	S.DIMP(R1),DIMP	;DIMS
	MOV	S.DOPE(R1),DOPE	;STRUCTURE DOPE
	BR	90$		;

80$:	TST	TYPE		;TYPE SPEC, DO WE HAVE ONE
	BEQ	85$		;NO
	MOV	#ERR05,R0	;YES, COMPLAIN
	CALL	ERROR		;
85$:	MOV	(R1),TYPE	;SET TYPE
 
;
; GET THE NEXT TOKEN. IF THERE IS NO TYPE YET SAVE THE CURRENT STATE
; OF 'INMOSF' AND FORCE CLEAR 'INMOSF' DURING THE SCAN. THIS IS DONE
; DO THAT TYPEDEF NAMES GET LOOKED UP IN THE RIGHT SYMBOL TABLE.
;

90$:	MOV	INMOSF,-(SP)	;SAVE OLD STATE
	TST	TYPE		;DO WE HAVE A TYPE
	BNE	92$		;YES
	CLR	INMOSF		;NO, FORCE NOT IN MOS
92$:	CALL	SCAN		;GET NEXT TOKEN
	MOV	(SP)+,INMOSF	;RESTORE MOS STATE
	BR	10$		;GO FOR ANOTHER
 
; 
; RESOLVE TYPES GIVEN ADJECTIVES.
;
 
100$:	MOV	LONGF,R0	;MUST BE 0 OR 1 ADJECTIVES
	ADD	SHORTF,R0	;
	ADD	USIGNF,R0	;
	DEC	R0		;WELL
	BMI	180$		;IF NONE, JUST LEAVE
	BEQ	110$		;EXACTLY 1
	MOV	#ERR06,R0	;COMPLAIN
	CALL	ERROR		;

110$:	MOV	TYPE,R0		;GET THE DECLARED TYPE
	BNE	120$		;IS ONE
	MOV	#TY.INT,R0	;DEFAULT TO INT

120$:	TST	LONGF		;LONG
	BEQ	140$		;NO
	CMP	R0,#TY.INT	;LONG INT
	BNE	130$		;IS
	MOV	#TY.LNG,R0	;LONG
	BR	160$		;

130$:	CMP	R0,#TY.FLT	;LONG FLOAT
	BNE	170$		;IS
	MOV	#TY.DBL,R0	;DOUBLE
	BR	160$		;

140$:	TST	SHORTF		;SHORT
	BEQ	150$		;NO
	CMP	R0,#TY.INT	;ONLY SHORT INT IS LEGAL
	BNE	170$		;
	BR	160$		;AND ITS JUST INT

150$:	TST	USIGNF		;UNSIGNED
	BEQ	160$		;NO
	CMP	R0,#TY.INT	;ONLY UNSIGNED INT
	BNE	170$		;
	MOV	#TY.UNS,R0	;SET TYPE

160$:	MOV	R0,TYPE		;SAVE THE (NEW) TYPE
	BR	180$		;

170$:	MOV	#ERR06,R0	;COMPLAIN
	CALL	ERROR		;

180$:	RETURN			;
 
;+
; ** SUDCL - DECLARE STRUCT OR UNION
;
; READ IN A STRUCTURE DECLARATION AND SET UP THE TYPE AND THE DOPE
; POINTER. MOST OF THE WORK IS ASSOCIATED WITH NESTED   STRUCTURES
; AND THE DOPE LIST.
;
; USES:
;	R0, R1
;-
 
SUDCL:	MOV	R5,-(SP)	;SAVE REGISTERS
	MOV	R4,-(SP)	;
 
	CALL	SCAN		;GET TOKEN AFTER 'STRUCT' INTO LEX1
	CLR	R4		;POINTER TO TAG
	CMP	LEX1,#OP.ID	;IS IT A TAG
	BNE	10$		;NO
	MOV	VAL1,R4		;YES, SAVE POINTER TO SYMBOL
	CALL	SCAN		;AND ADVANCE THE WINDOW
 
;
; IF THE NEXT TOKEN IS AN OPEN BRACE READ IN A STRUCTURE DEFINITION
; THE CLASS IS CL.MOS. THE INMOSF IS SET NON ZERO TO MAKE SCAN  USE
; THE RIGHT SYMBOL TABLE. THE SYMBOLS ARE THREADED (BY DEFINE) INTO
; A LIST THAT BEGINS AT DOPEPT AND WINDS ITS WAY THROUGH THE  NAMES
; IN THE STRUCTURE VIA THE S.AUXP FIELD OF THE SYMBOL NODES.   THIS
; LIST IS USED HERE TO BUILD THE DOPE BLOCK.
;
 
10$:	CMP	LEX1,#OP.LBR	;OPEN BRACE (DECLARATION)
	BNE	40$		;NO
 
	MOV	CLASS,-(SP)	;YES, SAVE THINGS
	MOV	OFFSET,-(SP)	;OFFSET
	MOV	MOFSET,-(SP)	;MAX OFFSET
	MOV	DOPEPT,-(SP)	;POINTER TO HEAD OF OLD DOPE LIST
	MOV	DIMP,-(SP)	;DIMS
	MOV	LONGF,-(SP)	;'LONG' FLAG
	MOV	SHORTF,-(SP)	;'SHORT' FLAG
	MOV	USIGNF,-(SP)	;'UNSIGNED' FLAG
	CLR	DOPEPT		;START ANEW
	CLR	MOFSET		;
	CLR	OFFSET		;AT LOC 0 OF THE STRUCTURE

	INC	INMOSF		;CORRECT SYMBOLS
	MOV	INMOSF,-(SP)	;BUT
	CLR	INMOSF		;SKIP THE BRACE
	CALL	SCAN		;IN THE ORDINARY TABLE FOR
	MOV	(SP)+,INMOSF	;BENEFIT OF TYPEDEF

20$:	CMP	LEX1,#OP.RBR	;LOOK FOR DELIMITERS
	BEQ	30$		;BUT
	CMP	LEX1,#OP.EOF	;DON'T GET STUCK
	BEQ	70$		;ON END OF FILE
	MOV	#CL.MOS,CLASS	;GET A TYPE-DECL-LIST
	CALL	CANDT1		;
	TST	TYPE		;IF NO TYPE
	BEQ	70$		;ITS AN ERROR
	CALL	DECLST		;DECLARE THE LIST OF NAMES AND
	BR	20$		;CONTINUE
 
30$:	DEC	INMOSF		;SWITCH BACK BEFORE WE
	CALL	SCAN		;SKIP THE RIGHT BRACE
 
	INC	OFFSET		;ROUND THE SIZE UP TO
	BIC	#1,OFFSET	;EVEN NUMBER
	INC	MOFSET		;
	BIC	#1,MOFSET	;
 
	MOV	#S.MEMB+2,R0	;BUILD DOPE BLOCK
	MOV	DOPEPT,R1	;SYMBOLS ARE CHAINED THRU 'S.AUXP'
	BEQ	32$		;NULL
31$:	ADD	#2,R0		;2 WORDS PER ENTRY
	MOV	S.AUXP(R1),R1	;CHAIN ALONG UNTIL
	BNE	31$		;NONE LEFT
32$:	CALL	$ALLOC		;ALLOCATE DOPE BLOCK
	MOV	R0,DOPE		;SAVE AND THEN
	CLR	(R0)+		;SET S.REFC TO 0
	MOV	OFFSET,R1	;FOR STRUCT
	TST	UNION		;DOING A UNION
	BEQ	3200$		;NO
	MOV	MOFSET,R1	;YES, USE MAX OFFSET
3200$:	MOV	R1,(R0)+	;SET S.SIZE
	MOV	DOPEPT,R1	;NOW MOVE IN DOPE ENTRIES
33$:	MOV	R1,(R0)+	;THE END IS MARKED BY A 0
	BEQ	34$		;
	MOV	S.AUXP(R1),R1	;CHAIN ALONG
	BR	33$		;
 
34$:	MOV	R4,R5		;DECLARE THE TAG IF REQUIRED
	BEQ	35$		;NO TAG
	MOV	#CL.TAG,CLASS	;SET CLASS (OFFSET IS ALREADY SET)
	CLR	TYPE		;
	CALL	DEFINE		;DEFINE WILL CALL BACKPG
 
35$:	MOV	(SP)+,USIGNF	;RESTORE THINGS
	MOV	(SP)+,SHORTF	;
	MOV	(SP)+,LONGF	;
	MOV	(SP)+,DIMP	;
	MOV	(SP)+,DOPEPT	;
	MOV	(SP)+,MOFSET	;
	MOV	(SP)+,OFFSET	;
	MOV	(SP)+,CLASS	;
	BR	60$		;DONE
 
;
; IF THERE IS NO STRUCTURE BODY THERE MUST BE A TAG. FORWARD POINTER
; REFERENCES WILL CAUSE THE TAG TO BE UNDEFINED. IN THIS CASE  SETUP
; A TYPE OF UNDEFINED STRUCTURE (TY.UST) AND POINT DOPE AND THE NAME
; NODE OF THE TAG. WHEN THE STRUCTURE TAG IS FINALLY DEFINED  DEFINE
; WILL CALL BACKPG, WHO WILL SET THE DOPE BLOCK POINTER INTO THE SYM
; BOL NODE AND FIX THE REFERENCE COUNT.
;
 
40$:	TST	R4		;IF NO BRACE, MUST BE A TAG
	BEQ	80$		;OR SYNTAX ERROR
	MOVB	S.CLAS(R4),R0	;IS THE TAG UNDEFINED
	BNE	50$		;NO
	MOV	R4,DOPE		;PTR TO REQUIRED TAG
	MOV	#TY.UST,TYPE	;UNDEFINED STRUCTURE
	TST	UNION		;IS THIS A UNION
	BEQ	100$		;NO
	MOV	#TY.UUN,TYPE	;SET UNDEFINED UNION
	BR	100$		;
 
50$:	CMP	R0,#CL.TAG	;IF DEFINED, MUST BE A TAG
	BNE	80$		;URK
	MOV	S.DOPE(R4),DOPE	;SET DOPE FROM THE TAG
 
60$:	MOV	#TY.STR,TYPE	;RETURN TYPE IS STRUCT
	TST	UNION		;IS THAT RIGHT
	BEQ	100$		;YES
	MOV	#TY.UNI,TYPE	;RETURN TYPE IS UNION
	BR	100$		;
 
;
; ERROR RECOVERY.
; MUST BE CAREFUL NOT TO LEAVE STUFF ON THE STACK, OR THE INMOSF FLAG
; SET.
;
 
70$:	DEC	INMOSF		;FIX 'IN MOS' FLAG
	MOV	(SP)+,USIGNF	;RESTORE VARIABLES
	MOV	(SP)+,SHORTF	;
	MOV	(SP)+,LONGF	;
	MOV	(SP)+,DIMP	;
	MOV	(SP)+,DOPEPT	;
	MOV	(SP)+,MOFSET	;
	MOV	(SP)+,OFFSET	;
	MOV	(SP)+,CLASS	;
80$:	CALL	DECSYN		;ERROR COMMENT
 
	MOV	LEX0,R0		;SKIP OVER BAD INPUT
90$:	CMP	R0,#OP.RBR	;
	BEQ	100$		;
	CMP	R0,#OP.EOF	;
	BEQ	100$		;
	CALL	ESCAN		;
	BR	90$		;
 
100$:	MOV	(SP)+,R4	;DONE
	MOV	(SP)+,R5	;
	RETURN			;
 
;+
; ** GDECLR - GET A DECLARATOR
;
; READ IN A SINGLE DECLARATOR. THE DIMENSIONS ARE KEPT IN THE DIM LIST
; WHICH BEGINS IN THE S.DIMP FIELD OF THE SYMBOL TABLE NODE. 
;
; OUTPUTS:
;	R5=POINTER TO THE SYMBOL TABLE NODE
;-
 
GDECLR:	MOV	R4,-(SP)	;SAVE REGISTERS
	MOV	R3,-(SP)	;
	MOV	R2,-(SP)	;
	MOV	R1,-(SP)	;
	MOV	R0,-(SP)	;
 
;
; SIMPLE STUFF.
; IDENTIFIERS.
; POINTER DECLARATORS.
; PARENTHESISED DECLARATORS.
;
 
	CALL	SCAN		;GET TOKEN
	CMP	R0,#OP.MUL	;'*'
	BNE	10$		;NO
	CALL	GDECLR		;YES, GET A DECLARATOR
	BCS	15$		;ERROR
	MOV	#DT.PTR,R3	;APPEND A 'POINTER TO'
	CLR	R4		;
	CALL	TACK		;
	JMP	100$		;DONE
 
10$:	CMP	R0,#OP.LPA	;'('
	BNE	20$		;NO
	CALL	GDECLR		;GET DECLARATOR
	BCS	15$		;ERROR
	CALL	SCAN		;CHECK FOR THE CLOSING PARENTHESIS
	CMP	R0,#OP.RPA	;
	BNE	95$		;ERROR IF NOT THERE
	BR	30$		;THEN GO GET '(' ')' AND '[' ']'
 
15$:	JMP	110$		;ERROR RETURN
 
20$:	CMP	R0,#OP.ID	;MUST BE AN IDENTIFIER
	BNE	95$		;NO, ERROR
	MOV	VAL0,R4		;CLEAR OUT DIMP AND DOPE
	CALL	FDIMP		;
	CALL	FDOPE		;
	MOV	DIMP,R0		;GET COPY OF THE DIMS
	CALL	DUPDIM		;
	MOV	R0,S.DIMP(R4)	;
	MOV	R4,R5		;AND GET POINTER IN R5
 
;
; A '(' MEANS FUNCTION DECLARATOR.
;
 
30$:	MOV	LEX1,R0		;PEEK AHEAD
	CMP	R0,#OP.LPA	;'(' (FUNCTION)
	BNE	80$		;NO
	CALL	SCAN		;YES, SKIP OVER IT
	TST	FSYMBL		;IN A FUNCTION
	BNE	60$		;YES, ARGS ARE ILLEGAL
	CMP	CLASS,#CL.TYP	;WORKING ON A TYPEDEF
	BEQ	60$		;YES, NO ARGS
 
	MOV	#PARMS,PARPTR	;CLEAR OUT PARAMETER POINTER
	CALL	SCAN		;CHECK FOR NULL ARGLIST
	CMP	R0,#OP.RPA	;
	BEQ	70$		;NULL
 
40$:	CMP	R0,#OP.ID	;MUST BE AN ID THEN
	BNE	95$		;ERROR
 
	MOV	R5,R3		;DECLARE THE ARGUMENT
	MOV	CLASS,-(SP)	;SAVE THE VARIABLES (FOR DEFINE)
	MOV	TYPE,-(SP)	;
	MOV	#CL.ARG,CLASS	;CLASS IS ARG
	MOV	#TY.INT,TYPE	;TYPE IS INT
	MOV	VAL0,R4		;CLEAR OUT DIMP AND DOPE
	CALL	FDIMP		;
	CALL	FDOPE		;
	MOV	R4,R5		;DECLARE IT
	CALL	DEFINE		;
	MOV	(SP)+,TYPE	;PUT VARIABLES BACK
	MOV	(SP)+,CLASS	;
	CMP	PARPTR,#PARMSE	;ADD TO LIST OF FORMAL PARMS
	BHIS	95$		;OVERFLOW
	MOV	R5,@PARPTR	;
	ADD	#2,PARPTR	;
	MOV	R3,R5		;GET DECLARATOR BACK IN R5
 
	CALL	SCAN		;GET NEXT TOKEN
	CMP	R0,#OP.RPA	;CLOSE PAREN MEANS END OF LIST
	BEQ	70$		;
	CMP	R0,#OP.CMA	;COMMA MEANS ANOTHER ID FOLLOWS
	BNE	95$		;ERROR
	CALL	SCAN		;SKIP THE COMMA
	BR	40$		;
 
60$:	CALL	SCAN		;ONLY LIST LEGAL IS '(' ')'
	CMP	R0,#OP.RPA	;
	BNE	95$		;SYNTAX ERROR
 
70$:	MOV	#DT.FUN,R3	;TACK ON A 'FUNCTION RETURNING'
	CLR	R4		;
	CALL	TACK		;
	BR	30$		;
 
;
; A '[' MEANS ARRAY DECLARATOR.
;
 
80$:	CMP	R0,#OP.LSQ	;'['
	BNE	100$		;END OF DECLARATOR
	CALL	SCAN		;SKIP THE '['
 
	CLR	R4		;DEFAULT BOUND
	CALL	SCAN		;TRY FOR CONSTANT
	CMP	R0,#OP.CON	;
	BNE	90$		;NO
	MOV	VAL0,R4		;BOUND
	CALL	SCAN		;AND SCAN THE DELIMITER
 
90$:	CMP	R0,#OP.RSQ	;MUST BE ']'
	BNE	95$		;OR ERROR
 
	MOV	#DT.ARY,R3	;TACK ON 'ARRAY OF'
	CALL	TACK		;
	BR	30$		;
 
95$:	CALL	DECSYN		;SYNTAX ERROR
	SEC			;ERROR RETURN
	BR	110$		;
100$:	CLC			;GOOD RETURN
110$:	MOV	(SP)+,R0	;RETURN
	MOV	(SP)+,R1	;
	MOV	(SP)+,R2	;
	MOV	(SP)+,R3	;
	MOV	(SP)+,R4	;
	RETURN			;
 
;+
; ** TACK - ADD AN ENTRY TO THE END OF THE DIM
;
; INPUTS:
;	R3=TYPE
;	R4=BOUND
;	R5=SYMBOL TABLE NODE
;
; USES:
;	R0, R1
;-
 
TACK:	MOV	#D.LENG,R0	;GET SPACE FOR
	CALL	$ALLOC		;THE NEW DIM ENTRY
	CLR	(R0)		;D.LINK
	MOV	R3,D.TYPE(R0)	;D.TYPE
	MOV	R4,D.BOUN(R0)	;D.BOUND
 
	MOV	S.DIMP(R5),R1	;IF THE DIM LIST IS NULL
	BNE	10$		;THEN
	MOV	R0,S.DIMP(R5)	;JUST STORE
	BR	30$		;
 
10$:	TST	(R1)		;OTHERWISE FIND THE END OF THE
	BEQ	20$		;EXISTING DIMS
	MOV	(R1),R1		;D.LINK IS ZERO
	BR	10$		;
20$:	MOV	R0,(R1)		;AND ADD IT THERE
 
30$:	RETURN			;FINIS
 
;+
; ** DECLST - RUN DOWN A ',' SEPARATED LIST OF DECLARATORS
;
; USES:
;	R0, R5
;-
 
DECLST:	CALL	GDECLR		;GET A DECLARATOR
	BCS	10$		;ERROR
	CALL	DEFINE		;DEFINE IT
 
;
; BE CAREFUL.
; IN STRUCTURES, THE READING OF THE ';' WILL (POSSIBLY) READ THE TYPE
; INTO LEX1. MUST NOT BE IN MOS TABLE FOR TYPEDEF TO WORK.
;

	MOV	INMOSF,-(SP)	;SAVE
	CLR	INMOSF		;SCAN IN THE
	CALL	SCAN		;ORDINARY TABLE
	MOV	(SP)+,INMOSF	;BACK

	CMP	R0,#OP.CMA	;IF COMMA
	BEQ	DECLST		;GET ANOTHER DECLARATOR
	CMP	R0,#OP.SEM	;IF SEMICOLON
	BEQ	30$		;DONE
 
	CALL	DECSYN		;OOPS
 
10$:	MOV	LEX0,R0		;SKIP BAD INPUT
20$:	CMP	R0,#OP.SEM	;
	BEQ	30$		;
	CMP	R0,#OP.EOF	;
	BEQ	30$		;
	CALL	SCAN		;
	BR	20$		;
 
30$:	RETURN			;
 
;+
; ** DECSYN - DECLARATION SYNTAX ERROR
;
; USES:
;	R0
;-
 
DECSYN:	MOV	#ERR07,R0	;WRITE OUT THE DIAGNOSTIC
	CALLR	ERROR		;
 
;+
; ** DEFINE - DEFINE A SYMBOL
;
; DEFINE A SYMBOL, USING INFORMATION STASHED IN THE GLOBAL VARIABLES
; CLASS, TYPE, DOPE AND OFFSET. MANY CHECKS ARE MADE FOR CLASHES AND
; RECLARATIONS.
;
; INPUTS:
;	R5=SYMBOL TABLE POINTER
;-
 
DEFINE:	MOV	R1,-(SP)	;SAVE REGISTERS
	MOV	R0,-(SP)	;
 
	CLRB	RF		;REDECLARATION FLAG
	MOV	CLASS,ACLASS	;GET WORKING COPIES OF CLASS
	MOV	TYPE,ATYPE	;AND TYPE
 
;
; AUTOMATIC FUNCTIONS DON'T MAKE ANY SENSE AND ARE, IN FACT, FORBID-
; DEN. HOWEVER, DMR'S COMPILER ALLOWED THEM INSIDE OF A FUNCTION; HE
; JUST CHANGED THE CLASS TO GLOBAL REFERENCE. HERE WE DO THE SAME.
;
 
	MOV	S.DIMP(R5),R0	;GET DIMS
	BEQ	70$		;NO DIMS
	CMP	D.TYPE(R0),#DT.FUN ;IS IT A FUNCTION
	BNE	10$		;NO
	CMP	ACLASS,#CL.AUT	;IS IT AN AUTOMATIC FUNCTION
	BNE	10$		;NO
	MOV	#CL.GBR,ACLASS	;MAKE IT GLOBAL REFERENCE
 
;
; CHECK FOR SEMANTICLY FORBIDDEN DECLARATORS.
; ARRAYS OF FUNCTIONS.
; FUNCTIONS RETURNING ARRAYS.
; FUNCTIONS RETURNING FUNCTIONS.
; FUNCTIONS RETURNING STRUCTURES.
;
; THE AF AND FF ARE USED TO REMEMBER WHAT THE LAST THING YOU FOUND ON
; THE DIM LIST WAS (POINTERS CLEAR BOTH). AS YOU WALK DOWN  THE  LIST
; FORBIDDEN DECLARATORS ARE RECOGNISED BASED ON D.TYPE AND  THE  LAST
; ITEM ON THE LIST.
;
 
10$:	CLRB	FF		;FUNCTION FLAG
	CLRB	AF		;ARRAY FLAG
 
20$:	MOV	D.TYPE(R0),R1	;DIM TYPE
	CMP	R1,#DT.ARY	;ARRAYS
	BNE	30$		;NO
	TSTB	FF		;ERROR IF ARRAY OF FUNCTIONS
	BNE	60$		;
	CLRB	FF		;SET ARRAY
	INCB	AF		;
	BR	50$		;
 
30$:	CMP	R1,#DT.PTR	;POINTERS
	BNE	40$		;NO
	CLRB	FF		;SET POINTER
	CLRB	AF		;
	BR	50$		;
 
40$:	BISB	FF,AF		;MUST BE FUNCTION
	BNE	60$		;ERROR IF REURNING FUNCTION OR ARRAY
	INCB	FF		;SET FUNCTION
	CLRB	AF		;
 
50$:	MOV	(R0),R0		;FOLLOW ALONG THE DIM LIST
	BNE	20$		;
 
	TSTB	FF		;WAS THE LAST ENTRY A FUNCTION
	BEQ	70$		;NO
	CMP	ATYPE,#TY.UST	;RETURNING A STRUCTURE (OR UNION)
	BLO	70$		;NO
60$:	MOV	#ERR08,R0	;ILLEGAL DECLARATOR
	CALL	ERROR		;
 
;
; BECAUSE THE PDP-11 DOES NOT HAVE A COMPLETELY UNIFORM INSTRUCTION
; SET WITH RESPECT TO BYTES AND FLOATS, WIDEN NAKED CHAR  AND FLOAT
; ITEMS (NOT IN STRUCTURES) INTO INT AND DOUBLE ITEMS. THIS CAN  BE
; DONE ON THE PDP-11 BECAUSE IT STORES THE BYTES IN A WORD RIGHT TO
; LEFT (POINTERS HAVE THE SAME ADDRESS).
;
 
70$:	CMP	ACLASS,#CL.MOS	;ARE WE IN A STRUCTURE
	BEQ	90$		;YES
	TST	S.DIMP(R5)	;NO, IS THIS A SOLITARY ITEM
	BNE	90$		;NO
 
	CMP	ATYPE,#TY.CHR	;CHAR
	BNE	80$		;
	MOV	#TY.INT,ATYPE	;BECOMES INT
	BR	90$		;
 
80$:	CMP	ATYPE,#TY.FLT	;FLOAT
	BNE	90$		;
	MOV	#TY.DBL,ATYPE	;BECOMES DOUBLE
 
;
; TYPE
;
 
90$:	CMPB	S.CLAS(R5),#CL.ARG ;IF THE OLD CLASS IS FLOATING ARG
	BNE	100$
	CALL	BADARG		;NO TYPE CHECK, BUT INSURE VALID ARG
	BR	120$
 
100$:	MOVB	S.TYPE(R5),R0	;OLD TYPE
	BEQ	120$		;WAS UNDEFINED
	MOVB	S.CLAS(R5),R1	;OLD CLASS
	CMP	R1,#CL.GBR	;REDEFINABLE IF GLOBAL REF
	BEQ	105$
	CMP	R1,#CL.TAG	;OR STRUCTURE TAG
	BEQ	105$
	CMP	R1,#CL.MOS	;OR MEMBER OF STRUCTURE
	BNE	110$
105$:	CMP	R0,ATYPE	;BUT THE TYPE MUST NOT CHANGE
	BEQ	120$
110$:	INCB	RF		;REDECLARATION
120$:	MOVB	ATYPE,S.TYPE(R5);SET THE TYPE
 
;
; DOPE
; THIS IS ONLY DONE FOR STRUCTURE  TAGS AND STRUCTURES SO THAT THE REF
; COUNT IN THE DOPE BLOCK WILL BE CORRECT. IF THE TYPE IS AN UNDEFINED
; STRUCTURE THE DOPE POINTER CONTAINS A POINTER TO THE SYMBOL NODE  OF
; THE TAG, AND THE REFERENCE COUNT MUST NOT BE TOUCHED!
;
 
	CMP	ATYPE,#TY.UST	;STRUCTS OR UNIONS
	BHIS	130$		;YES
	CMP	ACLASS,#CL.TAG	;NO, STRUCTURE TAG
	BNE	140$		;NO
130$:	MOV	DOPE,R0		;SET DOPE POINTER
	MOV	R0,S.DOPE(R5)	;INTO THE SYMBOL NODE
	CMP	ATYPE,#TY.UST	;AND IF THE TYPE
	BEQ	140$		;IS NOT UNDEFINED STRUCTURE
	CMP	ATYPE,#TY.UUN	;OR UNDEFINED UNION
	BEQ	140$		;
	INC	S.REFC(R0)	;FIX REFERENCE COUNT
 
;
; CLASS
;
 
140$:	CMP	ACLASS,#CL.MOS	;IF MEMBER OF STRUCTURE
	BNE	150$		;WE MUST
	CALL	ISBYTE		;CHECK IF A WORD ALLIGNMENT IS NEEDED
	BCC	150$		;BR IF IT IS NOT
	BIT	#1,OFFSET	;FIRST SEE IF WE NEED TO DO ANYTHING
	BEQ	150$		;NO
	INC	OFFSET		;FIX OFFSET AND
	BIS	#SF.RUP,S.FLAG(R5) ;SET ROUND UP FLAG (FOR CSINIT)
 
150$:	MOV	ACLASS,R1	;NEW CLASS
	MOVB	S.CLAS(R5),R0	;OLD CLASS
	BEQ	164$		;BR IF UNDEFINED
 
	CMP	R0,R1		;IF THEY ARE THE SAME CLASS
	BEQ	160$		;OK
 
	CMP	R0,#CL.ARG	;IF OLD IS FLOATING ARGUMENT
	BNE	151$		;
	CMP	R1,#CL.DEF	;AND NEW IS DEFINED ARG
	BEQ	160$		;
	CMP	R1,#CL.DRG	;OR DEFINED REGISTER ARGUMENT
	BEQ	160$		;ACCEPT IT

151$:	CMP	R0,#CL.GBR	;GLOBAL REF VS. GLOBAL DEF
	BEQ	152$
	CMP	R0,#CL.GBD
	BNE	156$
152$:	CMP	R1,#CL.GBR
	BEQ	154$
	CMP	R1,#CL.GBD
	BNE	156$
154$:	MOV	#CL.GBD,ACLASS	;RESOLVES AS GLOBAL DEF
	BR	170$
 
156$:	INCB	RF		;REDECLARATION
 
160$:	CMP	R1,#CL.TAG	;IF TAG OR MEMBER OF STRUCTURE
	BEQ	162$
	CMP	R1,#CL.MOS
	BNE	166$
162$:	CMP	S.ADDR(R5),OFFSET ;MAKE SURE THE OFFSET HASN'T MOVED
	BEQ	170$
	MOV	#ERR09,R0
	CALL	ERROR
	BR	170$
 
164$:	CMP	R1,#CL.DEF	;IF OLD UNDEFINED, BUT CLASS IS DEF
	BEQ	165$		;
	CMP	R1,#CL.DRG	;OR DRG
	BNE	166$		;
165$:	MOV	#ERR11,R0	;YOU ARE DECLARING A FORMAL PARAMETER
	CALL	ERROR		;THAT WASN'T IN THE ARGLIST
 
166$:	CMP	R1,#CL.REG	;REGISTER
	BEQ	1660$		;YES
	CMP	R1,#CL.DRG	;DEFINED REGISTER ARGUMENT
	BNE	170$		;NO
1660$:	CALL	OKREG		;WILL THE ITEM GO IN A REGISTER
	BCS	167$		;NO
	CMP	NXTREG,#1	;YES, IS THERE ONE FREE
	BHI	170$		;YES
167$:	MOV	#CL.AUT,R1	;MAKE AUTO
 
170$:	MOVB	R1,S.CLAS(R5)	;SET CLASS INTO THE SYMBOL
 
	TSTB	RF		;PRINT ERROR IF REDECLARATION
	BEQ	180$
	MOV	#ERR10,R0
	CALL	ERROR
 
; 
; FILL IN THE S.ADDR FIELD.
;
 
180$:	CALL	SLENG		;GET SIZE (BYTES) INTO R0
	CMP	R1,#CL.MOS	;IS IT MOS
	BNE	185$		;NO
	MOV	OFFSET,S.ADDR(R5) ;SET STRUCTURE OFFSET
	ADD	R0,OFFSET	;ADJUST BY SIZE
	CALL	ADOPE		;APPEND TO THE DOPE LIST
	TST	UNION		;DOING A UNION
	BEQ	200$		;NO
	MOV	OFFSET,R0	;GO BACK TO THE START
	CLR	OFFSET		;
	CMP	R0,MOFSET	;HAS THE UNION GROWN
	BLOS	200$		;NO
	MOV	R0,MOFSET	;RESET MAX SIZE
	BR	200$		;
 
185$:	CMP	R1,#CL.TAG	;IS IT A STRUCTURE TAG
	BNE	190$		;NO
	CALL	BACKPG
	BR	200$
 
190$:	CMP	R1,#CL.AUT	;AUTO
	BNE	193$		;NO
	CALL	RUP0		;MAKE THE SIZE EVEN
	SUB	R0,OFFSET	;GET THE ADDRESS AND
	MOV	OFFSET,S.ADDR(R5)
	BR	200$
 
193$:	CMP	R1,#CL.REG	;REGISTER
	BEQ	194$		;OR
	CMP	R1,#CL.DRG	;DEFINED REGISTER
	BNE	195$		;
194$:	MOV	NXTREG,S.ADDR(R5) ;USE NEXT AVAILABLE REGISTER
	DEC	NXTREG
	BR	200$
 
195$:	CMP	R1,#CL.SIN	;STATIC INTERNAL
	BNE	200$		;NO
	MOV	R0,-(SP)	;SAVE THE SIZE
	CALL	CREC		;GET INTO CORRECT PSECTION
	CALL	ALLIGN		;FORCE EVEN
	CALL	GENLAB		;A LABEL FOR THE SPACE
	MOV	R0,S.ADDR(R5)	;PUT IN THE SYMBOL NAME AND
	CALL	LREC		;PUT OUT A LABEL
	MOV	(SP)+,R0	;PUT OUT A BSS FOR THE SPACE
	CALL	BREC		;
	CALL	PREC		;GET BACK TO PROGRAMME PSECTION
 
;
; SET SF.PRM ON ALL EXTERNALS, AND ANY SYMBOL THAT IS ENCOUNTERED OUT
; OF A FUNCTION (EXCEPT FOR FUNCTION ARGUMENTS).
;
 
200$:	CMP	R1,#CL.GBR	;IF GLOBAL REF
	BEQ	210$		;
	CMP	R1,#CL.GBD	;OR GLOBAL DEF
	BEQ	210$		;
	TST	FSYMBL		;OR NOT IN A FUNCTION
	BNE	220$		;
	CMP	R1,#CL.ARG	;AND NOT AN ARG
	BEQ	220$		;
210$:	BIS	#SF.PRM,S.FLAG(R5) ;SET PERM SYMBOL FLAG
 
;
; IF THE -T FLAG IS SET, PUT OUT SYMBOL TABLE ENTRY.
;
 
220$:	TSTB	TFLAG		;-T
	BEQ	230$		;NO
	CALL	PRSTE		;PUT OUT SYMBOL TABLE ENTRY
 
230$:	MOV	(SP)+,R0	;RETURN
	MOV	(SP)+,R1	;
	RETURN			;
 
;+
; ** BADARG - LOOK FOR BAD ARGUMENTS
;
; THIS ROUTINE CHECKS FOR THINGS WHICH CANNOT BE PASSED AS A FUNCTION
; ARGUMENT (STRUCTURES AND FUNCTIONS). THIS ROUTINE IS CALLED BY DEF-
; INE WHEN THE SYMBOL IS NOT UNDEFINED AND THE NEW CLASS IS CL.DEF.
;
; INPUTS:
;	R5=POINTER TO SYMBOL TABLE
;
; USES:
;	R0
;-
 
BADARG:	MOV	S.DIMP(R5),R0	;GET DIMENSIONS
	BEQ	10$		;BR IF SCALAR
	CMP	D.TYPE(R0),#DT.FUN ;IS IT A FUNCTION
	BEQ	20$		;YES, BAD
	BR	30$		;OK
 
10$:	CMPB	S.TYPE(R5),#TY.UST ;SCALAR, CHECK FOR STRUCTURES
	BLO	30$		;OK
20$:	MOV	#ERR12,R0	;IMPOSSIBLE ARGUMENT
	CALL	ERROR
30$:	RETURN
 
;+
; ** OKREG - CHECK IF A SYMBOL CAN BE A REGISTER VARIABLE
;
; DEFINE USES THIS ROUTINE TO DETERMINE IF AN ITEM MAY BE BOUND TO A
; GENERAL REGISTER. ALL WORD ITEMS (INT, UNSIGNED) AND ALL  POINTERS
; ARE OK.
;
; THE SPECIFIED SYMBOL MUST HAVE VALID S.TYPE AND S.DIMP FIELDS.
;
; INPUTS:
;	R5=SYMBOL TABLE NODE
;
; USES:
;	R0
;-
 
OKREG:	MOV	S.DIMP(R5),R0	;GET DIMS
	BEQ	10$		;BR IF SCALAR
	CMP	D.TYPE(R0),#DT.PTR ;IS IT A POINTER
	BEQ	20$		;YES, OK
	BR	30$		;NO, NOT OK
 
10$:	MOVB	S.TYPE(R5),R0	;GET TYPE
	CMP	R0,#TY.INT	;INTS ARE
	BEQ	20$		;OK
	CMP	R0,#TY.UNS	;UNSIGNS ARE
	BNE	30$		;OK TOO
 
20$:	CLC			;GOOD RETURN
	BR	40$
30$:	SEC			;BAD RETURN
40$:	RETURN			;RETURN
 
;+
; ** ISBYTE - CHECK IF A SYMBOL IS BYTE ALLIGNED
;
; INPUTS:
;	R5=SYMBOL TABLE NODE
;
; OUTPUTS:
;	 C=0 IF BYTE ALLIGNED
;
; USES:
;	R0
;-
 
ISBYTE:	CMPB	S.TYPE(R5),#TY.CHR ;IS THE TYPE 'CHAR'
	BNE	20$		;NO, CANNOT POSSIBLE BY BYTE ALLIGNED
	MOV	S.DIMP(R5),R0	;GET DIMS
	BEQ	10$		;SCALAR IS BYTE ALLIGNED
	CMP	D.TYPE(R0),#DT.ARY ;ARRAYS OF CHAR ARE BYTE ALLIGNED
	BNE	20$		;NOT BYTE ALLIGNED
10$:	CLC			;GOOD RETURN
	BR	30$
20$:	SEC			;BAD (NOT BYTE) RETURN
30$:	RETURN
 
;+
; ** BACKPG - BACKPLUG STRUCTURES AND UNIONS
;
; THIS ROUTINE IS CALLED BY DEFINE WHEN A STRUCTURE TAG IS DEFINED. IT
; SEARCHES THROUGH THE SYMBOL TABLE, LOOKING FOR UNDEFINED  STRUCTURES
; AND/OR UNDEFINED UNIONS WAITING FOR THE DEFINITION OF THE TAG.  TYPE
; IS SET TO STRUCT OR UNION AND THE DOPE IS SET CORRECTLY.
;
; INPUTS:
;	R5=SYMBOL TABLE POINTER (TAG)
;
; USES:
;	R0, R1
;-
 
BACKPG:	MOV	#SYMTAB,R0	;SYMBOL TABLE HEAD
	MOV	DOPE,R1		;CURRENT DOPE

10$:	MOV	(R0),R0		;GET NEXT SYMBOL
	BEQ	20$		;BR IF END OF TABLE
 
	CMPB	S.TYPE(R0),#TY.UST ;UNDEFINED STRUCTURE?
	BEQ	15$		;YES
	CMPB	S.TYPE(R0),#TY.UUN ;UNDEFINED UNION
	BNE	10$		;NO

15$:	CMP	S.DOPE(R0),R5	;WAITING FOR THIS SYMBOL
	BNE	10$		;NO
 
	INCB	S.TYPE(R0)	;UST=>STR UUN=>UNI
	INCB	S.TYPE(R0)	;
	INCB	S.TYPE(R0)	;
	INCB	S.TYPE(R0)	;
	MOV	R1,S.DOPE(R0)	;SET DOPE
	INC	S.REFC(R1)	;FIX DOPE REFERENCE COUNT
	BR	10$		;ONWARD
 
20$:	RETURN			;DONE
 
;+
; ** ADOPE - APPEND TO THE DOPE LIST
;
; INPUTS:
;	R5=SYMBOL TABLE NODE
;
; USES:
;	R0
;-
 
ADOPE:	CLR	S.AUXP(R5)	;INSURE THE DOPE LIST PTR IS CLEAR
 
	MOV	DOPEPT,R0	;GET DOPE POINTER
	BNE	10$		;NOT NULL
	MOV	R5,DOPEPT	;START THINGS OFF
	BR	30$		;
 
10$:	TST	S.AUXP(R0)	;FIND THE END
	BEQ	20$		;PERHAPS A POINTER TO THE END WOULD
	MOV	S.AUXP(R0),R0	;BE USEFUL
	BR	10$		;
20$:	MOV	R5,S.AUXP(R0)	;ADD IT THERE
 
30$:	RETURN			;DONE
 
;+
; ** DUPDIM - DUPLICATE DIMS
;
; THIS ROUTINE, GIVEN A POINTER TO A DIMENSION LIST, MAKES A COPY OF IT.
; IT IS USED (BY GDECLR) TO INSURE THAT EVERY SYMBOL HAS ITS OWN DIMLIST
; EVEN IF THE DIMS CAME FROM A TYPEDEF.
;
; INPUTS:
;	R0=POINTER TO DIMS
;
; OUTPUTS:
;	R0=POINTER TO DUPLICATED DIMS
;-

DUPDIM:	MOV	R1,-(SP)	;SAVE R1
	MOV	R0,R1		;ANY DIMS HERE
	BEQ	10$		;NO
	MOV	D.LINK(R1),R0	;DUPLICATE THE REST
	CALL	DUPDIM		;
	MOV	R0,-(SP)	;SAVE REST
	MOV	#D.LENG,R0	;ALLOCATE A BLOCK
	CALL	$ALLOC		;
	MOV	(SP)+,D.LINK(R0);LINK IN DUPLICATED REST
	MOV	D.TYPE(R1),D.TYPE(R0) ;COPY TYPE
	MOV	D.BOUN(R1),D.BOUN(R0) ;AND BOUNDS
10$:	MOV	(SP)+,R1	;RESTORE R1
	RETURN			;

;+
; ** RUP0 - ROUND UP R0
;
; INPUTS:
;	R0=NUMBER TO ROUND
;
; OUTPUTS:
;	R0=NUMBER, ROUNDED UP EVEN
;-
 
RUP0:	INC	R0		;ROUND
	BIC	#1,R0		;IS EASY
	RETURN			;SOMETIMES
 
;+
; ** WARN  - ISSUE NON FATAL DIAGNOSTIC
; ** ERROR - ISSUE FATAL DIAGNOSTIC
;
; ALL PHASE 1 DIAGNOSTICS ARE ISSUED BY THESE ROUTINES. THEY FORMAT
; THE MESSAGE (ADDING THE LINE NUMBER AND THE FILE NAME) AND PUT IT
; OUT THE ERROR STREAM BY CALLING CCERR (IN CC0RT). THE ERROR COUNT
; IS INCREMENTED BY ERROR.
;
; IF THE -V OPTION IS SET DOECHO IS CALLED TO ECHO THE CURRENT LINE
; OF INPUT ONTO THE ERROR STREAM.
;
; INPUTS:
;	R0=POINTER TO ASCIZ MESSAGE
;-
 
ERROR:	INC	NERRS		;ERROR COUNTS ERRORS
 
WARN:	MOV	R1,-(SP)	;SAVE REGISTERS
	MOV	R0,-(SP)	;
	MOV	#MBUF,R1	;STORE LINE NUMBER
	MOV	LINENO,R0	;IN THE
	CALL	$ITOC		;MESSAGE BUFFER
	MOVB	#':,(R1)+	;FOR
	MOVB	#' ,(R1)+	;LOOKS
 
	MOV	#FILE,R0	;GET POINTER TO FILE NAME
	TSTB	(R0)		;IS THERE ONE
	BEQ	20$		;NO
10$:	MOVB	(R0)+,(R1)+	;COPY
	BNE	10$		;INTO
	DEC	R1		;MESSAGE
	MOVB	#':,(R1)+	;FOR
	MOVB	#' ,(R1)+	;LOOKS
 
20$:	MOV	(SP),R0		;COPY
30$:	MOVB	(R0)+,(R1)+	;THE
	BNE	30$		;MESSAGE
 
	MOV	#MBUF,R0	;PTR TO ASCIZ MESSAGE
	CALL	CCERR		;PUT OUT ERROR MESSAGE
 
	TSTB	VFLAG		;-V
	BEQ	40$		;BR IF NOT
	CALL	DOECHO		;ECHO THE LINE
 
40$:	MOV	(SP)+,R0	;DONE
	MOV	(SP)+,R1	;
	RETURN			;
 
	.END