Research V5 development

[unix-history] / usr / source / s1 / dc1.s

.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