.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 open; 0:.=.+2; 0 bec 2f mov $1,r0 sys write; 4f; 5f-4f sys exit / 4: <Input file.\n> 5: .even / 2: mov r0,source 1: sys intr; case177 clr delflag mov $pdl,r5 / 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 clr r0 jsr pc,allocate mov $1,r0 jsr pc,putchar mov r1,kptr 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 of delete character / 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 / delflag: .=.+2 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,chsign jsr pc,push br loop / / / case screamer / case041: jsr pc,in041 br loop / in041: sys fork br 9f sys wait mov $1,r0 sys write; screamer; 2 rts pc 9: sys exec; 7f; 8f 4 8: 7f; 0 7: </etc/msh\0> screamer: <!\n> .even / / / case d for duplicate / case144: cmp r5,$pdl bne 9f; jmp eh; 9: clr r0 jsr pc,allocate mov -2(r5),r0 jsr pc,move jsr pc,push br 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: jsr pc,push jmp loop / / / case c for flush / case143: 2: jsr pc,pop bec 9f; jmp loop; 9: jsr pc,release br 2b / / case s for save / case163: jsr pc,readc cmp r5,$pdl bne 2f movb $'s,ch jmp eh 2: cmpb r0,$128. blo 9f; jmp err; 9: asl r0 mov stable(r0),r1 beq 2f jsr pc,release 2: jsr pc,pop mov r1,stable(r0) jmp loop / / / case l for load / case154: jsr pc,in154 jmp loop / in154: jsr pc,readc cmp r0,$128. blo 9f; jmp err; 9: asl r0 mov stable(r0),r1 beq 1f 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 - for subtract / case055: jsr pc,in055 jmp loop / in055: jsr pc,pop bec 9f; jmp eh; 9: jsr pc,chsign jsr pc,push br in053 / / / case + for add / case053: jsr pc,in053 jmp loop / in053: mov $add3,r0 jsr pc,binop rts pc / / / case * for multiply / case052: mov $mul3,r0 jsr pc,binop tst k beq 1f jsr pc,pop mov r1,r3 mov kptr,r2 jsr pc,div3 jsr pc,push mov r3,r1 jsr pc,release mov r4,r1 jsr pc,release 1: jmp loop / / case / for divide / case057: mov $1f,r0 jsr pc,binop mov r4,r1 jsr pc,release jmp loop 1: tst k beq 1f mov r2,-(sp) mov kptr,r2 jsr pc,mul3 mov r1,-(sp) mov r3,r1 jsr pc,release mov (sp)+,r3 mov (sp)+,r2 1: jsr pc,div3 rts pc / / / case % for remaindering / case045: mov $div3,r0 jsr pc,binop jsr pc,pop jsr pc,release mov r4,r1 jsr pc,push jmp loop / / binop: jsr pc,pop bec 9f; jmp eh; 9: mov r1,r2 jsr pc,pop bec 9f; jmp eh; 9: mov r1,r3 jsr pc,(r0) jsr pc,push mov r2,r1 jsr pc,release mov r3,r1 jsr pc,release rts pc / / / case i for input base / case151: jsr pc,in151 jmp loop / in151: jsr pc,pop bec 9f; jmp eh; 9: mov r1,-(sp) mov inbas,r1 mov (sp)+,inbas jsr pc,release rts pc / inbas: .=.+2 / / / case o for output base / case157: jsr pc,in157 jmp loop / in157: jsr pc,pop bec 9f; jmp eh; 9: mov r1,-(sp) 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 cmp outdit,$hexout bne 2f mov $1,fw 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 / fw: 1 /field width for digits ll: 60. /line length / / / case k for skale factor / case153: jsr pc,pop bec 9f; jmp eh; 9: mov w(r1),r0 sub a(r1),r0 cmp r0,$1 blos 9f; jmp eh; 9: jsr pc,rewind jsr pc,getchar bpl 9f; jmp eh; 9: mov r0,k mov r0,r2 jsr pc,release mov kptr,r1 jsr pc,create clr r0 2: cmp r2,$2 blo 2f jsr pc,putchar sub $2,r2 br 2b 2: mov $1,r0 cmp r2,$1 blo 2f mov $10.,r0 2: jsr pc,putchar 1: jmp loop / / / case ^ for exponentiation / case136: jsr pc,pop bec 9f; jmp eh; 9: mov r1,r3 jsr pc,pop bec 9f; jmp eh; 9: mov r1,r2 jsr pc,exp3 jsr pc,push mov r2,r1 jsr pc,release mov r3,r1 jsr pc,release jmp loop / / / case v for square root / case166: jsr pc,pop bec 9f; jmp eh; 9: / / multiply argument by skale factor / mov r1,r2 mov kptr,r3 jsr pc,mul3 mov r1,r3 mov r2,r1 jsr pc,release / / check for zero or negative / mov w(r3),r2 sub a(r3),r2 tst r2 bne 9f; jmp sqz; 9: / / look at the top one or two digits / mov r3,r1 jsr pc,fsfile jsr pc,backspace mov r0,r4 bpl 9f; jmp eh; 9: 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 jsr pc,push mov (sp),r1 jsr pc,release tst (sp)+ tst (sp)+ jmp loop / sqz: clr r0 jsr pc,allocate jsr pc,push mov r3,r1 jsr pc,release jmp loop sqtemp: .=.+2 / / / 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 bec 9f; jmp eh; 9: 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 / 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,in055 /go subtract jsr pc,pop jsr pc,length tst r0 beq 1f jsr pc,fsfile jsr pc,backspace tst r0 bmi 1f jsr pc,release jsr pc,in154 /load from register br case170 / 1: jsr pc,release jsr pc,readc jmp loop / / / case = for conditional execution / case075: jsr pc,in055 /go subtract jsr pc,pop jsr pc,length tst r0 beq 1f /is zero jsr pc,release jsr pc,readc jmp loop 1: jsr pc,release jsr pc,in154 /load from register jmp case170 /go to execute code / / / case > for conditional execution / case076: jsr pc,in055 /go subtract jsr pc,pop jsr pc,length tst r0 beq 1f jsr pc,fsfile jsr pc,backspace tst r0 bpl 1f jsr pc,release jsr pc,in154 /load from register jmp case170 /go to execute code 1: jsr pc,release jsr pc,readc jmp loop err: 4 / eh: movb ch,1f+2 mov $1,r0 sys write; 1f; 2f-1f mov $readstack,readptr mov errstack,sp jmp loop 1: <( ) ?\n> 2: .even / / / 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 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 1f mov ch,r0 sub $'0,r0 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 jsr pc,readc mov r0,ch br 1b 1: mov ch,savec 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 bne 9f; jmp eh; 9: 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,r0 1: tst (r0)+ cmp r0,$stable+254. bhi 1f / mov (r0),r1 beq 1b mov r0,-(sp) sub $stable,r0 asr r0 movb r0,7f+1 mov $1,r0 sys write; 7f; 8f-7f jsr pc,printf mov (sp)+,r0 br 1b 1: mov (sp)+,r5 jmp loop / 7: <" " > 8: .even / / / routine to convert to decimal and print the / top element of the stack. / / jsr pc,printf / / printf: 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 write; 3:.=.+2; 0:.=.+2 br prout 2: jsr pc,fsfile jsr pc,backspace bec 1f mov $1,r0 sys write; blank; 1 mov $1,r0 sys write; asczero; 1 br 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 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 blo dingout bne 1f jsr pc,rewind jsr pc,getchar cmp r0,$1. beq unout cmp r0,$-1 beq dingout 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 / / cleanup, print new line and return / prout: mov $1,r0 sys write; nl; 1 mov (sp)+,r0 mov (sp)+,r1 mov (sp)+,r2 rts pc / / dingout: clr -(sp) br 1f unout: mov $1,-(sp) 1: 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 beq 9f; jmp in177; 9: sys write; ding; 3 br 1b 1: tst (sp)+ mov (sp)+,r1 jsr pc,release br prout / ding: < > /<bell prefix tab> blank: < > sp5: <\n > minus: <-> one: <1> .even count: .=.+2 / bigout: mov r1,-(sp) /big digit 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 mov strptr,r1 jsr pc,putchar br 2b 1: 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 $' ,r0 jsr pc,putchar tst (sp)+ tst (sp)+ mov (sp)+,r1 jsr pc,release rts pc / tenptr: .=.+2 / / / hexout: mov r1,-(sp) jsr pc,rewind jsr pc,getchar 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 beq 9f; jmp in177; 9: 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 1: <0 not in switch.\n> 2: .even / / / / 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 / / / / outdit: hexout source: .=.+2 savec: .=.+2 ch: .=.+2 nl: <\n> asczero: <0> qm: <?\n> .even / chptr: .=.+2 strptr: .=.+2 basptr: .=.+2 errstack:.=.+2 / .bss stable: .=.+256. .text casetab: case012; 012 /nl loop; 040 /sp case041; 041 /! case045; 045 /% case052; 052 /* case053; 053 /+ case055; 055 /- junk; 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 /? case143; 103 /C case144; 104 /D case146; 106 /F case151; 111 /I case153; 113 /K case154; 114 /L case157; 157 /O case160; 120 /P case161; 121 /Q case163; 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