MiniUnix/usr/source/s1/bas.s

Find at most related files.
including files from this version of Unix. 
/
/

/ bas0 -- basic

scope = 1
.globl	main
.globl	sin, cos, log, exp, atan, pow, sqrt
.globl	rand, srand
.globl	fptrap
.globl fopen, getc

indir =	0  /for  indirect sys calls. (not in as)
one = 40200

main:
	mov	$1,prfile /initial print file
	sys	signal; 4; fptrap
	setd
	sys	time
	mov	r1,r0
	mov	r0,randx
	jsr	pc,srand
	sys	signal; 2; intrup
	mov	sp,gsp
	clr	seeka
	mov	$'a,r1
1:
	movb	r1,tmpf+8
	sys	stat; tmpf; line
	bes	1f
	inc	r1
	cmp	r1,$'z
	blos	1b
	br	2f
1:
	sys	creat; tmpf; 600
	bes	2f
	mov	r0,tfo
	sys	open; tmpf; 0
	bec	1f
2:
	mov	$3f,r0
	jsr	pc,print
	sys	exit
3:
	<Tmp file?\n\0>; .even
1:
	mov	r0,tfi

	mov	gsp,sp
	cmp	(sp),$2  /is there a file argument
	blt	noarg
	mov	4(sp),r0
	mov	$argname,r1
1:
	movb	(r0)+,(r1)+
	bne	1b
aftered: / after edit
	mov	$argname,r0
	jsr	r5,fopen; iobuf
	bes	1f
noarg:
	jsr	pc,isymtab
	br	loop
1:
	mov	$1f,r0
	jsr	pc,print
	br	loop
1:
	<Cannot open file\n\0>; .even

intrup:
	sys	signal; 2; intrup
	mov	$'\n,r0
	jsr	r5,xputc
	jsr	r5,error
		<ready\n\0>; .even

loop:
	mov	gsp,sp
	clr	lineno
	jsr	pc,rdline
	mov	$line,r3
1:
	movb	(r3),r0
	jsr	pc,digit
		br 1f
	jsr	r5,atoi
	cmp	r0,$' /
	beq	3f
	cmp	r0,$'	 /tab
	bne	1f
3:
	mov	$lintab,r3
	mov	r1,r0
	bgt	2f
	jsr	pc,serror
2:
	cmp	r0,(r3)
	beq	2f
	tst	(r3)
	beq	2f
	add	$6,r3
	br	2b
2:
	cmp	r3,$elintab-12.
	blo	2f
	jsr	r5,error
		<too many lines\n\0>; .even
2:
	mov	r0,(r3)+
	mov	seeka,(r3)+
	mov	tfo,r0
	mov	seeka,seekx
	sys	indir; sysseek
	mov	$line,r0
	jsr	pc,size
	inc	r0
	add	r0,seeka
	mov	r0,wlen
	mov	tfo,r0
	mov	$line,wbuf
	sys	indir;syswrit
	br	loop
1:
	mov	$line,r3
	jsr	pc,singstat
	br	loop

nextc:
	movb	(r3)+,r0
	rts	r5

size:
	clr	-(sp)
1:
	inc	(sp)
	cmpb	(r0),$'\n
	beq	1f
	cmpb	(r0),$0
	beq	1f
	inc	r0
	br	1b
1:
	mov	(sp)+,r0
	rts	pc

rdline:  / read input (file or tty) to carr. ret.
	mov	$line,r1
1:
	jsr	r5,getc; iobuf
	bes	2f
	tst	r0
	beq	2f
	cmp	r1,$line+99.
	bhis	2f			/ bad check, but a check
	movb	r0,(r1)+
	cmpb	r0,$'\n
	bne	1b
	clrb	(r1)
	rts	pc
2:
	mov	fi,r0
	beq	1f
	sys	close
	clr	fi
	br	1b
1:
	jmp	_done

error:
	tst	fi
	beq	1f
	sys	close
	clr	fi
1:
	tst	lineno
	beq	1f
	jsr	pc,nextlin
		br 1f
	mov	$line,r0
	jsr	pc,print
1:
	mov	r5,r0
	jsr	pc,print
	jmp	loop

serror:
	dec	r3
	tst	fi
	beq	1f
	sys	close
	clr	fi
1:
	mov	$line,r1
1:
	cmp	r1,r3
	bne	2f
	mov	$'_,r0
	jsr	r5,xputc
	mov	$10,r0
	jsr	r5,xputc
2:
	movb	(r1),r0
	jsr	r5,xputc
	cmpb	(r1)+,$'\n
	bne	1b
	jmp	loop

print:
	mov	r0,wbuf
	jsr	pc,size
	mov	r0,wlen
	mov	prfile,r0
	sys	indir; syswrit
	rts	pc

digit:
	cmp	r0,$'0
	blo	1f
	cmp	r0,$'9
	bhi	1f
	add	$2,(sp)
1:
	rts	pc

alpha:
	cmp	r0,$'a
	blo	1f
	cmp	r0,$'z
	bhi	1f
	add	$2,(sp)
1:
	cmp	r0,$'A
	blo	1f
	cmp	r0,$'Z
	bhi	1f
	add	$2,(sp)
1:
	rts	pc

name:
	mov	$nameb,r1
	clr	(r1)
	clr	2(r1)
1:
	cmp	r1,$nameb+4
	bhis	2f
	movb	r0,(r1)+
2:
	movb	(r3)+,r0
	jsr	pc,alpha
		br 2f
	br	1b
2:
	jsr	pc,digit
		br 2f
	br	1b
2:
	mov	$resnam,r1
