/ tmg
/ main program and parsing rule interpreter
/
tracing = 1
f = r5
g = r4
i = r3

sef=sec^sec; clf=clc^clc; bfs=bcs^bcs; bfc=bcc^bcc	/fail indicator

.globl flush,obuild,putch,iget,kput
.globl generate
.globl cfile,dfile,ofile,input
.globl main,succ,fail,errcom,pbundle,parse,diag
.globl alt,salt,stop,goto
.globl tables,start,end
.globl stkb,stke
.globl ktab
.globl trswitch,trace
.globl x,si,j,k,n,g1,env

/ begin here
/ get arguments from shell
/ arg1 is input file
/ arg2 is output file (standard output if missing)

main:
	dec	(sp)
	beq	3f
	mov	4(sp),0f
	sys	open;0:0;0
	bes	1f
	mov	r0,input
	dec	(sp)
	beq	3f
	mov	6(sp),0f
	sys	creat;0:0;666
	bes	1f
	mov	r0,ofile

/ set up tables
/ initialize stack, for definitions see tmgc.s
/ go interpret beginning at "start"
/ finish up
3:
	mov	$stkb,f
	clr	j(f)
	clr	k(f)
	clr	n(f)
	mov	f,g
	add	$g1,g
	mov	$start,r0
	jsr	pc,adv
	jsr	pc,flush
1:
	sys	unlink;1f
	sys	exit
1:
		<alloc.d\0>;.even
/ fatal processor error
/write a two letter message on diagnostic file
/ get a dump

errcom:
	mov	dfile,cfile
	jsr	pc,obuild
	mov	$1f,r0
	jsr	pc,obuild
	jsr	pc,flush
stop:
	4
1:	<--fatal\n\0>;.even

/ all functions that succeed come here
/ test the exit indicator, and leave the rule if on

succ:
	inc	succc
	bit	$1,x(f)
	bne	sret
contin:
	inc	continc
    .if tracing
	tst	trswitch
	beq	1f
	mov	$'r,r0
	jsr	pc,trace
1:
    .endif
/ get interpreted instruction
/ save its exit bit (bit 0) on stack
/ distinguish type of instruction by ranges of value

	jsr	pc,iget
	mov	r0,x(f)
	bic	$1,r0
.if ..
	cmp	r0,$..
	blo	1f
.endif
	cmp	r0,$start
	blo	2f
	cmp	r0,$end
	blo	3f
	cmp	r0,$tables
	blo	2f

/ bad address
1:
	jsr	r0,errcom
		<bad address in parsing\0>;.even

/ machine coded function
2:
	jmp	(r0)

/ tmg-coded rule, execute and test its success
/ bfc = branch on fail clear
3:
	jsr	pc,adv
	bfc	succ

/ all functions and rules that fail come here
/ if exit bit is on do a fail return
/ if following instruction is an alternate (recognized literally)
/ do a goto, if a success alternate, do a nop
/ otherwise do a fail return

fail:
	inc	failc
	bit	$1,x(f)
	bne	fret
	jsr	pc,iget
	mov	r0,x(f)
	bic	$1,r0
	cmp	r0,$alt
	beq	salt
	cmp	r0,$salt
	bne	fret

alt:
	tst	(i)+
	br	succ

salt:
	jsr	pc,iget
	mov	r0,i
	br	contin

goto:
	br	salt

/ do a success return
/ bundle translations delivered to this rule,
/ pop stack frame
/ restore  interpreted instruction counter (i)
/ update input cursor (j) for invoking rule
/ update high water mark (k) in ktable
/ if there was a translation delivered, add to stack frame
/ clear the fail flag

sret:
	mov	f,r0
	add	$g1,r0
	jsr	pc,pbundle
	mov	f,g
	mov	(f),f
	mov	si(f),i
	mov	j(g),j(f)
	mov	k(g),k(f)
	tst	r0
	beq	1f
	mov	r0,(g)+
1:
	clf
	rts	pc

/ do a fail return
/ pop stack
/ do not update j or k
/ restore interpreted instruction counter

fret:
	mov	f,g
	mov	(f),f
	mov	si(f),i
	sef
	rts	pc

/ diag and parse builtins
/ set current file to diagnostic or output
/ save and restore ktable water mark around parse-translate
/ also current file and next frame pointer (g)
/ execute parsing rule

diag:
	mov	dfile,r1
	br	1f
parse:
	mov	ofile,r1
1:
	mov	cfile,-(sp)
	mov	r1,cfile
	mov	k(f),-(sp)
	mov	g,-(sp)
	jsr	pc,iget
	jsr	pc,adv
	bfs	1f
/ rule succeeded
/ if it delivered translation, put it in ktable and set
/ instruction counter for
/ translation generator to point there
/ go generate
	cmp	g,(sp)+
	ble	2f
	mov	-(g),r0
	jsr	pc,kput
	mov	k(f),i
	neg	i
	add	$ktab,i
	mov	f,-(sp)
	mov	g,f
	clr	x(f)
	jsr	pc,generate
	mov	(sp)+,f
	mov	si(f),i
2:
	mov	(sp)+,k(f)
	mov	(sp)+,cfile
	jmp	succ
1:
	mov	(sp)+,g
	mov	(sp)+,k(f)
	mov	(sp)+,cfile
	br	fail

/ advance stack frame to invoke a parsing rule
/ copy  corsor, watr mark, ignored class to new frame
/ set intial frame length to default (g1)
/ check end of stack
/ r0,r1 are new i,environment

