V7/usr/src/cmd/bas/bas.s
/
/
/ 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; 1; _done
sys signal; 2; intrup
tst r0
jeq 1f
sys signal; 2; 1
1:
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
fnlast
2:
mov $-1,r0
jsr pc,getloc / label not found diagnostic
fnarg:
cmp (r4)+,$1
jne 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
fnlast:
tst (r4)+
bne narg
movf lastpr,fr0
jbr advanc
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:
movf fr0,lastpr
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 $12.*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>
<last>
esymtnam:
/ indirect sys calls:
sysseek: sys lseek; 0; 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
lastpr: .=.+8 / last printed number
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 acquired??