1:
	cmp	nameb,(r1)
	bne	2f
	cmp	nameb+2,2(r1)
	bne	2f
	sub	$resnam,r1
	asr	r1
	add	$2,(sp)
	rts	pc
2:
	add	$4,r1
	cmp	r1,$eresnam
	blo	1b
	mov	$symtab,r1
1:
	tst	(r1)
	beq	1f
	cmp	nameb,(r1)
	bne	2f
	cmp	nameb+2,2(r1)
	bne	2f
	rts	pc
2:
	add	$14.,r1
	br	1b
1:
	cmp	r1,$esymtab-28.
	blo	1f
	jsr	r5,error
		<out of symbol space\n\0>; .even
1:
	mov	nameb,(r1)
	mov	nameb+2,2(r1)
	clr	4(r1)
	clr	14.(r1)
	rts	pc

skip:
	cmp	r0,$' /
	beq	1f
	cmp	r0,$'	  / tab
	bne	2f
1:
	movb	(r3)+,r0
	br	skip
2:
	rts	pc

xputc:
.if scope  / for plotting
	tstb	drflg
	beq	1f
	jsr	pc,drput
	rts	r5
1:
.endif
	mov	r0,ch
	mov	$1,r0
	sys	write; ch; 1
	rts	r5

nextlin:
	clr	-(sp)
	mov	$lintab,r1
1:
	tst	(r1)
	beq	1f
	cmp	lineno,(r1)
	bhi	2f
	mov	(sp),r0
	beq	3f
	cmp	(r0),(r1)
	blos	2f
3:
	mov	r1,(sp)
2:
	add	$6,r1
	br	1b
1:
	mov	(sp)+,r1
	beq	1f
	mov	(r1)+,lineno
	mov	(r1)+,seekx
	mov	tfi,r0
	sys	indir; sysseek
	mov	tfi,r0
	sys	read; line; 100.
	add	$2,(sp)
1:
	rts	pc

getloc:
	mov	$lintab,r1
1:
	tst	(r1)
	beq	1f
	cmp	r0,(r1)
	beq	2f
	add	$6,r1
	br	1b
1:
	jsr	r5,error
		<label not found\n\0>; .even
2:
	rts	pc

isymtab:
	mov	$symtab,r0
	mov	$symtnam,r1
	clrf	fr0
	movf	$one,fr1
1:
	mov	(r1)+,(r0)+
	mov	(r1)+,(r0)+
	mov	$1,(r0)+
	subf	r1,r0
	movf	r0,(r0)+
	cmp	r1,$esymtnam
	blo	1b
	clr	(r0)+
	rts	pc

/
/

/ bas1 -- compile
/
/    convention:	jsr pc,subrout /test
/				br failside
/			succeed ...

compile:
	clr	forp
	mov	$iflev,ifp /added for if..else..fi
	mov	$space,r4
	tst	lineno
	beq	1f
	rts	pc
1:
	jsr	pc,nextlin
		br 1f
	mov	lineno,r0
	jsr	pc,getloc
	mov	r4,4(r1)
	jsr	pc,statement
		br .+2
	inc	lineno
	cmp	r4,$espace+20  / out of code space?
	blo	1b
	jsr	r5,error
		<out of code space\n\0>; .even
1:
	tst	forp
	jne	forer
	cmp	ifp,$iflev
	jne	fier   /hanging if..fi
	mov	$loop,(r4)+
	rts	pc

singstat:
	clr	forp
	mov	$iflev,ifp
	mov	$exline,r4
	jsr	pc,statement
		br 1f
	cmp	-2(r4),$_asgn
	beq	1f
	mov	$_print,(r4)+
	mov	$_nline,(r4)+
1:
	tst	forp
	jne	forer
	cmp	r4,$eexline
	blo	1f
	jsr	r5,error
		<out of code space\n\0>; .even
1:
	mov	$loop,(r4)+
	mov	r4,exprloc
	mov	$exline,r4
	jmp	execute

statement:
	mov	$line,r3
	movb	(r3)+,r0
	jsr	pc,digit
		br stat1
	dec	r3
	jsr	r5,atoi
	cmp	r0,$' /
	beq	1f
	cmp	r0,$'	 /tab
	beq	1f
	mov	$line,r3
	movb	(r3)+,r0
	br	stat1
1:
	mov	$_line,(r4)+
	mov	r1,(r4)+

stat1:
	jsr	pc,skip
	cmp	r0,$'\n
	bne	.+4
	rts	pc
	mov	r3,-(sp)
	jsr	pc,alpha
		br 1f
	jsr	pc,name
		br 1f
	tst	(sp)+
	jsr	pc,skip
	dec	r3
	jmp	*2f(r1)
2:
	stlist
	stdone
	stdone
	strun
	stprint
	stprompt   / prompt is like print except for cr
	stif
	stgoto
	streturn
	stfor
	stnext
	stoctl
	stsave
	stdump
	stfi
	stelse
	stedit
	stcomment
.if scope    / for plotting on tektronix
	stdisp
	stdraw
	steras
.endif

1:
	mov	(sp)+,r3
	dec	r3
	jsr	pc,expr
	cmp	r0,$'\n
	jne	joe
	add	$2,(sp)
	rts	pc

stsave:
	mov	$_save,func
	br	1f

stlist:
	mov	$_list,func
1:
	cmp	r0,$'\n
	bne	1f
	clrf	r0
	jsr	pc,const
	movif	$77777,r0
	jsr	pc,const
	br	2f
1:
	jsr	pc,expr
	cmp	r0,$'\n
	bne	1f
	mov	$_dup,(r4)+
	br	2f
1:
	dec	r3
	jsr	pc,expr
	cmp	r0,$'\n
	jne	joe