adv:
	inc	advc
	mov	f,(g)
	mov	i,si(f)
	mov	j(f),j(g)
	mov	k(f),k(g)
	mov	n(f),n(g)
	mov	g,f
	add	$g1,g
	cmp	g,$stke
	bhis	1f
	mov	r0,i
	mov	r1,env(f)
	jmp	contin
1:
	jsr	r0,errcom
		<stack overflow\0>;.even

/pbundle entered with pointer to earliest element of bunlde
/to reduce from the top of stack in r0
/exit with pointer to bundle in r0, or zero if bundle is empty

pbundle:
	cmp	r0,g
	blo	1f
	clr	r0	/empty bundle
	rts	pc
1:
	mov	r0,-(sp)
	mov	r0,r1
	mov	(r1)+,r0
	cmp	r1,g
	beq	2f		/trivial bundle
1:
	mov	r1,-(sp)
	jsr	pc,kput
	mov	(sp)+,r1
	mov	(r1)+,r0
	cmp	r1,g
	blos	1b
	mov	k(f),r0
2:
	mov	(sp)+,g
	rts	pc

/ tmg translation rule interpreter (generator)
/ see tmgc.s for definitions

tracing = 1
f = r5
.globl x,si,ek,ep,ek.fs,ep.fs,fs
.globl trswitch,trace
.globl start,end,tables,ktab,ktat
.globl errcom
.globl generate,.tp
i = r3

/ if exit bit is on pop stack frame restore inst counter and return

generate:
bit	$1,x(f)
	beq	gcontin
	sub	$fs,f
	mov	si(f),i
	rts	pc
gcontin:
    .if tracing
	tst	trswitch
	beq	1f
	mov	$'g,r0
	jsr	pc,trace
1:
    .endif 
/ get interpreted instruction, decode by range of values

	mov	(i)+,r0
	mov	r0,x(f)
	bic	$1,r0
.if ..
	cmp	r0,$..
	blo	badadr
.endif
	cmp	r0,$start
	blo	gf
	cmp	r0,$end
	blo	gc
	cmp	r0,$tables
	blo	gf
	neg	r0
	cmp	r0,$ktat
	blo	gk
badadr:
	jsr	r0,errcom
		<bad address in translation\0>;.even

/ builtin  translation function
gf:
	jmp	(r0)

/ tmg-coded translation subroutine
/ execute it in current environment
gc:
	mov	i,si(f)
	mov	r0,i
	mov	ek(f),ek.fs(f)
	mov	ep(f),ep.fs(f)
	add	$fs,f
	jsr	pc,gcontin
	br	generate

/ delivered compound translation
/ instruction counter is in ktable
/ set the k environment for understanding 1, 2 ...
/ to designate this frame
gk:
	mov	f,ek(f)
	add	$ktab,r0
	mov	r0,i
	br	gcontin

/ execute rule called for by 1 2 ...
/ found relative to instruction counter in the k environment
/ this frame becomes th p environment for
/ any parameters passed with this invocation
/ e.g. for 1(x) see also .tq
.tp:
	movb	(i)+,r0
	movb	(i)+,r2
	inc	r0
	asl	r0
	mov	i,si(f)
	mov	f,ep.fs(f)
	mov	ek(f),r1
	mov	si(r1),i
	sub	r0,i
	add	$fs,f
	mov	f,ek(f)
	asl	r2
	beq	2f
/element is 1.1, 1.2, .. 2.1,...
	mov	(i),i
	neg	i
	bge	1f
	jsr	r0,errcom
		<not a bundle\0>;.even
1:
	cmp	i,$ktat
	bhis	badadr
	add	$ktab,i
	sub	r2,i
2:
	jsr	pc,gcontin
	br	generate

/ tmg output routines/ and iget
f = r5
i = r3
.globl env,si
.globl errcom
.globl cfile,lfile
.globl putch,obuild,iget,flush
.globl outb,outt,outw
.globl start

/ adds 1 or 2 characters in r0 to output

putch:
	clr	-(sp)
	mov	r0,-(sp)
	mov	sp,r0
	jsr	pc,obuild
	add	$4,sp
	rts	pc

/ r0 points to string to put out  on current output file (cfile)
/ string terminated by 0
/ if last file differed from current file, flush output buffer first
/ in any case flush output buffer when its write pointer (outw)
/ reaches its top (outt)

obuild:
	cmp	cfile,lfile
	beq	1f
	mov	r0,-(sp)
	jsr	pc,flush
	mov	(sp)+,r0
	mov	cfile,lfile
1:
	mov	outw,r1
1:
	tstb	(r0)
	beq	1f
	movb	(r0)+,outb(r1)
	inc	r1
	mov	r1,outw
	cmp	r1,$outt
	blt	1b
	mov	r0,-(sp)
	jsr	pc,flush
	mov	(sp)+,r0
	br	obuild
1:
	rts	pc

/ copy output buffer onto last output file and clear buffer

flush:
	mov	outw,0f
	mov	lfile,r0
	sys	write;outb;0:0
	clr	outw
	rts	pc


/ get interpreted instruction for a parsing rule
/ negative instruction is a pointer to a parameter in this
/ stack fromae, fetch that instead
/ put environment pointer in r1

iget:
	mov	f,r1
	mov	(i)+,r0
	bge	2f
	mov	r0,-(sp)	/save the exit bit 
	bic	$-2,(sp)
	bic	(sp),r0
1:			/chase parameter
	mov	env(r1),r1
	add	si(r1),r0
	mov	(r0),r0
	blt	1b
	mov	env(r1),r1
	bis	(sp)+,r0
2:
	rts	pc
/there followeth the driving tables
start:

.data
succc:	0
continc:	0
failc:	0
advc:	0
.text