minnie.tuhs.org/unixen.tar/unixen/PDP-11/Trees/V7/usr/src/cmd/bas/bas.s

Text File | 1979-01-10 | 22.8 KB | 2,129 lines

/
/

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