--- /dev/null
+/
+/
+
+/ f22 -- allocate common
+
+.globl calloc
+.globl entry
+
+.globl declimpl
+.globl size
+.globl getc
+.globl getw
+.globl xbuf
+.globl code
+.globl typ
+
+calloc:
+ clr r3
+1:
+ cmp r3,symtp
+ bhis 1f
+ mov symtab(r3),r0
+ bic $!70,r0 / class
+ cmp r0,$40 / common block
+ bne 3f
+ mov r3,-(sp)
+ mov symtab+2(r3),r3
+ clr r2 / byte offset
+2:
+ tst r3
+ beq 2f
+ jsr r5,declimpl
+ mov symtab+4(r3),-(sp)
+ mov 2(sp),symtab+4(r3)
+ mov r2,symtab+6(r3)
+ jsr r5,size
+ add r0,r2
+ mov (sp)+,r3
+ br 2b
+2:
+ mov (sp)+,r3
+ clr symtab+2(r3)
+ mov r2,symtab+6(r3) / common block size
+3:
+ add $8,r3
+ br 1b
+1:
+ rts r5
+
+entry:
+ mov progt,r0
+ jmp *1f(r0)
+1:
+ main
+ subr
+ funct
+ blocd
+
+main:
+ jsr r5,code
+ <main:\n\0>; .even
+ rts r5
+
+subr:
+funct:
+ jsr r5,code
+ <%n.: %n_\n\0>; .even
+ 8
+ 8
+ clr r3
+1:
+ cmp r3,symtp
+ bhis 1f
+ mov symtab+2(r3),r0
+ beq 2f
+ mov (r0)+,r1 / num dims
+ asl r1
+ add r0,r1 / ptr to last dim
+ mov r3,-(sp)
+ mov (r1),-(sp) / dope id
+ clr r2 / dope offset
+3:
+ add $2,r2
+ mov -(r1),r3
+ cmp r0,r1
+ bhi 3f
+ neg r3 / adjustable dimension
+ ble 3b
+ mov r0,-(sp)
+ jsr r5,declimpl
+ mov symtab(r3),r0
+ clrb r0
+ swab r0
+ jsr r5,code
+ < rval%dp; %n_\n\0>; .even
+ r0
+ r3
+ mov symtab(r3),r3
+ bic $![377\<8+7],r3
+ cmp r3,$2\<8+1 / is it i*2
+ beq 4f
+ bic $!7,r3
+ movb typ(r3),r3
+ jsr r5,code
+ < %c%di2\n\0>; .even
+ r3
+ r0
+4:
+ mov 2(sp),r0
+ jsr r5,code
+ < stst; d%d+%d.\n\0>; .even
+ r0
+ r2
+ mov (sp)+,r0
+ br 3b
+3:
+ tst (sp)+
+ mov (sp)+,r3
+2:
+ add $8,r3
+ br 1b
+1:
+blocd:
+ rts r5
+
--- /dev/null
+/
+/
+
+/ f23 -- do equivalence statements
+
+.globl equiv
+
+.globl getsym
+.globl consub
+.globl eqvtab
+.globl error
+.globl declimpl
+.globl perror
+.globl setln
+.globl getln
+
+/ equivalence statements, part 1
+/ destroys all registers
+
+equiv:
+ jsr r5,setln
+1:
+ jsr r5,getln
+ rts r5
+ cmp r0,$'e
+ bne 1b
+ mov $line+11.,r1
+ mov r5,-(sp)
+2: / start equivalence group
+ cmpb (r1)+,$'( / check (
+ bne 9f / syntax error
+ jsr r5,getsym
+ tst r0
+ bne 9f / not identifier
+ mov r3,r5
+ jsr r5,equset
+ movb (r1)+,r2
+ clr r4 / offset
+ cmp r2,$',
+ beq 3f
+ cmp r2,$'( / subscripted vble
+ bne 9f / syntax error
+ jsr r5,consub / get subscript
+ mov r0,r4
+ cmpb (r1)+,$',
+ bne 9f
+3: / rest of group
+ jsr r5,getsym / next ident
+ tst r0
+ bne 9f / syntax
+ jsr r5,equset
+ clr r0
+ mov r3,r2
+ cmpb (r1),$'( / subscript?
+ bne 4f
+ inc r1
+ jsr r5,consub
+4:
+ mov eqvtab+2(r2),r2
+ cmp r2,r5
+ beq 5f / already in same group
+ cmp r2,r3
+ bne 4b / not yet in different group
+ sub r4,r0 / adjust offsets
+ sub eqvtab+4(r5),r0 / left vble's offset
+ add eqvtab+4(r3),r0 / new vble's offset
+4:
+ sub r0,eqvtab+4(r2)
+ mov eqvtab+2(r2),r2
+ cmp r2,r3
+ bne 4b
+ mov eqvtab+2(r3),r0 / link up groups
+ mov eqvtab+2(r5),eqvtab+2(r3)
+ mov r0,eqvtab+2(r5) / link groups
+ br 6f
+5: / here already in same group
+ cmp r0,r4 / offset must be same
+ beq 6f
+ jsr r5,error; 23. / inconsistency!
+6:
+ movb (r1)+,r0
+ cmp r0,$',
+ beq 3b
+ cmp r0,$')
+ bne 9f
+ movb (r1)+,r0
+ bne 3f
+ jsr r5,perror
+ mov (sp)+,r5
+ br 1b
+3:
+ cmp r0,$',
+ beq 2b
+9:
+ jsr r5,error; 24. / equivalence syntax
+ jsr r5,perror
+ mov (sp)+,r5
+ br 1b
+
+/ initialize member of equivalence group
+
+equset:
+ jsr r5,declimpl / declare if necessary
+ mov symtab(r3),r0
+ bit $200,r0 / test parameter
+ bne 2f
+ bic $!70,r0
+ cmp r0,$10 / simple
+ beq 1f
+ cmp r0,$20 / array
+ beq 1f
+2:
+ jsr r5,error; 31. / non-equivalencable variable
+1:
+ tst eqvtab+2(r3) / see if mentioned yet
+ bne 1f
+ mov r3,eqvtab+2(r3) / points to itself
+1:
+ rts r5
+
--- /dev/null
+/
+/
+
+/ f24 -- allocate storage for non-common variables
+/ called after common and equivalence have been done
+
+.globl salloc
+
+.globl eqvtab
+.globl error
+.globl declimpl
+.globl size
+.globl perror
+
+/ destroys all registers
+
+salloc:
+ mov r5,-(sp)
+ clr r3 / loop over symbol table
+ br 2f
+1:
+ add $8.,r3 / next variable
+2:
+
+ cmp r3,symtp
+ blo 2f
+ mov (sp)+,r5
+ mov $line,r1
+ jsr r5,perror / flush errors
+ rts r5
+2:
+ bit $70,symtab(r3)
+ beq 1b / unclassed
+ jsr r5,declimpl / just in case
+ tst eqvtab(r3) / test for already allocated
+ bne 1b / yes
+ mov symtab(r3),r0
+ bic $!70,r0
+ cmp r0,$10 / test class=simple
+ beq 2f
+ cmp r0,$20 / test array
+ bne 1b / no, not a variable
+2:
+ bit $200,symtab(r3) / test parameter
+ bne 1b
+ tst eqvtab+2(r3) / test for equivalence
+ bne 2f / yes
+ bit $100,symtab(r3) / test common
+ bne 1b / yes, nothing to do
+ mov nxtaloc,symtab+6(r3) / offset
+ jsr r5,size / get byte count
+ add r0,nxtaloc
+ inc eqvtab(r3) / mark allocated
+ br 1b
+2:
+ clr r4 / common variable of group
+ mov $77777,r1 / infinity to smallest offset
+ mov r3,r5
+2:
+ cmp eqvtab+4(r3),r1
+ bgt 3f
+ mov eqvtab+4(r3),r1 / replace smallest offset
+3:
+ bit $100,symtab(r3) / test common
+ beq 3f
+ mov r3,r4 / yes
+3:
+ mov eqvtab+2(r3),r3 / next group member
+ cmp r3,r5
+ bne 2b
+ tst r4
+ bne 2f / *there was a common in group
+ / equivalence group w/o common
+ sub nxtaloc,r1 / get -(group offset)
+3:
+ inc eqvtab(r3) / mark allocated
+ mov eqvtab+4(r3),r2
+ sub r1,r2 / compute offset
+ mov r2,symtab+6(r3) / enter offset
+ jsr r5,size
+ add r0,r2 / highest loc of variable
+ cmp r2,r4
+ ble 4f
+ mov r2,r4 / extends storage
+4:
+ mov eqvtab+2(r3),r3 / next of group
+ cmp r3,r5
+ bne 3b
+ mov r4,nxtaloc / account for space
+ br 1b / done!
+2: / equivalence group w/ common
+ mov symtab+6(r4),r1 / actual common offset
+ sub eqvtab+4(r4),r1 / virtual common offset
+2:
+ inc eqvtab(r3) / mark allocated
+ bit $100,symtab(r3) / is variable already in common
+ beq 3f / *no
+ cmp symtab+4(r4),symtab+4(r3)
+ beq 4f
+ jsr r5,error; 25. / different blocks equiv.
+4:
+ mov r1,r0
+ add eqvtab+4(r3),r0
+ cmp r0,symtab+6(r3)
+ beq 4f / ok
+ jsr r5,error; 27. / same variable, different offsets
+ br 4f
+3:
+ bis $100,symtab(r3) / mark common now
+ mov symtab+4(r4),symtab+4(r3)/ get right common block
+ mov r1,r0
+ add eqvtab+4(r3),r0
+ bge 3f
+ jsr r5,error; 26. / block extended leftward
+ clr r0
+3:
+ mov r0,symtab+6(r3) / get proper offset
+ mov r0,-(sp)
+ jsr r5,size / see if size is extended
+ add (sp)+,r0
+ mov symtab+4(r3),r2 / common block
+ cmp symtab+6(r2),r0
+ bge 4f / ok
+ mov r0,symtab+6(r2) / extend size
+4:
+ mov eqvtab+2(r3),r3
+ cmp r3,r5
+ bne 2b
+ jmp 1b
+