2:
	mov	func,(r4)+
	rts	pc

stdone:
	cmp	r0,$'\n
	jne	joe
	mov	$_done,(r4)+
	rts	pc

strun:
	cmp	r0,$'\n
	jne	joe
	mov	$_run,(r4)+
	rts	pc


stprompt:
	clr	-(sp)
	br	stpr2

stdump:
	cmp	r0,$'\n
	jne	joe
	mov	$_dump,(r4)+
	rts	pc

stprint:
	mov	pc,-(sp)
stpr2:
	movb	(r3)+,r0
	jsr	pc,skip
1:
	cmp	r0,$'\n
	beq	2f
	cmp	r0,$'"
	beq	1f
	dec	r3
	jsr	pc,expr
	mov	$_print,(r4)+
	br	1b
1:
	mov	$_ascii,(r4)+
1:
	movb	(r3)+,(r4)
	cmpb	(r4),$'"
	beq	1f
	cmpb	(r4)+,$'\n
	bne	1b
	jbr	joe
1:
	add	$2,r4
	bic	$1,r4
	br	stpr2
2:
	tst	(sp)+
	beq	1f
	mov	$_nline,(r4)+
1:
	rts	pc

stif:
	jsr	pc,expr
	mov	$_if,(r4)+
	mov	r4,*ifp
	add	$2,ifp
	tst	(r4)+
	jsr	pc,skip
	cmp	r0,$'\n   / if ... fi
	beq	1f
	jsr	pc,stat1
		br  .+2
stfi:
	sub	$2,ifp
	cmp	ifp,$iflev
	jlo	fier
	mov	*ifp,r1  /for jump around if
	mov	r4,(r1)
1:
	rts	pc

fier:
	jsr	r5,error; <if...else...fi imbalance\n\0>; .even

stelse:
	mov	$_tra,(r4)+  /jump around else side
	mov	r4+,-(sp) / save hole
	tst	(r4)+
	sub	$2,ifp
	cmp	ifp,$iflev
	jlo	fier
	mov	*ifp,r1
	mov	r4,(r1)  /fill in jump to else
	mov	(sp)+,*ifp /save hole for fi
	add	$2,ifp
	rts	pc

stedit:  / enter the regular editor <ed>
	sys fork
	br	newpr
	mov	$lintab,r0  / zero out line table during edit
1:
	cmp	r0,$elintab  /done
	beq	1f
	mov	$0,(r0)+
	br	1b
1:
	sys	unlink; tmpf
	sys	wait
	jmp	aftered / start over
newpr:
	sys	exec; ed; edarg
	sys	exit
ed:	</bin/ed\0> ; .even
ednm:	<-\n>
 .even
edarg:	ednm; argname; 0

stcomment:  /comment line
	cmp	r0,$'\n
	beq	1f
	movb	(r3)+,r0
	br	stcomment
1:
	rts	pc
stgoto:
	jsr	pc,expr
	mov	$_goto,(r4)+
	rts	pc

streturn:
	cmp	r0,$'\n
	beq	1f
	jsr	pc,expr
	cmp	r0,$'\n
	bne	joe
	br	2f
1:
	clrf	r0
	jsr	pc,const
2:
	mov	$_return,(r4)+
	rts	pc

joe:
	jsr	pc,serror

stfor:
	mov	r4,-(sp)
	jsr	pc,e2
	mov	r4,-(sp)
	cmp	r0,$'=
	bne	joe
	tst	val
	bne	joe
	jsr	pc,expr
	mov	forp,(r4)+	/ overlay w _asgn
	mov	r4,forp
	cmp	(r4)+,(r4)+	/ _tra ..
	mov	(sp)+,r0
	mov	(sp)+,r1
1:
	mov	(r1)+,(r4)+
	cmp	r1,r0
	blo	1b
	mov	$_fori,(r4)+
	mov	forp,r1
	mov	$_tra,(r1)+
	mov	r4,(r1)+
	dec	r3
	jsr	pc,expr
	mov	$_lesseq,(r4)+
	mov	$_if,(r4)+
	mov	forp,(r4)+
	mov	r4,forp
	cmp	r0,$'\n
	beq	1f
	jsr	pc,stat1
		br .+2
	br	stnext
1:
	rts	pc

forer:
	jsr	r5,error; <for/next imbalance\n\0>; .even

stnext:
	mov	forp,r1
	beq	forer
	mov	-(r1),r0
	mov	-(r0),forp
	mov	$_ptra,(r4)+
	mov	$_asgn,(r0)+
	cmp	(r0)+,(r0)+
	mov	r0,(r4)+
	mov	r4,(r1)+
	rts	pc

stoctl:
	jsr	pc,expr
	mov	$_octal,(r4)+
	rts	pc

.if scope  / for plotting
stdisp:
	mov	$_sdisp,(r4)+
	jsr	pc,stprint
	mov	$_fdisp,(r4)+
	rts	pc
stdraw:
	jsr	pc,expr
	dec	r3
	jsr	pc,expr
	cmp	r0,$'\n
	bne	1f
	movf	$one,r0
	jsr	pc,const
	br	2f
1:
	dec	r3
	jsr	pc,expr
2:
	mov	$_draw,(r4)+
	rts	pc

steras:
	mov	$_erase,(r4)+
	rts	pc
.endif

/
/

/ bas2 -- expression evaluation

expr:
	jsr	pc,e1
	jsr	pc,rval
	rts	pc

/ assignment right to left
e1:
	jsr	pc,e2
	cmp	r0,$'=
	beq	1f
	jsr	pc,rval
	rts	pc
1:
	tst	val
	beq	1f
	jsr	pc,serror
