+.globl log2
+.globl getchar
+.globl lookchar
+.globl fsfile
+.globl seekchar
+.globl backspace
+.globl putchar
+.globl alterchar
+.globl move
+.globl rewind
+.globl create
+.globl zero
+.globl allocate
+.globl release
+.globl collect
+.globl w, r, a, l
+/
+ cmp (sp)+,$2
+ blo 1f
+ tst (sp)+
+ mov (sp)+,0f
+ sys 0; 9f
+.data
+9:
+ sys open; 0:.=.+2; 0
+.text
+ bec 2f
+ mov $1,r0
+ sys write; 4f; 5f-4f
+ sys exit
+
+error:
+ 4
+/
+4: <Input file.\n>
+5: .even
+/
+2:
+ mov r0,source
+1:
+ sys signal; 2; 1
+ ror r0
+ bcs 1f
+ sys signal; 2; case177
+1:
+ clr delflag
+ mov $pdl,r5
+/
+ mov $10.,r0
+ jsr pc,log2
+ mov r0,log10
+ clr r0
+ jsr pc,allocate
+ mov r1,basptr
+ mov $10.,r0
+ jsr pc,putchar
+ mov $1,r0
+ jsr pc,allocate
+ mov r1,inbas
+ mov $10.,r0
+ jsr pc,putchar
+ mov $1,r0
+ jsr pc,allocate
+ mov $10.,r0
+ jsr pc,putchar
+ mov r1,tenptr
+ clr r0
+ jsr pc,allocate
+ mov r1,chptr
+ clr r0
+ jsr pc,allocate
+ mov r1,strptr
+ mov $1,r0
+ jsr pc,allocate
+ mov $2,r0
+ jsr pc,putchar
+ mov r1,sqtemp
+ clr r0
+ jsr pc,allocate
+ mov r1,divxyz
+loop:
+ tst delflag
+ bne in177
+ mov sp,errstack
+ jsr pc,readc
+ mov $casetab,r1
+1: tst (r1)+
+ beq 2f
+ cmp r0,(r1)+
+ bne 1b
+ jmp *-4(r1)
+2: jmp eh
+/
+/
+/ case for new line (which is special for apl box)
+/
+case012:
+ br loop
+/
+/
+/ case q for quit
+/
+case161:
+ cmp readptr,$readstack+2
+ blos 1f
+ mov *readptr,r1
+ beq 2f
+ jsr pc,release
+2:
+ sub $2,readptr
+ mov *readptr,r1
+ beq 2f
+ jsr pc,release
+2:
+ sub $2,readptr
+ jmp loop
+1:
+ sys exit
+/
+/
+/ case Q for controlled quit
+/
+case121:
+ jsr pc,pop
+ jes eh
+ jsr pc,length
+ cmp r0,$1
+ jhi eh
+ jsr pc,rewind
+ jsr pc,getchar
+ jmi eh
+ jsr pc,release
+1:
+ cmp readptr,$readstack
+ jlos eh
+ mov *readptr,r1
+ beq 2f
+ jsr pc,release
+2:
+ sub $2,readptr
+ sob r0,1b
+ jbr loop
+/
+/
+/ case of delete character
+/
+case177:
+ sys signal; 2; case177
+ mov $1,delflag
+ mov r0,-(sp)
+ mov 2(sp),r0
+ cmp -6(r0),$sys+read
+ bne 1f
+ sub $6,2(sp)
+ clr delflag
+1:
+ mov (sp)+,r0
+ 2 /rti
+/
+in177:
+ mov $' ,ch
+ mov $1,r0
+ sys write; 1f; 1
+ clr delflag
+ jmp eh
+/
+.bss
+delflag: .=.+2
+.text
+1: <\n>
+ .even
+/
+/
+/ case digit
+/
+case060:
+ movb r0,savec
+ jsr pc,readin
+ jsr pc,push
+ br loop
+/
+/
+/ case _ for negative numbers
+/
+case137:
+ jsr pc,readin
+ jsr pc,fsfile
+ jsr pc,backspace
+ mov r0,savk
+ dec w(r1)
+ jsr pc,chsign
+ mov savk,r0
+ jsr pc,putchar
+ jsr pc,push
+ jbr loop
+/
+/
+/ case screamer
+/
+case041:
+ jsr pc,in041
+ jbr loop
+/
+in041:
+ jsr pc,readc
+ cmp r0,$'<
+ jeq case74a
+ cmp r0,$'=
+ jeq case75a
+ cmp r0,$'>
+ jeq case76a
+/
+ mov $field,r1
+ movb r0,(r1)+
+1:
+ jsr pc,readc
+ movb r0,(r1)+
+ cmpb r0,$'\n
+ bne 1b
+ clrb (r1)+
+/
+ sys fork
+ br 9f
+ sys wait
+ mov $1,r0
+ sys write; screamer; 2
+ rts pc
+9: sys exec; 6f; 8f
+ 4
+.data
+8: 6f; 7f; field; 0
+6: </bin/sh\0>
+7: <-c\0>
+screamer: <!\n>
+ .even
+.bss
+field: .=.+72.
+.text
+/
+/
+/ case d for duplicate
+/
+case144:
+ cmp r5,$pdl
+ jeq eh
+ clr r0
+ jsr pc,allocate
+ mov -2(r5),r0
+ jsr pc,move
+ jsr pc,push
+ jmp loop
+/
+/
+/ case z for stack size
+/
+case172:
+ clr r0
+ jsr pc,allocate
+ mov r5,r3
+ sub $pdl,r3
+ asr r3
+2:
+ beq 2f
+ clr r2
+ dvd $100.,r2
+ mov r3,r0
+ jsr pc,putchar
+ mov r2,r3
+ br 2b
+2:
+ clr r0
+ jsr pc,putchar
+ jsr pc,push
+ jmp loop
+/
+/
+/ case c for flush
+/
+case143:
+2: jsr pc,pop
+ jes loop
+ jsr pc,release
+ br 2b
+/
+/ case s for save
+/
+case163:
+ tst sfree
+ bne 1f
+ jsr pc,sinit
+1:
+ jsr pc,readc
+ cmp r5,$pdl
+ bne 2f
+ movb $'s,ch
+ jmp eh
+2:
+ cmpb r0,$128.
+ jhis err
+ asl r0
+ mov stable(r0),r1
+ beq 2f
+ mov r1,r0
+ mov 2(r0),r1
+ jsr pc,release
+ jsr pc,pop
+ mov r1,2(r0)
+ jbr loop
+2:
+ mov sfree,stable(r0)
+ mov stable(r0),r0
+ mov (r0),sfree
+ beq symout
+ clr (r0)
+ jsr pc,pop
+ mov r1,2(r0)
+ jmp loop
+/
+symout:
+ mov $1,r0
+ sys write; 7f; 8f-7f
+ sys exit
+/
+7: <Symbol table overflow.\n>
+8: .even
+/
+/
+sinit:
+ mov $sfree+4,r0
+1:
+ mov r0,-4(r0)
+ clr -2(r0)
+ add $4,r0
+ cmp r0,$sfend
+ blos 1b
+ clr sfend-4
+ rts pc
+/
+/
+.bss
+sfree: .=.+512.
+sfend:
+.text
+/
+/
+/ case S for save
+/
+case123:
+ tst sfree
+ bne 1f
+ jsr pc,sinit
+1:
+ jsr pc,readc
+ cmp r5,$pdl
+ bne 2f
+ movb $'S,ch
+ jbr eh
+2:
+ cmpb r0,$128.
+ jhis err
+ asl r0
+ mov stable(r0),r1
+ beq 2f
+ mov sfree,r2
+ mov (r2),sfree
+ beq symout
+ mov stable(r0),(r2)
+ mov r2,stable(r0)
+ jsr pc,pop
+ mov r1,2(r2)
+ jbr loop
+2:
+ mov sfree,stable(r0)
+ mov stable(r0),r0
+ mov (r0),sfree
+ beq symout
+ clr (r0)
+ jsr pc,pop
+ mov r1,2(r0)
+ jbr loop
+/
+/
+/ case l for load
+/
+case154:
+ jsr pc,in154
+ jmp loop
+/
+in154:
+ jsr pc,readc
+ cmp r0,$128.
+ jhis err
+ asl r0
+ mov stable(r0),r1
+ beq 1f
+ mov 2(r1),r1
+ mov r1,-(sp)
+ jsr pc,length
+ jsr pc,allocate
+ mov (sp)+,r0
+ jsr pc,move
+ jsr pc,push
+ rts pc
+1:
+ clr r0
+ jsr pc,allocate
+ jsr pc,push
+ rts pc
+/
+/
+/ case L for load
+/
+case114:
+ jsr pc,readc
+ cmp r0,$128.
+ jhis err
+ asl r0
+ mov stable(r0),r1
+ beq 1f
+ mov (r1),stable(r0)
+ mov sfree,(r1)
+ mov r1,sfree
+ mov 2(r1),r1
+ jsr pc,push
+ jbr loop
+1:
+ movb $'L,ch
+ jbr eh
+/
+/
+/ case - for subtract
+/
+case055:
+ jsr pc,in055
+ jmp loop
+/
+in055:
+ jsr pc,pop
+ jes eh
+ jsr pc,fsfile
+ jsr pc,backspace
+ mov r0,savk
+ dec w(r1)
+ jsr pc,chsign
+ mov savk,r0
+ jsr pc,putchar
+ jsr pc,push
+ br in053
+/
+/
+/ case + for add
+/
+case053:
+ jsr pc,in053
+ jmp loop
+/
+in053:
+ jsr pc,eqk
+ mov $add3,r0
+ jsr pc,binop
+ jsr pc,pop
+ mov savk,r0
+ jsr pc,putchar
+ jsr pc,push
+ rts pc
+/
+/
+/ case * for multiply
+/
+case052:
+ jsr pc,pop
+ jes eh
+ mov r1,-(sp)
+ jsr pc,pop
+ jec 1f
+ mov (sp)+,r1
+ jsr pc,push
+ jbr eh
+1:
+ mov r1,-(sp)
+ jsr pc,fsfile
+ jsr pc,backspace
+ mov r0,savk2
+ dec w(r1)
+ mov 2(sp),r1
+ jsr pc,fsfile
+ jsr pc,backspace
+ mov r0,savk1
+ dec w(r1)
+ mov r1,r3
+ mov (sp)+,r2
+ mov $mul3,r0
+ jsr pc,binop
+ jsr pc,pop
+ tst savk1
+ beq 1f
+ tst savk2
+ beq 2f
+ mov savk1,r2
+ cmp savk1,savk2
+ blos 3f
+ mov savk2,r2
+ mov savk1,savk2
+3:
+ jsr pc,removc
+1:
+ mov savk2,r0
+1:
+ jsr pc,putchar
+ jsr pc,push
+ jmp loop
+2:
+ mov savk1,r0
+ br 1b
+/
+/ r1 = string
+/ r2 = count
+/ result returned in r1 (old r1 released)
+/
+removc:
+ mov r1,-(sp)
+ jsr pc,rewind
+1:
+ cmp r2,$1
+ blos 1f
+ jsr pc,getchar
+ sub $2,r2
+ br 1b
+1:
+ mov $2,r0
+ jsr pc,allocate
+ mov r1,-(sp)
+1:
+ mov 2(sp),r1
+ jsr pc,getchar
+ bes 1f
+ mov (sp),r1
+ jsr pc,putchar
+ mov r1,(sp)
+ br 1b
+1:
+ cmp r2,$1
+ bne 1f
+ mov (sp),r3
+ mov tenptr,r2
+ jsr pc,div3
+ mov r1,(sp)
+ mov r3,r1
+ jsr pc,release
+ mov r4,r1
+ jsr pc,release
+1:
+ mov 2(sp),r1
+ jsr pc,release
+ mov (sp)+,r1
+ tst (sp)+
+ rts pc
+/
+/ case / for divide
+/
+case057:
+ jsr pc,dscale
+ mov $div3,r0
+ jsr pc,binop
+ mov r4,r1
+ jsr pc,release
+ jsr pc,pop
+ mov savk,r0
+ jsr pc,putchar
+ jsr pc,push
+ jmp loop
+/
+/
+dscale:
+ jsr pc,pop
+ jes eh
+ mov r1,-(sp)
+ jsr pc,pop
+ bec 1f
+ mov (sp)+,r1
+ jsr pc,push
+ jmp eh
+1:
+ mov r1,-(sp)
+ jsr pc,fsfile
+ jsr pc,backspace
+ mov r0,savk1
+ dec w(r1)
+ jsr pc,rewind
+ mov 2(sp),r1
+ jsr pc,fsfile
+ jsr pc,backspace
+ mov r0,savk2
+ dec w(r1)
+ mov k,r2
+ sub savk1,r2
+ add savk2,r2
+ mov k,savk
+ mov (sp)+,r1
+ jsr pc,add0
+ mov r1,r3
+ mov (sp)+,r2
+ rts pc
+/
+/
+/ case % for remaindering
+/
+case045:
+ jsr pc,dscale
+ mov $div3,r0
+ jsr pc,binop
+ jsr pc,pop
+ jsr pc,release
+ mov r4,r1
+ mov savk1,r0
+ add savk2,r0
+ jsr pc,putchar
+ jsr pc,push
+ jmp loop
+/
+/
+binop:
+ jsr pc,(r0)
+ jsr pc,push
+ mov r2,r1
+ jsr pc,release
+ mov r3,r1
+ jsr pc,release
+ rts pc
+/
+eqk:
+ jsr pc,pop
+ jes eh
+ mov r1,-(sp)
+ jsr pc,pop
+ bec 1f
+ mov (sp)+,r1
+ jsr pc,push
+ jbr eh
+1:
+ mov r1,-(sp)
+ mov 2(sp),r1
+ jsr pc,fsfile
+ jsr pc,backspace
+ mov r0,savk1
+ dec w(r1)
+ mov (sp),r1
+ jsr pc,fsfile
+ jsr pc,backspace
+ mov r0,savk2
+ dec w(r1)
+ cmp r0,savk1
+ beq 1f
+ blo 2f
+ mov savk2,savk
+ mov r0,r2
+ sub savk1,r2
+ mov 2(sp),r1
+ jsr pc,add0
+ mov r1,2(sp)
+ br 4f
+2:
+ mov savk1,r2
+ sub savk2,r2
+ mov (sp),r1
+ jsr pc,add0
+ mov r1,(sp)
+1:
+ mov savk1,savk
+4:
+ mov 2(sp),r3
+ mov (sp)+,r2
+ tst (sp)+
+ rts pc
+.bss
+savk1: .=.+2
+savk2: .=.+2
+savk: .=.+2
+.text
+/
+/
+/ r2 = count
+/ r1 = ptr
+/ returns ptr in r1
+add0:
+ mov r1,-(sp)
+ jsr pc,length
+ jsr pc,allocate
+ clr r0
+1:
+ cmp r2,$1
+ blos 1f
+ jsr pc,putchar
+ sub $2,r2
+ br 1b
+1:
+ mov r1,-(sp)
+ mov 2(sp),r1
+ jsr pc,rewind
+1:
+ jsr pc,getchar
+ bes 1f
+ mov (sp),r1
+ jsr pc,putchar
+ mov r1,(sp)
+ mov 2(sp),r1
+ br 1b
+1:
+ cmp r2,$1
+ bne 1f
+ mov (sp),r3
+ mov tenptr,r2
+ jsr pc,mul3
+ mov r1,(sp)
+ mov r3,r1
+ jsr pc,release
+1:
+ mov 2(sp),r1
+ jsr pc,release
+ mov (sp)+,r1
+ tst (sp)+
+ rts pc
+/ case i for input base
+/
+case151:
+ jsr pc,in151
+ jmp loop
+/
+in151:
+ jsr pc,pop
+ jes eh
+ jsr pc,scalint
+ mov r1,-(sp)
+ mov inbas,r1
+ mov (sp)+,inbas
+ jsr pc,release
+ rts pc
+/
+.bss
+inbas: .=.+2
+.data
+/
+/
+/ case o for output base
+/
+case157:
+ jsr pc,in157
+ jmp loop
+/
+in157:
+ jsr pc,pop
+ jes eh
+ jsr pc,scalint
+ mov r1,-(sp)
+ jsr pc,length
+ jsr pc,allocate
+ mov (sp),r0
+ jsr pc,move
+ jsr pc,fsfile
+ jsr pc,length
+1:
+ cmp r0,$1
+ beq 1f
+ jsr pc,backspace
+ bpl 2f
+ jsr pc,chsign
+ jsr pc,length
+ br 1b
+2:
+ clr sav
+ mov r0,-(sp)
+2:
+ jsr pc,backspace
+ bes 2f
+ mov (sp),r2
+ clr r3
+ mul $100.,r2
+ add r0,r3
+ mov r3,(sp)
+ tst sav
+ beq 3f
+ mov r2,r0
+ clr r3
+ mov sav,r2
+ mul $100.,r2
+ mov r3,sav
+ add r0,sav
+ br 2b
+3:
+ mov r2,sav
+ br 2b
+2:
+ mov (sp)+,r0
+ tst sav
+ beq 2f
+ mov sav,r0
+ jsr pc,log2
+ add $16.,r0
+ mov r0,logo
+ br 3f
+1:
+ jsr pc,backspace
+2:
+ tst r0
+ bpl 1f
+ mov $15.,logo
+ br 3f
+1:
+ jsr pc,log2
+ mov r0,logo
+3:
+ jsr pc,release
+ mov basptr,r1
+ jsr pc,release
+ mov (sp),basptr
+/
+/ set field widths for output
+/ and set output digit handling routines
+/
+ mov (sp),r1
+ mov $bigout,outdit
+ jsr pc,length
+ cmp r0,$1.
+ bne 2f
+ jsr pc,fsfile
+ jsr pc,backspace
+ cmp r0,$16.
+ bhi 2f
+ mov $hexout,outdit
+2:
+ jsr pc,length
+ jsr pc,allocate
+ mov (sp),r0
+ jsr pc,move
+ clr (sp)
+ jsr pc,fsfile
+ jsr pc,backspace
+ bpl 2f
+ add $1.,(sp)
+ jsr pc,chsign
+2:
+ mov r1,r2
+ mov $1,r0
+ jsr pc,allocate
+ mov $-1,r0
+ jsr pc,putchar
+ mov r1,r3
+ jsr pc,add3
+ jsr pc,length
+ asl r0
+ add r0,(sp)
+ jsr pc,fsfile
+ jsr pc,backspace
+ cmp r0,$9.
+ blos 2f
+ add $1,(sp)
+2:
+ jsr pc,release
+ mov r2,r1
+ jsr pc,release
+ mov r3,r1
+ jsr pc,release
+ mov (sp)+,fw
+ mov fw,fw1
+ dec fw1
+ cmp outdit,$hexout
+ bne 2f
+ mov $1,fw
+ clr fw1
+2:
+ mov $60.,ll
+ cmp fw,$60.
+ blo 9f; rts pc; 9:
+ mov $60.,r1
+ clr r0
+ dvd fw,r0
+ mov r0,r1
+ mpy fw,r1
+ mov r1,ll
+ rts pc
+/
+.data
+fw: 1 /field width for digits
+fw1: 0
+ll: 60. /line length
+.text
+/
+/
+/ case k for skale factor
+/
+case153:
+ jsr pc,pop
+ jes eh
+ jsr pc,scalint
+ mov w(r1),r0
+ sub a(r1),r0
+ cmp r0,$1
+ jhi 1f
+ jsr pc,rewind
+ jsr pc,getchar
+ jmi 1f
+ mov r0,k
+ jsr pc,release
+ jmp loop
+1:
+ jsr pc,release
+ jbr eh
+/
+scalint:
+ jsr pc,fsfile
+ jsr pc,backspace
+ dec w(r1)
+ mov r0,r2
+ jsr pc,removc
+ rts pc
+/
+/ case ^ for exponentiation
+/
+case136:
+ jsr pc,pop
+ jes eh
+ jsr pc,scalint
+ jsr pc,fsfile
+ jsr pc,backspace
+ tst r0
+ bge 1f
+ inc negexp
+ jsr pc,chsign
+1:
+ jsr pc,length
+ cmp r0,$3
+ blo 1f
+ jsr pc,release
+ jbr eh
+1:
+ mov r1,r3
+ jsr pc,pop
+ jes eh
+ jsr pc,fsfile
+ jsr pc,backspace
+ mov r0,savk
+ dec w(r1)
+ mov r1,r2
+ jsr pc,exp3
+ mov r1,-(sp)
+ mov r2,r1
+ jsr pc,release
+ tst savk
+ beq 1f
+ mov r3,r1
+ jsr pc,rewind
+ jsr pc,getchar
+ mov r0,-(sp)
+ jsr pc,getchar
+ bes 2f
+ mov r0,r1
+ mul $100.,r1
+ add (sp)+,r1
+ br 3f
+2:
+ mov (sp)+,r1
+3:
+ tst r1
+ beq 3f
+ dec r1
+ mul savk,r1
+ mov r1,r2
+ mov r3,r1
+ jsr pc,release
+ mov (sp)+,r1
+ jsr pc,removc
+ mov savk,r0
+ jsr pc,putchar
+ jsr pc,push
+ br 2f
+3:
+ mov r3,r1
+ jsr pc,release
+ mov (sp)+,r1
+ mov savk,r2
+ jsr pc,add0
+ mov savk,r0
+ jsr pc,putchar
+ jsr pc,push
+ jmp loop
+1:
+ mov r3,r1
+ jsr pc,release
+ mov (sp)+,r1
+ clr r0
+ jsr pc,putchar
+ jsr pc,push
+2:
+ tst negexp
+ jeq loop
+ clr negexp
+ jsr pc,pop
+ mov r1,-(sp)
+ mov $2,r0
+ jsr pc,allocate
+ mov $1,r0
+ jsr pc,putchar
+ clr r0
+ jsr pc,putchar
+ jsr pc,push
+ mov (sp)+,r1
+ jsr pc,push
+ jmp case057
+/
+.bss
+sav: .=.+2
+negexp: .=.+2
+.text
+/
+/ case v for square root
+/
+case166:
+ jsr pc,pop
+ jes eh
+/
+ jsr pc,fsfile
+ jsr pc,backspace
+ mov r0,savk
+ dec w(r1)
+ mov savk,r2
+ jsr pc,add0
+ mov r1,r3
+/
+/ check for zero or negative
+/
+ mov w(r3),r2
+ sub a(r3),r2
+ tst r2
+ jeq sqz
+/
+/ look at the top one or two digits
+/
+ mov r3,r1
+ jsr pc,fsfile
+ jsr pc,backspace
+ mov r0,r4
+ jmi eh
+ bit $1,r2
+ bne 2f
+ mov r4,r1
+ mul $100.,r1
+ mov r1,r4
+ mov r3,r1
+ jsr pc,backspace
+ add r0,r4
+2:
+/
+/ allocate space for result
+/
+ inc r2
+ asr r2
+ mov r2,r0
+ jsr pc,allocate
+ jsr pc,zero
+ mov r2,r0
+ jsr pc,seekchar
+ mov r1,r2
+/
+/ get high order digit of arg and square root it
+/
+ mov $1,r0
+2: sub r0,r4
+ blt 2f
+ add $2,r0
+ br 2b
+2: inc r0
+ asr r0
+ mov r0,r4
+ mov r2,r1
+ jsr pc,fsfile
+ jsr pc,backspace
+ mov r4,r0
+ jsr pc,alterchar
+ mov r1,-(sp)
+ mov r3,-(sp)
+/
+/ get successive approx. from Newton
+/
+1: mov (sp),r3 /arg
+ mov 2(sp),r2 /approx
+ jsr pc,div3
+ mov r1,r3
+ jsr pc,add3
+ mov r1,-(sp)
+ mov r3,r1
+ jsr pc,release
+ mov r4,r1
+ jsr pc,release
+ mov (sp)+,r1
+ mov sqtemp,r2
+ mov r1,r3
+ jsr pc,div3
+ mov r1,-(sp)
+ mov r3,r1
+ jsr pc,release
+ mov r4,r1
+ jsr pc,release
+ mov (sp)+,r3
+ mov 2(sp),r1
+ jsr pc,length
+ jsr pc,allocate
+ mov 2(sp),r0
+ jsr pc,move
+ jsr pc,chsign
+ mov r1,r2
+ jsr pc,add3
+ jsr pc,fsfile
+ jsr pc,backspace
+ jsr pc,release
+ mov r2,r1
+ jsr pc,release
+ tst r0
+ bpl 2f
+/
+/ loop if new < old
+/
+ mov 2(sp),r1
+ jsr pc,release
+ mov r3,2(sp)
+ br 1b
+/
+2:
+ mov r3,r1
+ jsr pc,release
+ mov 2(sp),r1
+ mov savk,r0
+ jsr pc,putchar
+ jsr pc,push
+ mov (sp),r1
+ jsr pc,release
+ tst (sp)+
+ tst (sp)+
+ jmp loop
+/
+sqz: mov $2,r0
+ jsr pc,allocate
+ clr r0
+ jsr pc,putchar
+ jsr pc,putchar
+ jsr pc,push
+ mov r3,r1
+ jsr pc,release
+ jmp loop
+.bss
+sqtemp: .=.+2
+.text
+/
+/
+/ case [ for subroutine definition
+/
+case133:
+ clr -(sp)
+ clr r0
+ jsr pc,allocate
+ jsr pc,push
+1: jsr pc,readc
+ cmp r0,$']
+ bne 3f
+ tst (sp)
+ beq 1f
+ dec (sp)
+ br 2f
+3:
+ cmp r0,$'[
+ bne 2f
+ inc (sp)
+2:
+ jsr pc,putchar
+ br 1b
+/
+1: tst (sp)+
+ jmp loop
+/
+/
+/ case x for execute top of stack
+/
+case170:
+ jsr pc,in170
+ jmp loop
+/
+in170:
+ jsr pc,pop
+ jes eh
+ mov r1,-(sp)
+ tst *readptr
+ beq 1f
+ mov *readptr,r1
+ cmp r(r1),w(r1)
+ bne 1f
+ jsr pc,release
+ br 2f
+1:
+ add $2,readptr
+ cmp readptr,$readtop
+ bhis 1f
+2: mov (sp)+,r1
+ mov r1,*readptr
+ beq 2f
+ jsr pc,rewind
+ rts pc
+2:
+ jsr pc,readc
+ cmp r0,$'\n
+ beq 3f
+ mov r0,savec
+3:
+ rts pc
+1:
+nderr:
+ mov $1,r0
+ sys write; 1f; 2f-1f
+ sys exit
+1: <Nesting depth.\n>
+2: .even
+/
+.data
+readptr: readstack
+.bss
+readstack: .=.+100.
+readtop:
+.text
+/
+/ case ? for apl box function
+/
+case077:
+ add $2,readptr
+ cmp readptr,$readtop
+ bhis nderr
+ clr *readptr
+in077:
+ mov source,-(sp)
+ clr source
+ jsr pc,readc
+ cmp r0,$'!
+ bne 1f
+ jsr pc,in041
+ mov (sp)+,source
+ br in077
+1:
+ mov r0,savec
+ clr r0
+ jsr pc,allocate
+ jsr pc,readc
+ jsr pc,putchar
+1:
+ jsr pc,readc
+ jsr pc,putchar
+ cmp r0,$'\n
+ bne 1b
+ mov (sp)+,source
+ mov r1,*readptr
+ jmp loop
+/
+/
+/ case < for conditional execution
+/
+case074:
+ jsr pc,in074
+ ble neg074
+ jmp aff074
+/
+/
+/ case !< for conditional execution
+/
+case74a:
+ jsr pc,in074
+ bgt neg074
+ jmp aff074
+/
+in074:
+ jsr pc,in055 /go subtract
+ jsr pc,pop
+ jsr pc,length
+ tst r0
+ beq 1f
+ jsr pc,fsfile
+ jsr pc,backspace
+ jsr pc,backspace
+ tst r0
+1:
+ rts pc
+/
+aff074:
+ jsr pc,release
+ jsr pc,in154 /load from register
+ jmp case170
+/
+neg074:
+ jsr pc,release
+ jsr pc,readc
+ jmp loop
+/
+/
+/ case = for conditional execution
+/
+case075:
+ jsr pc,in074
+ beq aff074
+ jmp neg074
+/
+/
+/ case != for conditional execution
+/
+case75a:
+ jsr pc,in074
+ bne aff074
+ jmp neg074
+/
+/
+/ case > for conditional execution
+/
+case076:
+ jsr pc,in074
+ bge neg074
+ jmp aff074
+/
+/
+/ case !> for conditional execution
+/
+case76a:
+ jsr pc,in074
+ blt neg074
+ jmp aff074
+/
+/
+err: 4
+/
+eh:
+ movb ch,1f+2
+ mov $1,r0
+ sys write; 1f; 2f-1f
+ mov $readstack,readptr
+ mov errstack,sp
+ jmp loop
+.data
+1: <( ) ?\n>
+2: .even
+.text
+/
+/
+/ routine to read and convert a number from the
+/ input stream. Numbers beginnig with 0 are
+/ converted as octal. Routine converts
+/ up to next nonnumeric.
+/
+/
+readin:
+ clr dp
+ clr dpt
+ clr r0
+ jsr pc,allocate
+ mov r1,-(sp)
+ mov strptr,r1
+ jsr pc,create
+ jsr pc,readc
+1:
+ cmpb ch,$'0
+ blt 1f
+ cmpb ch,$'9
+ bgt 3f
+ mov ch,r0
+ sub $'0,r0
+4:
+ tst dp
+ beq 8f
+ cmp dpt,k
+ beq 5f
+ inc dpt
+8:
+ mov chptr,r1
+ jsr pc,create
+ tst r0
+ beq 2f
+ jsr pc,putchar
+2: mov r1,chptr
+ mov (sp),r3
+ mov inbas,r2
+ jsr pc,mul3
+ mov r1,(sp)
+ mov r3,r1
+ jsr pc,release
+ mov (sp),r3
+ mov chptr,r2
+ jsr pc,add3
+ mov r1,(sp)
+ mov r3,r1
+ jsr pc,release
+5:
+ jsr pc,readc
+ mov r0,ch
+ br 1b
+3:
+ cmpb ch,$'A
+ blt 1f
+ cmpb ch,$'F
+ bgt 1f
+ mov ch,r0
+ sub $67,r0
+ br 4b
+1:
+ cmpb ch,$'.
+ bne 1f
+ tst dp
+ bne 1f
+ inc dp
+ clr dpt
+ br 5b
+1:
+ mov r0,savec
+/
+/ scale up or down
+2:
+ tst dp
+ bne 1f
+ mov (sp)+,r1
+ clr r0
+ jsr pc,putchar
+ rts pc
+1:
+ mov (sp),r1
+ jsr pc,scale
+ mov k,r0
+ jsr pc,putchar
+ tst (sp)+
+ rts pc
+/
+.bss
+dp: .=.+2
+dpt: .=.+2
+.text
+/
+scale:
+ mov k,r2
+ jsr pc,add0
+ mov r1,-(sp)
+ mov $1,r0
+ jsr pc,allocate
+ mov dpt,r0
+ jsr pc,putchar
+ mov r1,r3
+ mov inbas,r2
+ jsr pc,exp3
+ mov r1,-(sp)
+ mov r3,r1
+ jsr pc,release
+ mov (sp)+,r2
+ mov (sp)+,r3
+ jsr pc,div3
+ mov r1,-(sp)
+ mov r2,r1
+ jsr pc,release
+ mov r3,r1
+ jsr pc,release
+ mov r4,r1
+ jsr pc,release
+ mov (sp)+,r1
+ rts pc
+/
+/ routine to read another character from the input
+/ stream. If the caller does not want the character,
+/ it is to be placed in the cell savec.
+/ The routine exits to the system on end of file.
+/ Character is returned in r0.
+/
+/ jsr pc,readc
+/ movb r0,...
+/
+/
+readc:
+ tst savec
+ beq 1f
+ movb savec,r0
+ clr savec
+ rts pc
+1:
+ tst *readptr
+ bne 1f
+2: mov source,r0
+ sys read; ch; 1
+ bes eof
+ tst r0
+ beq eof
+ movb ch,r0
+ rts pc
+1:
+ mov r1,-(sp)
+ mov *readptr,r1
+ jsr pc,getchar
+ bes eof1
+ mov r0,ch
+ mov (sp)+,r1
+ rts pc
+/
+eof:
+ tst source
+ beq 1f
+ clr source
+ br 2b
+1:
+ sys exit
+/
+eof1:
+ mov *readptr,r1
+ beq 2f
+ jsr pc,release
+2:
+ sub $2,readptr
+ mov (sp)+,r1
+ jmp readc
+/
+/
+/ case p for print
+/
+case160:
+ cmp r5,$pdl
+ jeq eh
+ jsr pc,in160
+ jmp loop
+/
+/
+in160:
+ mov $1,r0
+ sys write; sphdr; 4
+ br 1f
+/
+sphdr: < >
+ .even
+/
+1: cmp r5,$pdl
+ bne 1f
+ mov $1,r0
+ sys write; qm; 1
+ mov $1,r0
+ sys write; nl; 1
+ rts pc
+/
+/ do the conversion
+/
+1:
+ mov -2(r5),r1
+ jsr pc,printf
+ rts pc
+/
+/
+/ case f for print the stack
+/
+case146:
+ mov r5,-(sp)
+1:
+ cmp r5,$pdl
+ beq 2f
+1:
+ jsr pc,in160
+ jsr pc,pop
+ cmp r5,$pdl
+ bne 1b
+2:
+ mov $stable-2,r2
+1:
+ tst (r2)+
+ cmp r2,$stable+254.
+ bhi 1f
+/
+ mov (r2),r3
+ beq 1b
+ movb $'0,7f+3
+ mov r2,r0
+ sub $stable,r0
+ asr r0
+ movb r0,7f+1
+3:
+ mov $1,r0
+ sys write; 7f; 8f-7f
+.data
+7: <" (0)">
+8: .even
+.text
+ mov 2(r3),r1
+ jsr pc,printf
+ tst (r3)
+ beq 1b
+ incb 7b+3
+ mov (r3),r3
+ br 3b
+1:
+ mov (sp)+,r5
+ jbr loop
+/
+/
+/ routine to convert to decimal and print the
+/ top element of the stack.
+/
+/ jsr pc,printf
+/
+/
+printf:
+ mov r4,-(sp)
+ mov r3,-(sp)
+ mov r2,-(sp)
+ mov r1,-(sp)
+ mov r0,-(sp)
+ clr -(sp)
+ jsr pc,rewind
+2:
+ jsr pc,getchar
+ bes 2f
+ cmp r0,$143
+ blos 2b
+ cmp r0,$-1
+ beq 2b
+ bis $1,(sp)
+ br 2b
+2:
+ tst (sp)+
+ beq 2f
+ jsr pc,length
+ mov r0,0f
+ mov a(r1),3f
+ mov $1,r0
+ sys 0; 9f
+.data
+9:
+ sys write; 3:.=.+2; 0:.=.+2
+.text
+ jbr prout
+2:
+ jsr pc,fsfile
+ jsr pc,backspace
+ bec 1f
+ mov $1,r0
+ sys write; blank; 1
+ mov $1,r0
+ sys write; asczero; 1
+ jbr prout
+1:
+ jsr pc,length
+ mov r1,-(sp)
+ jsr pc,allocate
+ mov (sp),r0
+ mov r1,(sp)
+ jsr pc,move
+ mov ll,count
+ inc count
+ jsr pc,fsfile
+ jsr pc,backspace
+ mov r0,savk
+ dec w(r1)
+ jsr pc,backspace
+ cmpb r0,$-1
+ bne 2f
+ mov basptr,r1
+ jsr pc,fsfile
+ jsr pc,backspace
+ cmp r0,$-1
+ beq 2f
+ mov (sp),r1
+ jsr pc,chsign
+ mov $'-,ch
+ jsr pc,wrchar
+ br 1f
+2:
+ mov $' ,ch
+ jsr pc,wrchar
+1:
+ mov strptr,r1
+ jsr pc,create
+ mov basptr,r1
+ jsr pc,length
+ cmp r0,$1
+ jlo dingout
+ bne 1f
+ jsr pc,rewind
+ jsr pc,getchar
+ cmp r0,$1.
+ jeq unout
+ cmp r0,$-1
+ jeq dingout
+ cmp r0,$10.
+ jeq tenout
+1:
+ mov log10,r1
+ mul savk,r1
+ clr r0
+ div logo,r0
+ mov r0,dout
+ clr ct
+1:
+ mov (sp),r3
+ mov savk,r2
+ jsr pc,getdec
+ mov r1,decimal
+ clr dflg
+ mov (sp),r1
+ mov savk,r2
+ jsr pc,removc
+ mov r1,(sp)
+1:
+ mov (sp),r3
+ mov basptr,r2
+ jsr pc,div3
+ mov r1,r2
+ mov (sp),r1
+ jsr pc,release
+ mov r2,(sp)
+ mov r4,r1
+ jsr pc,*outdit
+ mov (sp),r1
+ jsr pc,length
+ bne 1b
+/
+ mov strptr,r1
+ jsr pc,fsfile
+1:
+ jsr pc,backspace
+ bes 1f
+ mov r0,ch
+ jsr pc,wrchar
+ br 1b
+1:
+ mov (sp)+,r1
+ jsr pc,release
+ tst savk
+ bne 1f
+ mov decimal,r1
+ jsr pc,release
+ br prout
+1:
+ mov dot,ch
+ jsr pc,wrchar
+ mov strptr,r1
+ jsr pc,create
+ mov decimal,-(sp)
+ inc dflg
+1:
+ mov (sp),r3
+ mov basptr,r2
+ jsr pc,mul3
+ mov r1,(sp)
+ mov r3,r1
+ jsr pc,release
+ mov (sp),r3
+ mov savk,r2
+ jsr pc,getdec
+ mov r1,(sp)
+ mov r3,r1
+ mov savk,r2
+ jsr pc,removc
+ jsr pc,*outdit
+ mov strptr,r1
+ inc ct
+ cmp ct,dout
+ blo 1b
+ mov (sp)+,r1
+ jsr pc,release
+ mov strptr,r1
+ jsr pc,rewind
+1:
+ jsr pc,getchar
+ bes 1f
+ mov r0,ch
+ jsr pc,wrchar
+ br 1b
+1:
+/
+/ cleanup, print new line and return
+/
+prout: mov $1,r0
+ sys write; nl; 1
+ mov (sp)+,r0
+ mov (sp)+,r1
+ mov (sp)+,r2
+ mov (sp)+,r3
+ mov (sp)+,r4
+ rts pc
+/
+/
+/
+/ r2 = count
+/ r3 = pointer (not released)
+/
+.bss
+dflg: .=.+2
+dout: .=.+2
+logo: .=.+2
+log10: .=.+2
+decimal: .=.+2
+.text
+getdec:
+ mov r3,-(sp)
+ mov r3,r1
+ jsr pc,rewind
+ jsr pc,length
+ jsr pc,allocate
+ mov r1,-(sp)
+1:
+ cmp r2,$1
+ blt 1f
+ mov 2(sp),r1
+ jsr pc,getchar
+ mov (sp),r1
+ jsr pc,putchar
+ mov r1,(sp)
+ sub $2,r2
+ br 1b
+1:
+ tst r2
+ beq 1f
+ mov tenptr,r2
+ mov (sp),r3
+ jsr pc,mul3
+ mov r1,(sp)
+ mov r3,r1
+ jsr pc,length
+ jsr pc,release
+ mov r0,r3
+ jsr pc,allocate
+ mov r1,-(sp)
+ mov 2(sp),r1
+ jsr pc,rewind
+2:
+ tst r3
+ beq 2f
+ jsr pc,getchar
+ mov (sp),r1
+ jsr pc,putchar
+ mov r1,(sp)
+ dec r3
+ mov 2(sp),r1
+ br 2b
+2:
+ clr r0
+ mov (sp),r1
+ jsr pc,putchar
+ mov 2(sp),r1
+ jsr pc,release
+ mov (sp),r3
+ mov tenptr,r2
+ jsr pc,div3
+ mov r1,(sp)
+ mov r3,r1
+ jsr pc,release
+ mov r4,r1
+ jsr pc,release
+ mov (sp)+,r1
+ tst (sp)+
+ mov (sp)+,r3
+ rts pc
+1:
+ mov (sp)+,r1
+ mov (sp)+,r3
+ rts pc
+tenout:
+ mov savk,ct
+ mov $2,r0
+ jsr pc,allocate
+ mov r1,-(sp)
+ mov 2(sp),r1
+ jsr pc,fsfile
+ jsr pc,backspace
+ mov r0,r3
+ clr r2
+ dvd $10.,r2
+ beq 1f
+3:
+ add $60,r2
+ mov r2,r0
+ mov (sp),r1
+ jsr pc,putchar
+ mov r1,(sp)
+1:
+ mov (sp),r1
+ add $60,r3
+ mov r3,r0
+ jsr pc,putchar
+ mov 2(sp),r1
+1:
+ jsr pc,backspace
+ bec 2f
+ mov (sp),r1
+ jsr pc,length
+ cmp r0,ct
+ beq 4f
+ blo 5f
+ sub ct,r0
+ mov r0,ct
+1:
+ jsr pc,getchar
+ mov r0,ch
+ jsr pc,wrchar
+ dec ct
+ bne 1b
+ jsr pc,getchar
+ bes 6f
+ jsr pc,backspace
+4:
+ movb dot,ch
+ jsr pc,wrchar
+1:
+ jsr pc,getchar
+ bes 1f
+ mov r0,ch
+ jsr pc,wrchar
+ br 1b
+5:
+ sub r0,ct
+ movb dot,ch
+ jsr pc,wrchar
+ mov $60,ch
+5:
+ jsr pc,wrchar
+ dec ct
+ bne 5b
+ br 1b
+1:
+6:
+ mov (sp)+,r1
+ jsr pc,release
+ mov (sp)+,r1
+ jsr pc,release
+ jbr prout
+2:
+ mov r0,r3
+ clr r2
+ dvd $10.,r2
+ br 3b
+dot: <.>
+ .even
+ct: .=.+2
+/
+/
+dingout:
+ clr -(sp)
+ br 1f
+unout:
+ mov $1,-(sp)
+1:
+ mov 2(sp),r1
+ mov savk,r2
+ jsr pc,removc
+ mov r1,2(sp)
+ mov strptr,r1
+ jsr pc,create
+ mov $-1,r0
+ jsr pc,putchar
+ mov r1,r3
+1:
+ mov 2(sp),r1
+ jsr pc,length
+ beq 1f
+ mov r1,r2
+ jsr pc,add3
+ mov r1,2(sp)
+ mov r2,r1
+ jsr pc,release
+ mov $1,r0
+ tst (sp)
+ beq 2f
+ mov $'1,ch
+ jsr pc,wrchar
+ br 1b
+2:
+ tst delflag
+ jne in177
+ sys write; ding; 3
+ br 1b
+1:
+ tst (sp)+
+ mov (sp)+,r1
+ jsr pc,release
+ jmp prout
+/
+ding: <\a\e\f> /<bell prefix form feed>
+blank: < >
+sp5: <\n >
+minus: <->
+one: <1>
+ .even
+.bss
+count: .=.+2
+.text
+/
+bigout:
+ mov r1,-(sp) /big digit
+ tst dflg
+ beq 1f
+ clr r0
+ jsr pc,allocate
+ mov r1,tptr
+1:
+ mov strptr,r1
+ jsr pc,length
+ add fw,r0
+ dec r0
+ mov r0,-(sp) /end of field
+ clr -(sp) /negative
+ mov 4(sp),r1
+ jsr pc,length
+ bne 2f
+ mov strptr,r1
+ mov $'0,r0
+ jsr pc,putchar
+ br 1f
+2:
+ mov 4(sp),r1 /digit
+ jsr pc,fsfile
+ jsr pc,backspace
+ bpl 2f
+ mov $1,(sp) /negative
+ jsr pc,chsign
+2:
+ mov 4(sp),r3 /digit
+ mov r3,r1
+ jsr pc,length
+ beq 1f
+ mov tenptr,r2
+ jsr pc,div3
+ mov r1,4(sp) /digit
+ mov r3,r1
+ jsr pc,release
+ mov r4,r1
+ jsr pc,rewind
+ jsr pc,getchar
+ jsr pc,release
+ add $'0,r0
+ tst dflg
+ beq 3f
+ mov tptr,r1
+ jsr pc,putchar
+ mov r1,tptr
+ br 2b
+3:
+ mov strptr,r1
+ jsr pc,putchar
+ br 2b
+1:
+ tst dflg
+ beq 4f
+ mov tptr,r1
+ jsr pc,length
+ cmp r0,fw1
+ bhis 2f
+ mov fw1,r1
+ sub r0,r1
+ mov r1,-(sp)
+ mov strptr,r1
+3:
+ mov $'0,r0
+ jsr pc,putchar
+ dec (sp)
+ bne 3b
+ tst (sp)+
+2:
+ mov tptr,r1
+ jsr pc,fsfile
+2:
+ mov tptr,r1
+ jsr pc,backspace
+ bes 2f
+ mov strptr,r1
+ jsr pc,putchar
+ br 2b
+2:
+ mov tptr,r1
+ jsr pc,release
+ br 1f
+4:
+ mov strptr,r1
+ jsr pc,length
+ cmp r0,2(sp) /end of field
+ bhis 1f
+ mov $'0,r0
+ jsr pc,putchar
+ br 1b
+1:
+ tst (sp) /negative
+ beq 1f
+ mov $'-,r0
+ mov strptr,r1
+ dec w(r1)
+ jsr pc,putchar
+1:
+ mov strptr,r1
+ mov $' ,r0
+ jsr pc,putchar
+ tst (sp)+
+ tst (sp)+
+ mov (sp)+,r1
+ jsr pc,release
+ rts pc
+/
+.bss
+tptr: .=.+2
+tenptr: .=.+2
+.text
+/
+/
+/
+hexout:
+ mov r1,-(sp)
+ jsr pc,rewind
+ jsr pc,getchar
+ cmp r0,$16.
+ blo 1f
+ 4
+1:
+ add $60,r0
+ cmp r0,$'9
+ blos 2f
+ add $'A-'9-1,r0
+2:
+ mov strptr,r1
+ jsr pc,putchar
+ mov (sp)+,r1
+ jsr pc,release
+ rts pc
+/
+/
+wrchar:
+ tst delflag
+ jne in177
+ mov $1,r0
+ tst count
+ bne 7f
+ sys write; sp5; 6
+ mov ll,count
+ mov $1,r0
+7:
+ dec count
+ sys write; ch; 1
+ rts pc
+/
+/
+/ here for unimplemented stuff
+/
+junk:
+ movb r0,1f
+ mov $1,r0
+ sys write; 1f; 2f-1f
+ jmp loop
+.data
+1: <0 not in switch.\n>
+2: .even
+.text
+/
+/
+/
+/ routine to place one word onto the pushdown list
+/ Error exit to system on overflow.
+/
+/
+push:
+ mov r1,(r5)+
+ cmp r5,$pdltop
+ bhis pdlout
+ rts pc
+/
+pdlout:
+ mov $1,r0
+ sys write; 1f; 2f-1f
+ 4
+1: <Out of pushdown.\n>
+2: .even
+/
+/
+/ routine to remove one word from the pushdown list
+/ carry bit set on empty stack
+/
+/
+/ jsr pc,pop
+/
+pop:
+ cmp r5,$pdl
+ bhi 1f
+ clr r1
+ sec
+ rts pc
+1: mov -(r5),r1
+ clc
+ rts pc
+/
+/
+/
+/
+.data
+outdit: hexout
+.bss
+source: .=.+2
+savec: .=.+2
+ch: .=.+2
+.text
+nl: <\n>
+asczero: <0>
+qm: <?\n>
+ .even
+/
+.bss
+chptr: .=.+2
+strptr: .=.+2
+basptr: .=.+2
+errstack:.=.+2
+/
+stable: .=.+256.
+.text
+casetab:
+ case012; 012 /nl
+ loop; 040 /sp
+ case041; 041 /!
+ case045; 045 /%
+ case052; 052 /*
+ case053; 053 /+
+ case055; 055 /-
+ case060; 056 /.
+ case057; 057 //
+ case060; 060 /0
+ case060; 061 /1
+ case060; 062 /2
+ case060; 063 /3
+ case060; 064 /4
+ case060; 065 /5
+ case060; 066 /6
+ case060; 067 /7
+ case060; 070 /8
+ case060; 071 /9
+ case074; 074 /<
+ case075; 075 /=
+ case076; 076 />
+ case077; 077 /?
+ case060; 101 /A
+ case060; 102 /B
+ case060; 103 /C
+ case060; 104 /D
+ case060; 105 /E
+ case060; 106 /F
+ case151; 111 /I
+ case153; 113 /K
+ case114; 114 /L
+ case157; 157 /O
+ case160; 120 /P
+ case121; 121 /Q
+ case123; 123 /S
+ case166; 126 /V
+ case170; 130 /X
+ case172; 132 /Z
+ case133; 133 /[
+ case136; 136 /^
+ case137; 137 /_
+ case143; 143 /c
+ case144; 144 /d
+ case146; 146 /f
+ case151; 151 /i
+ case153; 153 /k
+ case154; 154 /l
+ case157; 157 /o
+ case160; 160 /p
+ case161; 161 /q
+ case163; 163 /s
+ case166; 166 /v
+ case170; 170 /x
+ case172; 172 /z
+ 0;0
+/
+.bss
+pdl: .=.+100.
+pdltop:
+.text
projects / unix-history / commitdiff