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