1:
	jsr	pc,e1
	jsr	r5,op; _asgn
	rts	pc

/ and or left to right
e2:
	jsr	pc,e3
1:
	cmp	r0,$'&
	beq	2f
	cmp	r0,$'|
	beq	3f
	rts	pc
2:
	jsr	pc,rval
	jsr	pc,e3
	jsr	r5,op; _and
	br	1b
3:
	jsr	pc,rval
	jsr	pc,e3
	jsr	r5,op; _or
	br	1b

/ relation extended relation
e3:
	jsr	pc,e4
	jsr	pc,e3a
		rts pc
	clr	-(sp)
1:
	mov	r0,-(sp)
	jsr	pc,e4
	jsr	pc,rval
	mov	(sp)+,(r4)+
	jsr	pc,e3a
		br 1f
	mov	$_extr,(r4)+
	inc	(sp)
	br	1b
1:
	dec	(sp)
	blt	1f
	mov	$_and,(r4)+
	br	1b
1:
	tst	(sp)+
	rts	pc

/ relational operator
e3a:
	cmp	r0,$'>
	beq	1f
	cmp	r0,$'<
	beq	2f
	cmp	r0,$'=
	beq	3f
	rts	pc
1:
	mov	$_great,r0
	cmpb	(r3),$'=
	bne	1f
	inc	r3
	mov	$_greateq,r0
	br	1f
2:
	cmpb	(r3),$'>
	bne	2f
	inc	r3
	mov	$_noteq,r0
	br	1f
2:
	mov	$_less,r0
	cmpb	(r3),$'=
	bne	1f
	inc	r3
	mov	$_lesseq,r0
	br	1f
3:
	cmpb	(r3),$'=
	beq	2f
	rts	pc
2:
	inc	r3
	mov	$_equal,r0
1:
	jsr	pc,rval
	add	$2,(sp)
	rts	pc

/ add subtract
e4:
	jsr	pc,e5
1:
	cmp	r0,$'+
	beq	2f
	cmp	r0,$'-
	beq	3f
	rts	pc
2:
	jsr	pc,rval
	jsr	pc,e5
	jsr	r5,op; _add
	br	1b
3:
	jsr	pc,rval
	jsr	pc,e5
	jsr	r5,op; _sub
	br	1b

/ multiply divide
e5:
	jsr	pc,e6
1:
	cmp	r0,$'*
	beq	2f
	cmp	r0,$'/
	beq	3f
	rts	pc
2:
	jsr	pc,rval
	jsr	pc,e6
	jsr	r5,op; _mult
	br	1b
3:
	jsr	pc,rval
	jsr	pc,e6
	jsr	r5,op; _divid
	br	1b

/ exponential
e6:
	jsr	pc,e6a
1:
	cmp	r0,$'^
	beq	2f
	rts	pc
2:
	jsr	pc,rval
	jsr	pc,e6a
	jsr	r5,op; _expon
	br	1b

e6a:
	movb	(r3)+,r0
	jsr	pc,skip
	cmp	r0,$'_
	bne	1f
	jsr	pc,e6a
	jsr	r5,op; _neg
	rts	pc
1:
	dec	r3
	jsr	pc,e7
	rts	pc
/ end of unary -

/ primary
e7:
	movb	(r3)+,r0
	jsr	pc,skip
	mov	$1,val
	cmp	r0,$'(
	bne	1f
	jsr	pc,e1
	cmp	r0,$')
	bne	2f
	movb	(r3)+,r0
	br	e7a
2:
	jsr	pc,serror
1:
	cmp	r0,$'.
	beq	2f
	jsr	pc,digit
		br 1f
2:
	dec	r3
	jsr	r5,atof; nextc
	jsr	pc,const
	br	e7a
1:
	jsr	pc,alpha
		br jim
	jsr	pc,name
		br 2f
	jsr	r5,error; <reserved name\n\0>; .even
2:
/ try to fix illegal symbol bug:
	cmp	r4,$eexline
	bhis	jim

	mov	$_lval,(r4)+
	mov	r1,(r4)+
	clr	val
	br	e7a
jim:
	jsr	pc,serror

e7a:
	jsr	pc,skip
	cmp	r0,$'(
	bne	1f
	jsr	pc,rval
	jsr	r5,rlist; _funct
	cmp	r0,$')
	bne	jim
	movb	(r3)+,r0
	br	e7a
1:
	cmp	r0,$'[
	bne	1f
	tst	val
	beq	2f
	jsr	pc,serror
2:
	jsr	r5,rlist; _subscr
	clr	val
	cmp	r0,$']
	bne	jim
	movb	(r3)+,r0
	br	e7a
1:
	rts	pc

op:
	jsr	pc,rval
	mov	(r5)+,(r4)+
	rts	r5

rval:
	tst	val
	bne	1f
	mov	$_rval,(r4)+
	inc	val
1:
	rts	pc

const:
	mov	r0,-(sp)
	movf	r1,-(sp)
	tstf	r0
	cfcc
	bne	1f
	mov	$_con0,(r4)+
	br	2f
1:
	cmpf	$one,r0
	cfcc
	bne	1f
	mov	$_con1,(r4)+
	br	2f
1:
	movfi	r0,r0
	movif	r0,r1
	cmpf	r0,r1
	cfcc
	bne	1f
	mov	$_intcon,(r4)+
	mov	r0,(r4)+
	br	2f
1:
	mov	$_const,(r4)+
	movf	r0,(r4)+
2:
	movf	(sp)+,r1
	mov	(sp)+,r0
	rts	pc

rlist:
	clr	-(sp)
	cmpb	(r3),$')
	bne	1f
	movb	(r3)+,r0
	br	2f
