bas.s

Version 6 Unix 核心源代码 Version 6 Unix 核心源代码

	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??