/ / copyright 1972 bell telephone laboratories inc. / / 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: mov argname,0f sys 0; 9f .data 9: sys creat; 0:..; 0666 .text bec 1f 4 1: mov r0,fo _list: movf (r3)+,r0 movfi r0,-(sp) 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: tst (sp)+ mov fo,r0 cmp r0,$1 beq 1f sys close mov $1,fo 1: jmp *(r4)+ _done: sys unlink; tmpf sys exit _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)+ _print: movf (r3)+,r0 jsr r5,ftoa; putc jmp *(r4)+ _octal: movf (r3)+,r0 jsr r5,ftoo; putc 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)+ _nline: mov $'\n,r0 jsr r5,putc jmp *(r4)+ _ascii: movb (r4)+,r0 cmp r0,$'" beq 1f jsr r5,putc 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 _negat: negf (r3) jmp *(r4)+ _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 r5,pow bec advanc jsr r5,error <Bad exponentiation\n\0>; .even _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 _dump: mov r4,-(sp) mov $9.*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,putc movf 6(r4),r0 jsr r5,ftoa; putc mov $'\n,r0 jsr r5,putc 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,putc mov *(sp),r0 com r0 movif r0,r0 jsr r5,ftoa; putc mov $'],r0 jsr r5,putc 1: mov (sp)+,r4 rts pc