1:
	inc	(sp)
	jsr	pc,expr
	cmp	r0,$',
	beq	1b
2:
	mov	(r5)+,(r4)+
	mov	(sp)+,(r4)+
	rts	r5

/
/
/ bas3 -- execution

execute:
	mov	$estack,r3
	mov	r3,sstack
	jmp	*(r4)+

_if:
	tstf	(r3)+
	cfcc
	beq	_tra
	tst	(r4)+
	jmp	*(r4)+

_ptra:
	mov	sstack,r3

_tra:
	mov	(r4)+,r4
	jmp	*(r4)+

_funct:
	mov	r4,-(r3)
	mov	sstack,-(r3)
	mov	r3,sstack
	inc	sublev
	clr	r0
	jsr	pc,arg
	tstf	r0
	cfcc
	bge	1f
	jmp	builtin

_goto:
	movf	(r3),r0
1:
	movfi	r0,-(sp)
	jsr	pc,compile
	mov	(sp)+,r0
	jsr	pc,getloc
	mov	4(r1),r4
	jmp	*(r4)+

_run:
	jsr	pc,isymtab
	mov	randx,r0
	jsr	pc,srand
	jsr	pc,compile
	mov	$space,r4
	jmp	*(r4)+

_save:    / _save is a _list to the file named on the bas command
	sys	creat; argname; 666
	bes	1f
	mov	r0,prfile
	br	2f
1:
	mov	1f,r0
	mov	$1,prfile
	jsr	pc,print
	br	_done
1:	<Cannot create b.out\n\0>; .even

_list:
	mov	$1,prfile
2:
	movf	(r3)+,r0
	movfi	r0,-(sp)
/ probably vistigal?? 	mov	r3,0f
	movf	(r3),r0
	movfi	r0,lineno
1:
	jsr	pc,nextlin
		br 1f
	cmp	lineno,(sp)
	bhi	1f
	mov	$line,r0
	jsr	pc,print
	inc	lineno
	br	1b
1:
	cmp	$1,prfile
	beq	1f
	mov	prfile,r0
	sys	close
	mov	$1,prfile
1:
	tst	(sp)+
	jmp	*(r4)+

_done:
	sys	unlink; tmpf
	sys	exit

.if scope  / for plotting
_sdisp:
	mov	$2,r0
	jsr	pc,drput
	jsr	pc,drxy
	mov	$1,r0
	jsr	pc,drput
	mov	$3,r0
	jsr	pc,drput
	incb	drflg
	jmp	*(r4)+

_fdisp:
	clr	r0
	jsr	pc,drput
	clrb	drflg
	jmp	*(r4)+

_draw:
	movf	(r3)+,r2
	movf	(r3)+,r1
	movf	(r3)+,r0
	jsr	r5,draw
	jmp	*(r4)+

_erase:
	mov	$1,r0
	jsr	pc,drput
	mov	$1,r0
	jsr	pc,drput
	jmp	*(r4)+
.endif

_print:
	movf	(r3)+,r0
	jsr	r5,ftoa; xputc
	jmp	*(r4)+

_octal:
	movf	(r3)+,r0
	jsr	r5,ftoo; xputc
	jmp	*(r4)+

_nline:
	mov	$'\n,r0
	jsr	r5,xputc
	jmp	*(r4)+

_ascii:
	movb	(r4)+,r0
	cmp	r0,$'"
	beq	1f
	jsr	r5,xputc
	br	_ascii
1:
	inc	r4
	bic	$1,r4
	jmp	*(r4)+

_line:
	mov	sstack,r3
	cmp	r3,$stack+20.
	bhi	1f
	jsr	r5,error
		<out of space\n\0>; .even
1:
	mov	(r4)+,lineno
	jmp	*(r4)+

_or:
	tstf	(r3)+
	cfcc
	bne	stone
	tstf	(r3)
	cfcc
	bne	stone
	br	stzero

_and:
	tstf	(r3)+
	cfcc
	beq	stzero
	tstf	(r3)
	cfcc
	beq	stzero
	br	stone

_great:
	jsr	pc,bool
	bgt	stone
	br	stzero

_greateq:
	jsr	pc,bool
	bge	stone
	br	stzero

_less:
	jsr	pc,bool
	blt	stone
	br	stzero

_lesseq:
	jsr	pc,bool
	ble	stone
	br	stzero

_noteq:
	jsr	pc,bool
	bne	stone
	br	stzero

_equal:
	jsr	pc,bool
	beq	stone

stzero:
	clrf	r0
	br	advanc

stone:
	movf	$one,r0
	br	advanc

_extr:
	movf	r1,r0		/ dup for _and in extended rel
	br	subadv

_asgn:
	movf	(r3)+,r0
	mov	(r3)+,r0
	add	$4,r0
	bis	$1,(r0)+
	movf	r0,(r0)
	br	subadv

_add:
	movf	(r3)+,r0
	addf	(r3),r0
	br	advanc

_sub:
	movf	(r3)+,r0
	negf	r0
	addf	(r3),r0
	br	advanc

_mult:
	movf	(r3)+,r0
	mulf	(r3),r0
	br	advanc

_divid:
	movf	(r3)+,r1
	movf	(r3),r0
	divf	r1,r0
	br	advanc

_expon:
	movf	(r3)+,fr1
	movf	(r3),fr0
	jsr	pc,pow
	bec	advanc
	jsr	r5,error
		<Bad exponentiation\n\0>; .even

_neg:  / unary -
	negf	r0
	jbr	advanc
/ end of _neg

_intcon:
	movif	(r4)+,r0
	jbr	subadv

_con0:
	clrf	r0
	jbr	subadv

