bas.s

Version 6 Unix 核心源代码 Version 6 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)