_con1:
	movf	$one,r0
	jbr	subadv

_const:
	movf	(r4)+,r0

subadv:
	movf	r0,-(r3)
	jmp	*(r4)+

advanc:
	movf	r0,(r3)
	jmp	*(r4)+

_rval:
	jsr	pc,getlv
	br	subadv

_fori:
	jsr	pc,getlv
	addf	$one,r0
	movf	r0,(r0)
	br	subadv

_lval:
	mov	(r4)+,-(r3)
	jmp	*(r4)+

_dup:
	movf	(r3),r0
	br	subadv

_return:
	dec	sublev
	bge	1f
	jsr	r5,error
		<bad return\n\0>; .even
1:
	movf	(r3),r0
	mov	sstack,r3
	mov	(r3)+,sstack
	mov	(r3)+,r4
	mov	(r4)+,r0
1:
	dec	r0
	blt	advanc
	add	$8,r3
	br	1b

_subscr:
	mov	(r4),r1
	mpy	$8.,r1
	add	r1,r3
	mov	r3,-(sp)
	mov	(r3),r0
	mov	(r4)+,-(sp)
1:
	dec	(sp)
	blt	1f
	movf	-(r3),r0
	movfi	r0,r2
	com	r2
	blt	2f
	jsr	r5,error
		<subscript out of range\n\0>; .even
2:
	mov	r0,r1
	mov	4(r0),r0
	bic	$1,r0
2:
	beq	2f
	cmp	r2,(r0)+
	bne	3f
	tst	-(r0)
	br	1b
3:
	mov	(r0),r0
	br	2b
2:
	mov	$symtab,r0
2:
	tst	(r0)
	beq	2f
	add	$14.,r0
	br	2b
2:
	cmp	r0,$esymtab-28.
	blo	2f
	jsr	r5,error
		<out of symbol space\n\0>; .even
2:
	cmp	(r1)+,(r1)+
	mov	r0,-(sp)
	clr	14.(r0)
	mov	r2,(r0)+
	mov	(r1),r2
	bic	$1,r2
	mov	r2,(r0)+
	clr	(r0)+
	mov	(sp)+,r0
	bic	$!1,(r1)
	bis	r0,(r1)
	br	1b
1:
	tst	(sp)+
	mov	(sp)+,r3
	mov	r0,(r3)
	jmp	*(r4)+

bool:
	movf	(r3)+,r1	/ r1 used in extended rel
	cmpf	(r3),r1
	cfcc
	rts	pc

getlv:
	mov	(r3)+,r0
	add	$4,r0
	bit	$1,(r0)+
	bne	1f
	jsr	r5,error;<used before set\n\0>; .even
1:
	movf	(r0),r0
	rts	pc

/
/

/ bas4 -- builtin functions

builtin:
	dec	sublev
	mov	(r3)+,sstack
	mov	(r3)+,r4
	movfi	r0,r0
	com	r0
	asl	r0
	cmp	r0,$2f-1f
	bhis	2f
	jmp	*1f(r0)
1:
	fnarg
	fnexp
	fnlog
	fnsin
	fncos
	fnatan
	fnrand
	fnexpr
	fnint
	fnabs
	fnsqr
2:
	mov	$-1,r0
	jsr	pc,getloc		/ label not found diagnostic

fnarg:
	cmp	(r4)+,$1
	bne	narg
	movf	(r3),r0
	movfi	r0,r0
	jsr	pc,arg
	br	fnadvanc

fnexp:
	jsr	r5,fnfn; exp
	br	fnadvanc

fnlog:
	jsr	r5,fnfn; log
	bec	fnadvanc
	jsr	r5,error
		<Bad log\n\0>; .even

fnsin:
	jsr	r5,fnfn; sin
	bec	fnadvanc
	jsr	r5,error
		<Bad sine\n\0>; .even

fncos:
	jsr	r5,fnfn; cos
	bec	fnadvanc
	jsr	r5,error
		<Bad cosine\n\0>; .even

fnatan:
	jsr	r5,fnfn; atan
	bec	fnadvanc
	jsr	r5,error
		<Bad arctangent\n\0>; .even

fnrand:
	tst	(r4)+
	bne	narg
	jsr	pc,rand
	movif	r0,r0
	divf	$44000,r0
	jmp	advanc

fnexpr:
	tst	(r4)+
	bne	narg
	mov	r3,-(sp)
	mov	r4,-(sp)
	jsr	pc,rdline
	mov	exprloc,r4
	mov	$line,r3
	jsr	pc,expr
	mov	$_tra,(r4)+
	mov	(sp)+,(r4)+
	mov	(sp)+,r3
	mov	exprloc,r4
	add	$8,r3
	jmp	*(r4)+

fnint:
	cmp	(r4)+,$1
	bne	narg
	movf	(r3),r0
	modf	$one,r0
	movf	r1,r0
	br	fnadvanc

fnabs:
	cmp	(r4)+,$1
	bne	narg
	movf	(r3),r0
	cfcc
	bge	fnadvanc
	negf	r0
	br	fnadvanc

fnsqr:
	jsr	r5,fnfn; sqrt
	bec	fnadvanc
	jsr	r5,error
	<Bad square root arg\n\0>; .even
fnadvanc:
	add	$8,r3
	jmp	advanc

narg:
	jsr	r5,error
		<arg count\n\0>; .even

arg:
	tst	sublev
	beq	1f
	mov	sstack,r1
	sub	*2(r1),r0
	bhi	1f
2:
	inc	r0
	bgt	2f
	add	$8,r1
	br	2b
2:
	movf	4(r1),r0
	rts	pc
1:
	jsr	r5,error
		<bad arg\n\0>; .even

fnfn:
	cmp	(r4)+,$1
	bne	narg
	movf	(r3),r0
	jsr	pc,*(r5)+
	rts	r5

.if scope / for plotting
draw:
	tstf	r2
	cfcc
	bne	1f
	movf	r0,drx
	movf	r1,dry
	rts	r5
1:
	movf	r0,-(sp)
	movf	r1,-(sp)
	mov	$3,r0
	jsr	pc,drput
	jsr	pc,drxy
	movf	(sp)+,r0
	movf	r0,dry
	movf	(sp)+,r0
	movf	r0,drx
	jsr	pc,drxy
	rts	r5

drxy:
	movf	drx,r0
	jsr	pc,drco
	movf	dry,r0

drco:
	tstf	r0
	cfcc
	bge	1f
	clrf	r0
1:
	cmpf	$40200,r0		/ 1.0
	cfcc
	bgt	1f
	movf	$40177,r0		/ 1.0-eps
1:
	subf	$40000,r0		/ .5
	mulf	$43200,r0		/ 4096
	movfi	r0,r0
	mov	r0,-(sp)
	jsr	pc,drput
	mov	(sp)+,r0
	swab	r0

drput:
	movb	r0,ch
	mov	drfo,r0
	bne	1f
	sys	open; vt; 1
	bec	2f
	4
2:
	mov	r0,drfo
1:
	sys	write; ch; 1
	rts	pc

.endif
/ bas4 -- old library routines
atoi:
	clr	r1
	jsr	r5,nextc
	clr	-(sp)
	cmp	r0,$'-
	bne	2f
	inc	(sp)
1:
	jsr	r5,nextc
2:
	sub	$'0,r0
	cmp	r0,$9
	bhi	1f
	mpy	$10.,r1
	bcs	3f / >32k
	add	r0,r1
	bcs	3f / >32k
	br	1b
1:
	add	$'0,r0
	tst	(sp)+
	beq	1f
	neg	r1
1:
	rts	r5
3:
	tst	(sp)+
	mov	$'.,r0  / faking overflow
	br	1b

ldfps = 170100^tst
stfps = 170200^tst
atof:
	stfps	-(sp)
	ldfps	$200
	movf	fr1,-(sp)
	mov	r1,-(sp)
	mov	r2,-(sp)
	clr	-(sp)
	clrf	fr0
	clr	r2
	jsr	r5,*(r5)
	cmpb	r0,$'-
	bne	2f
	inc	(sp)
1:
	jsr	r5,*(r5)
2:
	sub	$'0,r0
	cmp	r0,$9.
	bhi	2f
	jsr	pc,dig
		br	1b
	inc	r2
	br	1b
2:
	cmpb	r0,$'.-'0
	bne	2f
1:
	jsr	r5,*(r5)
	sub	$'0,r0
	cmp	r0,$9.
	bhi	2f
	jsr	pc,dig
		dec r2
	br	1b
2:
	cmpb	r0,$'e-'0
	bne	1f
	jsr	r5,atoi
	sub	$'0,r0
	add	r1,r2
1:
	movf	$one,fr1
	mov	r2,-(sp)
	beq	2f
	bgt	1f
	neg	r2
1:
	cmp	r2,$38.
	blos	1f
	clrf	fr0
	tst	(sp)+
	bmi	out
	movf	$huge,fr0
	br	out
1:
	mulf	$ten,fr1
	sob	r2,1b
2:
	tst	(sp)+
	bge	1f
	divf	fr1,fr0
	br	2f
1:
	mulf	fr1,fr0
	cfcc
	bvc	2f
	movf	$huge,fr0
2:
out:
	tst	(sp)+
	beq	1f
	negf	fr0
1:
	add	$'0,r0
	mov	(sp)+,r2
	mov	(sp)+,r1
	movf	(sp)+,fr1
	ldfps	(sp)+
	tst	(r5)+
	rts	r5

dig:
	cmpf	$big,fr0
	cfcc
	blt	1f
	mulf	$ten,fr0
	movif	r0,fr1
	addf	fr1,fr0
	rts	pc
1:
	add	$2,(sp)
	rts	pc

one	= 40200
ten	= 41040
big	= 56200
huge	= 77777

.globl	_ndigits
.globl ecvt
.globl fcvt

ftoa:
	jsr	pc,ecvt
	mov	r0,bufptr
	tstb	r1
	beq	1f
	mov	$'-,r0
	jsr	r5,*(r5)
1:
	cmp	r3,$-2
	blt	econ
	cmp	r2,$-5
	ble	econ
	cmp	r2,$6
	bgt	econ
	jsr	pc,cout
	tst	(r5)+
	rts	r5

econ:
	mov	r2,-(sp)
	mov	$1,r2
	jsr	pc,cout
	mov	$'e,r0
	jsr	r5,*(r5)
	mov	(sp)+,r0
	dec	r0
	jmp	itoa

cout:
	mov	bufptr,r1
	add	_ndigits,r1
	mov	r2,-(sp)
	add	bufptr,r2
1:
	cmp	r1,r2
	blos	1f
	cmpb	-(r1),$'0
	beq	1b
	inc	r1
1:
	mov	(sp)+,r2
	bge	2f
	mov	$'.,r0
	jsr	r5,*(r5)
1:
	mov	$'0,r0
	jsr	r5,*(r5)
	inc	r2
	blt	1b
	dec	r2
2:
	mov	r2,-(sp)
	mov	bufptr,r2
1:
	cmp	r2,r1
	bhis	1f
	tst	(sp)
	bne	2f
	mov	$'.,r0
	jsr	r5,*(r5)
2:
	dec	(sp)
	movb	(r2)+,r0
	jsr	r5,*(r5)
	br	1b
1:
	tst	(sp)+
	rts	pc

.bss
bufptr:	.=.+2
.text

ftoo:
	stfps	-(sp)
	ldfps	$200
	mov	r1,-(sp)
	mov	r2,-(sp)
	mov	$buf,r1
	movf	fr0,(r1)+
	mov	$buf,r2
	br	2f
1:
	cmp	r2,r1
	bhis	1f
	mov	$';,r0
	jsr	r5,*(r5)
2:
	mov	(r2)+,r0
	jsr	pc,oct
	br	1b
1:
	mov	$'\n,r0
	jsr	pc,*(r5)+
	ldfps	(sp)+
	rts	r5

oct:
	mov	r0,x+2
	setl
	movif	x,fr0
	mulf	$small,fr0
	seti
	mov	$6.,-(sp)
1:
	modf	$eight,fr0
	movfi	fr1,r0
	add	$'0,r0
	jsr	r5,*(r5)
	dec	(sp)
	bne	1b
	tst	(sp)+
	rts	pc

eight	= 41000
small	= 33600
.bss
buf:	.=.+8
x:	.=.+4
.text

itoa:
	mov	r1,-(sp)
	mov	r0,r1
	bge	1f
	neg	r1
	mov	$'-,r0
	jsr	r5,*(r5)
1:
	jsr	pc,1f
	mov	(sp)+,r1
	tst	(r5)+
	rts	r5

1:
	clr	r0
	dvd	$10.,r0
	mov	r1,-(sp)
	mov	r0,r1
	beq	1f
	jsr	pc,1b
1:
	mov	(sp)+,r0
	add	$'0,r0
	jsr	r5,*(r5)
	rts	pc
/ bas -- BASIC
/ new command "dump" which dumps symbol table values by name
/		R. Haight
/
_dump:
	mov	r4,-(sp)
	mov	$11.*14.+symtab-14.,r4
1:
	add	$14.,r4
	tst	(r4)
	beq	1f
	bit	$1,4(r4)
	beq	1b
	jsr	pc,dmp1
	mov	$'=,r0
	jsr	r5,xputc
	movf	6(r4),r0
	jsr	r5,ftoa; xputc
	mov	$'\n,r0
	jsr	r5,xputc
	br	1b
1:
	mov	(sp)+,r4
	jmp	*(r4)+

dmp1:
	tst	(r4)
	blt	1f
	mov	(r4),nameb
	mov	2(r4),nameb+2
	mov	$nameb,r0
	jsr	pc,print
	rts	pc
1:
	mov	r4,-(sp)
	mov	$symtab-14.,r4
1:
	add	$14.,r4
	tst	(r4)
	beq	1f
	mov	4(r4),r0
	bic	$1,r0
2:
	beq	1b
	cmp	r0,(sp)
	beq	2f
	mov	2(r0),r0
	br	2b
2:
	jsr	pc,dmp1
	mov	$'[,r0
	jsr	r5,xputc
	mov	*(sp),r0
	com	r0
	movif	r0,r0
	jsr	r5,ftoa; xputc
	mov	$'],r0
	jsr	r5,xputc
1:
	mov	(sp)+,r4
	rts	pc
/
/

/ basx -- data

one = 40200

.data

_ndigits:10.
tmpf:	</tmp/btma\0>
argname: <b.out\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0>
vt:	</dev/vt0\0>
.even
pname:	<\0\0\0\0\0\0>
	.even

resnam:
	<list>
	<done>
	<q\0\0\0>
	<run\0>
	<prin>
	<prom>   / prompt is like print without \n (cr)
	<if\0\0>
	<goto>
	<retu>
	<for\0>
	<next>
	<octa>
	<save>
	<dump>
	<fi\0\0>
	<else>
	<edit>
	<comm>  / comment
.if scope / for plotting
	<disp>
	<draw>
	<eras>
.endif
eresnam:

symtnam:
	<arg\0>
	<exp\0>
	<log\0>
	<sin\0>
	<cos\0>
	<atn\0>
	<rnd\0>
	<expr>
	<int\0>
	<abs\0>
	<sqr\0>
esymtnam:

/ indirect sys calls:
sysseek:	sys	seek; seekx: 0; 0
syswrit:	sys	write; wbuf: 0; wlen: 0
sysread:	sys	read; rbuf: 0; rlen: 0
sysopen:	sys	open; ofile: 0 ; omode: 0
syscreat:	sys	creat; cfile: 0; cmode: 0
.bss
drx:	.=.+8
dry:	.=.+8
drfo:	.=.+2
ch:	.=.+2
drflg:	.=.+2
randx:	.=.+2
gsp:	.=.+2
forp:	.=.+2
exprloc:.=.+2
sstack:	.=.+2
sublev:	.=.+2
val:	.=.+2
splimit:	.=.+2  / statement size limit
iflev:	.=.+20.  / nested if compile stack: 10 deep
ifp:	.=.+2    / current pointer to iflev
line:	.=.+100.
prfile:	.=.+2   / output from _list or _save
tfi:	.=.+2  / input file
func:	.=.+2   / alternate functions, eg: _list or _save
seeka:	.=.+2   / seek offset 1
lineno:	.=.+2
nameb:	.=.+4
tfo:	.=.+2
symtab:	.=.+2800.; esymtab: / symbol=7wds; symtab for 200
space:	.=.+8000.; espace: / code space
exline:	.=.+1000.; eexline: / line execute space
lintab:	.=.+1800.; elintab: / 3wds per statement = 300 stmts
stack:	.=.+800.; estack:

iobuf: fi: .=.+518.  / should be aquired??