! "W N, R=    @ #D  D ҃TP  B ы e@W 0 ,"& 7   0ߋp@E A Ze      |@7x@ eE "  ɋ -lɋ e-RNHɋ ^?assemŁ r massem.log r e.macő r h1.macő =r h2.macŁ r !<32 bytes/el.> inc r1 .endc ;$nostr open6: mov @sp,r0 cmpb @r1,#.lpar ;subscript declared? beq open6b clr -(sp) br open7 .endc ;$vf erropn: jmp errsyn .ifdf $vf open6b: inc r1 ;point to the beginning of the expression. jsr pc,eval ;evaluate the subscript bcc open6a e.iss: ertext iss, open6a: cmpb (r1)+,#.rpar ;end of expression? bne erropn ; no. mov @sp,r0 ;shuffle the descriptor word mov fac1(r5),-(sp) ;save high order ss mov fac2(r5),-(sp) ;save low order ss mov r0,-(sp) open7: .ifndf $nostr bit #fdbse$,r0 ;string elements? beq open7a ;no. cmpb @r1,#.eq ;stg. length declaration? bne open7a ;no. use default. inc r1 ;pt. to the beginning of the expr. jsr pc,inteval tst fac1(r5) ;stringth length must be an integer. bne e.iss mov fac2(r5),r0 ;r0 = stg. length => multiplier bgt open70 ;stg. length must be > 0 e.inc: ertext isl, open70: cmp r0,#256. ;0 < n < 256. bge e.inc push r1 push r0 mov r0,r1 dec r0 xor r1,r0 bic r0,r1 tst r1 bne e.inc pop r0 pop r1 ;stg. el. length is stored in the ; ;file descriptor block as the low ; order byte of the file descriptor word. .endc ;$nostr open7a: tst (sp)+ beq open7b mov (sp)+,fac2(r5) ;reload the fac with the ss to cal- mov (sp)+,fac1(r5) ;culate the absolute byte address bic #177400,r0 ;extract the el. length. movb r0,@sp ;store the correct el. length. .ifndf hvunix mov r0,-(sp) ;set as the ss multiplier. jsr r4,fppsav .word dimul .word fppres jsr pc,vfblk1 ;now convert that to blk. no. and ;offset .iff push r0 mov r0,@sp call vfblk pop r0 .endc inc r0 ;block numbering for enters starts ;from 1. the fdbmbn will be decremented ;by opnfil after the file is opened. clr r3 bisb @sp,r3 ;since the max ss is stored as a max add r2,r3 ;block no. and max offset, these mov r3,r2 ;values are: bic #177000,r2 ; ((max ss)*(el. [byte] length)/ sub #128.,r3 ; (512.))+(el. length) blt 1$ inc r0 1$: mov r0,t2(r5) mov r2,ss1save(r5) ;max offset. br opn11a open7b: movb r0,@sp .endc ;$vf open11: clr t2(r5) .ifdf $..$ clr ss1sav(r5) opn11a: mov #100000,r0 ;set the undeclared value. mov r0,mode(r5) ;ie., if these cells contain #100000, mov r0,recsiz(r5) ;when examined by opnfil, then => mov r0,filsiz(r5) ;the (respective) keyword did not appear ;in the open statement. opn11b: movb (r1)+,r0 ;parse the rest of the line and check cmpb r0,#.eol ;for the mode,filesize and beq open15 ;record size tokens in any order. cmpb r0,#.mode ;mode? bne open12 ;no; check recsiz. mov #mode,-(sp) br open14 open12: cmpb #.recsiz,r0 ;record size? bne open13 ;no; try file size. .ifdf $vf tst @sp ;this also is meaningless for vf. bpl opn12a jsr pc,eval ;ignor for vf bcs erropn ;this is still illegal (string) br opn11b .endc ;$vf opn12a: mov #recsiz,-(sp) br open14 open13: cmpb #.filsiz,r0 ;file size? bne erropn ;none of the above. illegal syntax. mov #filsiz,-(sp) clr ss1save(r5) ;if a file size declaration is given, ;the max offset within the block ;is set to 0. open14: jsr pc,eval ;evaluate the expression. bcs erropn ;string is illegal. jsr pc,int ;it must be < 32k tst fac1(r5) bne erropn ;>32k mov (sp)+,r0 ;calculate the adr.(storage cell) add r5,r0 cmp @r0,#100000 ;avoid multiple declarations. bne erropn mov fac2(r5),@r0 ;install the value. br opn11b ;iterate.. .endc ;$..$ .ifndf $..$ opn11a: cmpb (r1)+,#.eol bne erropn ; allocate file table, first buffer open12: mov #8.,r0 ;file table entry is 4 words jsr pc,freeget ;allocate space bcs openbf ; ; allocate first buffer then ; open 2nd buffer (if any), make sure handler is in core, ; and open the file. clr t3(r5) ;clear replace flag mov r1,r1save(r5) mov t1(r5),r1 ;get channel number jsr pc,filea ;chk already open tst (r1) bne errdev mov r0,r1 ;r1 is file header mov (sp)+,(r0)+ ;save file descriptor wd mov #-1,(r0)+ ;init current blk read in mov ss1save(r5),fnext(r1) ;save max vf ss jsr pc,opnfil ;open the file mov r1save(r5),r1 ;restore exec address .endc ;$..$ .ifdf $..$ open15: jsr pc,opnfil .endc ;$..$ jmp execute .ifndf $..$ errdev: jmp erchan openbf: jmp errbuf .endc ;$..$ ; 'close' statement close: cmpb (r1),#.eol ;check for close beq clos7 ;yes, go close all files clos1: clr -(sp) ;set up offset for seq file cmpb (r1),#.pound ;chk pound sign beq clos2 ;found it .ifndf $vf br clos3 .endc ;$vf .ifdf $vf cmpb (r1),#.vf bne clos3 mov #$vfoff,(sp) .endc ;$vf clos2: inc r1 ;pound or vir file-step over it clos3: jsr pc,inteval mov fac2(r5),r0 beq clos6 cmp r0,#$maxun bhi clos6 .ifdf $vf add (sp)+,r0 ;compute unit no. .endc ;$vf jsr pc,closch ;close the file bcs clos5 jsr pc,comeol br clos1 clos5: jmp errfno clos6: jmp erchan clos7: jsr pc,closall ;close all files open jmp execute ;-------------------------------------------------------- ; subroutine inteval called by jsr pc inteval:jmp reval revlret:rts pc ;------------------------------------------------------- ; subroutine "comeol" (common eol) comeol: cmpb (r1),#.eol beq comel1 ;eol, go to execute cmpb (r1)+,#.comma beq comel2 ;ok, return jmp errsyn comel1: tst (sp)+ ;execute does not reset the stack! jmp execute comel2: rts pc ;---------------------------------------------------- ; subr closys jsr pc,closys ; closes system sequential file ; carry is set if channel was not open ; closys: .ifndf $..$ mov #$sysfil,r0 ;sys seq file # to r0 mov r0,t1(r5) ;for opnfil jmp closch ;go do close .endc ;$..$ .ifdf $..$ mov syslun,r0 jmp closch .endc ;$..$ ; 'eof' or 'end' statement eof: tst lineno(r5) ;immediate mode execution? ble endrdy ;yes, don't close files end: mov #-1,lineno(r5) ;in case ctrl/c typed next. jsr pc,closall ;close all files endrdy: jmp ready ;and print "ready" ; 'stop' statement stop: .ifdf $tty clrb cncflg(r5) ;(ctrl/c traps jump here too) .endc .ifdf hvunix clrb cncflg(r5) call closall .endc jsr r1,msg ;print stop message .byte cr,lf .ascii 'stop' .byte 0 .even jmp bombdon ;go print "at line xxxx" .ifdf $disk ; restore file - end of 'restore' statement restj: cmpb (r1),#.pound bne restj1 inc r1 ;ignore # if present restj1: jsr pc,inteval .ifndf $..$&hvunix mov r1,-(sp) mov fac2(r5),r0 ;unit # in r0 mov r0,r1 jsr pc,filea mov (r1),r1 ;file address in r1 bne .+6 jmp errfno tst (r1) ;check sequential file bpl .+6 jmp erchan bit #20000,(r1) ;check 'for output' not specified beq .+6 jmp errwlo sub #$bufsz+4,fbufe(r1) ;adjust buffer pointer jsr pc,seqio ;start up i/o mov (sp)+,r1 ;exec address in r1 .endc ;$..$ .ifdf $..$!hvunix jsr pc,sfrset ;sequential file reset code in basics .endc ;$..$ jsr pc,comeol br restj .endc ;$disk ;--------------------------------------------------------------- ; subroutine allbuf called by jsr pc,allbuf ; t1(r5) is channel # ; r1 is file header address ; preserves r1,r3,r4 .ifndf $..$ .ifdf $bfalc allbuf: cmp t1(r5),#$sysfil ;system file? beq allb2 ;yes-special buffer jsr pc,bufget ;no-allocate general buffer mov r0,fbufe(r1) ;save addr mov r0,r2 clr (r0)+ ;init header mov r2,(r0) ;points to itself bit #10000,(r1) ;check double buf beq allb1 ;no-done jsr pc,bufget ;get another buffer clr (r0) ;init header mov r0,2(r2) ;they address each other mov r2,2(r0) allb1: rts pc allb2: mov #combuf,r0 ;address system buffer mov r0,fbufe(r1) ;save its addr clr (r0) ;init header mov r0,2(r0) ;points to itself rts pc ;done ;-------------------------------------------------------------- ; subroutine 'bufget' called by jsr pc,bufget ; gets the next unused i/o buffer ; from the buffer chain, or allocates ; one from free storage if there is none. ; r0 is set to the address of the buffer. bufget: mov bufchn(r5),r0 ;see if chain empty beq buf2 ;yes, must allocate mov (r0),bufchn(r5) ;no, get one from chain buf1: clr (r0) rts pc buf2: mov #$bufsz+4,r0 ;buffer is 4 + bufsiz bytes jsr pc,freeget bcc buf1 ;successful return .endc ;$bfalc errbuf: trap 0 .ifdf $longer .ascii 'buffer storage overflow' .endc ;$longer .ifndf $longer .ascii 'bso' .endc ;$longer .byte 0 .even .endc ;$..$ ;----------------------------------------------------------------- ; subroutine 'fndstv' called by jsr pc ; finds a string literal or variable ; at (r1). sets r0 to address, ; and r3 to length fndstv: .ifndf $nostr movb (r1),r2 ;first byte bmi fndsv2 ;token inc r1 swab r2 ;get symtab reference bisb (r1)+,r2 add (r5),r2 ;address symtab cmp (r2)+,#.svar ;check string variable bne fndsve ;no, bad mov (r2)+,r0 ;get variable or address cmp (r2),#-1 ;check scalar variable beq .+4 ;yes, address is ok mov (r0),r0 ;no, indirect clr r3 inc r0 ;check for null beq fndsv1 bisb -(r0),r3 ;r3 is length add #3,r0 fndsv1: rts pc .endc ;$nostr fndsv2: jsr pc,fndstl ;get string literal rts pc fndsve: jmp errsyn ;---------------------------------------------------------------- ; subroutine 'chkfil' called by jsr pc ; checks for the presence of a file spec ; following a file command ; ignores leading blanks just in case ; cc z is set if no file spec was given ; on entry, r1 points to the file command token chkfil: cmpb (r1)+,(r1)+ ;skip file command and .text tokens jsr pc,fndetxt ;find length, set pointer in r0 rts pc .ifdf $bfalc ;---------------------------------------------------------- ; subroutine 'chainb' chains unused buffers onto the ; buffer chain. ; called by jsr pc,chain ; r1 is the file header address ; fbufe(r1) points to the start of the ; first buffer .ifndf $..$ chainb: cmp t1(r5),#$sysfil ;check system unit beq chainx ;yes, don't chain mov bufchn(r5),r2 ;chain 1st buffer mov fbufe(r1),r3 mov r3,bufchn(r5) mov r2,(r3) bit #10000,(r1) ;check for double buf beq chainx ;no, bypass mov 2(r3),r0 ;chain 2nd buffer mov r0,bufchn(r5) mov r3,(r0) chainx: rts pc .endc ;$..$ .endc ;$bfalc ; ; --keyword table ; ; entries are ordered by their frequency of ; occurrence. alpha keywords start at 'keya'. keywds: .ascii '+' .byte .plus .ascii '-' .byte .minus .ascii '*' .byte .star .ascii '/' .byte .slash .ascii '^' .byte .uparro .ascii '(' .byte .lpar .ascii ')' .byte .rpar .ascii '\' .byte .eol .ascii '&' .byte .ampers .ascii ';' .byte .semi .ascii ',' .byte .comma .ascii '<=' .byte .le .ascii '=<' .byte .le .ascii '>=' .byte .ge .ascii '=>' .byte .ge .ascii '<>' .byte .ne .ascii '><' .byte .ne .ascii '<' .byte .lt .ascii '>' .byte .gt .ascii '=' .byte .eq .ascii '"' .byte .dquot .ascii "'" .byte .squot .ascii ':' .byte .colon .ascii '#' .byte .pound .ascii '[' .byte .lpar .ascii ']' .byte .rpar .ifdf $vf .ascii '%' .byte .perc .endc ;$vf .ifdf $disk .ascii '$' .byte .dol .endc ;$disk .byte 0 ;don't waste time searching rest keya: ;start of alpha keywords .ifdf $vf .ascii 'let vf' .byte .letvf .endc ;$vf .ascii 'if end #' .byte .ifend .ascii 'let ' .byte .let .ascii 'if ' .byte .if .ascii 'go to ' .byte .goto .ascii 'on ' .byte .on .ascii ' for input' .byte .forin .ascii ' for output' .byte .forot .ascii 'for ' .byte .for .ascii ' to ' .byte .to .ascii 'next ' .byte .next .ascii ' then ' .byte .then .ascii ' step ' .byte .step .ascii 'gosub ' .byte .gosub .ascii 'return' .byte .return .ascii 'input ' .byte .input .ascii 'linput ' .byte .linput .ascii 'print ' .byte .print .ifndf $nopru .ascii 'using ' .byte .using .endc ;$nopru .ascii 'rem' .byte .rem .ascii 'def ' .byte .def .ascii 'read ' .byte .read .ifdf $matrix .ascii 'mat ' .byte .mat .endc .ascii 'data ' .byte .data .ascii 'call ' .byte .call .ifdf $multi .ascii 'assign ' .byte .assign .ascii 'deassign' .byte .deass .ascii 'set tty' .byte .settty .endc ;$multi .ascii 'fn' .byte .fn .ascii 'pi' .byte .pi .ifdf $sysfn .ascii 'sys(' .byte .sys .ifdf hvunix .ascii 'subst(' .byte .sys .endc ;hvunix .endc ;$sysfn .ascii 'rnd(' .byte .rndl .ascii 'rnd' .byte .rnd .ascii 'sin(' .byte .sin .ascii 'cos(' .byte .cos .ascii 'sqr(' .byte .sqr .ascii 'atn(' .byte .atn .ascii 'exp(' .byte .exp .ascii 'log(' .byte .log .ascii 'log10(' .byte .log10 .ascii 'abs(' .byte .abs .ascii 'int(' .byte .int .ascii 'sgn(' .byte .sgn .ascii 'tab(' .byte .tab .ascii 'bin' .byte .bin .ascii 'oct' .byte .oct .ifndf $nostr .ascii 'len(' .byte .len .ascii 'asc(' .byte .asc .ascii 'chr$(' .byte .chr$ .ascii 'pos(' .byte .pos .ascii 'seg$(' .byte .seg .ascii 'val(' .byte .val .ascii 'trm$(' .byte .trm .ascii 'dat$' .byte .dat .ascii 'str$(' .byte .str .endc ;$nostr .ifdf $matrix .ascii 'trn(' .byte .trn .ascii 'inv(' .byte .inv .ascii 'num(' .byte .num .ascii 'det(' .byte .det .endc .ascii 'open ' .byte .open .ascii 'close ' .byte .close .ifdf $chain .ascii 'chain ' .byte .chain .ascii 'overlay ' .byte .ovrly .endc ;$chain .ascii ' as file ' .byte .asfil .ifdf hvunix .ascii 'shell' .byte .shell .ascii 'delete' .byte .delet .ifdf $reseq .ascii 'reseq' .byte .reseq .ascii 'from' .byte .to .endc .ifdf $ext .ascii 'extend(' .byte .extra .endc .endc .ifdf $..$ .ascii 'kill ' .byte .kill .ascii 'unsave' .byte .unsave .ascii 'name ' .byte .nameas .ascii ' as ' .byte .as .endc ;$..$ .ifdf $disk .ascii ' recordsize ' .byte .recsiz .ascii ' filesize ' .byte .filsiz .ascii ' mode ' .byte .mode .ascii ' double buf' .byte .dblbf .endc ;$disk .ifdf $chain .ascii ' line ' .byte .line .endc ;$chain .ifdf $vf .ascii 'vf' .byte .vf .endc ;$vf .ascii 'dim ' .byte .dim .ifdf $chain .ascii 'common ' .byte .common .endc ;$chain .ascii 'randomize' .byte .random .ascii 'restore ' .byte .restore .ascii 'reset ' .byte .reset .ascii 'stop' .byte .stop .ascii 'end' .byte .end .ifdf $disk .ascii 'rename' .byte .rename .ascii 'new' .byte .new .ascii 'replace' .byte .replace .endc ;$disk .ascii 'listnh' .byte .listnh .ascii 'runnh' .byte .runnh .ascii 'list' .byte .list .ascii 'run' .byte .run .ascii 'save' .byte .save .ascii 'append' .byte .append .ascii 'old' .byte .old .ascii 'scr' .byte .scr .ascii 'clear' .byte .clear .ascii 'bye' .byte .bye .ascii 'tek' .byte .tape .ascii 'tty' .byte .key keyz: .byte 0 ;end of table flag .even .ifdf $mortok ;new keywds table for extended tokens ;these tokens occur after the .more token newwds: .ascii 'zer' .byte .zer .ascii 'con' .byte .con .ascii 'idn' .byte .idn .ascii 'protocol' .byte .proto .ascii 'unprotocol' .byte .unproto .ascii 'info' .byte .news .ascii 'ddt' .byte .ddt .ascii 'unlink' .byte .ulink .ascii 'sys' .byte .sysxt .byte 0 .even .endc .ifndf hvunix comfil: ;buffer for sys seq files .ifndf $disk .=.+4 ;opnsys uses this .endc ;$disk .ifdf $disk .ifndf $..$ combuf=comfil+8. .=.+$bufsz+14 ;size=size of buffer +4bytes ;for bfr hdr +8 bytes for seq ;file table entry .endc ;$..$ .endc ;$disk .endc ;hvunix ;------------------------------------------------------------ ; ; edit - ; ; get line, translate into tokens, and move line into ; user code space, with all entries made into user ; symbol table, array space, and string space. edit: .ifdf $..$ jsr pc,nxtusr ;avoid locking out other users. .endc ;$..$ jsr pc,linget ;input a program line bcc editl ;normal return, go edit line .ifndf $chain cmpb @code(r5),#.eof ;check empty program bne edit1 ;no, return to tty input jmp deverr ;yes, device not ready edit1: jmp ready0 .endc ;$chain .ifdf $chain mov code(r5),r1 cmpb (r1),#.eof ;check empty program bne edit1 jmp deverr ;yes, device not ready edit1: jsr pc,closys ;close input unit clrb idev(r5) ;reset input unit mov editln(r5),r3 ;check line no. required bne edit1a ;yes, go look up tst chnflg(r5) ;check chain to program start bne edit5 ;yes, go start running readyj: jmp ready ;no, ready state edit1a: cmp r3,#.scalar ;check immed mode overlay stmt bhis readyj edit2: mov r1,r3 ;in case it's not a line number jsr pc,fline ;try to find line number (obviously defined) mov r3,r1 ;restore r1, c bit not affected by move bcs edit3 ;line number not found cmp -(r2),editln(r5);matches line number searched for? bhis edit4 ;greater than or equal to edit3: jsr pc,skipeol ;skip to next line of code cmpb (r1),#.eof ;hit end of program? bne edit2 ;falling through is ok if .eof edit4: tst chnflg(r5) ;is it a chain statement beq edit6 ;no, bypass cmp (r2),editln(r5) ;check line no. again bne edite ;must be equal edit5: mov r1,-(sp) ;save exec address .ifndf $nostr jsr pc,dnpack ;make room for allocating arrays .endc ;$nostr jsr pc,irun ;initialize to run chained program mov (sp)+,r1 clr chnflg(r5) edit6: clr editln(r5) ;reset flag jmp execute ;start execution ! edite: jmp errgo ;undefined line no. .endc ;$chain editl: jsr pc,tran inc r1 mov r1,-(sp) mov line(r5),r1 sub r1,(sp) movb (r1)+,r0 bmi edimmed swab r0 bisb (r1)+,r0 add (r5),r0 cmp (r0),#.scalar bhis edimmed mov code(r5),r1 cmp (sp),#3 ;if there are only 3 bytes then the line bne edisrch ;conatins lineno,cr and means delete. clr (sp) clr 2(r0) br edisrch edimmed:tstb idev(r5) bne edit ;ignore imm stmts from non-tty jmp immed ediskip:jsr pc,skipeol edisrch:mov r1,r4 ;r0 points to lineno of the new line. cmpb (r1),#.eof ;0(sp) contains length of the new line. beq ediput movb (r1),r3 bmi ediskip inc r1 swab r3 bisb (r1)+,r3 add (r5),r3 cmp (r3),#.scalar bhis ediskip cmp (r0),(r3) bhi ediskip bne ediput edipass:jsr pc,skipeol cmpb (r1),#.eof beq ediover movb (r1),r3 bmi edipass inc r1 swab r3 bisb (r1)+,r3 add (r5),r3 cmp (r3),#.scalar bhis edipass cmpb -(r1),-(r1) .ifdf hvunix mov arrays(r5),r0 .iff mov pdl(r5),r0 ;if a line is changed which is .endc mov gsbctr(r5),r2 ;referenced by the read pointer,an fn cmp (r0),#-1 ;initialized read pointer? beq edichi ;yes edichg: cmp (r0),r4 ;pointer or a gosub pointer then that blos edichi ;pointer must be cleared cmp (r0),r1 bhi edichi clr (r0) edichi: tst (r0)+ dec r2 bgt edichg ediover:sub r4,r1 br .+4 ediput: clr r1 sub (sp),r1 ;r1 now = #chars to contract. .ifdf hvunix mov arrays(r5),r0 .iff mov pdl(r5),r0 ;all references by the read pointer .endc mov gsbctr(r5),r2 ;which refer to lines which are moved cmp (r0),#-1 ;(initialized read pointer?) beq edimoi ;(yes) edimodf:cmp (r0),r4 ;because of editing must be relocated blo edimoi sub r1,(r0) edimoi: tst (r0)+ dec r2 bgt edimodf tst r1 bmi edigrow ;r4 now = address at which to insert. beq edisame edicont:mov r4,r2 add (sp),r2 mov r2,r3 add r1,r3 edimove:movb (r3)+,(r2)+ ;move down the code. cmp r3,(r5) blo edimove tstb -(r2) beq .+4 inc r2 ;r2 now points to byte after the .eof. bit r2,#1 beq .+4 clrb (r2)+ ;r2 now has the new start of the symtab. mov r2,(r5) mov (r3)+,(r2)+ ;move down the symbols. cmp r3,lofree(r5) blo .-6 mov r2,lofree(r5) br .+4 clr (r2)+ ;clear vacated string storage to zeroes. cmp r2,r3 blo .-4 br edisame edigrow:mov (r5),r0 tstb -(r0) beq .+4 inc r0 sub r1,r0 ;r0 now points past the new highest byte mov r0,r3 ;of code. inc r3 bic #1,r3 ;r3 now has the new start of symtab. sub (r5),r3 add lofree(r5),r3 ;r3 now has the new value of lofree. cmp r3,hifree(r5) ;check to see that there is enough blos .+6 errov1: jmp errov2 .ifndf $nostr mov r3,r2 ;check to see that the space that will tst (r2)+ ;be used is not occupied by strings cmp r2,lostr(r5) blo ediroom jsr pc,uppack ;no, move them up cmp r2,lostr(r5) ;try again bhis errov1 .endc ;$nostr ediroom:mov lofree(r5),r2 mov r3,lofree(r5) br .+4 edimvup:mov -(r2),-(r3) ;move up the symtab. cmp r2,(r5) bhi edimvup mov r3,(r5) clrb -(r3) ;clear the possibly used filler mov r0,r2 add r1,r0 ;r0 now points past old highest byte br .+4 ;of symtab. movb -(r0),-(r2) ;move up the code. cmp r0,r4 bhi .-4 edisame:mov line(r5),r0 ;move the new line into the code. mov r4,r1 mov (sp)+,r2 br .+4 movb (r0)+,(4)+ dec r2 bge .-4 edirlc8:cmpb (r1),#.eof beq edijmp movb (r1),r2 bmi edirloc inc r1 swab r2 bisb (r1)+,r2 add (r5),r2 cmp (r2)+,#.scalar bhis edirloc mov r1,(r2) sub #2,(r2) edirloc:jsr pc,skipeol br edirlc8 edijmp: jmp edit ;------------------------------------------------------------ ; ; immed - immediate mode commands ; ; do immediate only commands (run, list, scratch, clear, ; save, and old) and set up others (un-numbered) for ; execute. immed: mov (sp)+,r0 ;r0 now has # bytes on input line. clr odev(r5) ;take only this immed. comm. from non-tty mov #.scalar,lineno(r5) ;set 'null' line number mov pdsize(r5),r4 mov line(r5),r1 clr r2 bisb (r1),r2 sub #.stab4,r2 cmp r2,#.etab4-.stab4 bhi immstmt asl r2 mov table4(r2),pc ;dispatch thru table table4: .word clear .word scratch .word tape .word key .ifdf hvunix .ifdf $reseq .word reseq .endc .endc .word list .word listnh .ifdf $disk .word rename .word new .endc ;$disk .word append .word old .word run .word runnh .word save .ifdf $disk .word replace .endc ;$disk .ifdf $tty .word settty .endc .ifdf hvunix .word shell .word delet .endc .ifdf $..$ .word unsave .endc ;$..$ .ifdf $multi .word asign .word deass .endc ;$multi immstmt:add r1,r0 cmp r0,code(r5) ;see if an 'eof' can be fit on the line. blo .+6 jmp errtrn movb #.eof,(r0) clr clmntty(r5) ;re-set all colmn counts jmp execute ;start running. ; append and old commands append: jsr pc,oldfil .ifdf $..$ movb #aooip.,fadb(r5) .endc ;$..$ jsr pc,filspec ;can't subroutine this because of stack info .ifdf $namset .word dfexos .endc ;$namset br old1 old: jsr pc,initscr ;scratch jsr pc,oldfil .ifdf $..$ movb #old.,fadb(r5) .endc ;$..$ jsr pc,filspec .ifdf $namset .word dfexos jsr pc,namset .endc ;$namset old1: .ifndf $..$ movb #$maxun+1,idev(r5) ;input unit clr t3(r5) ;replace indicator clr r2 ;file descriptor(input seq.) mov r1,r1save(r5) jsr pc,opnsys ;open the file mov r1save(r5),r1 .endc ;$..$ .ifdf $..$ movb syslun,idev(r5) ;set the "system" logical unit no. mov #40000,-(sp) ;indicate input file to "opnfil" jsr pc,opnsys .endc ;$..$ old001: jmp edit ;this does the rest oldfil: jsr pc,chkfil ;was file given? bne oldfl1 ;yes jsr r1,msg ;ask for file name .ascii 'old ' .byte 0 .even jsr pc,fndfil oldfl1: rts pc .ifdf $disk ; new and rename commands new: jsr pc,initscr rename: jsr pc,chkfil ;name given with command? bne newfil1 ;yes jsr r1,msg ;no, prompt .ascii 'new ' .byte 0 .even jsr pc,fndfil ;get file name newfil1:.ifdf $..$ movb #newrn.,fadb(r5) jsr pc,filspec .endc ;$..$ .ifdf $namset jsr pc,namset .endc ;$namset br listj ;jmp ready .endc ;$disk .ifdf $disk ; 'replace' command replac: .ifndf $..$ mov #-1,t3(r5) ;set replace flag .endc ;$..$ .ifdf $..$ movb #repla.,fadb(r5) .endc ;$..$ br save0 .endc ;$disk ; 'save' command save: .ifndf $..$ mov #1,t3(r5) ;set save flag .endc ;$..$ .ifdf $..$ movb #save.,fadb(r5) .endc ;$..$ save0: jsr pc,chkfil jsr pc,filspec ;translate dev:fil.ext .ifdf $namset .word dfexos ;ptr to def. ext for old/save .endc ;$namset clr t2(r5) ;length of output file .ifndf $..$ movb #$maxun+1,odev(r5) ;output channel mov #20000,r2 ;file descriptor(output seq) mov r1,r1save(r5) jsr pc,opnsys ;open the file mov r1save(r5),r1 .endc ;$..$ .ifdf $..$ movb syslun,odev(r5) mov #20000,-(sp) jsr pc,opnsys .endc ;$..$ listsv: jsr pc,lstprog jsr pc,closys ;make sure system file closed listj: jmp ready ; 'list' command list: jsr r1,msg .byte lf,0 jsr pc,headr br list0 listnh: jsr r1,msg ;print a blank line before listnh .byte lf,0 list0: inc r1 cmpb (r1),#.eol ;check no arguments beq listsv ;yes, list entire program mov code(r5),-(sp) ;set default start addr tstb (r1) ;check token next bmi list1 ;yes, use default jsr pc,fline ;look up line no bcs list1 tst (r2) ;check undef beq list1 ;yes, use default mov (r2),(sp) ;save start addr list1: mov (sp),-(sp) ;default stop addr cmpb (r1)+,#.minus ;check keyword '-' bne list2 ;no, use default stop = start addr mov #-1,(sp) ;default is now end tstb (r1) ;check token next bmi list2 ;yes, use default stop jsr pc,fline ;get line no. bcs list2 tst (r2) ;check undef beq list2 ;yes, use default mov (r2),(sp) ;set stop addr list2: mov 2(sp),r1 ;get start addr list3: jsr pc,listl ;list 1 line bcs listj ;reached end of program cmp r1,(sp) ;check done blos list3 ;no, do next line br listj ; 'run' command ; initialize for run subroutine irun: jsr pc,closal ;this seems like the logical point ;at which to close any files left ;open by this user. mov code(r5),r1 ;initialize to search thru saved program dimloop:movb (r1)+,r2 bmi dimnono swab r2 bisb (r1)+,r2 add (r5),r2 mov (r2),lineno(r5) movb (r1)+,r2 dimnono:cmpb r2,#.dim ;check for dim, def, randomize statements beq dimcom cmpb r2,#.common beq dimcom cmpb r2,#.def beq defgot cmpb r2,#.random beq rndgot cmpb r2,#.eof beq dimdone dec r1 defdun: jsr pc,skipeol br dimloop dimcom: mov r2,-(sp) ;used at eol to remember whether dim or com dimgot: movb (r1)+,r2 ;dim statement - check syntax bmi dimsyn swab r2 bisb (r1)+,r2 add (r5),r2 cmpb (r1)+,#.lpar beq dimary cmpb (sp),#.dim beq dimsyn dec r1 ;scalars allowed in commom st. br dimeol dimary: clr r3 ;evaluate first subscript in r3 cmpb (r1),#.ilit1 beq alloc1 cmpb (r1)+,#.ilit2 bne errdim movb (r1),r3 bmi errdim swab r3 alloc1: inc r1 bisb (r1)+,r3 mov #-1,r4 cmpb (r1)+,#.rpar ;check for another subscript beq doalloc cmpb -(r1),#.comma bne dimsyn ;evaluate 2nd subscript in ky inc r1 clr r4 cmpb (r1),#.ilit1 beq alloc2 cmpb (r1)+,#.ilit2 bne errdim movb (r1),r4 bmi errdim swab r4 alloc2: inc r1 ;check syntax bisb (r1)+,r4 cmpb (r1)+,#.rpar bne dimsyn doalloc:cmp (r2),#.nvar ;make sure its not already dimensioned beq errdim blt dimsclr tst 4(r2) bpl errdim ;allocate array space dimsclr:mov r2,-(sp) ;save in case eol (for common) jsr pc,alloc ;var(r2),ss1(r3),ss2(4) mov (sp)+,r2 dimeol: cmpb (r1)+,#.comma beq dimgot cmpb -(r1),#.eol bne dimsyn inc r1 cmpb (sp)+,#.dim ;was this a dim st? beq dimloop add #10.,r2 ;compute comlof (5 words above last symbol) sub (r5),r2 ;keep as disp in case pgm modified mov r2,comlof(r5) mov hifree(r5),comhif(r5) br dimloop ;randomize statement rndgot: jsr pc,random mov rndct(r5),rnd1(r5) bisb #1,rnd1(r5) ;set search from rndct cmpb (r1)+,#.eol ;check syntax beq dimloop dimsyn: jmp errsyn errdim: trap 0 ;error in dim statement .ifndf $longer .ascii 'idm' .endc ;$longer .ifdf $longer .ascii 'illegal dim' .endc ;$longer .byte 0 .even errdef: trap 0 ;error in def statement .ifndf $longer .ascii \idf\ .endc ;$longer .ifdf $longer .ascii 'illegal def' .endc ;$longer .byte 0 .even defgot: cmpb (r1)+,#.fn ;def statement bne errdef movb (r1)+,r2 ;check syntax .ifdf hvunix add arrays(r5),r2 .iff add pdl(r5),r2 .endc tst (r2) bne errdef cmpb (r1)+,#.lpar bne errdef mov r1,(r2) ;save pointer to def in user's fn-table br defdun ;which is able pdllrs dimdone:clr clmntty(r5) ;re-set all column counts mov pdsize(r5),r4 mov code(r5),r1 rts pc ;return from irun subroutine ; 'run' command run: jsr r1,msg ;blank line after run command .byte lf,0 jsr pc,chkfil bne runfil jsr pc,headr br runnh1 runnh: jsr r1,msg ;blank line after runnh command .byte lf,0 jsr pc,chkfil bne runfil runnh1: jsr pc,initpgm jsr pc,clrvars jsr pc,irun ;initialize for run cmpb (r1),#.eof beq .+6 jmp execute errrun: jsr r1,msgerr .ifndf $longer .ascii \npr\ .endc ;$longer .ifdf $longer .ascii 'no program' .endc ;$longer .byte 0 .even jmp ready2 runfil: clr comlof(r5) ;must keep r0 and r3, will cause initscr br chain1 ;save code .ifdf $chain ; 'overlay' statement ovltst: call eval bcc errsxc pop r0 movb (r0),r3 add #3,r0 ret overlay:jsr pc,ovltst ;get file name .ifdf $..$ movb #aooip.,fadb(r5) .endc ;$..$ jsr pc,filspec ;translate dev:fil.ext .ifdf $namset .word dfexos ;ptr to def. ext .endc ;$namset mov lineno(r5),editln(r5) inc editln(r5) ;save edit return line no jsr pc,linego ;find line number to go to if present br chain4 ; 'chain' statement chain: jsr pc,ovltst chain1: .ifdf $..$ movb #runch.,fadb(r5) bic #uswpp$+uswro$,usw(r5) .endc ;$..$ jsr pc,filspec ;translate dev:fil.ext .ifdf $namset .word dfexos ;ptr to def. ext .endc ;$namset jsr pc,namset inc chnflg(r5) ;set to cause execution after "old" clr editln(r5) ;default line number jsr pc,linego ;check for line number spec. (won't hurt run) jsr pc,chnscr chain4: jmp old1 errsxc: jmp errsyn linego: cmpb (r1)+,#.line bne lineg1 jsr pc,fline ;check for line no. st entry bcs errsxc ;failed mov -(r2),editln(r5);found one, set it inc chnflg(r5) ;implied "run" (even for overlay) lineg1: rts pc .endc ;$chain .ifdf $..$ unsave: jsr pc,chkfil jsr pc,unkill jmp ready kill: jsr pc,fndstv jsr pc,unkill kill1: cmpb #.eol,(r1)+ bne namesyn ;kill and name as eol syntax check jmp execute unkill: movb #unsav.,fadb(r5) jsr pc,filspec jsr pc,de.let ;s1 rts pc nameas: jsr pc,fndstv movb #namas.,fadb(r5) jsr pc,filspec cmpb #.as,(r1)+ ;check syntax bne namesyn jsr pc,fndstv jsr pc,filsp2 ;same except rad50 goes into next devblk jsr pc,re.nam ;s1 br kill1 ;jmp execute namesyn:jmp errsyn .endc ;$..$ .ifdf $chain ;----------------------------------------------- ; subroutine 'chnscr' called by jsr pc ; performs same general functions as initscr ; but used only by "chain" to preserve common chnscr: mov comlof(r5),r2 ;disp to above last common symbol beq comsc2 ;no common, use normal scr mov code(r5),r0 mov #.eof,(r0)+ ;scr program mov (r5),r1 ;current bottom of st mov r0,(r5) ;new bottom of st add r1,r2 ;make comlof an absolute address comsc1: mov (r1)+,(r0)+ ;move symtab down cmp r1,r2 ;at comlof yet? blo comsc1 ;no mov r0,lofree(r5) ;after move, r0 is new lofree mov comhif(r5),hifree(r5) .ifndf $nostr jsr pc,uppack ;scratch unwanted strings .endc ;$nostr jsr pc,initpgm rts pc comsc2: jsr pc,initscr rts pc .endc ;$chain ;------------------------------------------------------------- ; subroutine 'clrvars' called by jsr pc ; clears vars to scalar zeros,null strings ; r0 destroyed ; r1,r2,r3,r4 unused ; r5 must point to user area ; sp goes no deeper after jsr clrvars:mov (r5),r0 clrloop:cmp r0,lofree(r5) bhis clrfree cmp (r0),#.scalar blo clrok .ifndf $nostr cmp (r0),#.svar beq clrsvar .endc ;$nostr mov #.scalar,(r0)+ clr (r0) .ifndf $nostr br .+4 clrsvar:mov (r0)+,(r0) .endc ;$nostr mov (r0)+,(r0) mov (r0)+,(r0) clrok: add #4,r0 br clrloop clrfree:mov arrays(r5),hifree(r5) sub #2,hifree(r5) mov lofree(r5),lostr(r5) mov lofree(r5),histr(r5) ;empty string storage clr comlof(r5) ;indicate no common rts pc ;------------------------------------------------------------------- ; subroutine 'fndfil' called by jsr pc ; types out the message 'file name--' ; inputs a line from the teletype which ; contains the file name, and returns ; with its address in r0 and length in r3. fndfil: jsr r1,msg .ifdf $disk .ascii 'file name--' .endc ;$disk .ifndf $disk .ascii 'device--' .endc ;$disk .byte 0 .even jsr pc,linget ;input a line mov line(r5),r0 mov r0,r3 fndf1: cmpb (r3)+,#cr ;look for end of line bne fndf1 sub r0,r3 ;compute length dec r3 rts pc ;--------------------------------------------------------------------- ; subroutine 'initpgm' called by jsr pc ; initializes for new program initpgm: jsr r4,savreg jsr pc,closall ;close all files .ifdf $bfalc .ifndf $..$ clr bufchn(r5) ;clear out buffer chain .endc ;$..$ .ifdf $..$ mov r5,r0 add #bufchn,r0 mov r0,r2 mov r0,(r2)+ mov r0,@r2 ;re-initialize the partition buffer deque list head .endc ;$..$ .endc ;$bfalc jsr pc,sreset ;reset i/o -- basics mov #32331,rnd1(r5) mov #163251,rnd2(r5) mov #33,gsbctr(r5) .ifdf hvunix mov arrays(r5),r0 .iff mov pdl(r5),r0 .endc mov #-1,(r0)+ clr (r0)+ cmp r0,limit(r5) blos .-6 rts pc ;----------------------------------------------------------- ; ; initscr - scratch user area ; ; call: jsr pc,initscr ; ; uses r0 ; initscr:mov code(r5),r0 mov #.eof,(r0)+ ;code area contains .eof only mov r0,(r5) mov r0,lofree(r5) ;reset free storage jsr pc,clrvars ;scratch strings jsr pc,initpgm ;reset other stuff rts pc ;-------------------------------------------------- ; subroutine 'lstprog' called by jsr pc ; lists the user program through 'putchar' ; r0 - r4 destroyed ; r5 must point to user area ; sp goes ?? deeper after jsr lstprog:mov code(r5),r1 lstloop: .ifdf $..$ jsr pc,nxtusr .endc ;$..$ jsr pc,listl bcc lstloop rts pc listl: movb (r1)+,r2 blt 1$ jmp lstptr 1$: cmpb r2,#.eol beq lsteol .ifdf $mortok cmpb r2,#.more bne lst2 jmp lstmor .endc lst2: cmpb r2,#.eof bne lst1 sec rts pc lst1: cmpb r2,#.flit bhis lstspec mov #keywds,r3 lstsrch:mov r3,r4 ;r4 is start of keyword movb (r3)+,r0 bpl .-2 ;loop till get end keyword cmpb r0,r2 ;compare values bne lstsrch cmpb r2,#.goto ;this part checks for on goto/gosub beq lstgoto ;a blank is needed before the goto/gosub cmpb r2,#.gosub ;in the on statement (but not otherwise) bne lstkwd lstgoto:cmpb -4(r1),#.eol ;eol means first thing in line beq lstkwd ;if so, no preceeding blank cmpb -2(r1),#.eol ;for \ goto or \ gosub beq lstkwd mov code(r5),-(sp) ;it could also be at the beginning add #3,(sp) cmp (sp)+,r1 beq lstkwd jsr r1,msgodev .ascii ' ' .byte 0 lstkwd: movb (r4)+,r0 bmi lstchk jsr pc,putchar br lstkwd lstchk: cmpb -(r1),#.next beq lstnext cmpb (r1)+,#.fn bne listl lstfn: movb (r1)+,r0 add #'a+'a-2,r0 ror r0 br lstchar lstnext:add #13,r1 br listl lsteol: movb (r1),r2 bpl lstlin cmpb r2,#.eof bne lstbslh lstcrlf:jsr r1,msgodev .byte cr,lf,0 .even clc rts pc lstlin: swab r2 inc r1 bisb (r1),r2 dec r1 add (r5),r2 cmp (r2),#.scalar blo lstcrlf lstbslh:jsr r1,msgodev .ascii ' \' .word 0 lstbl: mov #bl,r0 ;put blank after \ or line number lstchar:jsr pc,putchar lstbr: br listl lstspec:cmpb r2,#.flit beq lstflit cmpb r2,#.ilit2 blo lstil1 beq lstil2 lsttext:movb (r1)+,r0 beq listl jsr pc,putchar br lsttext lstil1: clrb fac2+1(r5) movb (r1)+,fac2(r5) br lstilb lstil2: movb (r1)+,fac2+1(r5) movb (r1)+,fac2(r5) lstilb: clr fac1(r5) br lstflb lstflit:movb (r1)+,fac1+1(r5) movb (r1)+,fac1(r5) movb (r1)+,fac2+1(r5) movb (r1)+,fac2(r5) lstflb: jsr pc,numout lstjmp: br lstbr lstptr: swab r2 bisb (r1)+,r2 add (r5),r2 cmp (r2),#.scalar bhis lstvar mov (r2),fac2(r5) ;list line number clr fac1(r5) jsr pc,numout cmpb (r1),#.eol ;is this line number last in statement? beq lstbr ;yes, no trailing blank cmpb (r1),#.comma ;is this line number in an on statement? bne lstbl ;no, print a trailing blank br lstbr ;yes, no trailing blanks in a list of line numbers lstvar: movb 10(r2),r0 jsr pc,putchar movb 11(r2),r0 beq .+6 jsr pc,putchar .ifdf $nostr br lstjmp .endc ;$nostr .ifndf $nostr cmp (r2),#.svar bne lstjmp mov #'$,r0 br lstchar .endc ;$nostr .ifdf $mortok lstmor: movb (r1)+,r2 ;get following byte mov #newwds,r3 ;start of table lmor2: mov r3,r4 ;start of word movb (r3)+,r0 ;next byte bpl .-2 ;wait for negative cmpb r0,r2 ;compare bne lmor2 ;nope - look for next lmor3: movb (r4)+,r0 ;get next char bmi lstbr ;done, next token jsr pc,putchar ;output char br lmor3 ;and loop .endc ;--------------------------------------------------------------- ; subroutine opnsys called by jsr pc,opnsys ; r0 contains file descriptor ; opens the system file ; uses comfil and combuf ; opnsys: .ifndf $..$ jsr pc,closys ;close the system file mov #comfil+2,r1 ;address file header mov #-1,(r1) ;current block mov r2,-(r1) ;file descriptor mov r2,r0 ;file desc to r0 for opnfil .endc ;$..$ .ifdf $..$ clr t2(r5) mov syslun,t1(r5) ;default to the system (per user) lun... ; ;set by basich .endc ;$..$ jmp opnfil ;goto opnfil routine ;-------------------------------------------------- ; 'tran' subroutine ; called by jsr pc,tran ; translates from input ascii code ; to internal code, consisting of tokens, ; line number references, symbol table ; references, and literals. always returns, ; no matter what is input. ; as new symbols are encountered, builds new ; entries into the symbol table. ; errors are translated to [.text,...] ; t3 non-zero means last alphabetic keyword was a ; goto, then, gosub, or list(nh) -- indicates that ; any numbers found after them are line numbers and ; not numeric constants tran: mov line(r5),r2 mov r2,r1 cmpb (r1)+,#cr bne .-4 mov code(r5),r0 movb -(r1),-(r0) cmp r1,r2 ;r0 is where original text is. bne .-4 ;r1 is where translated text goes tranrst:mov r1,t2(r5) ;save beginning of statement address mov r5,t3(r5) ;line number mode flag tranlup:clr t1(r5) ;last thing not var tranvar:tstb (r0) bne 1$ inc r0 br tranvar 1$: cmpb (r0)+,#bl beq tranvar cmpb -(r0),#cr bne trynum movb #.eol,(r1) rts pc trynum: cmpb (r0),#'. ;look for a number beq numjmp cmpb (r0),#'0 blo trykwd cmpb (r0),#'9 bhi trykwd numjmp: jmp isnum ;next try to match up a keyword trykwd: mov #keywds,r3 cmpb (r0),#'a ;check alpha keywords blo comtab ;too low cmpb (r0),#'z bhi comtab ;too high mov #keya,r3 ;just right clr t3(r5) ;anything aplha clears line no. mode flag comtab: tryagn: mov r0,r2 retry: cmpb (r2)+,(r3)+ beq retry movb -(r3),r4 ble amatch dec r2 cmpb (r2)+,#bl ;skip blanks in input and table beq retry dec r2 cmpb (r3)+,#bl beq retry tstb (r3)+ bpl .-2 br tryagn .ifdf $mortok amatch: beq newtab ;end of table, try new table .iff amatch: beq bchkvar ;neg if token, 0 if end of table .endc dec r2 ;keyword matches, save in code mov r2,r0 .ifdf $mortok cmp r3,#keyz ;first table or second? blos amat2 ;first movb #.more,(r1)+ ;second, add .more token movb r4,(r1)+ ;then matching token br tranlup ;and go back to trans next keyword amat2: movb r4,(r1)+ ;else just add matching token .iff movb r4,(r1)+ .endc cmp r3,#keya ;beginning of alpha keywords blo spchr ;special character cmpb r4,#.rem ;check special case beq rembr cmpb r4,#.fn beq trnfn cmpb r4,#.next beq nexfill cmpb r4,#.gosub ;check for keywords which beq sett3 ;are used with line numbers cmpb r4,#.goto beq sett3 cmpb r4,#.then beq thncall cmpb r4,#.list beq sett3 cmpb r4,#.listnh beq sett3 .ifdf $chain cmpb r4,#.line beq sett3 .endc ;$chain .ifdf hvunix cmpb r4,#.delet beq sett3 .endc cmpb r4,#.filcom ;check for file commands blo tranlup clr r2 ;set to ignore blanks in file names br rempack ;tran rest of line as text literal .ifdf $mortok newtab: cmp r3,#keyz ;which table did we just finish? bne chkvar ;second, so not a token mov #newwds,r3 ;first, let's try second table br tryagn ;and try, try again .endc thncall:mov r1,t2(r5) ;for implied call following then sett3: mov r5,t3(r5) ;something non-zero to indicate line number mode btrlup: br tranlup bchkvar:br chkvar spchr: cmpb r4,#.eol ;reinitialize all flags if end-of-line token beq tranrst cmpb r4,#.squot beq quotpak cmpb r4,#.dquot bne tranlup quotpak:cmpb #.squot,r4 ;save literal string beq .+6 mov #'"-''+.squot,r4 ;as: .quot, .text, chars, 0,.quot add #''-.squot,r4 movb #.text,(r1)+ ;the 2 quote characters must match cmp r1,r0 bhis errtr stostr: cmpb (r0),r4 ;same as initial quote char.? beq endquot cmpb (r0),#cr beq endcr movb (r0)+,(r1)+ br stostr endquot:clrb (r1)+ inc r0 cmpb r4,#'' beq endsquo movb #.dquote,(r1)+ br btrlup endsquo:movb #.squote,(r1)+ br nexjmp endcr: clrb (r1)+ ;if there is no matching close quote, movb #.eol,(r1) mov r1,r2 ;put eol in code cmpb -(r2),#.text ;search back to find .text bne .-4 movb r4,(r2) ;replace .quot, .text with .text movb #.text,-(r2) rts pc ;line is done, return trnfn: cmpb (r0)+,#bl ;fn keyword, look for function letter beq .-4 cmpb -(r0),#'a blo trfnbad cmpb (r0),#'z bhi trfnbad movb (r0)+,r2 asl r2 sub #'a+'a-2,r2 ;save function # * 2 movb r2,(r1)+ br nexjmp trfnbad:movb #'n,-(r0) ;if no letter following fn movb #'f,-(r0) ;un-translate fn dec r1 cmp r1,r0 bhi errtr rembr: br rempack ;go save remaining ascii chars nexfill:cmp r1,r0 ;after next, save extra bytes in code bhis errtr clrb (r1)+ clrb (r1) add #11,r1 cmp r1,r0 bhis errtr nexjmp: jmp tranlup errtr: jmp errtrn chkvar: cmp r3,#keya-1 ;was alpha or spchar table being searched? beq rempack ;can only be an invalid ! or @ mov r0,r3 ;save in case implied call movb (r0)+,r2 ;variable reference? - check digit cmpb (r0)+,#bl beq .-4 cmpb -(r0),#'9 bhi chkcall cmpb (r0),#'0 bhis isvar ;varible name with letter and digit chkcall:cmpb (r0),#'a ;check for a second alpha char blo nodigit ;variable name with letter only cmpb (r0),#'z bhi nodigit ;ditto cmp r1,t2(r5) ;first thing in statement? beq iscall ;yes tst t1(r5) ;last thing a var? beq nodigit ;no, otherwise syntax error br rempk1 ;keep blanks if syntax err iscall: clr r2 ;implied call flag rempk1: mov r3,r0 ;implied call or syntax error rempack:movb #.text,(r1)+ ;tran rest as .text, chars, 0 cmp r1,r0 bhis errtr ;overlap stotxt: movb (r0)+,r3 ;put char in r3 to speed up tests cmpb r3,#cr ;hit cr? beq remcr cmpb r3,#'\ ;\ terminates rem too! beq remeot cmpb r3,#'( ;check for implied call beq remlpar cmpb r3,#bl ;ignore blanks in implied call bne stotx1 tst r2 ;call? beq stotxt ;yes stotx1: movb r3,(r1)+ ;ok, store it br stotxt ;and try another remlpar:tst r2 ;implied call? bne stotx1 ;no, treat the ( as just another char remeot: clrb (r1)+ dec r0 ;point back at the \ or ( br nexjmp ;tran the ( or \ normally remcr: clrb (r1)+ movb #.eol,(r1) rts pc isvar: swab r2 bisb (r0)+,r2 swab r2 nodigit:mov (r5),r3 ;start searching symbol table (r3) cmpb (r0)+,#bl beq .-4 dec r0 varsrch:cmp r3,lofree(r5) ;symbol not found, go make new entry bhis putitin cmp (r3),#.scalar ;skip over line number entries bhis notit add #4,r3 br varsrch notit: add #10,r3 .ifndf $nostr cmp -10(r3),#.svar ;check string symtab entry beq trysvar .endc ;$nostr cmp (r3)+,r2 ;if variable in code is string, bne varsrch ;no match .ifndf $nostr cmpb (r0),#'$ beq varsrch br foundv trysvar:cmp (r3)+,r2 ;if symtab entry is string bne varsrch cmpb (r0),#'$ bne varsrch ;check for string variable ref inc r0 .endc ;$nostr foundv: sub #12,r3 ;go put in reference to existing br retvar ;sym tab entry putitin: .ifndf $nostr add #14,r3 cmp r3,lostr(r5) ;make sure strings are not there blo putaok jsr pc,uppack ;if they are, pack them upwards cmp r3,lostr(r5) ;and try again bhis errov2 ;no good putaok: tst -(r3) ;r3 is end of entry .endc ;$nostr .ifdf $nostr add #12,r3 ;address end of entry in r3 .endc ;$nostr cmp r3,hifree(r5) bhi errov2 mov r3,lofree(r5) mov r2,-(r3) clr -(r3) clr -(r3) clr -(r3) mov #.scalar,-(r3) ;entry is scalar numeric .ifndf $nostr cmpb (r0),#'$ ;changed it to string if required bne retvar inc r0 mov #.svar,(r3)+ com (r3)+ com (r3)+ com (r3) sub #6,r3 .endc ;$nostr retvar: mov r5,t1(r5) ;something non-zero to indicate var ref retlno: sub (r5),r3 ;put symbol table reference in code swab r3 ;2 bytes movb r3,(r1)+ swab r3 movb r3,(r1)+ cmp r1,r0 bhi trner4 jmp tranvar ;keep flag isnum: mov r0,-(sp) ;save ptr in case of bad num jsr pc,val ;find mantissa and exponent bcs badnum ;illegal number cmpb (r0),#'. bne expten badnum: mov (sp)+,r0 br rempack errov2: jsr r1,msgerr .ifndf $longer .ascii \ptb\ .endc ;$longer .ifdf $longer .ascii 'program too big' .endc ;$longer .byte 0 .even jmp ready2 expten: cmp r3,#14630 ;for + exponent, multiply mantissa bhi makflit ;by 10 tst r2 ble expneg jsr pc,mpyten dec r2 br expten expneg: bne makflit ;- exponent must be flt pt # tst r3 ;integer must be 15 bits bne makflit tst r4 ;line numbers too blt makflit cmp r1,line(r5) ;at beginning of line? beq maklno ;then it's a line number tst t3(r5) ;test the line number mode flag bne makln1 cmp r4,#377 bgt makei2 litzero:movb #.ilit1,(r1)+ br makeok makei2: movb #.ilit2,(r1)+ litcomn:swab r4 cmp r1,r0 bhis trner4 movb r4,(r1)+ swab r4 makeok: movb r4,(r1)+ tst (sp)+ cmp r1,r0 bhi trner4 jmp tranlup trner4: jmp errtrn errov3: jmp errov2 maklno: add #2,t2(r5) ;actual beginning of statement is after ln. makln1: mov (r5),r3 lnosrch:cmp r3,lofree(r5) ;look up line number in the symbol table bhis stolno cmp (r3),#.scalar blo islno add #12,r3 br lnosrch islno: cmp (r3),r4 beq foundln add #4,r3 br lnosrch stolno: .ifdf $nostr add #4,r3 .endc ;$nostr .ifndf $nostr add #6,r3 ;check that the symtab space cmp r3,lostr(r5) ;is not occupied by strings blo stoaok jsr pc,uppack ;if it is, move strings up cmp r3,lostr(r5) ;and check room enough again bhis errov3l stoaok: tst -(r3) ;adjust symtab address .endc ;$nostr cmp r3,hifree(r5) bhi errov3 mov r3,lofree(r5) clr -(r3) mov r4,-(r3) foundln:tst (sp)+ jmp retlno makflit:tst r3 ;create a floating point literal bne calnrm tst r4 beq litzero ;special case (0.0) calnrm: jsr pc,norm ;convert integer + exponent to flt pt. bcs badnum ;illegal number movb #.flit,(r1)+ ;save floating literal in the code swab r3 cmp r1,r0 bhis trner4 movb r3,(r1)+ swab r3 movb r3,(r1)+ br litcomn .ifndf $nostr ;-------------------------------------------------- ; subroutine 'uppack' called by jsr pc ; packs string storage toward high core ; r0 unused ; r1,r2,r3 preserved ; r4 unused ; r5 must point to user area ; sp goes 10 deeper after jsr uppack: mov r1,-(sp) mov r2,-(sp) mov r3,-(sp) clr -(sp) mov histr(r5),r1 mov hifree(r5),r2 mov r2,histr(r5) upploop:clr (sp) ;get end of the next string bisb -(r1),(sp) bne uppnzro ;(last byte contains the length uppbad: cmp r1,lostr(r5) bhi upploop mov r2,lostr(r5) tst (sp)+ mov (sp)+,r3 mov (sp)+,r2 mov (sp)+,r1 rts pc uppnzro:sub (sp),r1 ;address back ptr clr r3 bisb -(r1),r3 swab r3 bisb -(r1),r3 ;get it in r3 swab r3 dec r1 bit r3,#1 ;check rel to symbols beq .+6 dec r3 add (r5),r3 ;yes, add base of sym tab .ifdf hvunix cmp r3,arrays(r5) .iff cmp r3,pdl(r5) ;make sure it's not too hi .endc bhis uppbad cmp r3,sp ;in stack is ok bhis uppgood cmp r3,arrays(r5) ;in arrays is good bhi uppbad cmp r3,hifree(r5) ;in free storage is bad bhi uppgood cmp r3,lofree(r5) bhis uppbad cmp r3,(r5) blo uppbad ;below symbol table is bad uppgood:add #4,(sp) ;good string, move it up cmp (r3),r1 bne uppbad ;(don't garbage collect it) add (sp),r1 sub r1,(r3) add r2,(r3) movb -(r1),-(r2) dec (sp) bgt .-4 br uppbad .endc ;$nostr .title basice .end not too hi .endc bhis uppbad cmp r3,sp ;in stack is ok bhis uppgood cmp r3,arrays(r5) ;in arrays is good bhi uppbad cmp r3,hifree(r5) ;in free storage is bad bhi uppgood cmp r3,lofree(r5) bhis uppbad cmp r3,(r5) blo uppbad ;below symbol table is bad uppgood:add #4,(sp) ;good string, move it up cmp (r.title bash1 v02-01 functions ;basic kernel v02-01 ; ;the information in this document is subject to change ;without notice and should not be construed as a ;commitment by digital equipment corporation. digital ;equipment corporation assumes no responsibility for any ;errors that may appear in this document. ; ;the software described in this document is furnished ;to the purchaser under a license for use on a single ;computer system and can be copied (with inclusion of ;digital's copyright notice) only for use in such system, ;except as may otherwise be provided in writing by ;digital. ; ;digital equipment corporation assumes no responsibility ;for the use or reliability of its software on equipment ;that is not supplied by digital. ; ;copyright (c) 1974 ;by digital equipment corporation ;146 main street ;maynard, massachusetts 01754 ; ;january 1974 ; ; user area and once-only init. code. ; ; to be linked last after basics, ; the user function interface module, and ; any user assembly language routines. ; .hiseg ; basich: .ifdf hvunix .ifdf $sysfn ;--------------------------------------------------------------- ;sys routine -- extended feature routine ; to use, add to the key words table: ; .ascii 'fnname(' ; .byte sys ; and the function must be called with: ; "fnname(n,args)" ; where the 1st arg n is the dispatch number. ; when the code for a new function is added, ; parameter hisyfn must be changed to reflect ; the addition of the new function. sysfn: jsr pc,@#eval ;get dispatch # bcs ersyss jsr pc,@#int tst fac1(r5) bne ersysa mov fac2(r5),r0 cmp #losyfn,r0 bgt ersysa cmp #hisyfn,r0 blt ersysa asl r0 ;make dispatch table displacement mov sysftbl(r0),pc ersyss: jmp @#errsyn ersysa: jmp @#errarg losyfn=0 hisyfn=1 sysftbl:.word subst .word ddtx ; subst function - subst(a$,b$,i) - substitute ; string b for part of a, starting at position i in string a. ; nothing is copied. returns 0 if ok, 1 if b won't fit in a subst: push ss1sav(r5) ;have to save this stuff push ss2sav(r5) ;in case of x(i,j)=subst(...) push varsav(r5) ;so x(i,j) isn't destroyed cmpb (r1)+,#.comma bne ersubs movb (r1)+,r2 bmi ersubs swab r2 bisb (r1)+,r2 add (r5),r2 ;sym tab ref, should be stringvar cmp (r2),#.svar ; bne ersuba jsr pc,getvar ;do subscript stuff, if necessary mov varsav(r5),r2 ;may be redundant mov ss1sav(r5),r0 bmi subno ;no subscripts mov ss2sav(r5),r3 jsr pc,locget ;calc loc from ss's br subst1 ;no subscripts subno: tst (r2)+ ;at string ptr cmp 2(r2),#-1 beq subst1 ;not string array mov (r2),r2 ;non-subscripted array means extra ;level of indirection ; now r2 is string ptr subst1: pop varsav(r5) pop ss2sav(r5) pop ss1sav(r5) push (r2) ;save string ptr on stk cmpb (r1)+,#.comma bne ersubs jsr pc,eval bcc ersuba cmpb (r1)+,#.comma bne ersubs jsr pc,eval bcs ersuba jsr pc,int cmpb (r1)+,#.rpar bne ersubs tst fac1(r5) bne suberr ;hi order must be 0 mov fac2(r5),r0 ;i in r0 mov (sp)+,r4 ;b cmp r4,#177777 ;is b null? beq subdon ;yes, so there's nothing to do cmp (sp),#177777 ;is a null? beq suberr ;yes, so error clr r2 bisb (r4),r2 ;len(b) in r2 clr r3 bisb @(sp),r3 ;len(a) sub r2,r3 sub r0,r3 inc r3 ;len(a)-len(b)-i+1 < 0 ? blt suberr ;then b would overflow, so error add #3,r4 ;beginning of chars of b add (sp)+,r0 ;a+i add #2,r0 ;a+i+2=a+3+(i-1) posn in a sublop: movb (r4)+,(r0)+ ;mov byte from b->a dec r2 ;dec len(b)=chars left bgt sublop sub0: mov #1,fac2(r5) ;good return=1 sub1: jmp oprator suberr: clr fac1(r5) clr fac2(r5) ;error return=0 tst (sp)+ ;flush a$ from stack br sub1 subdon: tst (sp)+ ;flush a$ from stk br sub0 ;b$ null means good return ersuba: jmp errarg ersubs: jmp errsyn ;ddtx -- exit to ddt -- if ddt is loaded (if the first ; instruction of basic [baslow] is not at address 0) ; this executes a bpt which causes a "bad entry" to ; ddt which allows the programmer to set breakpoints with ddt ; and continue from the bad break. call: ; sys(1). returns a dummy value of 1. if ddt not loaded, prints ; error msg. ; courtesy of forrest howard. ddtx: cmpb (r1)+,#.rpar ;check syntax bne ersubs cmpb (r1),#.eol bne ersubs ddtgo: tst #baslow ;ddt loaded? bne xit ertext ddt, ;no! xit: bpt ;yes-- make bad entry clr fac1(r5) mov #1,fac2(r5) ;return dummy value jmp oprator ;insert new functions here .endc ;$sysfn .endc ;hvunix ;rnd function -- generate random number ; scan past arg if present rndlfn: jsr pc,@#eval bcs errnda cmpb (r1)+,#.rpar bne errnds rndfn: rndfn2: mov r5,r0 add #rnd2,r0 mov @r0,r3 mov -(r0),r2 asl r3 ;mult by 2 rol r2 add (r0)+,r2 ;now by 3 add @r0,r3 adc r2 add @r0,r2 ;now by 2**16+3 bpl rplus add #100000,r2 ;get 2**32+g rplus: mov r3,@r0 ;store new generators mov r2,-(r0) mov #201,r0 ;initial exponent rnorm: asl r3 ;float result rol r2 bcs rexp ;jump when leading bit found dec r0 ;adjust exponent for shift br rnorm rexp: clrb r3 bisb r2,r3 swab r3 clrb r2 bisb r0,r2 ;insert exponent into result swab r2 ror r2 ror r3 ;insert + sign mov r2,fac1(r5) mov r3,fac2(r5) jmp @#oprator errnds: jmp @#errsyn errnda: jmp @#errarg rndfne: ;abs function routine absfn: jsr pc,@#eval bcs erabsa cmpb (r1)+,#.rpar bne erabss tst fac1(r5) beq absint bpl absx bic #100000,fac1(r5) br absx absint: tst fac2(r5) bpl absx neg fac2(r5) bvc absx mov #44000,fac1(r5) clr fac2(r5) absx: jmp @#oprator erabsa: jmp @#errarg erabss: jmp @#errsyn absfne: ;sgn function routine sgnfn: jsr pc,@#eval bcs ersgna cmpb (r1)+,#.rpar bne ersgns clr r0 tst fac1(r5) bne sgnflt tst fac2(r5) beq sgnx sgnflt: bpl sgnpos dec r0 br .+4 sgnpos: inc r0 mov r0,fac2(r5) clr fac1(r5) sgnx: jmp @#oprator ersgna: jmp @#errarg ersgns: jmp @#errsyn sgnfne: ;bin function routine binfn: clr fac1(r5) clr -(sp) jsr pc,@#fndstr ;get string argument tst r3 ;check null beq bin3 bin1: movb (r0)+,r2 ;get next char cmpb r2,#bl ;is it blank beq bin2 ;yes, ignore it asl (sp) ;rotate previous bits bcs erbina ;too many sub #'0,r2 ;convert char to binary bmi erbina ;too low dec r2 bgt erbina ;too high bne bin2 inc (sp) bin2: dec r3 ;count chars bne bin1 bin3: mov (sp)+,fac2(r5) ;set integer output jmp @#oprator erbina: jmp @#errsyn binfne: ;oct function routine octfn: clr fac1(r5) clr -(sp) jsr pc,@#fndstr ;get string argument tst r3 ;check null beq oct3 ;yes, done oct1: movb (r0)+,r2 ;get next char cmpb r2,#bl ;check blank beq oct2 ;yes, ignore asl (sp) ;rotate previous digit bcs erocta asl (sp) bcs erocta asl (sp) bcs erocta sub #'0,r2 ;convert to octal bmi erocta ;check range cmp r2,#7 bhi erocta add r2,(sp) ;add into answer oct2: dec r3 ;count chars bne oct1 oct3: mov (sp)+,fac2(r5) ;set integer result jmp @#oprator erocta: jmp @#errsyn octfne: .ifndf $nostr ;tab function routine tabfn: jsr pc,@#argb cmpb (r1)+,#.rpar bne ertabs clr -(sp) movb fac2(r5),(sp) tabb: cmp (sp),#72. blo tabc sub #72.,(sp) br tabb tabc: sub @column(r5),(sp) bpl .+4 clr (sp) bne tabnon dec (sp) br tabnull tabnon: mov r5,r2 jsr pc,@#makestr mov (sp),r0 clr r2 bisb (r0),r2 add #3,r0 movb #bl,(r0)+ dec r2 bgt .-6 tabnull:jmp @#sopratr ertabs: jmp @#errsyn tabfne: ; len function routine lenfn: jsr pc,@#eval bcc erlena cmpb (r1)+,#.rpar bne erlens clr fac1(r5) clr fac2(r5) mov (sp)+,r2 inc r2 beq .+6 movb -(r2),fac2(r5) jmp @#oprator erlena: jmp @#errarg erlens: jmp @#errsyn lenfne: ; asc function routine ascfn: jsr pc,@#eval bcc erasca cmpb (r1)+,#.rpar bne erascs mov (sp)+,r2 cmp r2,#177777 beq erasca cmpb (r2),#1 bne erasca clr fac1(r5) clr fac2(r5) movb 3(r2),fac2(r5) jmp @#oprator erasca: jmp @#errarg erascs: jmp @#errsyn ascfne: ; chr$ function routine ; for rsts compatiblity, tries to convert # to an integer ; if it succeeds, it returns the low-order 8 bits chr$fn: jsr pc,@#eval bcs erchra ;string arg cmpb (r1)+,#.rpar bne erchrs jsr pc,@#int ;make it an integer tst fac1(r5) bne erchra ;not a basic integer mov #1,-(sp) mov r5,r2 jsr pc,@#makestr mov (sp),r0 movb fac2(r5),3(r0) jmp @#sopratr erchra: jmp @#errarg erchrs: jmp @#errsyn chrfne: ; pos function routine -- pos(x$,y$,n) ; unusual conditions and implementation; bs 1/74 ; if x$="" then 0 is returned ; if x$<>"" and y$="" then min(n,len(x$)+1) is returned ; if n<=0 then 1 is assumed for n ; if n>len(x$) and y$<>"" then 0 is returned posfn: jsr pc,@#eval bcc erposa cmpb (r1)+,#.comma bne erposs jsr pc,@#eval bcc erposa cmpb (r1)+,#.comma bne erposs jsr pc,@#eval bcs erposa jsr pc,@#int cmpb (r1)+,#.rpar bne erposs tst fac1(r5) ;check high order fac (n) blt posn1 ;<0, assume 1 for n bgt posrt0 ;very big and positive, return 0 mov fac2(r5),r0 ;r0 is n bgt posckx ;looks ok posn1: mov #-1,r0 ;n<=0, assume 1 posckx: cmp 2(sp),#177777 ;check null x$ beq posrt0 clr r2 ;compute len(x$), put in r2 bisb @2(sp),r2 cmp (sp),#177777 ;check null y$ bne posckn cmp r0,r2 ;y="", compare n to len(x$) ble posf ;return n mov r2,r0 inc r0 ;return len(x$)+1 br posf posckn: cmp r0,r2 ;y<>"", compare n to len(x$) bgt posrt0 clr r3 ;save address of end of y$ in t2 bisb @(sp),r3 add (sp),r3 add #3,r3 mov r3,t2(r5) mov (sp)+,r3 add #3,r3 ;addr of beginning of y in r3 add (sp),r2 ;compute addr of end of x, put in t1 add #3,r2 mov r2,t1(r5) mov (sp)+,r2 add r0,r2 add #2,r2 ;(beginning addr of x)+n in r2 posfst: cmpb (r3),(r2)+ ;find first matching character beq posrem postry: inc r0 cmp r2,t1(r5) bne posfst clr r0 br posf2 posrem: mov r2,-(sp) ;check that remaining chars match mov r3,-(sp) inc r3 posnxt: cmp r3,t2(r5) beq posf cmp r2,t1(r5) beq posno cmpb (r2)+,(r3)+ beq posnxt posno: mov (sp)+,r3 mov (sp)+,r2 br postry posrt0: clr r0 ;return 0 posf: cmp (sp)+,(sp)+ ;pop the two string pointers from stack posf2: mov r0,fac2(r5) clr fac1(r5) jmp @#oprator erposa: jmp @#errarg erposs: jmp @#errsyn posfne: ; seg function routine segfn: jsr pc,@#eval bcc ersega cmpb (r1)+,#.comma bne ersegs jsr pc,@#eval bcs ersega jsr pc,@#int mov fac1(r5),-(sp) mov fac2(r5),-(sp) cmpb (r1)+,#.comma bne ersegs jsr pc,@#eval bcs ersega jsr pc,@#int cmpb (r1)+,#.rpar bne ersegs ;get x value in r2 mov (sp)+,r2 mov (sp)+,r0 bmi segx0 bne segnul tst r2 bgt segl segx0: mov #1,r2 ;compute length of a$ in r0 segl: clr r0 cmp (sp),#177777 ;check null string beq segx bisb @(sp),r0 ;get y value in r3 segty: tst fac1(r5) bmi segnul beq segty2 mov r0,r3 br segrng segty2: mov fac2(r5),r3 ble segnul ;check 0<=r2<=r3<=r0 segrng: cmp r0,r3 bhi segr2 mov r0,r3 segr2: cmp r2,r3 bhi segnul ;compute length of output string sub r2,r3 inc r3 ;make new string of the correct length mov r2,-(sp) ;save start char mov r5,r2 mov r3,-(sp) jsr pc,@#makestr ;fix stack and move in chars from old string mov (sp)+,r2 ;new string pointer mov (sp)+,r0 ;start char add (sp),r0 ;add old str pointer mov r2,(sp) ;save new string clr r3 bisb (r2),r3 ;r3 is new string length add #3,r2 ;addr first char in new str add #2,r0 ;addr start char in old str seglp: movb (r0)+,(r2)+ ;fill in new string dec r3 bne seglp jmp @#stpro ;output null string segnul: mov #177777,(sp) segx: jmp @#sopratr ersega: jmp @#errarg ersegs: jmp @#errsyn segfne: ; val function routine valfn: jsr pc,@#eval bcc ervala cmpb (r1)+,#.rpar bne ervals ;read string mov (sp),r0 cmp r0,#177777 ;check null string bne valr clr fac1(r5) clr fac2(r5) tst (sp)+ br valj valr: mov sp,r2 ;r2 points to string ptr clr -(sp) bisb (r0),(sp) ;top of stack is length incb (sp) ; + 1 beq ervala mov (sp),-(sp) ;make a copy jsr pc,@#makestr ;create a string w 1 extra byte mov (sp)+,r0 ;address new string cmpb (r0)+,(r0)+ mov r0,r2 add (sp)+,r2 clrb (r2) ;make last byte null (00) mov r2,(sp) ;save address inc r0 ;r0 addresses chars jsr pc,@#sval ;read ascii number ;check end of string valce: tstb (r0) ;check ends on a null bne ervala cmp r0,(sp)+ ;check it's the right one bne ervala ;return to eval valj: jmp @#oprator ervals: jmp @#errsyn ervala: jmp @#errarg valfne: ; trm$ function - trim off trailing blanks trmfn: jsr pc,@#eval ;evaluate arg bcc ertrma ;(must be string) cmpb (r1)+,#.rpar ;check syntax bne ertrms mov sp,r2 ;r2 is string pointer mov (sp),r0 ;get string inc r0 ;check null beq trmj ;yes, return null clr r3 bisb -(r0),r3 ;r3 is string length add r3,r0 add #3,r0 ;r0 addresses last char (+1) trm1: cmpb -(r0),#bl ;check chars from end bne trm2 ;for first non-blank one dec r3 ;count chars bne trm1 ;loop. mov #-1,(sp) ;all blanks , return null trmj: jmp @#soprat trm2: mov r3,-(sp) ;r3 is new string length jsr pc,@#makestr ;create shortened string mov (sp)+,(sp) ;fix up stack jmp @#stpro ;go protect string ertrma: jmp @#errarg ertrms: jmp @#errsyn trmfne: ; str function routine strfn: jsr pc,@#eval bcs erstra cmpb (r1)+,#.rpar bne erstrs mov #20,-(sp) mov r5,r2 jsr pc,@#makestr mov (sp),r3 add #3,r3 mov r3,t2(r5) clr t1(r5) jsr pc,@#numsgn .word savchar mov sp,r2 mov t1(r5),-(sp) jsr pc,@#makestr mov (sp)+,(sp) jmp @#stpro ;protect string erstra: jmp @#errarg erstrs: jmp @#errsyn .endc ;$nostr strfne: .ifdf $matrix ;matrix package functions numfn: cmpb (r1)+,#.rpar ;check for closing paren bne numser ;no, error mov numsav,fac1(r5) ;return saved value mov numsav+2,fac2(r5) numx: jmp @#oprator ;done numser: jmp @#errsyn ;syntax error detfn: cmpb (r1)+,#.rpar ;check for closing paren bne numser ;no, error mov detsav,fac1(r5) ;return saved value mov detsav+2,fac2(r5) br numx ;done .endc fnend: ; ; ; user area storage cells .loseg ; ua: . =.+$lu ;user area for first user ; ; initialize user area(s) usr: clr r0 .ifndf $multi mov usrarea,r5 mov hicore,hilim .endc ;$multi .ifdf $multi usr1: mov r0,r2 asl r2 inc r0 mov usrtbl(r2),r5 mov usrtbl+2(r2),hilim .endc ;$multi mov r0,-(sp) jsr pc,mapusr mov (sp),r0 jsr pc,iniusr .ifdf $multi mov (sp)+,r0 cmp r0,lstusr bne usr1 clr curusr asl lstusr jmp rstart .endc ;$multi .ifndf $multi .ifdf hvunix $sig 2 break $sig 3 break clrb ttyiof .endc jmp start .endc ;$multi ; rand: .word 0 hilim: .word 0 ;subroutine to map out user area mapusr: mov r5,r1 mov #$lu,r0 ;count all words asr r0 ;change bytes to words map1: clr (r1)+ dec r0 ;count bne map1 map3: mov hilim,r0 tst -(r0) mov r0,limit(r5) sub #134,r0 ;space for pointers .ifdf hvunix mov sp,pdl(r5) add #2,pdl(r5) mov r0,arrays(r5) mov sp,pdsize(r5) sub #$stksz+$stkex-2,pdsize(r5) .iff mov r0,pdl(r5) ;base of stack sub #$stksz,r0 mov r0,arrays(r5) ;start of arrays add #$stkex,r0 mov r0,pdsize(r5) ;pdl limit .endc ; set up line(r5) and code(r5) mov #$lu,r0 add r5,r0 mov r0,line(r5) add #$ulnsp,r0 mov r0,code(r5) mov rand,rndct(r5) rts pc ;base of stack sub #$stksz,r0 mov r0,arrays(r5) ;start of arrays add #$stkex,r0 mov ;----------------------------------------------------------------------- ; bash2 for unix basic ; use with basic kernel v02-01 ; harvard university july 1974 ;print identification topcore:mov #2,r0 ;save the original tty mode $gtty ;for use on exiting ttymd mov ttymd3,oldmod pgmhdr: jsr r3,prmsg ;print version #,etc .byte lf,^o34 .ascii 'unix basic version 4-a' .byte lf .ascii /for news type 'info'/ .byte lf,0 .even ;set top of basic mov #savarg,r5 ;place to put text of arg mov #$deflo,arg ;default arg mov 2(sp),r0 ;arg count arloop: mov r0,r1 asl r1 add #2,r1 ;get around data on stack add sp,r1 ;point into stack cmpb #'+,@(r1) ;right arg? beq gotit ;yep sob r0,arloop ;no, dec count and try again setbrk: cmp #^d32,arg ;minimum is eight ble errbrk mov arg,r0 ash #^d11,r0 ;change to an address add #ua,r0 bcs errbrk mov r0,1$ $break 1$: .word 0 bcs errbrk mov 1$,r0 ;put the hi address in r0 ret gotit: mov (r1),r1 ;r1/--->string inc r1 ;step over the "+" movlop: movb (r1)+,(r5)+ ;move a char bne movlop ;if not end, move another mov #savarg,r5 call rdnum ;convert string to number bcs errbrk ;not a good number add r0,arg ;he's asking for minimum +arg br setbrk ;set the break there errbrk: jsr r3,prmsg .byte lf .ascii 'request too large' .byte lf,0 .even $exit arg: .word 0 savarg: .resw <^d8> ;input and output to tty during initialization inchar: movb (r5)+,r0 ;not from tty, but from area where the bne 1$ ;arg is so i can use rdnum to convert it movb #cr,r0 ;from a string to a number. 1$: ret outchar:movb r0,ttyiof ;put char in buffer mov #1,r0 ;tty file cookie $write ttyiof 1 bcc 5$ $exit ;if you can't write then hang it up 5$: ret ;another useless routine iniusr: ret ;handler for ^z and ^x during initialization brkhdl: push r0 $sig 2 brkhdl $sig 3 brkhdl pop r0 rti ;ignore breaks during initialization on inchar: movb (r5)+,r0 ;not from tty, but from area where the bne 1$ ;arg is so i c.title bash3 v02-01 initialization ;basic kernel v02-01 ; ;the information in this document is subject to change ;without notice and should not be construed as a ;commitment by digital equipment corporation. digital ;equipment corporation assumes no responsibility for any ;errors that may appear in this document. ; ;the software described in this document is furnished ;to the purchaser under a license for use on a single ;computer system and can be copied (with inclusion of ;digital's copyright notice) only for use in such system, ;except as may otherwise be provided in writing by ;digital. ; ;digital equipment corporation assumes no responsibility ;for the use or reliability of its software on equipment ;that is not supplied by digital. ; ;copyright (c) 1974 ;by digital equipment corporation ;146 main street ;maynard, massachusetts 01754 ; ;january 1974 ; .ifdf $tty ; subroutine 'setty' called by jsr pc,setty ; r5 is addr of user area ; r0 is term no (0 if none or 1-8) ; sets up term type in user area ; r1 destroyed setty: mov r1,-(sp) mov r0,-(sp) ;save term no set1: jsr r3,prmsg ;print start of message .ascii 'term' .byte 0 .even .ifdf $multi movb (sp),termno ;check term no. beq set2 ;none, bypass bisb #60,termno ;convert to ascii jsr r3,prmsg ;print '#n' .ascii ' #' termno: .ascii '1' .byte 0 .even .endc ;$multi set2: jsr r3,prmsg ;print qm .ascii '? ' .byte 0 .even jsr pc,rdans ;get response cmpb r0,#cr ;check default beq set3 ;yes, bypass sub #60,r0 ;convert to binary beq set3 ;0, bypass cmpb r0,#2 bhi set1 ;out of bounds, ask again mov r0,r1 ;mult r0 by 3 asl r0 add r1,r0 add #filltb,r0 ;address table mov r5,r1 add #fillco,r1 ;address user area movb (r0)+,(r1)+ ;move in fill chars movb (r0)+,(r1)+ movb (r0)+,(r1)+ set3: mov (sp)+,r0 ;restore r0+r1 mov (sp)+,r1 rts pc filltb=.-3 .byte 0,14,cr ;la30 .byte 0,04,lf ;vt05 .endc ;$tty ; --once-only init. code ; find out how much core and expand usrarea accordingly onceonl: .ifdf hvunix $sig 7 bomb $sig 2 brkhdl $sig 3 brkhdl .iff mov #tmpstck,sp .endc jsr pc,topcore mov r0,hicore .ifndf hvunix mov r0,sp ;use as temp stack .endc jsr pc,ifpmp ;init for fpmp routines ;initialize top of basic .ifdf hvunix mov #ua,usrarea .iff mov #basich,r1 .endc .ifndf hvunix ;print heading and read answer inihd: jsr r3,prmsg .ascii 'opt fns? ' .byte 0 .even jsr pc,rdans cmpb r0,#'n ;check for n beq inisav clr r2 ;clear all flag cmpb r0,#'a ;check for a beq inita cmpb r0,#cr ;or bne initi inita: inc r2 ;set all flag br iniall initi: cmpb r0,#'i ;check for i bne inihd ;print heading for indiv functions jsr r3,prmsg .ascii ' y-yes n-no' .byte cr,lf,lf,0 .even iniall: mov #fntab,r5 mov #table5,r4 ;get next function table address inilp: mov (r5),r3 bne inifn add #2,r5 ;skip a function add #2,r4 br inilp ;print question for function, get answer inifn: cmp r4,#tbl5end bhi inisav cmp r5,#fntabe bhis inisav tst r2 bne inidf mov 4(r5),fnnam1 mov 6(r5),fnnam2 jsr r3,prmsg fnnam1: .word 0 fnnam2: .word 0 .ascii '? ' .byte 0 .even jsr pc,rdans cmpb r0,#'n ;check for n bne inity tst (r4)+ br ininxt inity: cmpb r0,#'y ;check for y bne inifn ;define the function inidf: mov r1,(r4)+ ;place address in table inimv: mov (r3)+,(r1)+ cmp r3,2(r5) blo inimv ininxt: add #10,r5 cmp r4,#tbl5end blos inilp ;save top of basic inisav: mov r1,usrarea ;check if rndl loaded mov #tbl5rnd,r2 mov (r2)+,r3 beq nornd add #rndfn-rndlfn,r3 mov r3,(r2) ;define rnd also nornd: .endc ;print out if user functions loaded jsr pc,gtftabi ;puts adr of usr fnct table in r2 beq nousr jsr r3,prmsg .ascii 'user fns loaded' .byte 0 .even nousr: .ifdf $multi ;dialogue to set up user area sizes in mu-system size0: mov usrarea,r5 ;set usr area for basic calls mov hicore,-(sp) sub r5,(sp) clc ror (sp) ;top of stk is # words avail size1: mov (sp),fac2(r5) clr fac1(r5) jsr pc,numprt ;print # words avail jsr r3,prmsg .ascii ' words core available' .byte cr,lf,0 .even size1u: jsr r3,prmsg .ascii 'how many users? ' .byte 0 .even jsr pc,rdnum ;accept answer bcs size1u ;invalid character, try again cmp r0,#2 ;check for more than one user bhis size1b ;yes mov #1,lstusr ;default br size1a ;skip what immediately follows if only one user size1b: cmp r0,#8. bhi size1u ;greater than 8 users invalid mov r0,lstusr ;save number of users ; check enough terminals jsr pc,validt bcc sizeach jsr r3,prmsg .ascii /not enough tty's/ .byte cr,lf,0 .even br size1u ;ask him again sizeach:mov (sp),r1 ;total words available mov lstusr,r2 ;number of users clr r3 ;words each if divided evenly sizea1: inc r3 ;divide no. of words by no. of users sub r2,r1 bpl sizea1 ;(it's words so we can use signed br) cmp r3,#$minusr blt size3 ;not enough core mov r3,fac2(r5) clr fac1(r5) jsr pc,numprt ;give him some useful information jsr r3,prmsg .ascii ' words per user if divided evenly' .byte cr,lf,lf,0 .even size1a: mov #usrtbl,r2 mov r5,(r2)+ ;first user address clr r3 size2: inc r3 cmp r3,lstusr bhis size5 ;branch out on last user movb r3,sizusr ;compute ascii user # bisb #60,sizusr size2a: jsr r3,prmsg .ascii 'core #' sizusr: .ascii '1? ' ;ask for # words .byte 0 .even jsr pc,rdnum ;accept answer bcs size2a sub r0,(sp) ;update # available bhi size4 tst (sp)+ ;none left, message jsr r3,prmsg .byte cr,lf .ascii 'not enough core' .byte cr,lf,0 jmp size0 size3: tst (sp)+ jsr r3,prmsg .ascii 'too small' .byte cr,lf,0 .even jmp size0 size4: tst r0 beq size5 ;default, divide the rest cmp r0,#$minusr ;check minimum size blo size3 asl r0 add -2(r2),r0 ;compute next user addr mov r0,(r2)+ br size2 size5: mov lstusr,r0 sub r3,r0 ;compute # users remaining inc r0 mov r0,r3 ;copy in r3 clr r1 size6: inc r1 ;divide # words by # users sub r0,(sp) bpl size6 cmp r1,#$minusr ;check size big enough blo size3 asl r1 ;compute bytes size7: dec r3 beq size8 mov -2(r2),(r2) add r1,(r2)+ br size7 size8: mov hicore,(r2) ;set high limit .endc ;$multi jmp usr ;subroutine to read a decimal number rdnum: clr -(sp) clr -(sp) jsr pc,inchar cmpb r0,#'- bne rd4 inc 2(sp) rd1: jsr pc,inchar rd4: cmpb r0,#cr beq rd3 sub #'0,r0 blt rdnerr ;invalid character cmp r0,#9. blos rd2 rdnerr: cmp (sp)+,(sp)+ sec rts pc rd2: asl (sp) mov (sp),-(sp) asl (sp) asl (sp) add (sp)+,(sp) add r0,(sp) br rd1 rd3: mov (sp)+,r0 tst (sp)+ beq rd5 neg r0 rd5: clc rts pc .ifdf $multi ; subroutine to print an unsigned number numprt: jsr r4, savreg mov #outchar,r1 jmp numstt .endc ;$multi ;subroutine to print a message prch: jsr pc,outchar prmsg: movb (r3)+,r0 bne prch inc r3 asr r3 asl r3 rts r3 .ifndf hvunix ;subroutine to read answer from teletype rdans: mov #cr,-(sp) ;default br rda2 rda1: mov r0,(sp) ;save latest char rda2: jsr pc,inchar ;read a char cmpb r0,#cr ;is it ? bne rda1 ;no, try again mov (sp)+,r0 ;get answer rts pc ;return .endc hicore: .word 0 .ifndf hvunix fntab: .ifdf $disk .word 0 ; vf .endc ;$disk .word 0 ;pi .word rndlfn .word rndfne .ascii 'rnd ' .word 0 ; rnd .word 0 ; sin .word 0 ; cos .word 0 ; sqr .word 0 ; atn .word 0 ; exp .word 0 ; log .word 0 ; log10 .word absfn ; abs .word absfne .ascii 'abs ' .word 0 ; int .word sgnfn ; sgn .word sgnfne .ascii 'sgn ' .word binfn ; bin .word binfne .ascii 'bin ' .word octfn ; oct .word octfne .ascii 'oct ' .ifndf $nostr .word tabfn ; tab .word tabfne .ascii 'tab ' .word lenfn ; len .word lenfne .ascii 'len ' .word ascfn ; asc .word ascfne .ascii 'asc ' .word chr$fn ; chr$ .word chrfne .ascii 'chr$' .word posfn ; pos .word posfne .ascii 'pos ' .word segfn ; seg .word segfne .ascii 'seg$' .word valfn ; val .word valfne .ascii 'val ' .word trmfn ; trm$ .word trmfne .ascii 'trm$' .word 0 ; dat .word strfn ; str .word strfne .ascii 'str$' .endc ;$nostr fntabe: .endc .end onceonl 'trm$' .word 0 ; dat .word strfn ; str .word strfne .ascii 'str$' .endc ;$nostr fntabe: .endc .end onceonl .hiseg .GLOBL BKGI,FTABI FTABI: .+2 .WORD 0 BKGI: .WORD 0 .END linkr r.obj intr.obj conv3.obj fadd.obj fmul.obj conv2.obj fdiv.obj exp.obj sqrt.obj atan.obj alog.obj sin.obj ermod.obj i.obj matpak.obj e.obj x.obj s.obj h3.obj mv h3.out basic .ar .bp 1 .sp 4 .ce 1 BUILDING UNIX BASIC .he 'Building UNIX BASIC''Version 3-f' .fo ''-%-'' .hy 0 .pn .sp 3 .ti +5 This document is intended for use by system programmers building a copy of BASIC for use under the UNIX operating system. The BASIC described is a variant of DEC RT-11 BASIC, which was modified in July 1974 at Harvard University. .ti +5 The files required for UNIX BASIC version 3-f come in three packages: command files for use in building the system; the BASIC interpereter; and the BASIC floating point math package. They are: .sp 2 .in 5 Command files-- .ti -5 assem -- assembles the BASIC interpereter. .ti -5 fpassem -- assembles the floating point math package. .ti -5 link -- links the object files produced by the above command files to produce a shareable copy of BASIC. .ti -5 plink -- links the object files with DDT or ODT to produce an unshareable copy of BASIC for debugging. .sp 2 BASIC Interpereter files-- .ti -5 p1.mac -- macro definitions, system assembly constants, and global variable definitions. .ti -5 p2.mac -- system constants, globals, and token definitions. .ti -5 r.mac -- root segment: execution dispatch and data management routines. .ti -5 e.mac -- edit segment: lexer, parser, and editor. .ti -5 x.mac -- execution segment: commannd execution routines. .ti -5 s.mac -- I/O and resident utility routines. .ti -5 i.mac -- assembly language routine interface module (CALL statement). .ti -5 h1.mac, h2.mac, h3.mac -- once-only initialization code. .ti -5 matpak.mac -- matrix manipulation commands. .sp 2 Floating Point package-- .ti -5 p3.mat -- parameter definitions for assembly without hardware floating point. .ti -5 p3.fpu -- parameters for hardware floating point. .ti -5 ermod.mat - floating point error handler. .ti -5 conv2.mat, conv3.mat - integer/floating conversion. .ti -5 intr.mat -- floating truncation. .ti -5 fadd.mat -- floating addition. .ti -5 fmul.mat -- floating multiplication. .ti -5 fdiv.mat -- floating division. .ti -5 exp.mat -- exponential function. .ti -5 sin.mat -- sine and cosine functions. .ti -5 sqrt.mat -- square root function. .ti -5 alog.mat -- natural and common logarithm functions. .ti -5 atan.mat -- arctangent function. .in 0 .sp 2 .ti +5 These files must be assembled with Harvard MACRO-11 and linked with Harvard LINKR. All ASCII strings must be assembled in lower case. After completion of the command sequence: .br % sh assem .br % sh fpassem .br % sh link .br an executable file "basic" resides in the current directory (execution of plink produces "pbasic"), which may be run in the normal fashion. .ti +5 If an installation finds it necessary to reduce the size of UNIX BASIC, several parameters may be changed in p1.mac to eliminate certain features. These include: .in 5 .sp 1 .ti -3 $reseq -- if undefined, eliminates code for the RESEQuence statement. .ti -3 $ext -- if undefined, eliminates code for the EXTEND statement, which, in version 3-f, includes statements for producing protocols of BASIC sessions, for unlinking files, and typing update news. .ti -3 $deflo -- the default size for the BASIC loseg. See "USING UNIX BASIC" for an explanation of how each user may increase his area. Must be an integer in the range 2-31. .ti -3 protec -- the protection code given to files created with BASIC. Currently ^O644 (rw-r--r--). .ti -3 $nopru -- if defined, eliminates code for the PRINTUSING statement. .ti -3 $longer -- if defined, produces long error messages (about three words) instead of the usual three-letter messages. .ti -3 $ulnsp -- the maximum number of characters in a BASIC line. Must be even. .ti -3 $pnamsz -- the maximum number of characters in a file pathname. .ti -3 $sysfn -- if undefined, eliminates code for the SYS function, which, in version 3-f, includes a function to substitute characters in a string without making garbage copies, and an exit to DDT or ODT for debugging. .ti -3 $nostr -- if defined, the BASIC produced will not support string variables or string operations. .ti -3 $stksz, $stkex -- arbitrary parameters which determine the amount of stack which BASIC thinks it has. Since BASIC uses the UNIX stack, no space is saved by decreasing these parameters. The default value (^O200 for $stksz and ^O50 for $stkex) is generally sufficient, even for complex programs. .ti -3 $novf -- if defined, eliminates code which supports virtual files. .ti -3 $maxun -- the maximum I/O unit number, i.e. the maximum local value of n in the statements "PRINT #n" and "VFn". Should be left at 5 for unix systems. .ti -3 $bufsz -- the size of the I/O buffers. Must be even. If virtual files are supported, must be a power of 2 > ^D128. .in 0 .sp 1 .ti +5 The specifications for interfacing assembly language subroutines with BASIC for use via the CALL statement are given in reference 3) below. .ti +5 The EXTEND and SYS statements are as yet undocumented, since they will be changed in BASIC version 3-g. In 3-f, however, the EXTEND statement is of the form "EXTEND(n,args)" where n is a dispatch number which specifies what command is to be executed, and args are the arguments to the appropriate command. Commands supported are: .sp 1 .in 5 .ti -3 n=1 -- create a file "basic.protocol" in the current directory which will be a protocol of the BASIC session from the statement following "EXTEND(1)" up to the statement to terminate the protocolling. .ti -3 n=0 -- stop recording the session in the protocol file, and close that file. .ti -3 n=2 -- unlink the specified file from the specified directory. The single argument is a string expression which must evaluate to "pathname". No default extensions are appended. .ti -3 n=3 -- type the file /lib/basic/news.bas which is a summary of changes in the BASIC system from version to version. .sp 1 .in 0 The SYS functions are value- returning functions. They are of the form "SYS(n,args)" and dispatch numbers supported are: .sp 1 .in 5 .ti -3 n=0 -- string substitute function. Args are A$,B$,N,I where the effect is to substitute the characters B$ for characters in A$ beginning at character N, and leave I with the value 1 for a sucessful substitution or 0 for failure. Failure may occur if (LEN(A$)-N)-LEN(B$) <0 or if N >LEN(A$). .ti -3 n=1 -- exits to DDT or ODT with a continuable "bad entry". Returns a value of 1. If neither DDT nor ODT is loaded, produces an error message. .sp 1 .in 0 .ti +5 UNIX BASIC is still under development at Harvard. If users discover any inconsistencies or bugs, please send a description and minimal protocol to: .ti +10 John Burruss .ti +10 c/o Director's Office .ti +10 Science Center .ti +10 1 Oxford Street .ti +10 Harvard University .ti +10 Cambridge, MA 02138 .br Updates are in preparation. These will include, hopefully before the end of 1974, a Matrix function package and placing BASIC in I/D spaces to allow a larger user workspace. .ti +5 References which describe UNIX BASIC are: .in +5 .ti -2 1). BASIC-11 LANGUAGE REFERENCE MANUAL, DEC-11-LIBBA-A-D, 1974, Digital Equipment Corporation. .ti -2 2). USING UNIX BASIC, in HRSTS MATHEMATICAL LANGUAGES HANDBOOK, 1974, Harvard University. .ti -2 .in 0 Users planning to modify or extend UNIX BASIC will find useful information on format of data and symbol table in .in 5 .ti -2 3). BASIC/RT11 LANGUAGE REFERENCE MANUAL, DEC-11-LBACA-B-D, Digital Equipment Corporation. .in 0 r user workspace. .ti +5 References which describe UNIX BASIC are: .in +5 .ti -2 1). BASIC-11 LANGUAGE REFERENCE MANUAL, DEC-11-LIBBA-A-D, 1974, Digital Equipment Corporation. .ti -2 2). USING UNIX BASIC, in HRSTS MATHEMATICAL LANGUAGES HANDBOOK, 1974, Harvard University. .ti -2 .in 0 Users ;matrix routines to implement the 'mat' series of statements ; ;jeff herrmann 1-24-75 ; ; ;assemble p1,p2,matpak ; ;***************************************************************** .hiseg .title matpak matbeg: movb (r1)+,r2 ;get next byte bmi mtok1 ;token jsr pc,finsym ;symbol table reference cmpb (r1)+,#.eq ;next token better be = bne errjmp ;nope, error movb (r1)+,r2 ;get next byte bmi mtok2 ;token jsr pc,finsym ;symbol reference movb (r1)+,r0 ;get next byte bpl errjmp ;not a token cmpb r0,#.eol ;end of line? beq letjmp ;yes - mat a=b cmpb r0,#.plus ; + ? beq matop ;yes cmpb r0,#.minus ; - ? beq matop ;yes cmpb r0,#.star ; * ? beq matop ;yes br errjmp ;none of the above ;here on token right after .mat mtok1: cmpb r2,#.read ;dispatch on token beq rdjmp cmpb r2,#.print beq prtjmp cmpb r2,#.input beq iptjmp errjmp: jmp errsyn ;none of the above ;here on token after = mtok2: cmpb r2,#.lpar ;left paren? beq scljmp ;scalar multiply cmpb r2,#.trn ;trn(a) beq trnjmp ;transpose cmpb r2,#.inv ;inv(a) beq invjmp ;inverse cmpb r2,#.more ;extended token? bne errjmp ;no, error movb (r1)+,r2 ;get next token cmpb r2,#.zer ;zer? beq zerjmp cmpb r2,#.con ;con? beq conjmp cmpb r2,#.idn ;idn? beq idnjmp br errjmp ;none of the above letjmp: jmp matlet rdjmp: jmp matrd prtjmp: jmp matprt iptjmp: jmp matipt scljmp: jmp matscl trnjmp: jmp mattrn invjmp: jmp matinv zerjmp: jmp matzer idnjmp: jmp matidn conjmp: jmp matcon ;routine to finish, check and stack an array symbol ref finsym: swab r2 ;l.h.s. bisb (r1)+,r2 ;get other half add (r5),r2 ;absolute cmp (r2),#.nvar ;array? beq fsymx ;yes cmp (r2),#.scalar ;scalar? bne typerr ;must be string variable mov r2,-(sp) ;save some regs mov r3,-(sp) mov r4,-(sp) jsr pc,dnpack ;move down strings to make room mov #12,r3 ;default dimension is 10 mov r3,r4 ;second subscript also jsr pc,alloc ;useful subr does all the work mov (sp)+,r4 ;restore saved regs mov (sp)+,r3 mov (sp)+,r2 fsymx: mov (sp),-(sp) ;copy return address mov r2,2(sp) ;save ref to array rts pc typerr: ertext num, sizerr: ertext siz, ;here on mat +, -, * ;first 2 symbol refs are stacked ;op token is in r0 matop: movb (r1)+,r2 ;get next byte bmi syner2 ;token! syntax error jsr pc,finsym ;symbol table reference cmpb (r1)+,#.eol ;that's all bne syner2 ;more ... error mov (sp)+,r3 ;second arg mov 2(r3),mtarg2 ;adr of array mov (sp)+,r4 ;first arg mov 2(r4),mtarg1 ;adr of array mov (sp)+,r2 ;result array mov 2(r2),mtres ;adr of array mov r1,-(sp) ;save r1 cmpb r0,#.star ;mult? beq matmul ;yes matadd: cmp 4(r4),4(r3) ;compare first subscripts bne sizmat ;mismatch cmp 6(r4),6(r3) ;compare second subscripts bne sizmat ;mismatch mov 4(r4),ss1sav(r5) ;save first subscript mov 6(r4),ss2sav(r5) ;save second subscript jsr pc,redim ;redimension result array mov #addstk,r4 ;pretend add cmpb r0,#.plus ;add? beq 1$ ;yes mov #substk,r4 ;no, subtract 1$: mov ss1sav(r5),ss1 ;first subscript mov ss2sav(r5),ss2 ;second subscript addlp: mov ss1,r1 ;ss1 inc r1 ;ss1+1 tst ss2 ;test ss2 bmi addlp2 ;only one subscript? mov ss1sav(r5),r3 ;ss1max inc r3 ;ss1max+1 mul ss2,r3 ;ss2*(ss1max+1) add r3,r1 ;ss2*(ss1max+1)+ss1+1 addlp2: asl r1 ;mul by 4 asl r1 mov mtarg1,r2 ;get first array add r1,r2 ;get adr of element mov (r2)+,fac1(r5) ;store element in fac mov (r2),fac2(r5) mov mtarg2,r2 ;get second array add r1,r2 ;adr of element tst (r2)+ ;second word first mov (r2),-(sp) ;stack element mov -(r2),-(sp) jsr pc,(r4) ;call addstk or substk mov mtres,r2 ;result array add r1,r2 ;adr of element mov fac1(r5),(r2)+ ;move result to array mov fac2(r5),(r2) dec ss1 ;decrement index bgt addlp ;more, go back mov ss1sav(r5),ss1 ;else restore dec ss2 ;decrement other index bgt addlp ;more, go back mov (sp)+,r1 ;else restore r1 jmp execute ;done syner2: jmp errsyn sizmat: ertext siz, matmul: cmp r4,r2 ;result array must not be beq duperr ; the same as either arg cmp r2,r3 beq duperr mov 6(r4),ss3sav ;common dimension bpl 1$ ;allow x(n)*y(0,n) clr ss3sav ;(stt 11/5/75) 1$: cmp ss3sav,4(r3) ;compare columns with rows bne sizmat ;can't multiply mov 4(r4),ss1sav(r5) ;result has # rows like arg1 mov 6(r3),ss2sav(r5) ; # columns like arg2 jsr pc,redim ;redimension result array mov ss1sav(r5),ss1 ;init subscripts mov ss2sav(r5),ss2 mulolp: clr -(sp) ;accumulate dot product clr -(sp) mov ss3sav,ss3 mulilp: mov ss1,r1 ;get first element inc r1 tst ss3 bmi mulp2 mov ss1sav(r5),r3 inc r3 mul ss3,r3 add r3,r1 mulp2: asl r1 inc r1 asl r1 add mtarg1,r1 mov (r1),-(sp) ;stack first element mov -(r1),-(sp) mov ss3,r1 ;get second element inc r1 tst ss2 bmi mulp3 mov ss3sav,r3 inc r3 mul ss2,r3 add r3,r1 mulp3: asl r1 asl r1 add mtarg2,r1 mov (r1)+,fac1(r5) ;put second element in fac mov (r1),fac2(r5) jsr r4,fppsav ;enter polish mode .word tststk .word pushf .word $mlr .word $adr .word fppres dec ss3 ;decrement index bgt mulilp ;more, go back mov ss1,r1 ;get result location inc r1 tst ss2 bmi mulp4 mov ss1sav(r5),r3 inc r3 mul ss2,r3 add r3,r1 mulp4: asl r1 asl r1 add mtres,r1 mov (sp)+,(r1)+ ;store result mov (sp)+,(r1) dec ss1 ;decrement index bgt mulolp ;more, go back mov ss1sav(r5),ss1 ;else restore dec ss2 ;decrement other index bgt mulolp ;more, go back mov (sp)+,r1 ;restore saved r1 jmp execute ;done duperr: ertext roa, ;here on mat a=zer matzer: clr r0 ;fill with 0's br matfil ;on to do the work! ;here on mat a=con matcon: clr r0 ;fill with ones inc r0 br matfil ;do the work! ;here on mat a=idn matidn: clr r0 ;-1 means identity matrix dec r0 br matfil ;join common routine ;here to handle zer, con, and idn ;r0 contains 0, 1, or -1 respectively ;top of stack points to symbol table entry matfil: mov (sp)+,r2 ;get symbol ref movb (r1)+,r3 ;next token cmpb r3,#.eol ;end of line? beq dofill ;yes cmpb r3,#.lpar ;then better be left paren bne erjump ;no, error mov r0,-(sp) ;save r0 jsr pc,getdim ;get new dimensions mov (sp)+,r0 ;restore r0 cmpb (r1)+,#.eol ;now must be end of line bne erjump ;still more! error dofill: mov r1,-(sp) ;save r1 mov 4(r2),r3 ;ss1max mov 6(r2),r4 ;ss2max floop: mov r3,r1 ;ss1 inc r1 ;ss1+1 tst r4 ;test second subscript bmi floop2 ;only one subscript mov r1,-(sp) ;save r1 mov 4(r2),r1 ;get ss1max inc r1 ;ss1max+1 mul r4,r1 ;ss2*(ss1max+1) add (sp)+,r1 ;ss2*(ss1max+1)+ss1+1 floop2: asl r1 ;mul by 4 asl r1 ; add 2(r2),r1 ;add adr of array tst r0 ;what are we doing? beq fzdo ;zeroes bpl fcdo ;ones fido: cmp r3,r4 ;identity - compare subscripts beq fcdo ;equal, deposit a one ;else fall thru and deposit zero fzdo: clr (r1)+ ;deposit zero clr (r1) br floop3 fcdo: mov #40200,(r1)+ ;deposit one clr (r1) floop3: dec r3 ;decrement ss1 bgt floop ;if >0 go back mov 4(r2),r3 ;otherwise restore dec r4 ;decrement ss2 bgt floop ;if >0 go back mov (sp)+,r1 ;restore code pointer jmp execute ;done erjump: jmp errsyn ;routine to redimension arrays ;takes symbol table pointer in r2 ;picks up new dimensions from code via (r1) ;may use r0,r3,r4 getdim: mov r2,-(sp) ;save r2 mov #-1,ss2sav(r5) ;default second dimension jsr pc,eval ;get first dimension jsr pc,int ;need an int tst fac1(r5) ;check high order bne suberr ;too large mov fac2(r5),ss1sav(r5) ;save first dimension bmi suberr ;must be positive movb (r1)+,r3 ;get next token cmpb r3,#.rpar ;right paren? beq redimx ;yes, only one subscript cmpb r3,#.comma ;then must be comma next bne ejmp2 ;no, error jsr pc,eval ;get second dimension jsr pc,int ;convert to int tst fac1(r5) ;check high order bne suberr ;too large mov fac2(r5),ss2sav(r5) ;save second dimension bmi suberr ;should be positive cmpb (r1)+,#.rpar ;should have right paren next bne ejmp2 ;no, syntax redimx: mov (sp)+,r2 ;restore r2 and ;fall through to redim ;here to redimension an array ;symbol table pointer in r2 ;new dimensions in ss1sav(r5), ss2sav(r5) ;uses r3,r4 - preserves others redim: mov ss2sav(r5),r3 ;get new second dimension bpl redim2 ;if positive, then increment clr r3 ;otherwise 0 first redim2: inc r3 ;add 1 mov ss1sav(r5),r4 ;new first dimension inc r4 ;add 1 mul r4,r3 ;multiply mov r3,-(sp) ;save away needed space mov 6(r2),r3 ;get old second dimension bpl redim3 ;if positive, then increment clr r3 ;else 0 first redim3: inc r3 ;add 1 mov 4(r2),r4 ;old first dimension inc r4 ;add 1 mul r4,r3 ;multiply cmp (sp)+,r3 ;compare needed with actual bgt size3 ;not enough space! mov ss1sav(r5),4(r2) ;new first dimension mov ss2sav(r5),6(r2) ;new second dimension rts pc ;done suberr: jmp errsob ;subscript out of bounds size3: jmp sizerr ;here on mat a=b matlet: mov (sp)+,r3 ;second array mov (sp)+,r2 ;first array mov r1,-(sp) ;save r1 mov 4(r3),ss1sav(r5) ;new dimensions mov 6(r3),ss2sav(r5) mov r3,-(sp) ;save r3 over call to redim jsr pc,redim ;set up new dimensions mov (sp)+,r3 ;restore r3 mov 2(r3),r4 ;adr of second array mov 2(r2),r3 ;adr of first array mov ss1sav(r5),r0 ;first subscript mov ss2sav(r5),r2 ;second subscript letlp: mov r0,r1 ;ss1 inc r1 ;ss1+1 tst r2 ;test ss2 bmi letlp2 ;only one subscript mov r1,-(sp) ;save r1 mov ss1sav(r5),r1 ;ss1max inc r1 ;ss1max+1 mul r2,r1 ;ss2*(ss1max+1) add (sp)+,r1 ;ss2*(ss1max+1)+ss1+1 letlp2: asl r1 ;multiply by 4 asl r1 mov r0,-(sp) ;save a reg mov r1,r0 ;copy index add r3,r0 ;get adr of element add r4,r1 ;get adr of element mov (r1)+,(r0)+ ;copy first half of element mov (r1),(r0) ;copy second half of element mov (sp)+,r0 ;restore reg dec r0 ;decrement ss1 bgt letlp ;more - go back mov ss1sav(r5),r0 ;else restore dec r2 ;decrement ss2 bgt letlp ;more - go back mov (sp)+,r1 ;restore code pointer goback: jmp execute ;done ejmp2: jmp errsyn ;here on mat print matprt: mov #clmntty,column(r5) ;set up column count add r5,column(r5) clrb odev(r5) ;dev = tty prinxt: movb (r1)+,r2 ;get next byte bpl doprt ;symbol cmpb r2,#.eol ;end of line? bne ejmp2 ;no, error br goback ;done doprt: jsr pc,finsym ;finish symbol + stack movb (r1)+,r2 ;get next byte bpl ejmp2 ;better be token cmpb r2,#.eol ;end of line? beq doprt8 ;back up r1 cmpb r2,#.comma ;comma? beq doprt2 ;ok, go on cmpb r2,#.semi ;semicolon? ejmp7: bne ejmp2 ;none of the above, error (stt 11/5/75 -- ejmp7) doprt2: mov (sp)+,r4 ;symbol table ref to array mov r1,-(sp) ;save r1 mov r2,-(sp) ;save token mov #1,r2 ;first subscript mov r2,r3 ;second subscript tst 4(r4) ;kludge for (0,n) matrices bgt 1$ clr r2 ;(stt/fh 11/5/75) 1$: doprlp: mov r2,r1 ;ss1 inc r1 ;ss1+1 tst 6(r4) ;test ss2max ble doprt3 ;only one subscript mov r1,-(sp) ;save r1 mov 4(r4),r1 ;ss1max inc r1 ;ss1max+1 mul r3,r1 ;ss2*(ss1max+1) add (sp)+,r1 ;ss2*(ss1max+1)+ss1+1 doprt3: asl r1 ;multiply by 4 asl r1 add 2(r4),r1 ;add adr of array mov (r1)+,fac1(r5) ;get element in fac mov (r1),fac2(r5) cmpb @column(r5),#70 ;too far over on line? blos doprt4 ;no jsr pc,princr ;yes doprt4: jsr pc,numsgn ;output number .word putchar doprt5: jsr r1,msgodev ;followed by a space .byte bl,0 cmpb (sp),#.semi ;check for semicolon beq doprt6 ;got one clr r0 ;get column number bisb @column(r5),r0 cmp r0,#70 ;if not at next column bge doprt6 ;* cmp r0,#52 ;* beq doprt6 ;* cmp r0,#34 ;* beq doprt6 ;* cmp r0,#16 ;* bne doprt5 ;space over one more doprt6: inc r3 ;increment ss2 cmp r3,6(r4) ;compare ss2 and ss2max ble doprlp ;ok, do next element jsr pc,princr ;end of row, start new line mov #1,r3 ;start next row at beginning inc r2 ;next row cmp r2,4(r4) ;compare ss1 and ss1max ble doprlp ;ok, continue tst (sp)+ ;remove token from stack mov (sp)+,r1 ;restore r1 br prinxt ;do next array doprt8: dec r1 ;back up pointer to .eol br doprt2 ;and return in line size2: jmp sizerr ;here on mat input matipt: cmp r1,code(r5) ;see if this stmt is from a prog bhi iptok ;yes, ok ertext iln, iptok: clrb idev(r5) ;input device is tty movb (r1)+,r2 ;get next byte bmi ejmp2 ;can't be token jsr pc,finsym ;finish + stack symbol cmpb (r1)+,#.eol ;should be end of line bne ejmp7 ;nope, error (stt 11/5/75 -- ejmp2->ejmp7) mov (sp)+,r4 ;symbol reference mov r1,-(sp) ;save r1 mov 4(r4),r0 ;get ss1max inc r0 ;ss1max+1 mov 6(r4),r1 ;get ss2max bmi inpgo ;already a vector inc r1 ;ss2max+1 mul r0,r1 ;(ss1max+1)*(ss2max+1) dec r1 ;get new ss1max mov r1,4(r4) ;set up vector mov #-1,6(r4) ;no second dimension inpgo: clr r1 ;count of elements input inpagn: jsr r1,msg ;output prompt symbol .ascii '?' .byte 0 jsr pc,linget ;get a line of data bcc inp2 ;no error, go on jmp errdata ;bad inp2: mov line(r5),r0 ;beginning of line cmpb (r0),#cr ;end of input? beq indone ;yes inplp: jsr pc,sval ;get numeric value from r0 inc r1 ;increase count cmp r1,4(r4) ;check size of vector bgt size2 ;not enough room mov r1,r2 ;copy index inc r2 ;add 1 asl r2 ;multiply by 4 asl r2 add 2(r4),r2 ;add adr of array mov fac1(r5),(r2)+ ;copy element mov fac2(r5),(r2) cmpb (r0),#cr ;end of line? beq indone ;yes cmpb (r0),#'& ;continued? beq inpagn ;yes cmpb (r0)+,#', ;comma? beq inplp ;yes, get another number inpbad: jsr r1,msgerr ;bad syntax .ascii 'bad data - retype from error' .byte cr,lf,0 .even br inpagn ;try again indone: mov r1,-(sp) ;stack count jsr r4,fppsav ;float it .word $ir .word fppres mov (sp)+,numsav ;first word of count mov (sp)+,numsav+2 ;second word of count mov (sp)+,r1 ;restore r1 jmp execute ;done ;here on mat read matrd: movb (r1)+,r2 ;get next byte bpl doread ;symbol cmpb r2,#.eol ;end of line? bne syner4 ;no, syntax error jmp execute ;yes, done doread: jsr pc,finsym ;finish symbol and stack mov (sp)+,r2 ;symbol ref in r2 movb (r1)+,r0 ;get next byte cmpb r0,#.lpar ;left paren? bne dord2 ;no jsr pc,getdim ;get new dimensions and fix array movb (r1)+,r0 ;get next byte dord2: cmpb r0,#.comma ;comma? beq dord3 ;yes, ok cmpb r0,#.eol ;end of line? bne syner4 ;no, error dec r1 ;yes, reset r1 to point to it dord3: mov r1,-(sp) ;save r1 for later mov #1,ss1 ;init subscripts mov #1,ss2 mov 2(r2),mtres ;adr of result array mov 4(r2),ss1sav(r5) ;save max subscripts mov 6(r2),ss2sav(r5) mov @arrays(r5),r3 ;get pointer to data stmts beq rdout ;out of data cmp r3,#-1 ;-1 means haven't looked yet bne dordlp ;else ready to go findat: mov code(r5),r3 ;get start of code nxtdat: tstb (r3) ;line # first? bmi nxdat2 ;no add #2,r3 ;yes, skip over nxdat2: cmpb (r3)+,#.data ;found data stmt? beq gotdat ;yes cmpb -(r3),#.eof ;no, hit eof? beq rdout ;yes mov r3,r1 ;for skipeol jsr pc,skipeol ;to next .eol mov r1,r3 ;back in r3 br nxtdat ;try again dordlp: cmpb (r3),#.eol ;end of line? beq nxtdat ;yes, get next stmt cmpb (r3)+,#.comma ;must see comma first bne rdbad ;no, error gotdat: jsr pc,liteval ;get next datum br rdbad ;bad datum cmpb (r3),#.eol ;check delimiter beq dord4 ;ok cmpb (r3),#.comma ;or comma bne rdbad ;anything else, no good dord4: mov ss1,r2 ;get ss1 inc r2 ;ss1+1 tst ss2sav(r5) ;check second subscript bmi dord5 ;only one mov ss1sav(r5),r1 ;ss1max inc r1 ;ss1max+1 mul ss2,r1 ;ss2*(ss1max+1) add r1,r2 ;ss2*(ss1max+1)+ss1+1 dord5: asl r2 ;mul by 4 asl r2 add mtres,r2 ;adr of element mov fac1(r5),(r2)+ ;move element from fac to array mov fac2(r5),(r2) inc ss2 ;increment second subscript cmp ss2,ss2sav(r5) ;compare with max ble dordlp ;ok, go back for next mov #1,ss2 ;start next row at beg inc ss1 ;next row cmp ss1,ss1sav(r5) ;compare with max ble dordlp ;ok, go back mov r3,@arrays(r5) ;done, replace data pointer mov (sp)+,r1 ;restore r1 br matrd ;and look for more symbols syner4: jmp errsyn rdout: jmp readout rdbad: jmp readbad ;here on mat c=(exp)*a ;[scalar multiply] matscl: jsr pc,eval ;get scalar in fac bcs ejmp3 ;string = syntax error jsr r4,fppsav ;enter polish floating mode .word pushf ;stack fac, convert to floating .word pop ;result back to fac .word fppres ;done cmpb (r1)+,#.rpar ;better be right paren next bne ejmp3 ;no, error cmpb (r1)+,#.star ;then a star (*) bne ejmp3 ;no, error movb (r1)+,r2 ;get next byte bmi ejmp3 ;should not be a token jsr pc,finsym ;finish and stack array ref cmpb (r1)+,#.eol ;end of line? bne ejmp3 ;no, error mov (sp)+,r3 ;second array mov (sp)+,r2 ;first array (result) mov r1,-(sp) ;save r1 mov 4(r3),ss1sav(r5) ;new dimensions mov 6(r3),ss2sav(r5) ; mov r3,-(sp) ;save r3 jsr pc,redim ;set up new dimensions mov (sp)+,r3 ;restore r3 mov 2(r3),r4 ;adr of second array mov 2(r2),r3 ;adr of first array mov ss1sav(r5),r0 ;first subscript mov ss2sav(r5),r2 ;second subscript scalp: mov r0,r1 ;ss1 inc r1 ;ss1+1 tst r2 ;test ss2 bmi scalp2 ;only one subscript mov r1,-(sp) ;save r1 mov ss1sav(r5),r1 ;ss1max inc r1 ;ss1max+1 mul r2,r1 ;ss2*(ss1max+1) add (sp)+,r1 ;ss2*(ss1max+1)+ss1+1 scalp2: asl r1 ;multiply by 4 asl r1 mov r0,-(sp) ;save a register mov r1,r0 ;copy index add r3,r0 ;adr of result add r4,r1 ;adr of multiplicand tst (r1)+ ;point to second word mov (r1),-(sp) ;stack second word of element mov -(r1),-(sp) ;stack first word jsr r4,fppsav ;enter polish mode .word tststk ;make sure element is floated .word push ;now push fac on stack .word $mlr ;multiply .word fppres mov (sp)+,(r0)+ ;first word of result mov (sp)+,(r0) ;second word of result mov (sp)+,r0 ;restore register dec r0 ;decrement ss1 bgt scalp ;more, go back mov ss1sav(r5),r0 ;else restore ss1 dec r2 ;decrement ss2 bgt scalp ;more, go back mov (sp)+,r1 ;restore code pointer jmp execute ;done ejmp3: jmp errsyn ;relay ;here on mat c=trn(a) ;transpose mattrn: movb (r1)+,r2 ;get next byte bmi syner3 ;token - error jsr pc,finsym ;finish symbol & stack cmpb (r1)+,#.rpar ;need ) next bne syner3 ;no, error cmpb (r1)+,#.eol ;then end of line bne syner3 ;no, error mov (sp)+,r3 ;arg mov 2(r3),mtarg1 ;adr of arg array mov (sp)+,r2 ;result array mov 2(r2),mtres ;adr of result mov r1,-(sp) ;save r1 cmp r2,r3 ;result & arg can't be same array beq duper2 ;they are! error mov 4(r3),ss2sav(r5) ;first subscript becomes second mov 6(r3),r0 ;get second subscript bpl 1$ ;positive? clr r0 ;no, use 0 1$: mov r0,ss1sav(r5) ;second subscript becomes first jsr pc,redim ;redimension result mov ss1sav(r5),ss1 ;init for loop mov ss2sav(r5),ss2 trnlp: mov ss1sav(r5),r1 ;get result adr inc r1 mul ss2,r1 add ss1,r1 inc r1 asl r1 asl r1 add mtres,r1 ;result adr in r1 mov ss2sav(r5),r3 ;get arg adr inc r3 mul ss1,r3 add ss2,r3 inc r3 asl r3 asl r3 add mtarg1,r3 ;arg adr in r3 mov (r3)+,(r1)+ ;copy element mov (r3),(r1) dec ss1 ;decrement index bgt trnlp ;more, go back mov ss1sav(r5),ss1 ;else restore dec ss2 ;decrement other index bgt trnlp ;more, go back mov (sp)+,r1 ;restore saved r1 jmp execute ;done syner3: jmp errsyn duper2: jmp duperr ;error messages for mat inverse syner5: jmp errsyn ersqr: ertext ans, erspac: jmp erraray ersing: clr detsav clr detsav+2 jsr r1,msg .ascii /attempt to invert singular matrix/ .byte cr,lf,0 .even mov (sp)+,r1 ;restore saved r1 jmp execute ;done ;******* here on mat c=inv(a) ******* ;inverse matinv: movb (r1)+,r2 ;get next byte bmi syner5 ;token - error jsr pc,finsym ;finish symbol ref & stack cmpb (r1)+,#.rpar ;then must have ) bne syner5 ;no, error cmpb (r1)+,#.eol ;and end of line bne syner5 ;no, error mov (sp)+,r2 ;get ref to array mov (sp)+,r3 ;ref to result array mov r1,-(sp) ;save r1 mov 4(r2),r0 ;get first dimension cmp r0,6(r2) ;compare to second dimension bne ersqr ;must be square matrix mov r0,mtsiz ;save size mov 2(r2),mtarg1 ;save adr of array mov r0,ss1sav(r5) ;redimension result array mov r0,ss2sav(r5) mov r3,r2 mov 2(r3),mtres ;result array jsr pc,redim ;do the redimensioning jsr pc,dnpack ;move down strings mov hifree(r5),r2 ;highest free adr asl r0 ;compute # of words needed sub r0,r2 ;subtract needed room cmp r2,histr(r5) ;compare to lower bound blo erspac ;not enough room tst (r2)+ ;ok, fix r2 mov r2,mtpiv ;gives adr of pivot region mov r0,r1 ;compute n^2 mul r0,r1 ;(space needed for lu matrix) tst -(r2) ;fix r2 back sub r1,r2 ;subtract needed room cmp r2,histr(r5) ;check lower bound blo erspac ;not enough room tst (r2)+ ;fix r2 mov r2,mtlu ;adr of lu storage ;***** lu decomposition with partial pivoting ***** ;initialization - ;sets piv(i)=i i=1,...,n ;sets lu(i,j)=a(i,j) i,j=1,...,n mov #1,r2 ;init subscript mov mtsiz,r4 ;limit goes in r4 dcmp1: mov r2,-(sp) ;stack subscript jsr pc,getpiv ;get adr of pivot array mov r2,(r1) ;init pivot pointer mov #1,r3 ;init other subscript dcmp2: mov r2,-(sp) ;stack subscripts mov r3,-(sp) jsr pc,geta ;get adr of element of a mov r1,r0 ;save in r0 mov r2,-(sp) ;stack subscripts mov r3,-(sp) jsr pc,getlu ;get adr of element of lu mov (r0)+,(r1)+ ;copy both words of element mov (r0),(r1) inc r3 ;increment cmp r3,r4 ;test ble dcmp2 ;repeat inner loop inc r2 ;increment cmp r2,r4 ;test ble dcmp1 ;repeat outer loop ;main loop - gaussian elimination clr mtsw ;clear count of row switches mov mtsiz,r0 ;mtlim = mtsiz-1 dec r0 mov r0,mtlim mov #1,ss3 ;init loop on ss3 dcmp3: clr mtbig ;big = 0.0 clr mtbig+2 mov ss3,ss1 ;init loop on ss1 dcmp4: mov ss1,-(sp) ;stack subscript jsr pc,getpiv mov (r1),-(sp) ;stack piv(ss1) mov ss3,-(sp) ;stack ss3 jsr pc,getlu ;get lu(piv(ss1),ss3) mov (r1)+,fac1(r5) ;put in fac mov (r1),fac2(r5) tst fac1(r5) ;take absolute value beq 1$ ;int bpl 2$ ;floating bic #100000,fac1(r5) br 2$ 1$: tst fac2(r5) ;int bpl 2$ neg fac2(r5) bvc 2$ mov #44000,fac1(r5) ;overflow clr fac2(r5) 2$: mov fac1(r5),-(sp) ;save magnitude mov fac2(r5),-(sp) mov mtbig+2,-(sp) ;stack big mov mtbig,-(sp) jsr pc,substk ;fac = mag-big dcmp5: tst fac1(r5) ;test sign of fac beq 2$ ;int bpl 3$ ;positive 1$: cmp (sp)+,(sp)+ ;negative, pop mag off stack br 4$ ;done 2$: tst fac2(r5) ;check int beq 1$ ;if diff is 0, no swap needed bmi 1$ 3$: mov (sp)+,mtbig+2 ;positive big=mag mov (sp)+,mtbig mov ss1,mtip ;save pivot pointer 4$: inc ss1 ;increment cmp ss1,mtsiz ;test ble dcmp4 ;repeat mov mtbig,r0 ;get big bis mtbig+2,r0 ;and big2 bne 5$ ;if not 0, then ok jmp ersing ;0 means singular 5$: cmp mtip,ss3 ;compare pivot row to current beq dcmp6 ;same! mov ss3,-(sp) ;stack subscript jsr pc,getpiv ;get piv(k) mov r1,r2 ;save adr mov (r2),-(sp) ;save value also mov mtip,-(sp) ;stack mtip jsr pc,getpiv ;get piv(mtip) mov (r1),(r2) ;piv(k)=piv(mtip) mov (sp)+,(r1) ;piv(mtip)=piv(k) inc mtsw ;count row switch dcmp6: mov ss3,-(sp) ;stack k jsr pc,getpiv ;get piv(k) mov (r1),mtip ;mtip=piv(k) mov ss3,r0 ;init loop on ss1 inc r0 mov r0,ss1 mov mtip,-(sp) ;stack mtip mov ss3,-(sp) ;stack k jsr pc,getlu ;lu(mtip,k) mov (r1)+,mtbig ;save pivot mov (r1),mtbig+2 dcmp7: mov ss1,-(sp) ;stack i jsr pc,getpiv ;piv(i) mov (r1),r4 ;save row mov r4,-(sp) ;stack row mov ss3,-(sp) ;stack k jsr pc,getlu ;lu(row,k) tst (r1)+ ;point to second word mov (r1),-(sp) ;stack numerator mov -(r1),-(sp) mov mtbig,fac1(r5) ;get pivot mov mtbig+2,fac2(r5) jsr r4,fppsav ;divide .word tststk .word pushf .word $dvr .word pop .word fppres mov r1,r0 ;save adr of mult in r0 mov fac1(r5),(r1)+ ;assign to lu(row,k) mov fac2(r5),(r1) mov ss3,r3 ;init loop on ss1 inc r3 mov r3,ss2 dcmp8: mov r0,r2 ;put mult in fac mov (r2)+,fac1(r5) mov (r2),fac2(r5) mov mtip,-(sp) ;stack mtip mov ss2,-(sp) ;stack j jsr pc,getlu ;lu(mtip,j) tst (r1)+ mov (r1),-(sp) ;stack it mov -(r1),-(sp) jsr r4,fppsav ;multiply .word tststk .word pushf .word $mlr .word fppres mov r4,-(sp) ;get lu(row,j) mov ss2,-(sp) jsr pc,getlu mov (r1)+,fac1(r5) ;put in fac mov (r1),fac2(r5) jsr pc,substk ;and subtract mov fac2(r5),(r1) ;result stored in lu(row,j) mov fac1(r5),-(r1) inc ss2 ;increment cmp ss2,mtsiz ;test ble dcmp8 ;repeat inc ss1 ;increment cmp ss1,mtsiz ;test ble dcmp7 ;repeat inc ss3 ;increment cmp ss3,mtlim ;test bgt 5$ ;exit loop jmp dcmp3 ;repeat big loop!! 5$: mov mtsiz,-(sp) ;stack n jsr pc,getpiv ;piv(n) mov (r1),-(sp) ;stack it mov mtsiz,-(sp) ;stack n jsr pc,getlu ;lu(piv(n),n) mov (r1)+,r0 ;get both words bis (r1),r0 ; anded together bne dcmp8a ;if not 0, then ok jmp ersing ;0 means singular ;solve lu decomposition with identity matrix ;to get inverse of original matrix dcmp8a: mov #1,ss3 ;init outer loop ;forward substitution dcmp9: mov #1,-(sp) ;stack 1 jsr pc,getpiv ;piv(1) clr -(sp) ;move a 0 onto stack clr -(sp) cmp (r1),ss3 ;row same as column bne dcmp10 ;no, identity matrix has a 0 mov #40200,(sp) ;yes, identity matrix has a 1 dcmp10: mov #1,-(sp) ;stack 1 mov ss3,-(sp) ;stack column jsr pc,getb ;b(1,column) mov (sp)+,(r1)+ ;copy in the 0 or 1 mov (sp)+,(r1) cmp mtsiz,#1 ;is size of array = 1? beq dcmp9a ;yes, skip rest of this section mov #2,ss1 ;init loop on ss1 dcmp11: mov ss1,-(sp) ;stack i jsr pc,getpiv ;piv(i) mov (r1),mtip ;save row clr -(sp) ;move a 0 to stack clr -(sp) mov #1,ss2 ;init a loop on ss2 dcmp12: mov mtip,-(sp) ;stack mtip mov ss2,-(sp) ;stack j jsr pc,getlu ;lu(mtip,j) mov (r1)+,fac1(r5) ;save in fac mov (r1),fac2(r5) mov ss2,-(sp) ;stack j mov ss3,-(sp) ;stack k jsr pc,getb ;b(j,k) tst (r1)+ ;fix mov (r1),-(sp) ;save on stack mov -(r1),-(sp) jsr r4,fppsav ;mult and add to sum .word tststk .word pushf .word $mlr .word $adr .word fppres inc ss2 mov ss1,r0 dec r0 cmp ss2,r0 ;j=i-1? ble dcmp12 ;loop clr fac1(r5) ;get a 0 clr fac2(r5) cmp mtip,ss3 ;compare row and column bne dcmp13 ;not equal, use 0 mov #40200,fac1(r5) ;same, use 1 dcmp13: jsr pc,substk ;subtract mov ss1,-(sp) mov ss3,-(sp) jsr pc,getb ;b(i,k) mov fac1(r5),(r1)+ ;save result of computation mov fac2(r5),(r1) inc ss1 ;increment cmp ss1,mtsiz ;test ble dcmp11 ;repeat ;back substitution dcmp9a: mov mtsiz,-(sp) mov ss3,-(sp) jsr pc,getb ;get b(n,k) mov r1,r3 ;save loc in r3 tst (r1)+ ;fix mov (r1),-(sp) ;save value on stack mov -(r1),-(sp) mov mtsiz,-(sp) jsr pc,getpiv ;piv(n) mov (r1),-(sp) ;stack it mov mtsiz,-(sp) jsr pc,getlu ;lu(piv(n),n) mov (r1)+,fac1(r5) ;save in fac mov (r1),fac2(r5) jsr r4,fppsav ;divide - result on stack .word tststk .word pushf .word $dvr .word fppres mov (sp)+,(r3)+ ;result goes in b(n,k) mov (sp)+,(r3) mov mtsiz,r0 ;get mtsiz cmp r0,#1 ;is size of array = 1? beq dcmp19 ;yes, skip rest of this section dec r0 ;get mtsiz-1 mov r0,ss1 ;init a loop on ss1 dcmp14: mov ss1,-(sp) ;mtip=piv(i) jsr pc,getpiv mov (r1),mtip clr -(sp) ;put a 0 on stack clr -(sp) mov ss1,ss2 ;j=i+1 inc ss2 ;init a loop on j dcmp15: mov mtip,-(sp) mov ss2,-(sp) jsr pc,getlu ;lu(mtip,j) mov (r1)+,fac1(r5) ;put in fac mov (r1),fac2(r5) mov ss2,-(sp) mov ss3,-(sp) jsr pc,getb ;b(j,k) tst (r1)+ ;fix mov (r1),-(sp) ;put on stack mov -(r1),-(sp) jsr r4,fppsav ;mult, add - result on stack .word tststk .word pushf .word $mlr .word $adr .word fppres inc ss2 ;increment cmp ss2,mtsiz ;test ble dcmp15 ;repeat mov ss1,-(sp) mov ss3,-(sp) jsr pc,getb ;b(i,k) mov r1,r0 ;save loc mov (r1)+,fac1(r5) ;value in fac mov (r1),fac2(r5) jsr pc,substk ;subtract accumulated sum mov fac2(r5),-(sp) ;result stacked mov fac1(r5),-(sp) mov mtip,-(sp) mov ss1,-(sp) jsr pc,getlu ;lu(mtip.i) mov (r1)+,fac1(r5) mov (r1),fac2(r5) jsr r4,fppsav ;divide .word tststk .word pushf .word $dvr .word fppres mov (sp)+,(r0)+ ;result in b(i,k) mov (sp)+,(r0) dec ss1 ;decrement index bgt dcmp14 ;test and repeat inc ss3 ;outer loop - increment k cmp ss3,mtsiz ;done? bgt dcmp19 ;end of loop jmp dcmp9 ;no, repeat whole mess ;compute determinant and save for the det fn dcmp19: clr -(sp) ;put a 1 on the stack mov #40200,-(sp) mov #1,r0 ;index dcmp20: mov r0,-(sp) mov r0,-(sp) jsr pc,getlu ;lu(r0,r0) mov (r1)+,fac1(r5) ;save in fac mov (r1),fac2(r5) jsr r4,fppsav ;multiply diagonal element .word tststk .word pushf .word $mlr .word fppres inc r0 ;go back for next cmp r0,mtsiz ble dcmp20 mov (sp)+,detsav ;save result for det fn mov (sp)+,detsav+2 bit #1,mtsw ;check # of row switches beq dcmp21 ;even, we are done add #100000,detsav ;odd, change sign of det dcmp21: mov (sp)+,r1 ;restore saved r1 jmp execute ;done ;subroutines to fetch adr of array elements into r1 ;stack first (and second) subscripts, then jsr pc getpiv: mov 2(sp),r1 ;get subscript dec r1 ;subtract one asl r1 ;mul by 2 add mtpiv,r1 ;add adr of vector mov (sp),2(sp) tst (sp)+ rts pc getlu: mov 2(sp),r1 ;second subscript dec r1 ;subtract one mul mtsiz,r1 ;mtsiz*(b-1) add 4(sp),r1 ;mtsiz*(b-1)+a dec r1 ;mtsiz*(b-1)+a-1 asl r1 ;mul by 4 asl r1 add mtlu,r1 ;add adr of array getxit: mov (sp),4(sp) cmp (sp)+,(sp)+ rts pc geta: mov mtsiz,r1 ;get size inc r1 ;mtsiz+1 mul 2(sp),r1 ;b*(mtsiz+1) add 4(sp),r1 ;b*(mtsiz+1)+a inc r1 ;b*(mtsiz+1)+a+1 asl r1 ;mul by 4 asl r1 add mtarg1,r1 ;add adr of array br getxit getb: mov mtsiz,r1 ;same as geta, except for result array inc r1 mul 2(sp),r1 add 4(sp),r1 inc r1 asl r1 asl r1 add mtres,r1 br getxit ;******************** .end +a dec r1 ;mtsiz*(b-1)+a-1 asl r1 ;mul by 4 asl r1 add mtlu,r1 ;add adr of array getxit: mov (sp),4(sp) cmp (sp)+,(sp)+ rts pc geta: mov mtsiz,r1 ;get size inc r1 ;mtsiz+1 mul 2(sp),r1 ;b*(mtsiz+1) add 4(sp),r1 ;b*(mtsiz+1)+a inc r1 ;b*(mtsiz+1)+a+1 asl r1 ;mul by 4 asl r1 add mtarg1,r1 ;add adr of array br getxit getb: mov mtsiz,r1 ;same as geta, ;----------------------------------------------------------------------- ;basp1 for unix basic .title basp1.mac hvunix=1 $deflo= ^d8 protec= ^o644 $ext=1 $mortok=1 $matrix=1 $reseq=1 $ulnsp=^d140 $disk=1 $namset=1 $longer=1 $sysfn=1 $pnamsz=^d30 $maxun=5 $bufsz=^d128 $nopow=1 $nolpt=1 $noptp=1 $files=1 input$=040000 outpt$=020000 fdbse$=004000 fdbie$=002000 fdbda$=000400 fdb1t$=001000 fdbra$=100000 fdbdb$=010000 fdbio$=000001 fdbwl$=001000 .globl ddtgo, sysxit .globl savreg, topcore, ttyiof, break, ua, resig, usig .globl rndlfn,rndfn,absfn,sgnfn,binfn,octfn,tabfn,lenfn .globl ascfn,chr$fn,posfn,segfn,valfn,trmfn,strfn .globl shell,sysfn,sfrset,$fperr,ttymd,ttymd3,oldmod .globl delet, reseq, edipass, locget, extend, ovltst, opnsys, closys .ifndf $novf .globl wbl,wfblk1,rnb,vffndl,errfpv .endc .ifdf $matrix .globl matbeg, numfn, detfn .globl mtarg1, mtarg2, mtres, ss1, ss2, ss3, ss3sav .globl erraray, readout, readbad .globl mtlim, mtbig, mtip, mtsw, mtsiz .globl mtpiv, mtlu, addstk, substk .endc $vfoff=$maxun+1 .macro trap n ;unix uses traps so bombs must be emts emt n ;look out dec!!!!!!!!! .endm .mcall $sig,$read,$write,$exit,$time,$open,$close .mcall $stat,$creat,$indir,$fork,$exec,$wait .mcall $gtty,$stty,$seek,$break,$unlink ; macros - dummy pseudo-ops .macro .hiseg .psect hiseg con,shr .endm .macro .loseg .psect loseg con .endm .macro .bsect .psect blank con,bss .endm .macro .resw n .if b .blkw .iff .blkw n .endc .endm .macro .resb n .if b .blkb .iff .blkb n .endc .endm ;macros for readability .macro ertext a,b trap 0 .ifndf $longer .asciz "a" .iff .asciz "b" .endc .even .endm .macro push a mov a,-(sp) .endm .macro pop a mov (sp)+,a .endm .macro call s jsr pc,s .endm .macro ret rts pc .endm .macro lower ?a cmpb (r4),#^o101 blt a cmpb (r4),#^o132 bgt a bisb #^o40,(r4) a: inc r4 .endm ss .endm .macro .resw n .if b .blkw .iff .blkw n .endc .endm .macro .resb n .title basp2 v02-01 parameters ;basic kernel v02-01 ; ;the information in this document is subject to change ;without notice and should not be construed as a ;commitment by digital equipment corporation. digital ;equipment corporation assumes no responsibility for any ;errors that may appear in this document. ; ;the software described in this document is furnished ;to the purchaser under a license for use on a single ;computer system and can be copied (with inclusion of ;digital's copyright notice) only for use in such system, ;except as may otherwise be provided in writing by ;digital. ; ;digital equipment corporation assumes no responsibility ;for the use or reliability of its software on equipment ;that is not supplied by digital. ; ;copyright (c) 1974 ;by digital equipment corporation ;146 main street ;maynard, massachusetts 01754 ; ; basic consists of the following modules: ; 1] basp1 - system dependent parameter file ; 2] basp2 - system independent parameter file ; 3] vecdef - floating vectors definition file ; 4] basicr - root section ; 5] fpmp; 5] fortran ots math routines ; 6] basice - editor ; 7] basicx - execution time code for interpreter ; 8] basics - system dependent module ; 9] basint - interface to user-written assembly language ; functions and background routine ; 10] ftbl - table of assembly language routine names. ; 11] basich - optional functions, user area, and ; once-only code. basich consists of ; bash1,bash2, and bash3 where bash2 is ; system-dependent once-only code. ; ; original paper tape version by: len elekman ; ; completion by: ann stankard ; ; rt-11 version by: ann stankard ; ; caps-11 version by: bill clogher ;************************************************** ;************************************************** ;************ ************ ;************ globals; assy. params,; ************ ;************ description; low core; ************ ;************ general tables, ************ ;************ constants, storage ************ ;************ ************ ;************************************************** ;************************************************** ; ; set default assembler switches ; .ifdf $disk $bfalc =1 .ifndf $novf $vf =1 ;set internal "virtual file" flag .endc ;$novf .endc ;$disk .ifndf $nochain $chain =1 .endc ;$nochain $sysfil=$maxun+1 ;setup sys sequential file # ; ; globals ; ; --fpmp; -- fortran ots math routines ; .globl $polsh .globl $ir .globl $mlr .globl $dvr .globl $adr,$sbr .globl sin,cos,sqrt,alog,alog10,atan,exp .globl ifpmp ; --basicr ; .globl alloc, baslow, bomb, bombdd, bombdo .globl chkchr, clear, divten, dnpack, errgo .globl errnob, errsyn, errtrn, execute, ex3 .globl fline, fndetxt, fndstl, freeget, go, gtftabi .globl ignore, int16, linget, liteval, mpyten .globl msg, msgerr, msgode, norm, numout .globl numsgn, ready, ready0, ready2 .globl savcha, savreg, scratc, skipeol .globl start, table5, tbl5rnd, tbl5en, usrare, val .globl reval .ifdf $multi .globl curusr, exct, lstusr, numstt, usrtbl .endc ;$multi .ifdf $vf .globl vfblk, vffn .endc ;$vf .ifdf $tty .globl savrgi .endc ;$tty .ifndf $nopru .globl asccon .endc ;$nopru ; ; --basice ; .globl clrvar, edit, initsc, stop .globl chkfil,chnscr,closys .ifndf $..$ .ifdf $bfalc .globl allbuf,bufget,combuf,comfil,chainb .endc ;$bfalc .endc ;$..$ .ifdf $..$ .ifdf $vf .globl e.iss .endc ;$vf .endc ;$..$ .ifdf $ovlay .globl exece .endc ;$ovlay .ifdf $disk .globl restj .endc ;$disk .globl revlret .ifndf $ovlay .globl chain, close, end, eof, open, overlay .ifdf $..$ .globl kill, nameas .endc ;$..$ .endc ;$ovlay ; ; --basicx ; .globl argb, assign, atnfn, calret, cosfn, errarg .globl errmix, errpdl, eval, expfn, fndstr, getvar, int, intfn .globl logfn, l10fn, makest, oprato, pifn, pop, push .globl push1, sinfn, soprat, sqrfn, stosva .globl stovar, stpro, sval .ifdf $ovlay .globl execx .endc ;$ovlay .ifndf $nostr .globl datfn .endc ;$nostr .ifndf $ovlay .globl call, callimp, for, gosub, goto, if .globl ifend, input, let, next, on, print, read .globl restor, return .endc ;$ovlay .ifndf $nopru .globl expf2 .endc ;$nopru .ifdf $vf .globl vfget,vffn,letvf .endc ;$vf .globl errdata, errsob, princr, tststk, pushf .globl fppsav, fppres ; ; --basics ; .globl bye,chkiset,chkoset,deverr,erchan,getchar,iready,istart .globl putchar,random,rctrlo,setcol,sreset,tape,key .globl block,closall,closch,datcom,datest .globl errfno,errwlo,filspec .globl headr,opnfil .ifdf $namset .globl namset,dfexos,dfexop .endc ;$namset .ifndf $..$ .ifdf $bfalc .globl errbuf .endc ;$bfalc .globl filea .ifdf $disk .globl seqfil,seqio .endc ;$disk .ifdf $vf .globl vffnd,vfblk .endc ;$vf .endc ;$..$ .ifdf $..$ .globl errfpv ;file protection violation. .ifdf $vf .globl vffnd,vfblk,wbl,vfblk1,rnb,vffndl .endc ;$vf .endc ;$..$ .ifdf $multi .globl asign, deass, nxtusr, rstart, settty .endc ;$multi .ifndf $..$ .ifndf $nopow .globl powdwn .endc ;$nopow .ifndf $noptp .globl ppint,ptrint .endc ;$noptp .ifndf $nolpt .globl lpint .endc ;$nolpt .endc ;$..$ .ifdf $matrix .globl numsav,detsav .endc .ifdf $mortok .globl progo, uprogo, ulkgo, newsgo .endc ; --basich .globl onceonl ; --interface module .globl ftabi,bkgi ; --vecdef .ifdf $multi .globl tks1, tks2, tks3, tks4 .globl tks5, tks6, tks7, tks8 .globl kbi1, kbi2, kbi3, kbi4 .globl kbi5, kbi6, kbi7, kbi8 .globl tkf1, tkf2, tkf3, tkf4 .globl tkf5, tkf6, tkf7, tkf8 .endc ;$multi ; ; assembly params. ; .ifndf $stksz $stksz =200 ;size of stack, in bytes .endc ;$stksz ; .ifndf $stkex $stkex =50 ;extra bytes on stack .endc ;$stkex ; .ifndf $ppbsz $ppbsz =30 ;pp buff. size .endc ;$ppbsz ; .ifndf $prbsz $prbsz =30 ;paper-tape reader buff. size .endc ;$prbsz ; .ifndf $lpbsz $lpbsz =40 ;line-printer buff. size .endc ;$lpbsz ; .ifndf $tpbsz $tpbsz =20 ;teleprinter buffer size .endc ;$tpbsz ; .ifndf $kbbsz $kbbsz =20 ;keyboard buff. size .endc ;$kbbsz ; .ifndf $ulnsp $ulnsp =120 ;user line space .endc ;$ulnsp ; .ifndf $minusr $minusr =500. ;minimum # words in user area .endc ;$minusr .ifndf $exno $exno =10. ;# lines to execute per user .endc ;$exno ; ; ; $longer - long error messages: define to get long, ; explanatory error messages. ; ; $nostr - no strings: define to eliminate string variable code ; ; $nopow - no power fail: define to assemble without ; power fail/restart routine. ; ; $novf - no virtual files option: define to assemble ; version without virtual files. ; ; $nopru - no print using: define to assemble without ; code to handle print using statement ; ; general assignments ; ; --register assignments ; r0 =%0 r1 =%1 r2 =%2 r3 =%3 r4 =%4 r5 =%5 sp =%6 pc =%7 ; ; --general constants ; tab =11 lf= 012 ff =14 cr= 015 bl= 040 ctrlc =3 ctrlo =17 xon= 21 ;ctrl/q xoff= 23 ;ctrl/s ctrlu= 25 ctrlz= 32 rubout= 177 ps =177776 pr3 =140 ;priority level 3 pr4 =200 pr5 =240 pr6 =300 pr7 =340 ; ; --bit definitions ; input$ =40000 outpt$ =20000 .scalar =177775 ;user sym. table flag for scalar .nvar =177776 ;flag for numeric array variable .svar =177777 ;flag for string var. ; ; --user area storage cell offsets ; symbols = 0 ;contains addr of the first symbol limit = symbols+2 ;contains addr of highest wd of user area pdl = limit+2 ;contains addr of empty stack pdsize = pdl+2 ;contains low limit of stack arrays = pdsize+2 ;contains addr of highest word of arrays hifree = arrays+2 ;contains addr of highest free word lofree = hifree+2 ;contains addr of lowest free word code = lofree+2 ;contains addr of interpretive code line = code+2 ;contains addr of user line buffer varsav = line+2 ;var save for assignment ss1save = varsav+2 ;ss1 save for assignment ss2save = ss1save+2 ;ss2 save for assignment lineno = ss2save+2 ;contains the line number gsbctr = lineno+2 ;contains 33+depth of active gosubs column = gsbctr+2 ;has addr of col ct for current dev clmntty = column+2 ;last tty column typed fac1 = clmntty+2 ;high order floating value fac2 = fac1+2 ;low order floating value r0save = fac2+2 ;place for r0 while in fpmp11 r1save = r0save+2 ;ditto r1 r2save = r1save+2 ;ditto r2 r3save = r2save+2 ;ditto r3 r4save = r3save+2 ;ditto r4 t1 = r4save+2 ;short term temporary t2 = t1+2 ;ditto t3 = t2+2 ;ditto rnd1 = t3+2 ;history of rnd rnd2 = rnd1+2 ;ditto rndct = rnd2+2 ;randomizer lostr = rndct+2 ;lo string address histr = lostr+2 ;hi string address comlof = histr+2 ;1 entry above highest common symbol - (r5) comhif = comlof+2 ;hifree for common ; --these next two must be lo byte and hi byte, respectively, ; of same word odev = comhif+2 ;output dev code (tty=0,pt=2,lp=4) idev = odev+1 ;input dev code (tty=0,pr=2) $lu = idev+1 ;length of user area (same for all systems) .ifdf $bfalc bufchn = $lu ;buffer chain address .ifdf $..$ bfchbp=bufchn+2 ;buffer deque list head backward pointer bfchsz =bfchbp+2 ;null word to indicate a list head $lu = bfchsz+2 .endc ;$..$ .ifndf $..$ $lu = bufchn+2 ;line number for edit search .endc ;$..$ .endc ;$bfalc .ifdf $chain editln = $lu chnflg = editln+2 ;flag for 'chain' statement $lu = chnflg+2 .endc ;$chain .ifdf $files prognm = $lu ;saved program name $lu = prognm+$pnamsz ;start of byte fields in user area .endc ;$files .ifdf $miscsp ;additional space $misc=$lu ;its purpose is described in basp1 $lu=<<$misc+$miscsp+1>/2>*2 .endc ;$miscsp .ifdf $tty tphd = $lu ;holds start of teleprt buff hdr kbhd = tphd+2 ;holds start of kbd buff hdr echosp = kbhd+2 ;addr of next echo char (if non-0) cncflg = echosp+2 ;'^c' flag, non-0 if pending cnoflg = cncflg+1 ;'^o^ flag, ditto fillco = cnoflg+1 ;fill-count fillno = fillco+1 ;no of fill chars fillch = fillno+1 ;char before fill tsflgs = fillch+1 ;terminal status flags $lu = </2>*2 ;must be word boundary ; tsflgs bit definitions necho$= 1 ;no echo tape$= 2 ;tape mode (ignore rubouts) xoff$= 4 ;stop terminal output (but not echoing) rubot$= 10 ;rubout mode flag ctlcd$= 20 ;ctrl/c as data flag .endc ;$tty .ifdf hvunix cncflg=$lu $lu=cncflg+2 .endc .ifdf $multi pdlsave = $lu tksu = pdlsave+2 tkbu = tksu+2 tpsu = tkbu+2 tpbu = tpsu+2 attflg = tpbu+2 $lu = attflg+2 .endc ;$multi .ifdf $tty ; ; --i/o buffer header offsets ; bstrt =0 ;(r1) start of buff. bend =2 ;bend(r1) end of buffer bget1 =4 ;bget1(r1) first get pointer bget2 =6 ;bget2(r1) second get ptr. bput =10 ;bput(r1) put ptr. bfspec =12 ;bfspec(r1) special word $bhsiz =14 ;size of buffer header kbha = $lu tpha = kbha+$bhsiz+$kbbsz $lu = tpha+$bhsiz+$tpbsz .endc ;$tty .ifdf $..$ ; the following definitions are additional storage cells used by ; mu/basic/rt-11. cfdba=$lu ;current file descriptor block address cdba=cfdba+2 ;current device block address hfa=cdba+2 ;handler fetch address usw=hfa+2 ;user status word ustpc=usw+2 ;user transfers pending count fadb=ustpc+1 ;file activity descriptor byte cnoc=fadb+1 ;current number of open channels cpcn=cnoc+1 ;current physical channel number nsr=cpcn+1 ;number of statements remaining lunsav=nsr+1 ;logical unit number of the last accessed virtual array. cdnb=lunsav+1 ;current device name block cfn1=cdnb+2 ;current file name (1) cfn2=cfn1+2 ;current file name (2) cfn3=cfn2+2 ;current file name (extension) filsiz=cfn3+2 ;this and the next 3 words are used as a 2nd recsiz=filsiz+2 ;device name block for rename. when doing an open, mode=recsiz+2 ;they are also used for temporary storage. empty=mode+2 cduswa=empty+2 ;current device/unit status word address uid=cduswa+2 ;user id (two characters) $lu=uid+2 .endc ;$..$ .ifndf $..$ ; the following definitions are dummy storage cells ; to allow the kernel to assemble for systems other than ; mu/basic/rt-11. lunsav=$lu fdbdaw=$lu $lu=$lu+2 .endc ;$..$ ; --file status block entry offsets fcurbl =2 ;current block read in fbufe =4 ;end of current buffer fnext =6 ;pointer to next char - 1 ; ; --definitions for print using command ; (see print using command in basicx) ; .ifndf $nopru ;expon=0 mant=-6 chrct=-10 nch=-12 strflg=-13 plsflg=-14 sigdig=-15 dolflg=-16 expflg=-17 decpl=-20 rjflg=-21 ;only for strings zerflg=-21 ;only for numeric sigflg=-22 ; action code definitions .dl = 0 .pl = 1 .mi = 2 .n2 = 3 .n1 = 4 .ex = 5 .rj = 6 .lj = 7 .ns = 10 .dt = 11 .dn = 12 .er = 13 .d1 = 14 .endc ;$nopru ; ; -- system token definitions ; ; .eol= 200 .for= .eol+1 .gosub= .for+1 .goto= .gosub+1 .on= .goto+1 .if= .on+1 .input= .if+1 .linput=.input+1 .let= .linput+1 .next= .let+1 .ifdf hvunix .ifdf $ext .extra= .next+1 .print= .extra+1 .iff .print= .next+1 .endc .iff .print= .next+1 .endc .ifdf $matrix .mat=.print+1 .return=.mat+1 .iff .return=.print+1 .endc .restor=.return+1 .reset= .restore+1 .read= .reset+1 .call= .read+1 .ifend= .call+1 .letvf= .ifend+1 .dim= .letvf+1 .common=.dim+1 .random=.common+1 .rem= .random+1 .def= .rem+1 .data= .def+1 .end= .data+1 .stop= .end+1 .eof= .stop+1 .open= .eof+1 .close= .open+1 .ovrly= .close+1 .chain= .ovrly+1 .bye= .chain+1 .etab1= .bye .ifdf $..$ .kill= .etab1+1 .nameas=.kill+1 .etab1= .nameas .endc ;$..$ .ampers=.etab1+1 .unary= .ampers+1 .uparro=.unary+1 .star= .uparro+1 .slash= .star+1 .plus= .slash+1 .minus= .plus+1 .term= .minus+1;end of sequence used by 'table2' .semi= .term+1 .rpar= .semi+1 .to= .rpar+1 .step= .to+1 .then= .step+1 .comma= .then+1 .le= .comma+1 .el= .le+1 .ge= .el+1 .eg= .ge+1 .ne= .eg+1 .en= .ne+1 .lt= .en+1 .gt= .lt+1 .eq= .gt+1 ;end of sequence used by operator precedence .lpar= .eq+1 .dquot= .lpar+1 .squot= .dquot+1 .colon= .squot+1 .pound= .colon+1 .fn= .pound+1 .forot= .fn+1 ;must precede .asfil for mu/rt filspec .asfil= .forot+1 .forin= .asfil+1 .perc= .forin+1 .dol= .perc+1 .dblbf= .dol+1 .recsiz=.dblbf+1 .filsiz=.recsiz+1 .mode= .filsiz+1 .as= .mode+1 ;name-as statement .using= .as+1 .line= .using+1 .ifndf $disk .stab5= .pi .endc ;$disk .ifdf $disk .stab5= .vf .endc ;$disk .vf= .line+1 ;beginning of sequence used by 'table5' .pi= .vf+1 .ifndf $sysfn .rndl= .pi+1 .endc ;$sysfn .ifdf $sysfn .sys= .pi+1 .rndl= .sys+1 .endc ;$sysfn .rnd= .rndl+1 .sin= .rnd+1 .cos= .sin+1 .sqr= .cos+1 .atn= .sqr+1 .exp= .atn+1 .log= .exp+1 .log10= .log+1 .abs= .log10+1 .int= .abs+1 .sgn= .int+1 .bin= .sgn+1 .oct= .bin+1 .ifdf $matrix .trn = .oct + 1 .inv = .trn + 1 .num = .inv + 1 .det = .num + 1 .tab = .det + 1 .iff .tab = .oct + 1 .endc .ifdf $mortok .more = .tab + 1 .len = .more + 1 .iff .len = .tab + 1 .endc .asc= .len+1 .chr$= .asc+1 .pos= .chr$+1 .seg= .pos+1 .val= .seg+1 .trm= .val+1 .dat= .trm+1 .str= .dat+1 .bcomp= .str+1 ;beginning of command parameters .ifdf $nostr .etab5= .oct .endc ;$nostr .ifndf $nostr .etab5= .str .endc ;$nostr .stab4= .bcomp ;beginning of commands (not statements) .clear= .stab4 ;commands common to all systems .scr= .clear+1 .tape= .scr+1 .key= .tape+1 .ifdf hvunix .ifdf $reseq .reseq=.key+1 .list=.reseq+1 .iff .list=.key+1 .endc .iff .list=.key+1 .endc .listnh=.list+1 .ifdf $disk .rename=.listnh+1 .filcom=.rename ;used by tran .new= .rename+1 .append=.new+1 .endc ;$disk .ifndf $disk .append=.listnh+1 .filcom=.append .endc ;$disk .old= .append+1 .run= .old+1 .runnh= .run+1 .save= .runnh+1 .ifdf $disk .replace=.save+1 .ifndf $tty .settty=.replace .iff .settty=.replace+1 .endc .endc ;$disk .ifndf $disk .settty=.save+1 .endc ;$disk .etab4= .settty .ifdf hvunix .shell=.etab4+1 .delet=.shell+1 .etab4=.delet .endc .ifdf $..$ .unsave=.etab4+1 .etab4= .unsave .endc ;$..$ .ifdf $multi .assign=.etab4+1 .deass= .assign+1 .etab4= .deass .endc ;$multi .flit= 374 .ilit1= 375 .ilit2= 376 .text =377 .ifdf $mortok ;extra tokens for use after .more ;note that eol (200) is not duplicated ;*** be sure not to duplicate .eof (234) .zer = 201 .con = .zer + 1 .idn = .con + 1 .proto = .idn + 1 .unproto = .proto + 1 .news = .unproto + 1 .ddt = .news + 1 .ulink = .ddt + 1 .sysxt = .ulink + 1 .endc .endc .ifdf $..$ .unsave=.etab4+1 .etab4= .unsave .endc ;$..$ linkr -ls -dd -xs:10 r.obj intr.obj conv3.obj fadd.obj fmul.obj conv2.obj fdiv.obj exp.obj sqrt.obj atan.obj alog.obj sin.obj ermod.obj i.obj matpak.obj e.obj x.obj s.obj h3.obj mv h3.out pbasic l (200) is not duplicated ;*** be sure not to duplicate .eof (234) .zer = 201 .con = .zer + 1 .idn = .con + 1 .proto = .idn + 1 .unproto = .proto + 1 .news = .unproto + 1 .ddt = .news + 1 .ulink = .ddt + 1 .sysxt = .ulink + 1 .endc .endc .ifdf $..$ .unsave=.etab4+1 .etab4= .unsave .endc ;$..$ .title basicr v02-01 root: edit # 001 ;basic kernel v02-01 ; ;the information in this document is subject to change ;without notice and should not be construed as a ;commitment by digital equipment corporation. digital ;equipment corporation assumes no responsibility for any ;errors that may appear in this document. ; ;the software described in this document is furnished ;to the purchaser under a license for use on a single ;computer system and can be copied (with inclusion of ;digital's copyright notice) only for use in such system, ;except as may otherwise be provided in writing by ;digital. ; ;digital equipment corporation assumes no responsibility ;for the use or reliability of its software on equipment ;that is not supplied by digital. ; ;copyright (c) 1974 ;by digital equipment corporation ;146 main street ;maynard, massachusetts 01754 ; ;january 1974 ; ; ;these globals are in basicr and not in basp2, because ;if they were in basp2, we'd get multiply defined ;error messages for them, since they are also defined in ;basp2 ; .globl .comma, .dquot, .eol, .lpar, .rpar, .squot .hiseg .loseg .hiseg baslow: ;lowest address in basic go: jmp onceonl ;start address ; .ifdf $multi usrtbl: .word 0,0,0,0 .word 0,0,0,0 curusr: .word 0 lstusr: .word 0 exct: .word $exno .endc ;$multi ;************************************************** ;************************************************** ;************ ************ ;************ main flow routines ************ ;************ ************ ;************************************************** ;************************************************** ; ; start - program starting point ; .ifdf $disk restt: br ready0 ;program restart point .endc ;$disk start: mov usrarea,r5 mov pdl(r5),sp .ifdf $tty clr echosp(r5) .endc ;$tty jsr pc,istart ;init for start .ifdf $namset clr r3 jsr pc,namset .endc ;$namset scratch:mov pdl(r5),sp jsr pc,initscr clear: jsr pc,clrvars br ready ;---------------------------------------------------------- ; ; ready - print 'ready' ; ready0: mov usrarea,r5 mov pdl(r5),sp jsr pc,closall ready: mov usrarea,r5 mov pdl(r5),sp .ifdf $chain clr chnflg(r5) ;clr chain flag clr editln(r5) .endc ;$chain jsr pc,iready ;initialize subr. mov #clmntty,column(r5) add r5,column(r5) clr odev(r5) jsr r1,msg .byte cr,lf .ascii 'ready' .byte 0 .even .ifdf $..$ bit #uswro$+uswpp$,usw(r5) ;if program was read-only then: beq notro bic #uswro$+uswpp$,usw(r5) ;clear ro and pp bits and jsr pc,initscr ;scratch program notro: .endc ;$..$ ready2: mov pdl(r5),sp jsr r1,msg .byte cr,lf,lf .byte 0 .even ioinit: clr odev(r5) ;clr odev and idev bytes in user area jmp edit .ifndf $ovlay ;------------------------------------------------------------ ; ; execute - execute command line ; .ifdf $multi exshr: mov #$exno,exct ;re-init count jsr pc,nxtusr ;give someone else a chance br ex0 ;continue .endc ;$multi .ifdf $tty excnc: clrb cncflg(r5) jmp stop .endc ;$tty .ifdf hvunix excnc: clrb cncflg(r5) jmp stop .endc ignore: jsr pc,skipeol execute: .ifdf $multi dec exct ;check # statements executed bmi exshr ;reached count, time to share ex0: .endc ;$multi .ifdf $tty tstb cncflg(r5) ;'^c' hit? bne excnc .endc ;$tty .ifdf hvunix tstb cncflg(r5) bne excnc .endc nocnc: movb (r1)+,r2 bge notsym ;its a pointer. .ifdf $mortok cmpb r2,#.more ;extended token? beq domort ;yes .endc bic #-200,r2 cmp r2,#.etab1-.eol blos exec1 cmpb r2,#.text-200 ;check for implied call bne ex1 jmp callimp ex1: .ifdf $vf cmp r2,#.vf-200 ;implied let vf? bne ex2 ;no jmp letvf ;yes ex2: .endc ;$vf jmp errsyn exec1: asl r2 mov table1(r2),pc .ifdf $mortok domort: movb (r1)+,r2 ;get next token bic #-200,r2 asl r2 mov mortab(r2),pc ;use to index into table mortab: .word errsyn .word errsyn .word errsyn .word errsyn .word progo .word uprogo .word newsgo .word ddtgo .word ulkgo .word sysxit .endc table1: .word execute .word for .word gosub .word goto .word on .word if .word input .word input ;linput .word let .word next .ifdf hvunix .ifdf $ext .word extend .endc .endc .word print .ifdf $matrix .word matbeg .endc .word return .word restore .word restore ;reset .word read .word call .word ifend .ifdf $vf .word letvf .endc ;$vf .ifndf $vf .word errsyn .endc ;$vf .word ignore ;dim .word ignore ;common .word ignore ;random .word ignore ;rem .word ignore ;def .word ignore ;data .word end .word stop .word eof .word open .word close .ifdf $chain .word overlay .word chain .endc ;$chain .ifndf $chain .word errsyn .word errsyn .endc ;$chain .word bye .ifdf $..$ .word kill .word nameas .endc ;$..$ .endc ;$ovlay .ifdf $ovlay ;------------------------------------------------------------- ; ; command line dispatch for systems with $ovlay ; .ifdf $multi .ifndf $..$ exshr: mov #$exno,exct ;re-init count jsr pc,nxtusr ;give someone else a chance br ex0 ;continue .endc ;$..$ .endc ;$multi ignore: jsr pc,skipeol execute: .ifdf $multi .ifndf $..$ dec exct ;check # statements executed beq exshr ;reached count, time to share .endc ;$..$ .ifdf $..$ decb nsr(r5) ;# statements remaining (per user) bne ex0 ;don't switch jsr pc,nxtusr ;do switch movb exct,nsr(r5) ;reset count .endc ;$..$ ex0: .endc ;$multi .ifdf $tty tstb cncflg(r5) ;'^c' hit? bne excnc ;yes .endc ;$tty nocnc: movb (r1)+,r2 bge notsym bic #-200,r2 beq execute ;empty program line cmp r2,#.letvf-.eol ;exec overlay stmt? bhi ex1 exj: jmp execx ;yes, go to exec overlay ex1: sub #.data-.eol,r2 ;non-executable statement? ble ignore cmp r2,#.chain-.data ;illegal keyword bhi ex2 jmp exece ;no, to edit overlay ex2: sub #.vf-.data,r2 ;check .vf keyword beq exj cmpb -1(r1),#.text ;check for implied call bne exec1 ;no good mov #.letvf-200+1,r2;last in tablex br exj exec1: jmp errsyn .ifdf $tty excnc: clrb cncflg(r5) jmp stop .endc ;$tty .endc ;$ovlay notsym: swab r2 bisb (r1)+,r2 add (r5),r2 cmp (r2),#.scalar blo ex3 jmp assign ex3: mov (r2),lineno(r5) ;save the lineno. br nocnc errgo: trap 0 .ifndf $longer .ascii \uln\ .endc ;$longer .ifdf $longer .ascii 'undefined line number' .endc ;$longer .byte 0 .even ;-------------------------------------------------- ; subroutine 'alloc' called by jsr pc ; allocates array space from freespace ; r0,r1 preserved ; r2 must point to var gets destroyed ; r3 must contain ss1max gets destroyed ; r4 must contain ss2max gets destroyed ; r5 must point to user area ; sp goes ?? deeper after jsr alloc: mov r0,-(sp) mov r1,-(sp) inc r3 mov r4,r1 alloc1: inc r1 beq alloc1 clr r0 ;**** mov #20,-(sp) ;* * allloop:asl r1 ;* * bcc allnoad ;* * add r3,r0 ;* * multiply (r1)*(r3)*2 bcs erraray ;* * result in r0 allnoad:asl r0 ;* * watch for overflows bcs erraray ;* * dec (sp) ;* * bgt allloop ;* * tst (sp)+ ;**** add #2,r0 bcs erraray ;r0 now = 2 times # elements needed. .ifndf $nostr cmp (r2),#.svar beq alloc2 .endc ;$nostr asl r0 bcs erraray ;r0 now = # bytes needed. alloc2: mov hifree(r5),r1 sub r0,r1 bcs erraray cmp r1,histr(r5) blo erraray tst (r1)+ br alloc3 alloc4: clr (r1)+ alloc3: cmp r1,hifree(r5) blos alloc4 sub r0,r1 .ifndf $nostr cmp (r2),#.svar beq allstrn .endc ;$nostr mov #.nvar,(r2)+ mov (r2)+,(r1)+ mov (r2)+,(r1)+ mov r4,(r2) dec r3 mov r3,-(r2) mov r1,-(r2) sub #4,(r2) .ifndf $nostr br allexit allstrn:tst (r2)+ mov (r2)+,(r1)+ dec r3 mov r3,(r2)+ mov r4,(r2) mov r1,-4(r2) sub #2,-4(r2) alloc5: mov #-1,(r1)+ cmp r1,hifree(r5) blos alloc5 sub r0,r1 mov (r1),r2 inc r2 beq allexit swab r1 movb r1,(r2)+ swab r1 movb r1,(r2) .endc ;$nostr allexit:sub r0,hifree(r5) mov (sp)+,r1 mov (sp)+,r0 getx: rts pc erraray:trap 0 .ifndf $longer .ascii \atl\ .endc ;$longer .ifdf $longer .ascii 'arrays too large' .endc ;$longer .byte 0 .even .ifndf $nopru asccon: mov r4,-(sp) mov fac2(r5),r4 ;r4 = low order mantissa. clr r2 ;r2 = decimal exponent. mov fac1(r5),r3 ;r3 = high order mantissa. bne numflt mov #37,r0 ;r0 = binary exponent. tst r4 bne numshft mov (sp)+,r4 ;get table address clr (r4) ;set exponent = 0 add #mant,r4 ;address mantissa mov #30060,(r4) ;set ascii result mov (r4)+,(r4) ;to '000000' mov (r4)+,(r4)+ rts pc numflt: mov r3,r0 asl r0 clrb r0 swab r0 sub #171,r0 bic #177600,r3 bis #200,r3 numshft:dec r0 asl r4 rol r3 numnorm:bit r3,#40000 beq numshft tst r0 bgt numbig asr r3 ror r4 asr r3 ror r4 asr r3 ror r4 asr r3 ror r4 add #4,r0 jsr pc,mpyten dec r2 br numnorm numbig: cmp r0,#4 ble numok numdiv: jsr pc,divten inc r2 br numnorm numaln: inc r0 asr r3 ror r4 numok: cmp r0,#4 blt numaln cmp r3,#50000 bhis numdiv add #1250,r4 ;rounding. bcc norndov inc r3 cmp r3,#50000 blo norndov mov #4000,r3 clr r4 inc r2 norndov:mov r2,@(sp) ;save exponent mov (sp),r2 mant=-6 add #mant,r2 mov #6,r0 numdig: mov r3,-(sp) swab (sp) ror (sp) ror (sp) ror (sp) bic #177760,(sp) add #'0,(sp) movb (sp)+,(r2)+ bic #174000,r3 jsr pc,mpyten dec r0 bgt numdig mov (sp)+,r4 rts pc .endc ;$nopru ;-------------------------------------------------- ; subroutine 'bomb' called by trap 0 ; prints error message from after trap 0 ; r0 destroyed ; r1 preserved ; r2,r3,r4 unused ; r5 must point to user area ; sp reset to empty stack ; pc does not return bomb: $sig 7 bomb mov (sp),r1 mov usrarea,r5 mov pdl(r5),sp clr odev(r5) ;cause mes output to tty mov #clmntty,column(r5) ;set-up tty for col. count add r5,column(r5) jsr r1,msg .byte cr,lf .ifndf $longer .ascii '?' .endc ;$longer .byte 0 .even bombnx: movb (r1)+,r0 beq bombdon jsr pc,putchar br bombnx bombdon:mov lineno(r5),r1 blt bombjmp ;negative if immediate mode jsr pc,bombdd mov #-1,lineno(r5) ;in case of ^c in immediate mode. br bombjmp bombdd: clr odev(r5) ;msg goes to tty jsr r1,msg .ascii ' at line ' .byte 0 .even clr fac1(r5) mov r1,fac2(r5) jsr pc,numout jsr r1,msg .byte cr,lf,0 .even rts pc bombjmp: jsr pc,closys ;close system channel jmp ready ;-------------------------------------------------------------- ; ; chkchr - check ascii char. for special cases ; ; call: mov [char.],r0 ; jsr r3,chkchr ; instruc. ;execute if line del. (,'^u') ; instruc. ;exec. if ; instruc. ;exec. if (or back arrow) ; instruc. ;exec. if below 40 or above 137 ; instruc. ;exec. if good stuff ; ; uses r0 ; chkchr: cmpb r0,#176 ;alt mode beq ccexit cmpb r0,#175 ;alt mode beq ccexit cmpb r0,#33 ;alt mode beq ccexit .ifndf hvunix cmpb r0,#25 ;'^u' beq ccexit .endc tst (r3)+ ;to return cmpb r0,#cr beq ccexit tst (r3)+ ;to rub out return .ifndf hvunix cmpb r0,#177 ;rub out beq ccexit .endc cmpb r0,#137 beq ccexit tst (r3)+ ;to limit return .ifndf hvunix cmpb r0,#40 blo ccexit .endc .ifdf hvunix tst r0 beq ccexit cmpb r0,#172 .iff cmpb r0,#137 .endc bhi ccexit tst (r3)+ ;reg. char. return ccexit: rts r3 ;-------------------------------------------------- ; subroutine 'divten' called by jsr pc ; divides r3,r4 by decimal 10 ; r0,r1,r2 unused ; r3,r4 is the 31 bit unsigned integer to divide ; r5 unused ; sp goes 2 deeper after jsr divten: mov #34,-(sp) divloop:cmp #50000,r3 bhi divl1 add #130000,r3 divl1: rol r4 rol r3 dec (sp) bgt divloop bic #170000,r3 tst (sp)+ rts pc .ifndf $nostr ;-------------------------------------------------- ; subroutine 'dnpack' called by jsr pc ; packs string storage toward low core ; all registers preserved ; r5 must point to user area ; to understand these routines it is helpful to ; know that non-null strings are stored as ; (length,2 byte backptr,n byte string,length) ; where length is the value of n and if backptr ; is odd, then it is relative to symbols dnpack: jsr r4,savreg ;saves all registers clr -(sp) mov lostr(r5),r2 mov lofree(r5),r1 mov r1,lostr(r5) dnploop:clr (sp) bisb (r2)+,(sp) bne dnpnzro dnpbad: cmp r2,histr(r5) blo dnploop mov r1,histr(r5) ;save high string address tst (sp)+ rts pc dnpnzro:clr r3 bisb (r2)+,r3 swab r3 bisb (r2)+,r3 add (sp),r2 inc r2 bit r3,#1 beq dnp1 dec r3 add (r5),r3 .ifdf hvunix dnp1: cmp r3,arrays(r5) .iff dnp1: cmp r3,pdl(r5) .endc bhis dnpbad cmp r3,sp bhis dnpgood cmp r3,arrays(r5) bhi dnpbad cmp r3,hifree(r5) bhi dnpgood cmp r3,lofree(r5) bhis dnpbad cmp r3,(r5) blo dnpbad dnpgood:add #4,(sp) sub (sp),r2 cmp r2,(r3) bne dnpigno mov r1,(r3) movb (r2)+,(r1)+ dec (sp) bgt .-4 br dnpbad dnpigno:add (sp),r2 br dnpbad .endc ;$nostr ;the function table entries which ;are 0 (undefined) are ;filled in by basich table5: .ifdf $vf .word vffn ;virtual file element .endc ;$vf .ifndf $vf .ifdf $disk .word 0 .endc ;$disk .endc ;$vf .word pifn .ifdf $sysfn .ifdf hvunix .word sysfn .iff .word 0 .endc ;hvunix .endc ;$sysfn tbl5rnd: .ifdf hvunix .word rndlfn .word rndfn .iff .word 0 ; rnd( .word 0 ; rnd .endc .word sinfn .word cosfn .word sqrfn .word atnfn .word expfn .word logfn .word l10fn .ifdf hvunix .word absfn .iff .word 0 ; abs .endc .word intfn .ifdf hvunix .word sgnfn .word binfn .word octfn .iff .word 0 ; sgn .word 0 ; bin .word 0 ; oct .endc .ifdf $matrix .word 0 ; trn() .word 0 ; inv() .word numfn ; num() .word detfn ; det() .endc .ifndf $nostr .ifdf hvunix .word tabfn .ifdf $mortok .word 0 ;.more .endc .word lenfn .word ascfn .word chr$fn .word posfn .word segfn .word valfn .word trmfn .iff .word 0 ; tab .word 0 ; len .word 0 ; asc .word 0 ; chr$ .word 0 ; pos .word 0 ; seg .word 0 ; val .word 0 ; trm .endc .ifdf $disk .word datfn ; dat$ .endc ;$disk .ifndf $disk .word errsyn .endc ;$disk .ifdf hvunix .word strfn .iff .word 0 ; str .endc .endc ;$nostr tbl5end =.-2 .ifdf $nostr ;dummy entry points for $nostr savchar: argb: makest: soprat: stosvar: errmix: stpro: dnpack: datfn: .endc ;$nostr ;dummy entry points for $novf .ifndf $vf vfblk: vffn: .endc ;$vf errsyn: trap 0 .ifndf $longer .ascii 'syn' .endc ;$longer .ifdf $longer .ascii 'syntax error' .endc ;$longer .byte 0 .even ;---------------------------------------------------- ; subroutine 'fline' called by jsr pc ; finds the address of the line no ; referenced by (r1) in r2. ; if the symbol table reference is not a line no, ; sets carry. otherwise, the carry is clear. fline: movb (r1)+,r2 ;get next byte from code bmi fle ;a token-bad swab r2 bisb (r1)+,r2 add (r5),r2 ;address symbol table entry mov (r2)+,r0 cmp r0,#.scalar ;make sure it's a line number blo flx fle: sec ;failure rts pc flx: clc ;success rts pc ;---------------------------------------------------------- ; subroutine 'fndstl' called by jsr pc ; finds the length and address of ; a literal starting at (r1) ; returns the length in r3, ; and address in r0. ; r1 is moved past the literal in the code. ; called by 'call', 'print' routines ; tran checks syntax so we don't do it here, ; except to check that the first char is a quote fndstl: cmpb (r1),#.dquot ;check for a quote beq fndsl1 cmpb (r1),#.squot bne fndsle fndsl1: cmpb (r1)+,(r1)+ ;skip over quote and .text tokens jsr pc,fndetxt ;find end of literal (and length) inc r1 ;move past close quote rts pc fndsle: jmp errsyn ;---------------------------------------------------------------- ; subroutine 'fndetxt' called by jsr pc,fndetxt ; referenced by fndstl and chkfil ; on entry, the first character to be considered ; part of the literal is pointed to by r1 ; on exit, r1 points to the byte after the 0 byte ; r3 is the length, cc set to "tst r3" ; r0 is r1 saved fndetxt:mov r1,r0 ;save beginning address of literal fndet1: tstb (r1)+ ;search for 0 byte bne fndet1 mov r1,r3 ;end of literal +2 sub r0,r3 ;-beginning dec r3 ;-1=length (end-begining-1) rts pc ;--------------------------------------------------------------- ; subroutine 'freeget' called by jsr pc,freeget ; allocates the number of bytes specified by ; r0 from free storage. carry is set ; if there is not enough room available. ; on return, r0 is the address of the free area. freeget: .ifndf $nostr jsr pc,dnpack .endc neg r0 add hifree(r5),r0 bcc freer cmp r0,histr(r5) blo freer mov r0,hifree(r5) tst (r0)+ rts pc ;'c' bit is clear from tst!!!!! freer: sec rts pc ;------------------------------------------------------------- ; ;subroutine gtftabi jsr pc,gtftabi ; picks up user function table address ; if first wd is 0 no user functions ; gtftabi: mov @#ftabi,r2 ;retn addr in r2 tst (r2) ;check for null function table rts pc ;------------------------------------------------------------ ; subroutine 'int16' called by jsr pc,int16 ; integerizes the fac to a 16-bit unsigned ; integer in fac2(r5). carry is set if ; the fac is not in the range ; 0 <= fac < 2^16 int16: mov fac1(r5),r0 ;check upper fac beq int16b ;if 0, means integer bmi int16c mov r0,r2 bic #100177,r0 ;extract exponent cmp #44000,r0 ;check exponent of 220 bne int16c bic #177600,r2 ;ok, get mantissa bis #200,r2 ;set hidden bit movb r2,fac2(r5) ;combine with lower mantissa swab fac2(r5) ;in proper order int16a: rts pc ;ok return 'c' bit clr from tst and swab int16b: tst fac2(r5) ;make sure integer's not negative bpl int16a int16c: sec ;unsuccessful return rts pc ;------------------------------------------------------------- ; ; linget - edit a line into line buffer using getchar ; ; call: user area base into r5 ; jsr pc,linget ; ; preserves all registers ; ; recognizes back arrow and ; for rub out and ; and '^u' for line delete; as line terminator. ; throws away all others below ascii 40 and above ; ascii 137. ; linget: jsr r4,savreg ;save regs. tstb idev(r5) ;reset ctrlo if input requested from term bne lina jsr pc,rctrlo lina: linein: mov line(r5),r2 linrub: cmp r2,line(r5) ;don't rub out too much beq dochar dec r2 dochar: jsr pc,getchar ;don't come back 'till you got one bcc gotone rts pc ;indicate incomplete line (carry set) gotone: movb r0,(r2) ;put her in cmpb r0,#11 ;check input tab char beq goodch cmpb r0,#ff ;check ff, also beq goodch jsr r3,chkchr ;return exec. one of next five locs. br lina ;if line delete rts pc ;done () (carry clear) br linrub br dochar ;meaningless chars. goodch: inc r2 ;good char. cmp r2,code(r5) ;check line space overflow blo dochar jsr r1,msgerr .byte cr,lf .ifndf $longer .ascii 'ltl' .endc ;$longer .ifdf $longer .ascii 'line too long' .endc ;$longer .byte cr,lf .byte 0 .even br linein ;-------------------------------------------------- ; 'liteval' subroutine ; called by jsr pc,liteval ; .word ret ;return if not literal ; r3 points to the code ; this subroutine is called to evaluate a ; literal in the code. liteval:clr r0 clr fac1(r5) clr fac2(r5) cmpb (r3),#.plus ;check leading sign character beq levplus cmpb (r3),#.minus bne levlit com r0 levplus:inc r3 levlit: cmpb (r3)+,#.ilit1 ;check 1 byte literal in code beq lev1lt cmpb -(r3),#.flit ;or floating point literal beq levflt cmpb (r3)+,#.ilit2 ;or 2 byte literal beq lev2lt rts pc levflt: inc r3 movb (r3)+,fac1+1(r5) ;format, return answer in fac movb (r3)+,fac1(r5) lev2lt: movb (r3)+,fac2+1(r5) lev1lt: movb (r3)+,fac2(r5) tst r0 beq levpos tst fac1(r5) bne levfneg neg fac2(r5) br levpos levfneg:add #100000,fac1(r5) levpos: add #2,(sp) rts pc ;-------------------------------------------------- ; subroutine 'mpyten' called by jsr pc ; multiplies r3,r4 by decimal 10 ; r0,r1,r2 unused ; r3,r4 is the 32 bit unsigned integer to multply ; r5 unused ; sp goes 4 deeper after jsr mpyten: mov r3,-(sp) mov r4,-(sp) asl r4 rol r3 asl r4 rol r3 add (sp)+,r4 adc r3 add (sp)+,r3 asl r4 rol r3 rts pc ; ; msg - output a line to tty ; msgodev - output a line to curr. output dev. ; ; call: jsr r1,msg (msgodev) ; .ascii "[message]" ; .byte 0 ; .even ; ;return here ; ; uses r0 ; ; set up line with number of bytes terminated ; by a byte of 000. ; msgerr: .ifndf $longer movb #'?,r0 br msgcom .endc ;$longer msg: movb (r1)+,r0 msgcom: jsr pc,rctrlo ;reset ^o flag mov column(r5),-(sp) ;save for temp switch mov #clmntty,column(r5) add r5,column(r5) movb odev(r5),-(sp) ;save odev clrb odev(r5) ;set to tty br frstout msgodev:mov column(r5),-(sp) movb odev(r5),-(sp) domsg: movb (r1)+,r0 beq lindun frstout:jsr pc,putchar ;put char. to tty br domsg ;do next char lindun: inc r1 ;to insure return on asr r1 ; even word boundary asl r1 movb (sp)+,odev(r5) ;restore odev mov (sp)+,column(r5) rts r1 ;------------------------------------------------------ ; subroutine 'norm' normalizes integer contained in ; r3 and r4, multiplied by exponent ; in r2. answer is in r3, r4. ; called by jsr pc norm: mov #237,-(sp) tst r3 beq littst bpl litnorm ror r3 ror r4 inc (sp) litnorm:bit r3,#40000 bne litok asl r4 rol r3 dec (sp) br litnorm littst: tst r4 bne litnorm tst (sp)+ rts pc litok: tst r2 beq litsto bmi litdiv asr r3 ror r4 asr r3 ror r4 asr r3 ror r4 asr r3 ror r4 add #4,(sp) jsr pc,mpyten dec r2 br litnorm litdiv: jsr pc,divten inc r2 br litnorm litshr: asr r3 ror r4 litsto: bit r3,#177000 bne litshr tst (sp) ble norund ;underflow cmp (sp),#377 bhi norov ;overflow movb r3,1(sp) mov (sp)+,r3 swab r3 ror r3 ror r4 clc ;no error rts pc norund: norov: tst (sp)+ ;fix stack sec ;underflow or overflow rts pc ;-------------------------------------------------------- ; 'numout' subroutine ; called by jsr pc,numout ; outputs an unsigned number from the fac ; via the subroutine putchar. numout: jsr r4,savreg mov #putchar,r1 br numstt .ifdf $nopru ;-------------------------------------------------- ; 'numsgn' subroutine ; called by jsr pc,numsgn ; .word output ; where output is the output routine, ; which may be putchar or savchar. ; outputs a signed number from the ; fac via the output routine. numsgn: mov @(sp),r0 add #2,(sp) jsr r4,savreg mov r0,r1 tst fac1(r5) beq numfix bpl numpos add #100000,fac1(r5) bne numneg clr fac2(r5) bne numpos numfix: tst fac2(r5) bpl numpos neg fac2(r5) bvc numneg mov #44000,fac1(r5) clr fac2(r5) numneg: mov #'-,r0 br numprs numpos: .ifndf $nostr cmp r1,#savchar beq numstt ;don't output blank for str$ .endc ;$nostr mov #bl,r0 numprs: jsr pc,(r1) numstt: mov fac2(r5),r4 ;r4 = low order mantissa. clr r2 ;r2 = decimal exponent. mov fac1(r5),r3 ;r3 = high order mantissa. bne numflt mov #37,r0 ;r0 = binary exponent. tst r4 bne numshft mov #'0,r0 jsr pc,(r1) rts pc numflt: mov r3,r0 asl r0 clrb r0 swab r0 sub #171,r0 bic #177600,r3 bis #200,r3 numshft:dec r0 asl r4 rol r3 numnorm:bit r3,#40000 beq numshft tst r0 bgt numbig asr r3 ror r4 asr r3 ror r4 asr r3 ror r4 asr r3 ror r4 add #4,r0 jsr pc,mpyten dec r2 br numnorm numbig: cmp r0,#4 ble numok numdiv: jsr pc,divten inc r2 br numnorm numaln: inc r0 asr r3 ror r4 numok: cmp r0,#4 blt numaln cmp r3,#50000 bhis numdiv add #1250,r4 ;rounding. bcc norndov inc r3 cmp r3,#50000 blo norndov mov #4000,r3 clr r4 inc r2 norndov:mov #6,r0 numdig: mov r3,-(sp) swab (sp) ror (sp) ror (sp) ror (sp) bic #177760,(sp) add #'0,(sp) bic #174000,r3 jsr pc,mpyten dec r0 bgt numdig mov sp,r3 add #14,r3 cmp r2,#-2 blt numfm1 beq numfm2 cmp r2,#6 blt numfm3 numfm1: mov -(r3),r0 jsr pc,(r1) mov #'.,r0 jsr pc,(r1) mov #5,r4 numlp1: mov -(r3),r0 jsr pc,(r1) dec r4 bgt numlp1 mov #'e,r0 jsr pc,(r1) mov #'+,r0 tst r2 bpl numlp2 mov #'-,r0 neg r2 numlp2: jsr pc,(r1) mov #'0,r0 numlp5: sub #12,r2 bmi numlp4 inc r0 br numlp5 numlp4: jsr pc,(r1) mov r2,r0 add #'0+12,r0 jsr pc,(r1) br numexit numfm2: mov #'.,r0 jsr pc,(r1) mov #'0,r0 jsr pc,(r1) numfm3: mov #6,r4 mov sp,r0 numlp7: cmp (r0)+,#'0 bne numlp6 dec r4 br numlp7 numlp6: cmp r4,r2 bgt numlp8 mov r2,r4 inc r4 numlp8: inc r2 inc r2 numlp3: dec r2 bne numlp9 mov #'.,r0 jsr pc,(r1) numlp9: mov -(r3),r0 jsr pc,(r1) dec r4 bgt numlp3 numexit:add #14,sp rts pc .endc ;$nopru .ifndf $nopru ;-------------------------------------------------- ; 'numsgn' subroutine ; called by jsr pc,numsgn ; .word output ; where output is the output routine, ; which may be putchar or savchar. ; outputs a signed number from the ; fac via the output routine. numsgn: mov @(sp),r0 add #2,(sp) jsr r4,savreg mov r0,r1 tst fac1(r5) beq numfix bpl numpos add #100000,fac1(r5) bne numneg clr fac2(r5) bne numpos numfix: tst fac2(r5) bpl numpos neg fac2(r5) bvc numneg mov #44000,fac1(r5) clr fac2(r5) numneg: mov #'-,r0 br numprs numpos: .ifndf $nostr cmp r1,#savchar beq numstt ;don't output blank for str$ .endc ;$nostr mov #bl,r0 numprs: jsr pc,(r1) mant=-6 numstt: clr -(sp) mov sp,r4 sub #6,sp jsr pc,asccon mov (r4),r2 ;get exponent mov r4,r3 add #mant,r3 ;address mantissa movb (r3),r0 ;check special case, 0 cmpb r0,#'0 bne numfm0 jsr pc,(r1) br numexit numfm0: cmp r2,#-2 blt numfm1 beq numfm2 cmp r2,#6 blt numfm3 numfm1: movb (r3)+,r0 jsr pc,(r1) mov #'.,r0 jsr pc,(r1) mov #5,-(sp) numlp1: movb (r3)+,r0 jsr pc,(r1) dec (sp) bgt numlp1 tst (sp)+ mov r2,r3 jsr pc,expf2 br numexit numfm2: mov #'.,r0 jsr pc,(r1) mov #'0,r0 jsr pc,(r1) numfm3: mov #6,-(sp) mov r4,r0 numl01: cmpb -(r0),#'0 bne numl00 dec (sp) br numl01 numl00: cmp (sp),r2 bgt numl02 mov r2,(sp) inc (sp) numl02: inc r2 inc r2 numlp3: dec r2 bne numl03 mov #'.,r0 jsr pc,(r1) numl03: movb (r3)+,r0 jsr pc,(r1) dec (sp) bgt numlp3 tst (sp)+ numexit:mov r4,sp tst (sp)+ rts pc .endc ;$nopru .ifndf $nostr savchar: jsr r4,savreg mov t2(r5),r1 movb r0,(r1)+ mov r1,t2(r5) inc t1(r5) rts pc .endc ;$nostr ;------------------------------------------------------------------- ; subroutine reval reval: jsr pc,eval bcs reserr jsr pc,int jsr pc,int16 bcs reserr jmp revlret reserr: jmp errsyn ;;------------------------------------------------------------- ; ; savreg - save all registers ; ; call: [jsr pc,subr.] ;must call savreg from subrtn. ; jsr r4,savreg ; ; pushes all regs. and exits with addr. on stack ; which brings control back when subr. does 'rts pc'. ; then, restores regs. and does 'rts pc' which returns to just ; after call to initial subroutine (modified bowering special) ; .ifdf $tty intext: mov (sp)+,r5 rti savrgi: mov #intext,-(sp) mov 2(sp),-(sp) mov r5,4(sp) .endc ;$tty savreg: mov r3,-(sp) mov r2,-(sp) mov r1,-(sp) mov r0,-(sp) mov r4,-(sp) ;for return to subr. mov 10.(sp),r4 ;get old r4 jsr pc,@(sp)+ ;stack next loc.! resreg: mov (sp)+,r0 mov (sp)+,r1 mov (sp)+,r2 mov (sp)+,r3 mov (sp)+,r4 rts pc ;back to caller of init. subr. ;-------------------------------------------------- ; subroutine 'skipeol' called by jsr pc ; moves r1 past the next 'eol' ; r0 unused ; r1 modified to reflect operation ; r2,r3,r4,r5 unused ; sp goes no deeper after jsr skip05: add #3,r1 skip02: inc r1 skip01: inc r1 skipeol:tstb (r1)+ bge skip01 cmpb -(r1),#.flit beq skip05 bhi skiphi cmpb (r1)+,#.eol beq skiprts cmpb -(r1),#.fn beq skip02 cmpb (r1)+,#.next bne skipeol add #12,r1 br skipeol ; either .ilit1(375), .ilit2(376) or .text(377) skiphi: cmpb (r1)+,#.ilit2 beq skip02 blo skip01 skiptxt:tstb (r1)+ bne skiptxt br skipeol skiprts:rts pc errtrn: jsr r1,msgerr .ifndf $longer .ascii \tlt\ .endc ;$longer .ifdf $longer .ascii 'line too long to translate' .endc ;$longer .byte 0 .even jmp ready2 ;------------------------------------------------------------ ; subroutine 'val' called by jsr pc ; converts an ascii string at (r0) ; to a value in r3,r4, and ; an exponent in r2 val: clr r2 ;dec places+100000 or trailing zeroes. clr r3 ;high order of 32 bit integer. clr r4 ;low order of 32 bit integer. nudigit:cmpb (r0)+,#bl beq nudigit cmpb -(r0),#'0 blo notdig cmpb (r0),#'9 bhi notdig cmp r3,#14630 ;if high word greater than this blos canfit ;then cant fit another digit in 32 bits. inc r0 tst r2 ;cant fit digits in mantissa. bit its blt nudigit ;after point so neednt count them. inc r2 ;cant fit digits in mantissa so must br nudigit ;keep track of trailing zeroes. canfit: jsr pc,mpyten clr -(sp) movb (r0)+,(sp) ;and add in the digit. sub #'0,(sp) add (sp)+,r4 adc r3 tst r2 beq nudigit ;fits in mantissa. inc r2 ;fits in mantissa but after point so br nudigit ;count decimal places. notdig: tst t3(r5) ;line no.? bne valok ;yes cmpb (r0)+,#'. bne notdot tst r2 bne dotrot mov #100000,r2 ;dot comes after short number so get br nudigit ;ready to count decimal places. dotrot: bgt dotigno dotigno:cmpb (r0)+,#bl beq dotigno cmpb -(r0),#'0 ;dot comes after full mantissa with blo pastdot ;trailing zeroes so ignore more digits. cmpb (r0),#'9 bhi pastdot inc r0 br dotigno notdot: dec r0 pastdot:mov r4,-(sp) ;save r4 mov #2,r4 ;no more than 2 digits for exponent mov r0,-(sp) ;save pointer clr -(sp) cmpb (r0),#'e bne noexpon ;no 'e' after the number val01: inc r0 cmpb (r0),#bl beq val01 cmpb (r0)+,#'+ beq expdig ;check negative exponent cmpb -(r0),#'- bne expdig inc r0 mov #100000,(sp) expdig: cmpb (r0)+,#bl ;look at next char of exponent beq expdig cmpb -(r0),#'0 blo expdun cmpb (r0),#'9 bhi expdun dec r4 ;too many digits? bmi experr ;yes mov (sp),-(sp) ;multiply prev exponent by 10 asl (sp) asl (sp) add 2(sp),(sp) asl (sp) bic #77777,2(sp) add (sp)+,(sp) clr -(sp) movb (r0)+,(sp) ;add in new digit sub #'0,(sp) add (sp)+,(sp) br expdig expdun: tst (sp) ;fix up exponent and return bge noexpon bic #100000,(sp) neg (sp) noexpon:tst r2 bge expok bic #100000,r2 neg r2 expok: add (sp)+,r2 cmp #2,r4 ;is r4 still 2 (i.e. no digits found) bne expok1 ;no mov (sp),r0 ;restore pointer expok1: tst (sp)+ ;and pop it mov (sp)+,r4 ;restore r4 valok: clc ;no error rts pc experr: add #6,sp ;fix stack sec ;exponent error rts pc errnob: trap 0 .ifndf $longer .ascii 'nob' .endc ;$longer .ifdf $longer .ascii 'number out of bounds' .endc ;$longer .byte 0 .even ; .end go onger .ifdf $longer .ascii 'number out of bounds' .endc ;$longer .byte 0 .even ; .end go ;====================================================================== ;********************************************************************** ; basics -- system dependent resident module for unix interface ; with dec basic v02-01 ; ; harvard university july 1974 ;********************************************************************* ;===================================================================== .title basics ;---------------------------------------------------------------------- ;subroutinessubroutinessubroutinessubroutinessubroutinessubroutinessubr .hiseg ;---------------------------------------------------------------------- ; chkiset and chkoset ; these subrs evaluate the specified logical unit ; number, check that it is valid, and load it ; into idev(r5) or odev(r5). chkiset:call eval ;evaluate the unit # bcs ersynj ;if a string is returned, then error call int ;integerize the value returned from eval tst fac1(r5) ;make sure its an integer beq 1$ jmp erchan ;if it's not, then error 1$: mov fac2(r5),r2 beq devok ;0 means tty cmp r2,#$maxun+1+$maxun ble 2$ ;# in range? jmp erchan ;no 2$: tstb devtab(r2) ;file already open on that #? bne 3$ jmp erchan ;yes 3$: asl r2 ;address file header bit #^o40000,@filtab(r2) ;for output? bne 4$ jmp erchan ;yes, error 4$: asr r2 ;fix r2 devok: movb r2,idev(r5) ;load idev ret ersynj: jmp errsyn ;syntax error msg chkoset:call eval bcs ersynj call int tst fac1(r5) bne erchan mov fac2(r5),r2 beq devik cmp r2,#$maxun+1+$maxun bgt erchan tstb devtab(r2) beq erchan asl r2 bit #20000,@filtab(r2) beq erchan asr r2 devik: movb r2,odev(r5) ret erchan: trap 0 .ifdf $longer .asciz 'device channel error' .iff .asciz 'dce' .endc .even ;---------------------------------------------------------------------- ; namset -- sets prognm(r5) to the string pointed to by r0. ; uses default name at namdef if no name is given. name may ; contain an extension and may be 10 characters long. namset: jsr r4,savreg ;save registers tst r3 ;name specified? bgt given ;yes mov #6,r3 ;default length mov #namdef,r0 ;default name given: mov #prognm,r1 add r5,r1 ;address prognm(r5) cmp r3,#$pnamsz ;name too long? ble namok ;no jmp ntlerr ;yes, so error namok: mov r3,fnamsz ;set name size for filspec 1$: movb (r0)+,(r1)+ ;move a character sob r3,1$ ;if not last, move next movb #0,(r1) ;put in null ret ;restore regs and go home ;------------------------------------------------------------------- ;sfrset -- restore on seq fil -- does seek to the beginning sfrset: mov fac2(r5),r0 ;get unit # tstb devtab(r0) ;is file open? bne 1$ jmp erchan ;no 1$: push r0 mov r0,r1 call filea bit #fdbra$,(r1) ;vf? beq 2$ ertext nsf, 2$: bit #input$,(r1) bne 3$ jmp errwlo 3$: movb devtab(r0),r0 $seek .word 0 .word 0 clr @fbufe(r1) pop r1 ret ;---------------------------------------------------------------------- ; seqio -- fixes pointers in sequential file buffer headers seqio: mov fbufe(r1),fnext(r1) ;fnext points to beginning of add #3,fnext(r1) ;i/o area add #2,fbufe(r1) ;fbufe points at count clr @fbufe(r1) bit #20000,(r1) ;fix count for output files beq 1$ mov #$bufsz,@fbufe(r1) 1$: ret ;---------------------------------------------------------------------- ; filea -- called with unit # in r1. returns address of 4-word ; file table entry for that unit. filea: tst r1 ;unit # > 0 ? ble filx ;no cmp r1,#$maxun+1+$maxun ;too big? bgt filx ;yes tstb devtab(r1) ;file open? beq nopnd ;no asl r1 mov filtab(r1),r1 ;address the header ret nopnd: mov #filtab,r1 ;if file not open, r1 addresses ret ;zero word filx: jmp erchan ;--------------------------------------------------------------------- ; random -- adds pseudo-random value into random seed rndcnt(r5) random: push r1 $time ;get seconds since 1970 add r1,rndct(r5) ;add it to seed pop r1 ret ;---------------------------------------------------------------------- ; filspec -- translates ascii string pointed to by r0 into name of ; file to be opened by opnfil. filspec:mov @(sp),r2 ;get default extension add #2,(sp) ;fix return push r4 push r3 push r0 tst r3 ;name specified? bne specd ;yes mov #prognm,r0 ;no, use default add r5,r0 mov fnamsz,r3 ;and its length specd: clr -(sp) ;zero dot flag push r0 mov #filhdr,r4 ;where to put name cmp r3,#$pnamsz ;name too long? ble putlp ;no ntlerr: ertext ntl, putlp: cmpb (r0),#'/ ;is the char a slash? bne 4$ mov r0,(sp) ;save address of slash clr 2(sp) ;and zero dot flg 4$: cmpb (r0),#'. ;is the char a dot? bne 1$ mov r0,2(sp) ;save address of dot 1$: movb (r0)+,(r4)+ ;move a char sob r3,putlp ;if not last, move next cmpb @(sp),#'/ ;slash seen? bne 16$ inc (sp) ;it doesn't count as char in name 16$: tst 2(sp) ;dot seen? bne 3$ sub (sp),r0 ;is there room for extension? sub #10.,r0 ble 2$ sub r0,r4 ;make room if there isn't enough 2$: movb (r2)+,(r4)+ ;move in extension bne 2$ br 5$ ;clean stack and exit 3$: sub (sp),r0 ;is name too long? sub #14.,r0 ble 22$ sub r0,r4 ;if so, shorten it 22$: cmpb -(r4),#'. ;remove dot if last char beq 23$ inc r4 23$: clrb (r4) ;move in a null 5$: cmp (sp)+,(sp)+ ;clean stack pop r0 pop r3 pop r4 ret ;and go home ;----------------------------------------------------------------- ;delet and reseq -- delete lines and resequence a program ; courtesy of mark davis delet: inc r1 jsr pc,fline bcs errdes mov (r2),r3 ;ptr into code beq errdea ;undef ln # ->error cmpb (r1)+,#.minus bne errdes jsr pc,fline ;2nd line bcs errdes mov (r2),r2 ;ptr to 2nd ln beq errdea ;undef cmp r2,r3 blo errdea ;last < first so error cmpb (r1)+,#.eol bne errdes ; ok, now get end of last line mov r2,r1 del1: jsr pc,skipeol cmpb (r1),#.eof beq del2 ;got to end of "last" jsr pc,fline bcs del1 ;must be "\" , try again cmpb -(r1),-(r1) ;got ln of next line; r1 now after eol of last del2: mov r1,r4 ;put into r4 ; r4- end of last statement to be deleted ; r3- beginning of first stmt ; all stmts r3 beq 1$ ;br if 1 byte literal inc r1 bisb (r1),r0 ;2 byte lit, high order byte swab r0 1$: inc r1 bisb (r1)+,r0 ;low order byte clr 2(sp) ;clear default flag, and also cl c which ;means returning ok result notlit: rts pc ;either c off and r0/value or ;c set and not an arg ;reseq a - b from c to d ;where args are ints of size for linenos. ;any or all may be absent; but an arg must be there if the ;preceding keyword exists (eg. "-" means b must exist). ;before doing the renumbering, the line#'s are checked to make ;sure the newly renumbered lines don't overlap ;any others - if they did, would have to do a fancy overlay ;and was probably an error on the part of the user. maxln= ^d32767 reseq: push #^d10 ;8(sp) - step 10 push @sp ;6(sp) - start 10 push #maxln ;4(sp) - last - 63997 clr -(sp) ;2(sp) - first 0 push #1 ;(sp) - all defaults jsr pc,resarg bcs tok1 ;no first arg mov r0,2(sp) ;first tok1: cmpb (r1),#.minus bne tok2 jsr pc,resarg bcs tok2 mov r0,4(sp) ;last tok2: cmpb (r1),#.to bne tok3 jsr pc,resarg bcs tok3 mov r0,6(sp) ;start tok3: cmpb (r1),#.step bne reseol jsr pc,resarg bcs reseol mov r0,^d8(sp) ;step reseol: cmpb (r1),#.eol bne errres pop r0 ;are all args default? bne notest ;yes ;no, so have to check linenos in sym tab to ;make sure there is no overlap pop r3 ;first pop r2 ;last cmp r3,r2 ;is last < first ? bhi errrea ;yes, so error clr -(sp) ;place for start addr in code clr -(sp) ;count of statements in range clr r0 ;glb=largest ln < first mov #maxln,r1 ;lub=smallest ln > last mov (r5),r4 ;sym tab br reslp1 ;error messages errres: jmp errsyn errrea: jmp errarg ;stack regs ;(sp) count r0 glb ;2(sp) start addr r1 lub ;4(sp) start r2 last ;6(sp) step r3 first ; r4 symtab (r4) cur ln reslp0: cmp (r4)+,(r4)+ ;skip over ln reslp1: cmp r4,lofree(r5) bhis reschk ;end of symtab cmp (r4),#.scalar bhis resvar ;not a lineno, so skip it tst 2(r4) ;2nd wd of ln entry beq reslp0 ;undef, so ignor cmp (r4),r3 bhi reslp2 ;cur > first beq gotfst ;cur=first , get addr of line cmp (r4),r0 blos reslp0 ;cur < glb, so try next mov (r4),r0 ;glb < cur < first so new glb br reslp0 gotfst: mov 2(r4),2(sp) ;addr of first line br reslp0 ; cur > first reslp2: cmp (r4),r2 bhi reslp3 ;cur > last inc (sp) ;first < cur <= last br reslp0 ;so increment count reslp3: cmp (r4),r1 bhis reslp0 ;cur > lub so try next mov (r4),r1 ;last < cur < lub, so new lub br reslp0 resvar: add #^d10,r4 ;skip over var sym entry br reslp1 ;from below strt0: mov code(r5),r4 ;start from begin of code br resck1 ;skip check for glb, since is now 0 ;check that glb < start < start + count*step < lub ;so that here is no "overlaying" of lines!!!! reschk: pop r3 ;count pop r4 ;start addr ;(sp) = start 2(sp) = step beq strt0 ;no start addr, use code(r5) cmp r0,(sp) blo resck1 ;glb < start, so ok tst r0 ;also ok if glb=0 (default) bne errrea ;but bad if 0< glb >= start resck1: mul 2(sp),r3 ;step*count bcs errrea ;too big add (sp),r3 ;start+step*count bcs errrea ;too big cmp r3,r1 bhis errrea ;start+step*count > lub ;error ;everything is now ok resok: mov r4,r1 ;code ptr in r1 for skipeol resok1: pop r3 ;start mov r2,r4 ;last ln to change br renxt1 ;start at eof test ;all defaults so no tests necessary, just set up args notest: mov code(r5),r1 tst (sp)+ ;dump first mov (sp)+,r2 ;last br resok1 ;get start and step ;r1 - pts to code ;r3 - new number for this line ;r4 - last ln to change ;(sp) - step reloop: cmp -(r2),r4 ;lin# > last? bhi resdon ;yes mov r3,(r2) ;no, change it add (sp),r3 ;increment it by step renext: jsr pc,skipeol ;find eol renxt1: cmpb (r1),#.eof beq resdon ;eof, so done jsr pc,fline ;next thing ln? bcc reloop ;yes change if in range(nb r2 pts to ;second word of sym tab entry sob r1,renext ;no, at "\", get next eol. ;must first dec r1, as fline incs r1. otherwise ;get errors when "next i" is second statement ;on a line (rem also sometimes screw up) ;guaranteed that r1 isn't zero because if you get ;here, must be second statement on line... resdon:jmp ready ;garbage on stk, but rdy resets .endc .ifdf $ext ;--------------------------------------------------------------------- ;extend -- extended feature routine like sysfn, only for immediate mode ;commands and non-value returning functions. use like sysfn, call with: ; extend(dispatch#,args) extend: jsr pc,eval ;get dispatch # bcs erexts jsr pc,int tst fac1(r5) bne erexta mov fac2(r5),r0 cmp #loexcm,r0 bgt erexta cmp #hiexcm,r0 blt erexta asl r0 mov excmtbl(r0),pc erexts: jmp errsyn erexta: jmp errarg loexcm=0 hiexcm=3 excmtbl:.word unprot .word proto .word unlink .word news .endc ;proto -- produces a protocol file of a basic session ; call extend(1) proto: cmpb (r1)+,#.rpar ;check syntax bne erexts cmpb (r1)+,#.eol bne erexts progo: tst lineno(r5) blt lkj eriln: ertext iln, lkj: tstb ttyiof beq 1$ ertext pro, 1$: jsr r1,msg .byte cr .ascii /protocolling/ .byte cr,0 .even $creat .word protnm .word protec bcc 2$ ertext niu, 2$: movb r0,ttyiof jmp ready ;unprot -- stop protocolling unprot: cmpb (r1)+,#.rpar bne erexts cmpb (r1)+,#.eol bne erexts uprogo: tstb ttyiof bne 1$ ertext npr, 1$: tst lineno(r5) bge eriln jsr r1,msg .byte cr .ascii /end protocol/ .byte cr,0 .even movb ttyiof,r0 $close clrb ttyiof jmp ready ;unlink -- unlink a file from the current directory ; or other directory if specified. by mwd. unlink: cmpb (r1)+,#.comma bne erexts call ovltst cmpb (r1)+,#.rpar bne erexts ulnk2: cmpb (r1)+,#.eol bne erexts call filspec .word filtab $unlink filhdr bcc 1$ jmp erfnd 1$: jmp execute .ifdf $mortok ulkgo: call ovltst br ulnk2 .endc ;----------------------------------------------------------------------- ;news -- to print the current information on new features. ; news: cmpb (r1)+,#.rpar bne nwserr newsgo: mov #newsf,r0 mov #^d15,r3 jsr pc,filspec .word dfexos mov #040000,r2 jsr pc,opnsys movb #6,idev(r5) clrb odev(r5) 1$: jsr pc,getchar bcs 2$ jsr pc,putchar br 1$ 2$: jsr pc,closys jmp ready nwserr: jmp errsyn newsf: .asciz '/lib/basic/news' ;-------------------------------------------------------------------- ;shell -- top level exit to shell ; courtesy of bob case shell: push r0 ;i'm not sure i need this, but just in case call usig ;unsignal everything $fork ;create new process br rshell ;new process return bcs sherr ;if not able to fork $wait ;otherwise wait for child to die call resig ;resignal for everything pop r0 ; restore regs when you wake up jmp ready ;let the usr know he's back rshell: $exec ;execute the shell in the new process rshnam rsharg jsr r1,msgerr ;can't do it .asciz 'shell not found' .even $exit ;if you can't then kill yourself sherr: call resig ;resignal for everything ertext fkf, rshnam: .asciz '/bin/sh' .even rsharg: .word rshnam .word 0 resig: $sig ;signal for ^z 2 break $sig ;signal for ^x 3 break $sig ;signal for emt traps 7 bomb $sig ;signal for floating point exceptions ^d8 $fperr ret usig: $sig 7 1 $sig 8. 1 $sig 3 1 $sig 2 1 ret ;----------------------------------------------------------------- ; control z handler break: push r0 $sig ;resignal for ^z 2 break $sig ;resignal for ^x 3 break tstb iflg ;in slow wait? beq cont ;no -- so keep going until clean point clrb iflg ;yes - so clear the flag and jump to stop msg jmp stop cont: incb cncflg(r5) ;set the ^c flag and go back to where you were pop r0 rti ;---------------------------------------------------------------------- ; putchar -- puts one character into the buffer ; of the device specified by unit # in odev. ; uses block to address next byte of the buffer. putchar:push r1 tst r0 beq 8$ cmp r0,#lf ;ignore line feeds bne 1$ 8$: pop r1 ret 1$: cmp r0,#cr ;make crs into lfs bne 2$ mov #lf,r0 clr @column(r5) 2$: add r0,rndct(r5) ;add into random seed bit #40,r0 ;printing char? bne 3$ cmp #^o11,r0 ;tab bne 4$ bis #7,@column(r5) ;adjust for tab 3$: inc @column(r5) 4$: movb odev(r5),r1 ;get unit # beq 6$ mov #$bufsz,bufsiz push r0 call block 7$: pop r0 movb r0,@fnext(r1) 9$: pop r1 ret 6$: mov #ttyho,r1 push r0 mov #1,r0 mov #^d80,bufsiz call block1 movb (sp),@fnext(r1) cmpb (sp)+,#lf bne 9$ mov #1,r0 ;the fh-rb-jrs-psl-r.silveman(??!) memorial bug call dumpbf br 9$ ;--------------------------------------------------------------------- ; getchar -- gets a character from input buffer. very much the ; same as putchar. getchar:movb idev(r5),r1 ;get unit # call block bcc 1$ ;got one!!!!! ret ;didn't get one.(shucks) 1$: movb @fnext(r1),r0 ;get it out of buffer cmpb r0,#^o101 ;case conversion blt 2$ cmpb r0,#^o132 bgt 3$ add #^o40,r0 2$: cmp r0,#cr beq getchar cmp r0,#lf bne 3$ mov #cr,r0 3$: add r0,rndct(r5) clc ;return with no error ret ;---------------------------------------------------------------------- ; block -- address next byte if i/o buffer. does file input or ; output if necessary to clear or fill buff before the next ; byte can be addressed. block: tst r1 beq usetty ;if unit # is 0, device is tty movb devtab(r1),r0 ;get file cookie call filea ;address file header block1: dec @fbufe(r1) ;decrement count bge 1$ ;buffer must be filled or cleared call newbuf ;do necessary i/0 dec @fbufe(r1) 1$: inc fnext(r1) ;address the next byte ret ;---------------------------------------------------------------------- usetty: mov #ttyhd,r1 ;file header for tty dec @fbufe(r1) ;decrement count bge 1$ push r1 mov #1,r0 mov #ttyho,r1 mov #^d80,bufsiz call dumpbf ;dump output tty buffer pop r1 clr r0 call getmor ;get another buffer full dec @fbufe(r1) 1$: inc fnext(r1) ;address next byte ret ;--------------------------------------------------------------------- ; newbuf, dumpbf, and fillbf handle file i/o for block newbuf: bit #20000,(r1) ;input or output? beq fillbf ;input dumpbf: push r2 mov fbufe(r1),r2 ;points to count tst (r2) bpl 7$ inc (r2) 7$: sub bufsiz,(r2) neg (r2) mov (r2)+,wrtnby ;put it in wrtnby mov r2,wrtbuf ;buffer address in wrtbuf .ifdf $ext ;protocolling code cmp r0,#1 bne 3$ movb ttyiof,r0 beq 2$ $indir wrtsys jsr pc,fioerr ; ##stt-4/13/76 will return if no error 2$: mov #1,r0 3$: .endc $indir ;$write call wrtsys bcc 1$ ; tstb odev(r5) ; beq 66$ jsr pc,fioerr ; ##stt-4/13/76 will return if no error ;66$: $exit 1$: mov bufsiz,-(r2) inc r2 mov r2,fnext(r1) ;fnext pts to 1st byte of buf pop r2 ret fillbf: push r2 mov fbufe(r1),r2 tst (r2)+ mov r2,rdbuf ;buffer address to rdbuf mov #$bufsz,rdnby ;# of bytes to be read $indir ;$read call rdsys jsr pc,fioerr ; ##stt-4/13/76 will return if no error 1$: mov r0,-(r2) ;# of bytes read bne 2$ bis #1,-(r2) ;set eof bit if no chars read sec ;set carry bit to indicate eof br 3$ 2$: inc r2 mov r2,fnext(r1) ;set pointer clc ;clear c-bit for normal return 3$: pop r2 ret ;---------------------------------------------------------------------- ; getmor -- gets a line from the tty into the tty buffer getmor: push r2 mov fbufe(r1),r2 ;pt to tty buf tst (r2)+ mov r2,rdbuf ;set up for $read mov #^d80,rdnby ;always try for 80 chars incb iflg $indir rdsys decb iflg jsr pc,fioerr ; ##stt-4/13/76 will return if no error 1$: mov r0,-(r2) bne 2$ jmp sysxit ;eof from tty means exit 2$: inc r2 ;fix pointers mov r2,fnext(r1) .ifdf $ext ;protocolling code tstb ttyiof beq 3$ mov r0,wrtnby inc r2 mov r2,wrtbuf movb ttyiof,r0 $indir wrtsys jsr pc,fioerr ; ##stt-4/13/76 will return if no error 3$: .endc pop r2 clc ;normal return ret ;---------------------------------------------------------------------- ;opnvf -- opens a virtual file. called from opnfil opnvf: $stat ;file exists? filhdr statsp bcc opanex ;yes bit #input$,(r1) ;for input? beq 1$ ;no jmp erfnd ;yes so error 1$: $creat ;create an output file filhdr protec bcc 2$ jmp erfnd ;create failed so cryptic msg 2$: $close ;close it $open ;then re-open it filhdr 2 ;for both reading and writing bcc exists ;its open ok jmp erfnd opanex: bit #input$,(r1) ;for input? bne 1$ ;yes $open ;open an output file filhdr 2 ;for both in and out puts bcc exists ;ok jmp erfnd 1$: bis #fdbwl$,(r1) $open ;open an input file filhdr 0 ;for input only bcc exists ;ok jmp erfnd ;---------------------------------------------------------------------- ; opnfil -- naturally enough, this routine opens a file for i/o. ; filspec has stored away the filename at filhdr. r1 contains ; the file table entry, t1(r5) the unit #, and t3 the ; "replace" indicator. allocates a buffer with allbuf. opnfil: jsr r4,savreg ;save regs mov t1(r5),r3 ;get the unit # tstb devtab(r3) ;is the file already open? beq opnok ;no jmp erchan ;yes opnok: bit #fdbra$,(r1) ;virtual file? bne opnvf bit #20000,(r1) ;for output? beq frin ;no $stat ;does file exist? filhdr statsp bcc opnit ;file exists so open it tst t3(r5) ;replace? bmi erfnd ;error - file doesn't exist create: $creat ;create the file filhdr protec ;with mode protec bcs erfnd ;creat bombed, print cryptic msg exists: movb r0,devtab(r3) ;save file cookie asl r3 bic #10000,(r1) ;we do not double buff our i/o mov r1,filtab(r3) ;save the file table entry call allbuf ;allocate the buffer bit #100000,(r1) ;sequential file? bne opnx ;no call seqio ;fix pointers to buffer ret opnx: add #2,fbufe(r1) clr @fbufe(r1) sub #2,fbufe(r1) clr fcurbl(r1) ;fcurbl=0 movb t1(r5),lunsav(r5) call rb ;read first block ret opnit: tst t3(r5) ;save? bgt errrpl ;error - file exists br create ;always create on replace ;always create seq files for output frin: $open ;open it filhdr 0 bcc exists erfnd: trap 0 ;file not found, protection failure,etc .ifdf $longer .asciz 'file not found' .iff .asciz 'fnf' .endc .even errrpl: trap 0 ;attempt to replace a file that .ifdf $longer ;doesn't exist .asciz 'replace or rename' .iff .asciz 'rpl' .endc .even ;--------------------------------------------------------- ; closch -- closes an open file. unit # in r0. ; writes last block of file if necessary, and ; releases the file's buffer with chainb. closch: push r1 mov r0,r1 ;get unit # in r1 tstb devtab(r1) ;file open? bne opnd ;yes so close it pop r1 sec ;set c-bit for error return ret opnd: push r0 ;save the unit # call filea bit #20000,(r1) ;output file? beq closit ;no bit #fdbra$,(r1) ;vf? beq 1$ ;no bit #fdbda$,(r1) ;dirty block? beq closit ;no mov (sp),lunsav(r5) call wb ;write the block br closit ;and close the channel 1$: call wlstbl ;yes so write last block closit: mov (sp),r3 ;get unit # movb devtab(r3),r0 ;get file cookie $close ;close the file clrb devtab(r3) ;remove entry from device table mov r3,t1(r5) sub #2,fbufe(r1) ;get ready to give back buffer call chainb ;give it back pop r0 pop r1 clc ;so basic will know that the file was open ret wlstbl: push r0 movb r0,odev(r5) mov #cr,r0 call putchar pop r0 cmp @fbufe(r1),#$bufsz ;anything to write? bge 1$ ;no movb devtab(r0),r0 call dumpbf 1$: ret ; closall -- closes all open files closall:clr r0 ;begin at the beginning 1$: inc r0 call closch ;close the file cmp r0,#$maxun+1+$maxun ;done all? blt 1$ ret ; fioerr -- i/o error - print msg and close all open files ; without writing last blocks. indicates a system error ; somewhere. fioerr: bcc 1$ ;if no error, return immed. cmp r0,#4 ;if ^c error, return immed. bne 2$ 1$: rts pc 2$: tst (sp)+ ;throw away return addr clr r0 ;begin at beginning fioer1: inc r0 tstb devtab(r0) ;file open? beq fioer1 ;check next one push #1$ push r1 push r0 br closit ;close without writing last block 1$: cmp r0,#$maxun+1+$maxun ;done? blt fioer1 trap 0 ;print msg .ifdf $longer .asciz 'file i/o error' .iff .asciz 'fio' .endc .even ;---------------------------------------------------------------------- ; setcol -- address column count for sequential files setcol: add #coltab,r2 ;address appropriate counter mov r2,column(r5) ;put address in column(r5) ret ;--------------------------------------------------------------------- ; sys -- leave basic and return to unix sysxit: call setty ;reset tty mode call closall ;close everything $exit ;au revoir !!! ;bye - types error message for now ... later may be logout bye: ertext sys, ;-------------------------------------------------------------------- ; iready, sreset, and rctrlo -- mainly dummy routines, since ; they do things we don't need. iready closes all files, the others ; do nothing at all. iready: call closall istart: sreset: rctrlo: ret ;------------------------------------------------------------------- ; datcom -- this is a stopgap routine that merely prints a ; significant date. will be replaced. datcom: push r1 mov #datest+3,r0 mov #dumdat,r1 mov (r1)+,(r0)+ mov (r1)+,(r0)+ mov (r1)+,(r0)+ mov (r1)+,(r0)+ movb (r1),(r0) pop r1 ret dumdat: .asciz '07-NOV-53' .even ;--------------------------------------------------------------------- ;tape and key -- set tty in or out of raw mode -- for use by tektronix ; graphics routines tape: jsr r1,msg ;print warning msg .byte cr .ascii /in graphics mode/ .byte cr,0 .even mov #2,r0 ;gttys and sttys on cookie 2 $gtty ;get the current tty mode ttymd bic #4,ttymd3 ;set for upper case mov #2,r0 $stty ;set to uc mode ttymd jmp ready key: call setty ;reset to old tty mode jsr r1,msg .byte cr .ascii /in tty mode/ .byte cr,0 .even jmp ready ;---------------------------------------------------------------------- ;setty -- sets tty back to mode in which basic was entered setty: mov #2,r0 $gtty ttymd mov oldmod,ttymd3 mov #2,r0 $stty ttymd ret ;----------------------------------------------------------------------- ;seekto -- seeks to the specified block of a vf for ; reading or writing seekto: push r0 push r2 push r3 mov fcurbl(r1),r2 ;get block # mul #^d128,r2 ;get # of bytes div #^d512,r2 ;convert it to 512 blocks mov #3,sekptr ;setup for seek mov r2,sekofs $indir ;seek to nearest 512 byte block seksys mov #1,sekptr mov r3,sekofs $indir ;seek to correct 128 byte block seksys bcc $2 ersob: ertext sob, $2: pop r3 pop r2 pop r0 ret ;---------------------------------------------------------------------- ;wb -- write a vf block as block fcurbl(r1) wbl: wb: push r0 movb lunsav(r5),r0 movb devtab(r0),r0 ;get file cookie call seekto ;seek to correct block mov fbufe(r1),wrtbuf ;setup for write call mov #$bufsz,wrtnby $indir ;write the block wrtsys jsr pc,fioerr ; ##stt-4/13/76 will return if no error 1$: pop r0 bic #fdbda$,(r1) ;indicate clean block ret ;-------------------------------------------------------------- ;rb,rnb -- read virtual file blocks rb: push r0 movb lunsav(r5),r0 movb devtab(r0),r0 ;get file cookie call seekto ;seek to correct block br rb1 rnb: push r0 inc fcurbl(r1) ;increment block number movb lunsav(r5),r0 movb devtab(r0),r0 ;get cookie rb1: mov fbufe(r1),rdbuf ;setup for read call mov #$bufsz,rdnby $indir ;read the block rdsys jsr pc,fioerr ; ##stt-4/13/76 will return if no error 1$: tst r0 ;if eof detected, bne 3$ bit #input$,(r1) ;and it is an input file, beq 2$ jmp ersob ;print err msg 2$: call zbuf ;if output file, then make sure the usr ;knows no file elements already exist on this block 3$: pop r0 bic #fdbda$,(r1) ;indicate a clean block ret zbuf: push fbufe(r1) mov fbufe(r1),r0 add #$bufsz,r0 1$: clr @fbufe(r1) ;zero the buffer add #2,fbufe(r1) cmp fbufe(r1),r0 ble 1$ pop fbufe(r1) ret ;----------------------------------------------------------------- ;vffnd -- address vf element vffnd: call vfget ;get lun and ss vffndl: push r1 movb lunsav(r5),r1 tstb devtab(r1) ;make sure the file is open bne 1$ jmp errfno 1$: call filea ;address the fil table entry mov (r1),r0 bic #177400,r0 ;get element size in r0 push r0 call vfblk ;calculate blk # and offset cmp fcurbl(r1),r0 ;is this element on the current blk? beq advfe ;then no need to change blks bit #fdbda$,(r1) ;dirty block? beq 2$ call wb ;if dirty, then write the block 2$: mov r0,fcurbl(r1) call rb ;get to the correct blk advfe: add fbufe(r1),r2 ;add the offset to the buffer address mov r1,r3 pop r0 pop r1 ret ;--------------------------------------------------------------------- ;vfblk -- calculates blk # and offset for vfs vfblk: push r1 push r0 call int ;integerize the ss pop r0 tst fac1(r5) beq vfok tst fac2(r5) bgt vfok error: ertext iss, vfok: mul fac2(r5),r0 ;ss*ele.size bcs error ;----------- = blk # div #^d128,r0 ; 128 remainder=offset mov r1,r2 pop r1 ret ;-------------------------------------------------------------------- ; default names and extensions dfexos: .asciz '.bas' ;ext. for old and save dfexop: .asciz '.dat' ;ext. for open namdef: .asciz 'noname' ;def. filename protnm: .asciz /basic.protocol/ ;protocol filename .even ;---------------------------------------------------------------------- ; assorted error messages deverr: trap 0 .ifdf $longer .asciz 'device not ready' .iff .asciz 'dnr' .endc .even errfno: trap 0 .ifdf $longer .asciz 'file not open' .iff .asciz 'fno' .endc .even errfpv: ertext fpv, errwlo: trap 0 .ifdf $longer .asciz 'write lockout' .iff .asciz 'wlo' .endc .even ;---------------------------------------------------------------------- .loseg ; headr -- prints out run and list headers with version, date, and ; program name. headr: jsr r4,savreg mov #head1,r2 ;where to put name mov #prognm,r4 ;where to get it add r5,r4 1$: tstb (r4) ;end of name? beq pad ;yes movb (r4)+,(r2)+ ;move a character br 1$ pad: movb #' ,(r2)+ ;pad with blanks cmp r2,#head1+$pnamsz+2 ;filled up? blo pad ;no prinit: call datcom ;compute date jsr r1,msg head1: .blkb $pnamsz+2 datest=.-3 .blkb ^d9 .byte cr,lf,lf,0 .even ret ;---------------------------------------------------------------------- ; basics data area - goes in loseg .loseg usrarea:.resw .ifdf $matrix numsav: .resw 2 ;save for num fn detsav: .resw 2 ;save for det fun mtarg1: .resw mtarg2: .resw mtres: .resw ss1: .resw ss2: .resw ss3: .resw ss3sav: .resw mtlim: .resw mtbig: .resw 2 mtip: .resw mtsw: .resw mtsiz: .resw mtpiv: .resw mtlu: .resw .endc fnamsz: .resw filhdr: .resw $pnamsz+2 statsp: ttymd: .resw 2 ttymd3: .resw <^d16> coltab: .resw $maxun+2 filtab: .resw $maxun+2+$maxun devtab: .resb $maxun+2+$maxun ttybuf: .resb <^d84> ttyiof: .resb iflg: .resb .even oldmod: .resw comfil: combuf=comfil+10 .resw $bufsz+14 rdsys: $read rdbuf: 0 rdnby: 0 wrtsys: $write wrtbuf: 0 wrtnby: 0 seksys: $seek sekofs: 0 sekptr: 0 ttyhd: 0 0 ttybuf+2 ttybuf+3 ttyho: outpt$ 0 ttybof+2 ttybof+3 bufsiz: 0 ttybof: 0 ^d80 .blkb ^d80 .end namsz: .resw filhdr: .resw $pnamsz+2 statsp: ttymd: .resw 2 ttymd3: .resw <^d16> coltab: .resw $maxun+2 filtab: .resw $maxun+2+$maxun devtab: .resb $maxun+2+$maxun ttybuf: .resb <^d84> ttyiof: .resb iflg: .resb .even oldmod: .resw comfil: combuf=comfil+10 .resw $bufsz+14 rdsys: $read rdbuf: 0 rdnby: 0 wrtsys: $write wrtbuf: 0 wrtnby: 0 seksys: $seek sekofs: 0 sekptr: 0 ttyhd: 0 0 ttybuf+2 ttybuf+3 ttyho: outpt$ 0 ttybo.title basicx v02-01 execution ;basic kernel v02-01 ; ;the information in this document is subject to change ;without notice and should not be construed as a ;commitment by digital equipment corporation. digital ;equipment corporation assumes no responsibility for any ;errors that may appear in this document. ; ;the software described in this document is furnished ;to the purchaser under a license for use on a single ;computer system and can be copied (with inclusion of ;digital's copyright notice) only for use in such system, ;except as may otherwise be provided in writing by ;digital. ; ;digital equipment corporation assumes no responsibility ;for the use or reliability of its software on equipment ;that is not supplied by digital. ; ;copyright (c) 1974 ;by digital equipment corporation ;146 main street ;maynard, massachusetts 01754 ; ;january 1974 ; .hiseg .ifdf $ovlay ; execution overlay dispatch execx: asl r2 mov tablex(r2),pc tablex: .ifdf $vf .word letvf ;special case-- 'vf =' .endc ;$vf .ifndf $vf .word errsyn .endc ;$vf .word for .word gosub .word goto .word on .word if .word input .word input ;linput .word let .word next .word print .ifdf $matrix .word matbeg .endc .word return .word restore .word restore ;reset .word read .word call .word ifend .ifdf $vf .word letvf .endc ;$vf .ifndf $vf .word errsyn .endc ;$vf .word callimp .endc ;$ovlay .ifdf $vf ; 'letvf' statement ;the algorithm here is to evaluate letvf: jsr pc,vfget ;the rhs first and then the left hand mov fac2(r5),-(sp) ;save the subscript and lun to avoid mov fac1(r5),-(sp) ;double evaluation of the lhs. movb lunsav(r5),-(sp) ;low order byte will be saved and restored. cmpb #.eq,(r1)+ ; beq letvf1 letve0: jmp errsyn letvf1: jsr pc,eval ;this may result in another data block bcs letvf2 ;of the same file on the same lun mov fac2(r5),-(sp) ;being read in, but since the rhs mov fac1(r5),-(sp) ;is evaluated first, things work properly. clr -(sp) ;eval returned a numeric value which br letvf3 ;has just been saved on the stack. letvf2: mov @sp,-(sp) ;the stack frame at letvf3 is as follows: mov @sp,-(sp) ; number string ; ;12(sp): low order lhs subscript ;10(sp): high order lhs subscript ;6(sp): lun of the lhs letvf3: cmpb #.eol,(r1)+ ; bne letve0 ;4(sp):fac2 stg. ptr. ;2(sp):fac1 stg. ptr. ;@sp :0 stg. ptr. movb 6(sp),lunsav(r5) ;now restore the file context mov 10(sp),fac1(r5) ;of the lhs and call vffnd at a late entry mov 12(sp),fac2(r5) mov r1,12(sp) ;save r1 since it may be used down below. jsr pc,vffndl ;address and access the correct block mov r3,t3(r5) ;save the fdb adr. since r3 is used for scratch letv3a: bit #fdbwl$,@r3 ;declare an error if the file is write locked. beq letv3d ;ok -- bypass error jmp. jmp errfpv letv3d: bit #fdbse$,@r3 ;now do type matching and checking bne letvf6 ;string elements. tst (sp)+ ;numeric file...see if numeric rhs beq letv3b ;ok so far. now check real vs integer. letve2: jmp errmix ;data type mismatch letv3b: bit #fdbie$,@r3 ;integer elements? beq letvf4 ;no mov (sp)+,fac1(r5) ;see if the number can be mov (sp)+,fac2(r5) ;integerized; if not, declare jsr pc,int ;an error mov fac2(r5),-(sp) tst fac1(r5) ;if(fac1(r5)><0), error. beq letvf5 ;ok. ertext idt, letvf4: tst @sp ;this basic will retain numeric variables bne letv4a ;as integers as long as possible to speed tst (sp)+ ;$ir takes only one argument. jsr r4,fppsav ;computation. however, a data file which .word $ir ;is supposed to contain real elements .word fppres ;should not have integers mixed in. letv4a: mov (sp)+,(r2)+ ;set high order fac letvf5: mov (sp)+,(r2)+ ;set low order fac br letvf9 letvf6: mov (sp)+,r1 ;r1 = pointer to the temporary string element beq letve2 ;0 => numeric rhs. clr r3 inc r1 ;if() then = -1 beq letv6a bisb @(sp)+,r3 ;bisb to avoid the sign extend. cmpb (r1)+,(r1)+ ;point to the beginning of the stg. br letvf7 letv6a: tst (sp)+ letvf7: mov r0,-(sp) bpl letv7a ;if length < 0, this stg. crosses a blk. neg r0 letv7a: movb (r1)+,(r2)+ ;move the string into the data buffer dec r3 ;and pad with blanks if short. bpl letvf8 clrb -(r2) ;delimit the stg. with nulls!!!!!!!!! inc r2 letvf8: dec r0 ;the data element stg. length set by vffnd bne letv7a tst @sp ;check for crossing block boundary bmi letv8b ;- is yes. letv8a: tst (sp)+ ;no. exit normally. br letv8c letv8b: jsr pc,wbl ;first, write the current blk. jsr pc,rnb ;then read the next (sequential) block add (sp)+,r0 ;calculate the remainder br letvf7 ;finish writing the string. letv8c: tst (sp)+ ;pop the stack for an early exit. letvf9: cmp (sp)+,(sp)+ mov (sp)+,r1 ;now restore the code ptr. bis #fdbda$,@t3(r5) ;set the dirty bit. jmp execute vfget: mov r1,r3 ;vfget is also called from basics (vffnd) jsr pc,liteval ;the vf lun must be a literal. br letve1 ;syntax error. tst fac1(r5) ;check lun integrity bne letve1 ;must be int. cmp fac2(r5),#$maxun bgt letve1 tst fac2(r5) ble letve1 add #$vfoff,fac2(r5) movb fac2(r5),lunsav(r5) mov r3,r1 ;restore updated code pointer. cmpb #.lpar,(r1)+ ; the ss must start here. bne letve1 jsr pc,eval ;evaluate the ss bcs erltva ;it can't be a string tst fac1(r5) bmi erltva bpl 1$ tst fac2(r5) bmi erltva 1$: cmpb #.rpar,(r1)+ bne letve1 rts pc letve1: jmp errsyn erltva: jmp errarg .endc ;$vf ; 'call' statement ; call "prog" (...) call: jsr pc,fndstr tst r3 beq errfn1 ; init table search call1: jsr pc,gtftabi ;addr of usr fn table in r2 on rtn beq errfn1 ;no functions defined mov r2,-(sp) ;save on stack ; check end table (this is in search loop) callck: tst (r2) beq errfn1 ; check that (r3) chars match mov r0,-(sp) mov r3,-(sp) callm1: cmpb (r0)+,(r2)+ bne callnm dec r3 bne callm1 ; check that 4-(r3) chars are 0 in table sub (sp),r3 add #4,r3 blt errfn1 beq callx callm2: tstb (r2)+ bne callnm dec r3 bne callm2 ; return answer callx: add #6,sp ;pop stack mov (r2),r2 beq errfn1 mov r1,-(sp) mov r4,-(sp) mov r5,-(sp) jsr pc,(r2) ;call user's subroutine calret: mov (sp)+,r5 mov (sp)+,r4 ;restore registers mov (sp)+,r1 jmp ignore ;go to next program line errfn1: jmp errufn errsx1: jmp errsyn ; advance to next table entry callnm: mov (sp)+,r3 mov (sp)+,r0 add #6,(sp) mov (sp),r2 br callck ; implied call statement, bs 1/74 ; any line beginning with a .text comes here ; two or more consecutive alphabetic characters are converted by tran ; into a .text literal, up to, but not including a ( callimp:jsr pc,fndetxt ;name can't be null so don't check cmp r3,#4 ;check for syntax error ble call1 ;ok, name not too long br errsx1 ;probably a syntax error ; 'let' statement routine let: movb (r1)+,r2 bmi errsx1 ;not a pointer. swab r2 bisb (r1)+,r2 add (r5),r2 assign: jsr pc,getvar cmpb (r1)+,#.eq bne errsx1 ;not eqsign. jsr pc,eval ;evaluate expression .ifndf $nostr bcs assstr ;branch if string value .endc ;$nostr cmpb (r1)+,#.eol ;check syntax bne errsx1 jsr pc,stovar ;store numeric variable exjmp: jmp execute .ifndf $nostr assstr: cmpb (r1)+,#.eol ;check syntax bne errsx1 ;store string variable jsr pc,stosvar br exjmp .endc ;$nostr ; 'if' statement routine if: jsr pc,eval ;evaluate lhs of expression bcc ifnumer cmpb (r1),#.le ;string if statement blo errsx1 ;check relational operator cmpb (r1),#.eq bhi errsx1 cmp sp,r4 blo errpd3 movb (r1)+,-(sp) ;push relation on stack jsr pc,eval ;evaluate rhs .ifndf $nostr bcc errmx4 ;rhs must match lhs .endc ;$nostr mov (sp)+,r3 ; mov (sp)+,r0 mov (sp)+,r2 mov r0,-(sp) ; clr -(sp) cmp r2,#-1 beq if1 bisb (r2),(sp) if1: clr r0 cmp r3,#-1 beq if2 bisb (r3),r0 if2: add #3,r2 add #3,r3 br if3 ifloop: cmpb (r3)+,(r2)+ ;compare strings bne ifcomp if3: dec r0 blt iflend dec (sp) bge ifloop if4: cmpb (r3)+,#bl bne ifcomp dec r0 bge if4 br ifseq iflend: tst (sp) ble ifseq if5: cmpb #bl,(r2)+ bne ifcomp dec (sp) bgt if5 ifseq: tst (sp)+ mov (sp)+,r0 ifleqr: movb (r1)+,r2 cmpb r2,#.then beq if6 cmpb r2,#.goto bne errsx7 if6: cmpb r0,#.le beq ifxtnd cmpb r0,#.ge beq ifxtnd cmpb r0,#.eq beq ifxtnd br ifign errsx7: jmp errsx5 ifcomp: blt ifsgt tst (sp)+ mov (sp)+,r0 br iflltr ifnumer:cmpb (r1),#.le ;numeric if blo errsx7 cmpb (r1),#.eq ;check relational operator bhi errsx7 cmp sp,r4 blo errpd3 mov fac2(r5),-(sp) ;save value of lhs on stack mov fac1(r5),-(sp) movb (r1)+,-(sp) ;save relation on stack jsr pc,eval ;evaluate lhs .ifndf $nostr bcs errmx4 ;it must be numeric also .endc ;$nostr mov (sp)+,r0 jsr pc,substk beq ifleqr blt iflgtr iflltr: movb (r1)+,r2 cmpb r2,#.then beq if7 cmpb r2,#.goto bne errsx7 if7: cmpb r0,#.le beq ifxtnd cmpb r0,#.lt beq ifxtnd cmpb r0,#.ne beq ifxtnd br ifign errpd3: jmp errpdl .ifndf $nostr errmx4: jmp errmix .endc ;$nostr ifsgt: tst (sp)+ mov (sp)+,r0 iflgtr: movb (r1)+,r2 cmpb r2,#.then beq if8 cmpb r2,#.goto bne errsx7 if8: cmpb r0,#.ge beq ifxtnd cmpb r0,#.gt beq ifxtnd cmpb r0,#.ne beq ifxtnd br ifign ; extended if statement routine, bs 1/74 ; if and if end come here when condition statisfied ; checks for extended form of if statement: ; if then ; if standard form, branches into goto routine ; no "else" ; on entry, r1 points to byte after .then or .goto ; next item might be line number, keyword token, or symbol reference ; (implied let) ifxtnd: mov r1,r3 ;fline moves r1 an arbitrary amount jsr pc,fline ;check for line number bcc goto1 ;normal if mov r3,r1 ;restore r1 cmpb -1(r1),#.goto ;if goto not allowed beq errsx6 ;errsyn (in goto) cmpb (r1),#.eol ;if then not allowed bne gogo ;jmp execute (in goto), save one word br errsx6 ;errsyn (in goto) ; if ignore ifign: cmpb (r1),#.eol ;then or goto followed immmediately by .eol beq errsx6 ;is an error mov r1,r3 ;save it (fline moves r1 an arbitrary amount) jsr pc,fline ;is there a line number next? bcc ifign2 ;yes ifign1: mov r3,r1 ;restore jsr pc,skipeol ;this is an extended if cmpb (r1),#.eof ;don't go off the end beq gogo ;jmp execute (in goto) mov r1,r3 jsr pc,fline ;we must find the next line bcs ifign1 ;keep going tst -(r2) ;point back at line number (not address) jmp ex3 ;part of execute ifign2: cmpb (r1),#.eol ;and next thing better be .eol beq gogo ;ok, jmp execute br errsx6 ;syntax err ; 'if end #' statement ifend: movb idev(r5),-(sp) ;this may not be necessary!!!! jsr pc,chkiset ;set up the appropriate information .ifdf $..$ bit #input$,@cfdba(r5) ;chkiset may also wind up doing ;this in which case this would be deleted bne ifend3 jmp erchan ;inaccurate diagnostic? ifend3: .endc ;$..$ movb (r1)+,r0 ;get next token cmpb r0,#.then ;check legal beq ifend0 cmpb r0,#.goto bne errsx6 ifend0: mov r1,-(sp) .ifdf $pts br ifend4 ;don't advance first time .endc ;$pts ifend1: .ifdf $pts jsr pc,getchar ifend4: .endc ;$pts mov fac2(r5),r1 ;channel no. in r1 jsr pc,block ;address next char bcc ifend2 ;no eof, bypass mov (sp)+,r1 ;eof -- restore r1 movb (sp)+,idev(r5) ;again, unncessary if done by chliset br ifxtnd ;check for extended if .ifdf hvunix ifend2: tstb @fnext(r1) beq ifend1 cmpb @fnext(r1),#ff beq ifend1 .iff ifend2: tstb @r1 beq ifend1 ;ignore nulls cmpb @r1,#ff beq ifend1 ;also ignore form feeds cmpb @r1,#lf ;check for line feed beq ifend1 ;ignore it, too cmpb @r1,#rubout ;rubouts, too beq ifend1 .endc .ifdf $..$ mov cfdba(r5),r0 ;decrement the byte pointer to the char. buffwr dec fdbdaw(r0) .endc ;$..$ .ifdf hvunix dec fnext(r1) inc @fbufe(r1) .endc mov (sp)+,r1 ;restore r1 movb (sp)+,idev(r5) ;!!!!!!!!!!!!!!!!!!!!!!!!!!!!! br ifign ; 'gosub' and 'goto' statements gosub: goto: jsr pc,fline ;look up line number bcs errsx6 goto1: cmpb (r1)+,#.eol ;check eol token bne errsx6 tst (r2) ;check undefined line number beq errgoto cmpb -4(r1),#.gosub ;is this a gosub bne gonosav gosub1: mov gsbctr(r5),r3 ;if so, push return address on gosub-stack asl r3 ;which is stored after pdl, .ifdf hvunix sub #3,r1 ;go back a few bytes ;return will skipeol add arrays(r5),r3 .iff add pdl(r5),r3 .endc cmp r3,limit(r5) ;checking for overflow bhi errdeep mov r1,(r3) inc gsbctr(r5) gonosav:mov (r2),r1 ;give control to first line of subroutine gogo: jmp execute errdeep:trap 0 .ifndf $longer .ascii \gnd\ .endc ;$longer .ifdf $longer .ascii 'gosubs nested too deeply' .endc ;$longer .byte 0 .even errsx6: jmp errsyn errgoto:jmp errgo ; on goto and on gosub statements, bs 1/74 on: jsr pc,eval ;evaluate expression bcs errsx6 ;string, errsyn (in goto) jsr pc,int jsr pc,int16 ;integerize bcs onerr ;not in range 0<=x<2^16 mov fac2(r5),r3 ;r3 is index ble onerr ;0 or >=2^15 mov r1,-(sp) ;save position of .goto or .gosub inc r1 ;now find corresponding line number online: jsr pc,fline ;find line number reference bcs errsx6 ;no, errsyn (in goto) dec r3 ;decrement index beq onkywrd ;found corresponding line number cmpb (r1)+,#.comma ;comma is the only valid delimiter beq online ;try next cmpb -(r1),#.eol ;have we run out of line numbers? beq onerr ;yes br errsx6 ;bad delimiter onkywrd:tst (r2) ;check for undefined line number beq errgoto movb @(sp)+,r3 ;check for .goto or .gosub token cmpb r3,#.goto ;goto? beq gonosav cmpb r3,#.then ;dartmouth standard beq gonosav cmpb r3,#.gosub ;gosub? beq gosub1 br errsx6 ;not a valid separating token onerr: trap 0 .ifndf $longer .ascii \oor\ .endc ;$longer .ifdf $longer .ascii 'on out of range' .endc ;$longer .byte 0 .even ; 'restore' statement .ifndf $disk restore:mov #-1,@pdl(r5) jmp execute .endc ;$disk .ifdf $disk restore:cmpb (r1),#.eol bne rest1 .ifdf hvunix mov #-1,@arrays(r5) .iff mov #-1,@pdl(r5) .endc jmp execute rest1: jmp restj .endc ;$disk ; 'return' statement return: cmpb (r1)+,#.eol ;check syntax bne errsx6 mov gsbctr(r5),r3 ;pop return address from gosub stack cmp r3,#33 ;if stack empty, error beq errret ;if return loc is 0, error dec r3 mov r3,gsbctr(r5) asl r3 .ifdf hvunix add arrays(r5),r3 .iff add pdl(r5),r3 .endc tst (r3) beq errret mov (r3),r1 .ifdf hvunix jsr pc,skipeol .endc jmp execute .ifndf $nostr errmx5: jmp errmix .endc ;$nostr errret: trap 0 .ifndf $longer .ascii \rbg\ .endc ;$longer .ifdf $longer .ascii 'return before gosub' .endc ;$longer .byte 0 .even ; 'for' statement for: mov r1,-(sp) dec (sp) ;(loc of the 'for') movb (r1)+,r2 bmi errsx6 swab r2 bisb (r1)+,r2 ;address running variable in symbol table add (r5),r2 cmp (r2),#.svar ;it must not be a string variable beq errsx6 cmpb (r1)+,#.eq ;check "-" bne errsx6 mov r2,varsav(r5) ;(var of the for) jsr pc,eval ;evaluate start variable .ifndf $nostr bcs errmx5 .endc ;$nostr mov #-1,ss1sav(r5) ;force to scalar. jsr pc,stovar ;save as value of running variable cmpb (r1)+,#.to ;check 'to' keyword bne errsx6 jsr pc,eval ;evaluate limit of for .ifndf $nostr bcs errmx5 .endc ;$nostr mov fac1(r5),ss1sav(r5) mov fac2(r5),ss2sav(r5);(limit of the for) clr fac1(r5) mov #1,fac2(r5) ;assumed step is 1.0 cmpb (r1),#.eol ;check end of line beq forone cmpb (r1)+,#.step ;check optional 'step' keyword bne ersx10 jsr pc,eval ;evaluate the step size .ifndf $nostr bcs errmx5 .endc ;$nostr cmpb (r1),#.eol ;check end of line bne ersx10 forone: inc r1 mov lineno(r5),r3 br forlook forskip:jsr pc,skipeol forlook:movb (r1),r2 bmi fornol inc r1 swab r2 bisb (r1)+,r2 add (r5),r2 cmp (r2),#.scalar bhis fornol mov (r2),r3 ;(the lineno while looking) fornol: cmpb (r1),#.eof beq err4wo cmpb (r1),#.next ;the code is now being searched beq fornext ;foreward from the 'for' for a next with cmpb (r1),#.for ;the same var. if 'eof' or another 'for' bne forskip ;with the same var is found first:error. inc r1 movb (r1),r2 bmi forskip inc r1 swab r2 bisb (r1)+,r2 add (r5),r2 cmp r2,varsav(r5) bne forskip err4wo: trap 0 .ifndf $longer .ascii 'fwn' .endc ;$longer .ifdf $longer .ascii 'for without next' .endc ;$longer .byte 0 .even fornext:add #13,r1 movb (r1),r2 bmi forskip inc r1 swab r2 bisb (r1)+,r2 add (r5),r2 cmp r2,varsav(r5) bne forskip cmpb (r1),#.eol bne ersx10 sub #14,r1 movb 1(sp),(r1)+ ;put addr of the 'for' after the 'next'. movb (sp),(r1)+ ;(thats what the 2+4+4 bytes are for) movb ss1sav+1(r5),(r1)+;put the limit after that. movb ss1sav(r5),(r1)+ movb ss2sav+1(r5),(r1)+ movb ss2sav(r5),(r1)+ movb fac1+1(r5),(r1)+ ;put the step after that. movb fac1(r5),(r1)+ movb fac2+1(r5),(r1)+ movb fac2(r5),(r1)+ mov r3,(sp) ;put the search lineno on the stack. mov fac1(r5),-(sp) ;put sgn(step) on the stack. bne for1 mov fac2(r5),(sp) for1: mov ss2sav(r5),-(sp) ;put the limit on the stack. mov ss1sav(r5),-(sp) jsr pc,eval ;get the current value of the index. jsr pc,substk ;subtract the limit. beq forgogo bmi forltlm forgtlm:tst (sp)+ bmi forgo br forzero ersx10: jmp errsx5 forltlm:tst (sp)+ bpl forgo forzero:mov (sp)+,lineno(r5) clrb -14(r1) clrb -13(r1) inc r1 jmp execute forgogo:tst (sp)+ forgo: tst (sp)+ movb -13(r1),-(sp) movb -14(r1),1(sp) mov (sp)+,r1 jmp ignore ; 'next' statement next: clr r2 ;get symtab reference in r2 bisb (r1)+,r2 swab r2 bisb (r1)+,r2 cmp r2,lofree(r5) ;just to prevent an nxm trap. bhis errnext cmpb (r2)+,#.for bne errnext add #10,r1 movb (r1)+,r3 bmi errsx2 swab r3 bisb (r1),r3 add (r5),r3 dec r1 cmpb (r1)+,(r2)+ bne errnext cmpb (r1),(r2)+ bne errnext cmpb (r2),#.eq bne errnext mov r3,varsav(r5) ;save variable address. cmp (r3),#.svar beq errsx2 cmp (r3)+,#.scalar beq next1 mov (r3),r3 next1: mov (r3)+,fac1(r5) ;put the for var value into fac. mov (r3),fac2(r5) dec r1 movb -(r1),-(sp) ;put step on the stack. movb -(r1),1(sp) movb -(r1),-(sp) movb -(r1),1(sp) mov (sp),ss2sav(r5) ;save sgn(step). bne next2 mov 2(sp),ss2sav(r5) next2: jsr pc,addstk mov fac2(r5),-(sp) mov fac1(r5),-(sp) movb -(r1),-(sp) movb -(r1),1(sp) movb -(r1),-(sp) movb -(r1),1(sp) jsr pc,substk beq nexgo bmi nexltlm nexgtlm:tst ss2sav(r5) bmi nexgo br nexend nexltlm:tst ss2sav(r5) bpl nexgo nexend: clrb -(r1) clrb -(r1) add #15,r1 cmp (sp)+,(sp)+ ;throw away incremented index. jmp execute nexgo: movb -(r1),-(sp) movb -(r1),1(sp) mov (sp)+,r1 mov (sp)+,fac1(r5) ;store the incremented index. mov (sp)+,fac2(r5) mov #-1,ss1sav(r5) jsr pc,stovar jmp ignore errnext:trap 0 .ifndf $longer .ascii \nbf\ .endc ;$longer .ifdf $longer .ascii 'next before for' .endc ;$longer .byte 0 .even errsx2: jmp errsx5 .ifndf $nopru ; 'print using' statement errpru: jmp errsyn pru: inc r1 ;step over .using token .ifndf $nostr jsr pc,eval ;evaluate format picture bcc errpru ;must be string .endc ;$nostr .ifdf $nostr jsr pc,fndstr mov r3,-(sp) ;save length mov r0,-(sp) ;and addr of format string .endc ;$nostr clr -(sp) ;init # chars used so far pru1: cmpb (r1)+,#.comma ;check ',' in stmt beq pru3 ;yes cmpb -1(r1),#.semi ;no, check end of line beq pru2 dec r1 jsr pc,princr ;if no ';' print cr pru2: cmpb (r1),#.eol bne errpru cmp (sp)+,(sp)+ ;pop stack .ifdf $nostr tst (sp)+ ;pop length from stk .endc ;$nostr jmp prijmp ;go to next progr line pru3: .ifdf $nostr clr -(sp) ;dummy to keep stk depth constant cmpb (r1),#.squot ;is next item str literal? beq pru3a ;yes cmpb (r1),#.dquot bne pru3b ;no pru3a: jsr pc,fndstr ;translate it mov r3,(sp) ;save length mov r0,-(sp) ;and addr br pru4 .endc ;$nostr pru3b: jsr pc,eval ;evaluate next variable bcs pru4 clr -(sp) ;0 means numeric pru4: mov r4,-(sp) ;save basic's r4 mov r1,-(sp) ; and r1 clr -(sp) ;create format table mov sp,r4 ;at (r4) mov #11,r0 ; (on stack) pru5: clr -(sp) sob r0,pru5 pru5a: mov r4,r3 .ifndf $nostr add #12,r3 ;r3 addresses format picture mov (r3),r2 ;get it clr r0 cmp r2,#-1 ;is it null beq errpru ;yes,error bisb (r2)+,r0 ;r0 is length cmpb (r2)+,(r2)+ ;r2 addresses chars .endc ;$nostr .ifdf $nostr add #16,r3 mov (r3),r0 ;length beq errpru ;0=error mov -(r3),r2 ;r2 pts to string .endc ;$nostr add -(r3),r2 ;adjust for # chars used so far sub (r3),r0 bgt pru5b clr (r3) ;no more, back up counter jsr pc,princr ;print br pru5a ;start format over again pru5b: jsr pc,format ;decipher format mov 6(r4),r1 ;get argument indicator beq pru12 ;real, bypass tstb strflg(r4) ;string, check format is too beq errpru ;no, error .ifndf $nostr clr -(sp) cmp r1,#-1 ;is string null? .endc ;$nostr .ifdf $nostr mov 10(r4),-(sp) ;length to stk from stk .endc ;$nostr beq pru5c ;if null string, bypass .ifndf $nostr bisb (r1)+,(sp) ;top of stk is string len cmpb (r1)+,(r1)+ ;r1 addresses string .endc ;$nostr .ifdf $nostr mov 6(r4),r1 .endc ;$nostr pru5c: mov nch(r4),r0 ;get # spaces in format mov r0,r3 ;compute filler = spaces sub (sp),r3 ; - string len bpl pru6 mov r0,(sp) ;if -, use # spaces as count pru6: tstb rjflg(r4) ;right-justified-(rjflg for strings ;is same byte as zerflg for numeric) beq pru8 ;no, bypass tst r3 ;check filler bpl pru7 ;if +, bypass sub r3,r1 ;adjust start of string pru7: jsr pc,prufil ;print filler blanks pru8: dec (sp) ;output string chars bmi pru9 movb (r1)+,r0 jsr pc,outchr br pru8 pru9: jsr pc,prufil ;print remaining filler tst (sp)+ ;pop count pru10: dec chrct(r4) ;output remaining chars bmi pru11 movb (r2)+,r0 jsr pc,pputchar br pru10 pru11: mov r4,sp ;pop format table tst (sp)+ mov (sp)+,r1 ;restore basic's r1 mov (sp)+,r4 ; and r4 .ifndf $nostr tst (sp)+ .endc ;$nostr .ifdf $nostr cmp (sp)+,(sp)+ .endc ;$nostr br pru1 ;go to next field pru12: tstb strflg(r4) ;is format a string? erpruj: bne errpru ;yes, error tst fac1(r5) ;compute sign beq pru13 ;and abs value bpl pru15 ;of expression bic #100000,fac1(r5) br pru14 pru13: tst fac2(r5) bne pru13a ;is number 0? incb zerflg(r4) ;yes-set flag-(zerflg for numeric ;is same byte as rjflg for strings) pru13a: bpl pru15 neg fac2(r5) pru14: movb #'-,plsflg(r4) pru15: mov r2,-(sp) jsr pc,asccon ;convert to ascii mov (sp)+,r2 clr -(sp) ;compute sigdig - sign movb sigdig(r4),(sp) tstb plsflg(r4) bne pru15a tstb expflg(r4) ;exp format reserves space for sign beq pru16 tstb dolflg(r4) ;if no $ to be prrinted beq pru15b dec (r4) ;if $ and no sign, dec expon br pru16 pru15b: movb #bl,plsflg(r4) pru15a: dec (sp) pru16: mov (sp),r0 ble pru20c tstb expflg(r4) ;exponent format? beq pru17 ;no, bypass cmpb expflg(r4),#5 ;must be 5 '^'s bne erpruj ;wasn't=error clr -(sp) ;# blanks is 0 clr -(sp) ;# leading 0's is 0 br pru19 ;roundoff digit is r0 pru17: clr -(sp) ;non-exp format, compute leading 0's mov 2(sp),-(sp) ;compute # blanks movb decpl(r4),r0 ; = sigdig-sign sub r0,(sp) ; - decpl bne pru17a ; if = 0, dec 2(sp) ; dec # 0's pru17a: sub (r4),(sp) ; - expon dec (sp) ; - 1 bmi pru20c tst (r4) bpl pru18 add (r4),(sp) ; = + expon (if neg) sub (r4),2(sp) ; subtr expon from # 0's pru18: add (r4),r0 ;compute roundoff digit inc r0 ; = expon + decpl + 1 ble pru20c pru19: mov r0,-(sp) ;save roundoff cmp r0,#6 ;6 or more signif digits? bhis pru22 ;yes, done mov r0,r3 ;copy it add #mant,r0 ;addr round off char add r4,r0 cmpb (r0),#'5 ;5 or more blo pru22 ;no, done pru20: cmpb -(r0),#'9 ;is prev digit a 9 bne pru21 ;no, go add 1 movb #'0,(r0) ;yes, set it 0 and dec r3 ;go add 1 to prev digit bne pru20 ;ran out, make it mov #30061,(r0)+ ; 1 0 mov #30060,(r0) ; 0 0 mov (r0)+,(r0) ; 0 0 inc (r4) ;adjust exponent add #6,sp ;pop stack br pru16 ;back up ; value won't fit into field, print *'s pru20a: movb -1(r2),r0 ;get non-special char pru20b: jsr pc,pputchar ;print char pru20c: jsr r1,nxtchr ;get next format char br pru11 ;no more, done br pru20a ;not special, go print it movb #'*,r0 ;special char, get '*' br pru20b pru21: incb (r0) pru22: mov (sp)+,4(sp) ;save signif digits incb sigflg(r4) ;init significance flag mov #outchr,r1 ;output routine mov (sp),r3 ;get # blanks jsr pc,prufil ;print filler mov #dolflg,r0 ;chk dol sgn to be printed jsr pc,ckcr mov #plsflg,r0 ;chk sign to be printed jsr pc,ckcr gon: jsr r1,nxtchr ;look at nxt fmt chr br adone ;no more-print stored chrs br pblnk1 ;not special-prnt blank adone: tst (sp)+ ;pop flag inc chrct(r4) ;reset count dec r2 ;first sig dig prnted w/this chr movb nch(r4),r0 ;print stored chrs beq gon1 ;if 0-no chr jsr pc,pputchar gon1: movb nch+1(r4),r0 beq gon2 jsr pc,pputchar gon2: br pru24 pblnk1: movb #bl,r0 ;print blank tst (sp) ;if we are into field bne pbl1pt movb -1(r2),r0 ;else print literal char. pbl1pt: jsr pc,pputchar br gon ckcr: add r4,r0 ;calc adr of byte tstb (r0) ;chr non-zero? beq rtnc ;no mov r0,-(sp) ;yes-save addr ckcr1: jsr r1,nxtchr ;look at nxt fmt chr br printit ;no more br pblnk2 ;not special-print blank movb @(sp)+,nch(r4) ;special-store saved chr-print later swab nch(r4) ;put in hi byte inc 2(sp) ;set flg if chr was not 0 rtnc: rts pc printit: movb @(sp)+,r0 ;print it prnti1: jsr pc,outchr br rtnc pblnk2: movb #bl,r0 tst 4(sp) ;before strt of field? bne pblput ;no movb -1(r2),r0 ;yes-print char pblput: jsr pc,pputchar br ckcr1 pru24: mov (sp)+,r3 ;get # leading 0's movb #'0,r0 jsr pc,pruf1 ;print them pru25: mov #mant,r3 ;print mantissa add r4,r3 pru26: movb (r3)+,r0 ;get next char jsr pc,(r1) ;print it clrb sigflg(r4) ;start significance cmp r3,r4 ;was it last one? beq pru26a ;yes dec (sp) ;no, count chars bne pru26 ;print up to 6 pru26a: mov (sp)+,r3 ;get remaining count dec r3 ;adjust movb #'?,r0 ;print ?'s jsr pc,pruf1 tstb expflg(r4) ;exponent format? beq pru29 ;no, go finish up pru27: movb decpl(r4),r3 ;compute exponent in r3 clr -(sp) ;exp=2+dec. exp. of # bisb sigdig(r4),(sp) ;-(#of sig. dig. in fmt.-#dec.pl.) sub (sp)+,r3 add #2,r3 add (r4),r3 tstb zerflg(r4) ;is number 0? beq pru28 ;no clr r3 ;yes-adjust exp pru28: jsr pc,expf1 ;print out exponent pru29: jmp pru10 format: mov r2,-(sp) ;save string start mov r0,chrct(r4) ;and char counter clr -(sp) ;init program state form1: jsr r1,nxtchr ;get next char from format br done1 ;no more br form1 ;not special, ignore add (sp),r0 ;special, add in program state movb btabl(r0),r0 ;address transition table entry movb atabl(r0),r3 ;and action table add r3,pc ;to branch to appropriate action action: fordol: movb #'$,dolflg(r4) ;note floating dollar sign movb #10,(sp) ;and advance program state br form1 forpls: movb #'+,plsflg(r4) ;save sign indicator formin: incb sigdig(r4) ;count number places mov #20,(sp) ;change program state br form1 fornm2: incb decpl(r4) ;count decimal places fornm1: incb sigdig(r4) ;and number places br form1 forexp: incb expflg(r4) ;note exponent format mov #40,(sp) ;change program state br form1 forrj: comb rjflg(r4) ;note right-justified forlj: comb strflg(r4) ;note string format formns: inc nch(r4) ;count string places mov #50,(sp) ;change program state br form1 fordot: mov #30,(sp) ;change program state fordts: br form1 done: dec r2 ;ignore last char done1: tst (sp)+ sub (sp),r2 ;compute # chars used mov r2,chrct(r4) ;save it .ifndf $nostr add r2,10(r4) ;update # used so far .endc ;$nostr .ifdf $nostr add r2,12(r4) .endc ;$nostr mov (sp)+,r2 ;address beginning of string rts pc errfrm: trap 0 .ifndf $longer .ascii 'frm' .byte 0 .endc ;$longer .ifdf $longer .ascii 'format error' .byte 0 .endc ;$longer .even ; action dispatch table atabl: .byte fordol-action .byte forpls-action .byte formin-action .byte fornm2-action .byte fornm1-action .byte forexp-action .byte forrj-action .byte forlj-action .byte formns-action .byte fordot-action .byte done-action .byte errfrm-action .byte fordts-action ; ; program transition matrix btabl: ; char: . $ + - < > # ^ .byte .er,.dl,.pl,.mi,.lj,.rj,.er,.er ;state 0 .byte .dt,.dn,.pl,.mi,.dn,.dn,.n1,.ex ;state 10 .byte .dt,.dn,.dn,.dn,.dn,.dn,.n1,.ex ;state 20 .byte .dn,.dn,.dn,.dn,.dn,.dn,.n2,.ex ;state 30 .byte .dn,.dn,.dn,.dn,.dn,.dn,.dn,.ex ;state 40 .byte .d1,.dn,.dn,.dn,.dn,.dn,.ns,.dn ;state 50 .even prufil: mov #bl,r0 pruf1: dec r3 bmi pruf2 jsr pc,outchr br pruf1 outchr: mov r0,-(sp) ;save char out1: jsr r1,nxtchr ;look at next format char br out2 ;no more br out3 ;not special tstb sigflg(r4) ;special, switch signif flag ble out1a negb sigflg(r4) out1a: tst r0 ;is char '.' beq out4 ;yes, go print it out2: mov (sp),r0 ;get output char jsr pc,pputchar ;print it pop r0 pruf2: rts pc ;return out3: tstb sigflg(r4) ;check signif flag bpl out4 ;set, bypass out6: movb #bl,r0 ;suppressed, get blank br out5 out4: movb -1(r2),r0 ;get non-special format char out5: jsr pc,pputchar ;print it out br out1 ;go to next format char nxtchr: mov r3,-(sp) dec chrct(r4) ;count chars bmi nxtc3 ;no more, exit tst (r1)+ ;advance exit mov #spectab,r3 ;address table of spec chars mov #-1,r0 ;init index nxtc1: tstb (r3) ;any more spec chars in table? beq nxtc2 ;no, exit inc r0 ;count cmpb (r3)+,(r2) ;matching char? bne nxtc1 ;no, loop tst (r1)+ ;yes, advance return nxtc2: inc r2 nxtc3: mov (sp)+,r3 rts r1 spectab:.ascii '.$+-<>#^' ;leave chars in this order-see outchr! .byte 0 .even expf1: mov #bl,r0 ;print blank jsr pc,(r1) clr -(sp) ;save 0 on stack br expcom expf2: mov r1,-(sp) ;save non-0 on stack expcom: movb #'e,r0 ;print e jsr pc,(r1) movb #'+,r0 ;compute sign--assume + tst r3 bpl expc1 neg r3 cmpb (r0)+,(r0)+ ;change to - expc1: jsr pc,(r1) ;print sign clr r0 expc2: sub #10.,r3 ;divide exponent by 10 bmi expc3 inc r0 br expc2 expc3: add r0,(sp) ;save quotient beq expc4 ;in expf1, if 0, bypass add #'0,r0 jsr pc,(r1) ;print 1st digit expc4: mov r3,r0 ;get remainder add #10.+'0,r0 ;compute ascii char jsr pc,(r1) ;print 2nd digit tst (sp)+ ;check 0 quotient in expf1 bne expc5 ;no, bypass mov #bl,r0 ;yes, print blank jsr pc,(r1) expc5: rts pc ;return ; pputchar:tstb odev(r5) ;is output dev tty? bne pput2 ;no cmp @column(r5),#110 ;end of line? blo pput2 ;no mov r0,-(sp) ;yes-save char jsr pc,princr ;print cr,lf mov (sp)+,r0 pput2: jsr pc,putchar ;print char rts pc .endc ;$nopru ; 'print' statement print: mov #clmntty,column(r5) add r5,column(r5) clrb odev(r5) ;init dev to tty cmpb (r1),#.pound ;is it 'print #n: ...'? bne prnt00 inc r1 jsr pc,chkoset ;check channel and set-up i/o .ifndf $..$ ;in case this is "kb:", go to setcol. asl r2 ;device code * 2 beq colonch .endc ;$..$ jsr pc,setcol ;setup column(r5) pting to column count ;for this lun colonch:cmpb (r1),#.eol ;don't need colon if nothing beq prnt00 ; follows number jsr pc,comcol ;check for comma or colon prnt00: .ifndf $nopru cmpb (r1),#.using bne prnt01 jmp pru .endc ;$pru prnt01: cmpb (r1),#.comma beq pricm cmpb (r1),#.semi beq priboth cmpb (r1),#.eol beq priboth .ifdf $nostr cmpb (r1),#.squot ;check print string beq pristr cmpb (r1),#.dquot beq pristr cmpb (r1),#.tab ;or tab function beq pritb .endc ;$nostr jsr pc,eval ;evaluate string .ifndf $nostr bcs pristr .endc ;$nostr cmpb @column(r5),#74 ;check too far over on line blos prnt02 tstb odev(r5) ;is dev tty? bne prnt02 ;no jsr pc,princr ;yes, do prnt02: jsr pc,numsgn ;print out signed number .word putchar jsr r1,msgodev ;followed by a space .ascii ' ' .byte 0 .even br priboth .ifndf $nostr pristr: mov (sp)+,r2 ;print a string, r2 is pointer inc r2 beq priboth ;if string is null, don't to anything clr r3 bisb -(r2),r3 add #3,r2 priloop:tstb odev(r5) bne prist2 cmpb @column(r5),#110 ;check beyond column 72 blo prist2 jsr pc,princr ;yes, do prist2: movb (r2)+,r0 jsr pc,putchar ;print next char of string dec r3 bgt priloop br priboth .endc ;$nostr pricm: jsr r1,msgodev ;for common print a blank .byte bl,0 priboth:cmpb (r1),#.eol ;check eol without, n ; bne primore jsr pc,princr ;yes, print br prijmp ;and go exit primore:cmpb (r1)+,#.comma bne prisemi pricomm:clr r0 bisb @column(r5),r0 ;position to the next column with spaces. beq pritest pricm1: cmp r0,#70 beq pritest blo prnt03 sub #70,r0 ;(get cols right for >72 col devs) tstb odev(r5) ;is dev tty? bne pricm1 ;no-don't chk line size-just ;do cols properly jsr pc,princr br pritest prnt03: cmp r0,#52 beq pritest cmp r0,#34 beq pritest cmp r0,#16 beq pritest jsr r1,msgodev .ascii ' ' .byte 0 .even br pricomm prisemi:cmpb -(r1),#.semi ;for semi, do nothing bne prnt01 inc r1 pritest:cmpb (r1),#.eol bne prnt01 prijmp: inc r1 mov #clmntty,column(r5) ;re-set to tty column count add r5,column(r5) clrb odev(r5) jmp execute .ifdf $nostr ;print a literal string - no string version pristr: jsr pc,fndstr ;look for the string mov r0,r2 tst r3 prist1: beq priboth ;done printing all chars tstb odev(r5) bne prist2 cmp @column(r5),#110 blo prist2 jsr pc,princr ;print if needed prist2: movb (r2)+,r0 jsr pc,putchar ;print next char dec r3 ;loop till done br prist1 pritb: tstb (r1)+ ;tab funchion for no strings jsr pc,eval jsr pc,int cmpb (r1)+,#.rpar beq pritb2 jmp errsyn pritb2: movb fac2(r5),r2 ;get fn value sub @column(r5),r2 ;compute # spaces pritb0: cmp r2,#72. blo pritb1 sub #72.,r2 br pritb0 pritb1: dec r2 bmi priboth jsr r1,msgodev .byte bl,0 br pritb1 .endc ;$nostr ;print a literal string - no string version princr: jsr r1,msgodev .byte cr,lf .byte 0 .even clrb @column(r5) rts pc ; 'input' statement input: cmp r1,code(r5) ;make sure it's called from program bhi inpyes jsr r1,msgerr .ifndf $longer .ascii \iln\ .endc ;$longer .ifdf $longer .ascii 'illegal now' .endc ;$longer .byte 0 .even jmp ready2 inpyes: clrb t3(r5) clrb idev(r5) ;reset input to tty cmpb (r1),#.pound ;is it 'input #n: ...'? bne inpy01 incb t3(r5) inc r1 jsr pc,chkiset ;check channel and set-up input jsr pc,comcol ;check for comma or colon inpy01: mov #inpcr,-(sp) inploop:movb (r1)+,r2 bmi errsx8 swab r2 bisb (r1)+,r2 add (r5),r2 jsr pc,getvar inprtry:mov (sp),r3 cmpb (r3),#cr bne inpok ; get a new line of data inpnew: tstb t3(r5) ;for no'#' print '?' bne noqm jsr r1,msg .ascii '?' .byte 0 .even noqm: mov r1,-(sp) jsr pc,linget ;input from idev fill bcc noqm1 ;if error, means no data jmp errdata noqm1: mov (sp)+,r1 mov varsav(r5),r2 .ifndf $nostr cmp (r2),#.svar ;check for a string variable beq inpstr .endc ;$nostr mov line(r5),r0 ;bypass blanks inplp: cmpb (r0)+,#bl ;at start of line beq inplp dec r0 mov r0,(sp) br inprtry inpok: mov varsav(r5),r2 .ifndf $nostr cmp (r2),#.svar beq inpnew .endc ;$nostr mov r3,r0 jsr pc,sval mov r0,r3 inpsto: mov r3,(sp) jsr pc,stovar mov (sp),r3 cmpb (r3),#cr beq inpgood inc (sp) ;step over comma cmpb (r3),#', bne inpngud inpgood:cmpb (r1)+,#.comma beq inploop inpend: cmpb -1(r1),#.eol bne errsx8 tst (sp)+ tstb idev(r5) ;if tty input, clr column count bne goexec clr clmntty(r5) ; for same goexec: jmp execute inpngud:jsr r1,msgerr .ifndf $longer .ascii \brt\ .endc ;$longer .ifdf $longer .ascii 'bad data-retype from error.' .endc ;$longer .byte cr,lf .byte 0 .even br inpnew errsx8: jmp errsyn .ifndf $nostr inpstr: mov line(r5),r3 mov r3,r2 inps1: cmpb (r3)+,#cr bne inps1 mov r2,-(sp) sub #3,(sp) mov r3,-(sp) sub r2,(sp) dec (sp) beq inpnull mov sp,r2 add #2,r2 jsr pc,makestr inpnnul:jsr pc,stosvar tst (sp)+ cmpb (r1)+,#.comma bne inpend tst (sp)+ jmp inpy01 inpnull:mov #-1,(sp) br inpnnul .endc ;$nostr inpcr: .word cr errtr8: jmp errtrn comcol: cmpb (r1),#.colon ;subroutine to check for comma or colon beq comskp ;if either present, skip over cmpb (r1),#.comma ;for rsts compatibility bne errsx8 ;if neither, syntax err comskp: inc r1 rts pc ; 'read' statement read: movb (r1)+,r2 bmi errsx8 swab r2 bisb (r1)+,r2 add (r5),r2 jsr pc,getvar .ifdf hvunix mov @arrays(r5),r3 .iff mov @pdl(r5),r3 .endc beq errdata cmp r3,#-1 beq reasrch cmpb (r3),#.eol beq reafind cmpb (r3)+,#.comma bne readbad readgot:movb (r3),r2 .ifndf $nostr cmpb r2,#.dquote beq readqt cmpb r2,#.squote beq readqt .endc ;$nostr jsr pc,liteval br readbad mov r3,-(sp) jsr pc,stovar readdun:mov (sp)+,r3 cmpb (r3),#.eol beq read1 cmpb (r3),#.comma bne readbad .ifdf hvunix read1: mov r3,@arrays(r5) .iff read1: mov r3,@pdl(r5) .endc cmpb (r1)+,#.comma beq read cmpb -1(r1),#.eol bne errsx8 jmp execute .ifdf hvunix readout:clr @arrays(r5) .iff readout:clr @pdl(r5) .endc errdata:trap 0 .ifndf $longer .ascii \ood\ .endc ;$longer .ifdf $longer .ascii 'out of data' .endc ;$longer .byte 0 .even .ifdf hvunix readbad:clr @arrays(r5) .iff readbad:clr @pdl(r5) .endc trap 0 .ifndf $longer .ascii \bdr\ .endc ;$longer .ifdf $longer .ascii 'bad data read' .endc ;$longer .byte 0 .even reasrch:mov code(r5),r3 reafind:tstb (r3) bmi read2 add #2,r3 read2: cmpb (r3)+,#.data beq readgot cmpb -(r3),#.eof beq readout mov r1,-(sp) mov r3,r1 jsr pc,skipeol mov r1,r3 mov (sp)+,r1 br reafind .ifndf $nostr readqt: inc r3 cmpb (r3)+,#.text bne readbad mov r3,r0 readq1: tstb (r3)+ bne readq1 cmpb (r3)+,r2 bne readbad mov r3,-(sp) mov r0,-(sp) sub #3,(sp) mov sp,r2 mov r3,-(sp) sub r0,(sp) sub #2,(sp) beq reanull jsr pc,makestr mov (sp)+,r3 mov r3,(sp) mov sp,r0 add #3,r3 movb r0,-(r3) swab r0 movb r0,-(r3) br readstr reanull:dec (sp) mov (sp)+,(sp) readstr:jsr pc,stosvar br readdun .endc ;$nostr ;-------------------------------------------------- ; subroutine 'addstk' called by jsr pc ; adds (sp)+,(sp)+ to fac1(r5),fac2(r5) watching type ; r0,r1 unused ; r2,r3 destroyed ; r4 modified to reflect stack usage ; r5 must point to user area ; sp goes ?? deeper after jsr addstk: mov (sp)+,r3 jsr pc,fixup beq addint jsr r4,fppsav .word push .word $adr .word pop .word fppres tst fac1(r5) jmp (r3) ;cond codes=sgn(result) addint: tst (sp)+ mov (sp)+,r2 add fac2(r5),r2 bvs addovf mov r2,fac2(r5) jmp (r3) ;cond codes=sgn(result) addovf: bmi addpos beq addzero neg r2 clrb fac2(r5) movb r2,fac2+1(r5) swab r2 movb r2,fac1(r5) clrb fac1+1(r5) add #143600,fac1(r5) jmp (r3) ;cond codes=sgn(result) addzero:clr fac2(r5) mov #144200,fac1(r5) jmp (r3) ;cond codes=sgn(result) addpos: clrb fac2(r5) movb r2,fac2+1(r5) swab r2 movb r2,fac1(r5) clrb fac1+1(r5) add #43600,fac1(r5) jmp (r3) ;cond codes=sgn(result) .ifndf $nostr ;------------------------------------------------ ; 'argb' subroutine ; called by jsr r7 ; calls eval to get a 1-byte ; argument. branches to errarg ; if arg no good argb: jsr pc,eval bcs errarg jsr pc,int tst fac1(r5) bne errarg tstb fac2+1(r5) bne errarg rts pc .endc ;$nostr ersqr: erlog: errarg: trap 0 .ifdf $longer .ascii 'argument error' .endc ;$longer .ifndf $longer .ascii 'arg' .endc ;$longer .byte 0 .even ;-------------------------------------------------- ; ; eval - evaluate expression ; ; call: mov [user-area] ; mov [stack size],r4 ; mov [char. ptr.],r1 ; jsr pc,eval ; ; uses all regs. ; ; returns 'c' bit set if string val. ; clr if not string ; ; returns value in fac1(r5), fac2(r5) ; eval: mov pdsize(r5),r4 ;set the stack limit (resetting ;it upon recursion does not hurt!). cmp sp,r4 blo bpdl mov #.term,-(sp) br operand uminus: mov #.unary,-(sp) cmp sp,r4 bpdl: blo errpdl operand:movb (r1)+,r2 ;yet next program byte bge varble ;if +, a sym table reference cmpb r2,#.ilit1 ;check for literal token. beq ilit1 cmpb r2,#.ilit2 beq ilit2 cmpb r2,#.flit beq flit cmpb r2,#.lpar ;or a sub-expression beq lpar cmpb r2,#.minus ;or othere special tokens beq uminus cmpb r2,#.plus beq operand cmpb r2,#.fn beq gotofn .ifndf $nostr cmpb r2,#.squot beq gotoqt cmpb r2,#.dquot bne noquote gotoqt: jmp quote .endc ;$nostr noquote:bic #177400,r2 ;try lookup in table 5 sub #.stab5,r2 cmp r2,#.etab5-.stab5 bhi errsx4 asl r2 add #table5,r2 tst (r2) beq undef mov (r2),pc ;dispatch to function routine undef: jmp errufn ilit1: clr fac1(r5) ;1-byte literal clrb fac2+1(r5) movb (r1)+,fac2(r5) jmp oprator ilit2: clr fac1(r5) ;2-byte literal br ilitcom flit: movb (r1)+,fac1+1(r5) ;floating point literal movb (r1)+,fac1(r5) ilitcom:movb (r1)+,fac2+1(r5) movb (r1)+,fac2(r5) br oprator lpar: jsr pc,eval ;eval sub-expr by calling eval .ifndf $nostr bcs lpstrng .endc ;$nostr cmpb (r1)+,#.rpar beq oprator errsx4: jmp errsx5 .ifndf $nostr lpstrng:cmpb (r1)+,#.rpar ;sub-expression is string type bne errsx4 jmp sopratr .endc ;$nostr varble: swab r2 ;evaluate variable reference bisb (r1)+,r2 add (r5),r2 ;collect offset cmpb (r1),#.lpar ;check for subscripting beq varss .ifndf $nostr cmp (r2),#.svar ;check string variable beq strgjmp .endc ;$nostr cmp (r2)+,#.scalar ;correct addressing for array symbol beq varnoss mov (r2),r2 br varnoss .ifndf $nostr strgjmp:jmp strgvar .endc ;$nostr errpdl: trap 0 .ifndf $longer .ascii \etc\ .endc ;$longer .ifdf $longer .ascii 'expression too complex' .endc ;$longer .byte 0 .even gotofn: jmp fnfn .ifndf $nostr errmx2: jmp errmix .endc ;$nostr varss: inc r1 ;subscripted variable mov r2,-(sp) jsr pc,eval ;evaluate subscript .ifndf $nostr bcs errmx2 ;(it must be numeric) .endc ;$nostr jsr pc,int ;integerize it tst fac1(r5) bne errss2 ;out of integer range cmpb (r1),#.rpar ;check one-subscript beq voness cmpb (r1)+,#.comma ;or two bne errsx4 mov fac2(r5),-(sp) ;push lst subscripton stack jsr pc,eval ;evaluate 2nd subscript .ifndf $nostr bcs errmx2 ;it must be numeric .endc ;$nostr jsr pc,int ;integerize it tst fac1(r5) bne errss2 cmpb (r1)+,#.rpar ;must have '9' now bne errsx4 mov fac2(r5),r3 bmi errss2 mov (sp)+,r0 ;pop 1st subscript br vtwoss errss2: jmp errss3 voness: inc r1 ;for 1 subscript mov #-1,r3 ;dummy 2nd subscript of -1 mov fac2(r5),r0 vtwoss: bmi errss2 mov (sp)+,r2 .ifndf $nostr cmp (r2),#.svar ;branch for string array bne v1 jmp strgarr .endc ;$nostr v1: jsr pc,locget ;address array element in r2 varnoss:mov (r2)+,fac1(r5) ;get its value in fac mov (r2),fac2(r5) oprator:movb (r1),r3 ;next character. cmpb r3,#.eol beq doitnow cmpb r3,#.goto ;expression termination, for on goto/gosub beq doitnow cmpb r3,#.gosub beq doitnow cmpb r3,#.unary blo errsx4 mov (sp),r2 ;previous operator. cmpb r2,#.uparro blos doitnow ;jump if ^ or unary. cmpb r2,#.slash blos prec2 ;jump if * or /. cmpb r2,#.minus blos prec3 ;jump if + or -. cmpb r2,#.eq blos prec4 ;jump if = <> <= >= < or >. prec5: cmpb r3,#.eq blos notnow ;jump if any operator. prec4: cmpb r3,#.minus blos notnow ;jump if + - * / ^ or unary. prec3: cmpb r3,#.slash blos notnow ;jump if * / ^ or unary. prec2: cmpb r3,#.uparro blos notnow ;jump if ^ or unary. doitnow:clr r2 ;(e.g. a*b+ ) do the * now. bisb (sp)+,r2 asl r2 ;jump to do the appropriate oper add #table2-.unary-.unary,r2 mov (r2),pc ;left operand is 0(sp),2(sp) table2: .word unary .word uparro ;right operand is fac1(r5),fac2(r5). .word star .word slash .word plus .word minus .word termin notnow: mov fac2(r5),-(sp) ;(e.g. a+b* ) dont do the + yet. cmp sp,r4 blo errpd5 mov fac1(r5),-(sp) mov r3,-(sp) inc r1 jmp operand termin: clc ;carry off means numeric result. rts pc errpd5: jmp errpdl minus: jsr pc,substk unary: tst fac1(r5) beq uinteg add #100000,fac1(r5) br oprator uinteg: neg fac2(r5) bvc oprator mov #44000,fac1(r5) clr fac2(r5) br oprator plus: jsr pc,addstk br oprator star: jsr r4,fppsav .word tststk ;test top of stack and float if int .word pushf ;push fac and float if nec .word $mlr ;perform mult .word pop ;pop result .word fppres star1: jmp oprator slash: jsr r4,fppsav .word tststk ;test top of stack and float if int .word pushf ;push fac and float if necessary .word $dvr ;perform division .word pop ;pop result .word fppres br star1 tststk: tst (sp) bne tsts2 tsts1: tst (sp)+ jmp $ir tsts2: jmp @(r4)+ ;return pushf: mov fac2(r5),-(sp) mov fac1(r5),-(sp) beq tsts1 ;float if integer jmp @(r4)+ ;return errsx5: jmp errsyn .ifndf $nostr quote: dec r1 jsr pc,fndstl ;find string literal tst r3 beq gotval ;null string sub #3,r0 ;r0 is addr - 3 mov r0,-(sp) mov sp,r2 ;r2 is pointer mov r3,-(sp) ;length jsr pc,makestr ;create a string mov (sp)+,(sp) ;fix up stack jmp stpro ;go protect string gotval: mov #-1,-(sp) br sopratr .endc ;$nostr erpd02: jmp errpd2 .ifndf $nostr strgarr:jsr pc,locget ;evaluate string array element - address it br strgbth strgvar:tst (r2)+ ;evaluate string variable - address it cmp 2(r2),#-1 beq strgbth mov (r2),r2 strgbth:mov (r2),r3 ;place string pointer cmp r3,#-1 beq gotval cmp sp,r4 blo erpd02 clr -(sp) movb (r3),(sp) jsr pc,makestr sopratr:cmpb 2(sp),#.ampers ;string operator' routine beq concat cmpb 2(sp),#.plus ;accept + for concat -- rsts compatibilty beq concat cmpb (r1),#.ampers beq ampwait cmpb (r1),#.plus ;here too beq ampwait cmpb 2(sp),#.term bne errsx5 mov (sp)+,r0 tst (sp)+ mov (sp),r2 mov r0,(sp) inc r0 beq soprx ;check null string add #2,r0 mov sp,r3 movb r3,-(r0) swab r3 movb r3,-(r0) soprx: sec ;indicate string expression jmp (r2) ampwait:movb (r1)+,-(sp) jsr pc,eval bcs sopratr errmix: trap 0 .ifndf $longer .ascii \nsm\ .endc ;$longer .ifdf $longer .ascii 'numbers and strings mixed' .endc ;$longer .byte 0 .even concat: cmp (sp),#-1 ;concatenate 2 strings a$ & b$ bne catnot ;first check if either one null cmp (sp)+,(sp)+ ;and return the other if yes br sopratr catnot: mov 4(sp),r2 cmp r2,#-1 bne catlong mov (sp)+,r0 tst (sp)+ mov r0,(sp) br catcom catlong:clr r0 ;both are non-null bisb (r2),r0 ;create a string with length n1+n2, mov (sp),r3 cmp sp,r4 ;with the first n1 characters of a$ blo erpd02 ;then copy the n2 characters of b$ clr -(sp) ;to the end of the string movb (r3),(sp) add r0,(sp) cmp (sp),#377 bhi errstr mov sp,r2 add #6,r2 jsr pc,makestr mov (sp)+,r3 mov 4(sp),r2 clr r0 bisb (r2),r0 mov r3,4(sp) add r0,r3 add #3,r3 mov (sp)+,r2 tst (sp)+ clr r0 bisb (r2),r0 add #3,r2 cat1: movb (r2)+,(r3)+ dec r0 bgt cat1 stpro: quotbum:mov (sp),r0 catcom: mov sp,r2 ;protect the string pointer at the top of add #3,r0 movb r2,-(r0) ;the stack from garbage collection swab r2 movb r2,-(r0) br sopratr .endc ;$nostr errpd2: jmp errpdl .ifndf $nostr errstr: trap 0 .ifndf $longer .ascii \stl\ .endc ;$longer .ifdf $longer .ascii 'string too long' .endc ;$longer .byte 0 .even .endc ;$nostr ; math ots function routines. sinfn: mov #sin,-(sp) ;fpmp function routines br functi cosfn: mov #cos,-(sp) ;set fpmp routine address br functi sqrfn: mov #sqrt,-(sp) br functi atnfn: mov #atan,-(sp) br functi expfn: mov #exp,-(sp) br functi l10fn: mov #alog10,-(sp) br functi logfn: mov #alog,-(sp) br functi .ifndf $nostr errmx9: jmp errmix .endc ;$nostr erpd11: jmp errpd2 ; common code for function routines functi: jsr pc,eval ;evaluate function argument .ifndf $nostr bcc functj jmp errarg ;it must be numeric! functj: .endc ;$nostr mov (sp)+,r3 bne funct1 jmp errufn ;if fpmp routine not loaded, don't bomb! funct1: cmpb (r1)+,#.rpar bne errsx9 jsr r4,fppsav .word pushf ;push fac, float if necessary .word funok ;go do function .word fppres br oprfn funok: mov sp,r1 ;save address of pushed arg mov r4,-(sp) ;save r4 mov r1,-(sp) ;addr of argument mov r5,-(sp) mov r5,r0 mov sp,r5 ;return address (to dummy prog in stk) jsr pc,@r3save(r0) funret: mov (sp)+,r5 ;restore r4 tst (sp)+ mov (sp)+,r4 cmp (sp)+,(sp)+ ;remove old fac from stack mov r0,fac1(r5) ;store result in fac mov r1,fac2(r5) jmp @(r4)+ ;and return .ifndf $nostr errmx8: jmp errmix .endc ;$nostr intfn: jsr pc,eval ;evaluate argument in fac .ifndf $nostr bcs errmx8 .endc ;$nostr cmpb (r1)+,#.rpar ;check syntax bne errsx9 jsr pc,int oprfn: jmp oprator ;integerize fac errsx9: jmp errsx5 ;exponentiation routine ; if a is not 0,float it uparro: tst (sp) ;is upper a 0 bne ua1 tst 2(sp) ;is lower a 0 beq ua1 tst (sp)+ jsr r4,fppsav .word $ir .word fppres ua1: tst fac1(r5) ;is upper b = 0 bne ua10 tst fac2(r5) ;is lower b = 0 bne ua5 mov #1,fac2(r5) ;set result 1 ua4: cmp (sp)+,(sp)+ jmp oprator ; b is integer ua5: tst (sp) ;is a = 0 bne ua17 tst fac2(r5) ;is lower b > 0 bpl ua9 ;no, error message ua8: trap 0 .ifndf $longer .ascii 'dv0' .endc ;$longer .ifdf $longer .ascii 'division by 0' .endc ;$longer .byte 0 .even ua9: clr fac1(r5) ;set result 0 clr fac2(r5) br ua4 ;fix b if integer < 256 ua10: tst fac2(r5) bne ua10.5 mov fac1(r5),r0 mov r0,r2 bic #100177,r0 ;extract exponent cmp r0,#40200 ;check too small blo ua10.5 bic #177600,r2 bis #200,r2 ;r2 is mantissa ua10a: cmp r0,#42000 beq ua10b bhi ua10.5 asr r2 bcs ua10.5 ;if bit cleared,no good add #200,r0 ;update exponent br ua10a ua10b: tst fac1(r5) bpl ua10c neg r2 ua10c: clr fac1(r5) mov r2,fac2(r5) br ua5 ;b is real ua10.5: tst (sp) ;is a = 0 beq ua12 jsr r4,fppsav .word push .word uajmp,ua23 ua12: tst fac1(r5) ;is upper b> 0 bpl ua9 ;yes br ua8 ;no, error ;b integer, a real ua17: mov fac2(r5),r0 mov r0,r2 ;save for sign test bge ua17a neg r0 ua17a: cmp r0,#256 ;r0 is abs(b) if too big, float bhis ua20 jsr r4,fppsav ;go into polish mode .word pop ;current product is a .word push1 ;current answer is 1 (on stk) ua17b: .word uaasr,ua17d ;shift b, branch if bit is 0 .word push ;get current product ont ostack .word $mlr ;multiply into current answer ua17d: .word uatst0,ua17f ;test if done, branch if so .word push,push ;two copies of current product .word $mlr ;square it .word pop ;and put result back .word uajmp,ua17b ;polish jump to 17b ua17f: .word pop ;store answer into fac .word uatst2,ua19 ;test sign b, if + jump .word push1 ;push 1 onto stack .word push .word $dvr ;ans = 1/ans if b neg .word pop ;pop answer to fac ua19: .word fppres jmp oprator ;and get out ua21: trap 0 .ifndf $longer .ascii \^er\ .endc ;$longer .ifdf $longer .ascii '^ error' .endc ;$longer .byte 0 .even uaasr: asr r0save(r5) bcc uajmp uanjmp: tst (r4)+ ;skip over jump address jmp @(r4)+ uajmp: mov @r4,r4 ;polish mode jump jmp @(r4)+ uatst0: tst r0save (r5) beq uajmp br uanjmp uatst2: tst r2save(r5) ;test sign of b bpl uajmp ;polish jump if b + br uanjmp uatsta: tst @sp bmi ua21 jmp @(r4)+ ua20: mov r2,-(sp) ;push int b on stack jsr r4,fppsav .word $ir ;float b ua23: .word revrse ;reverse top two on stk .word uatsta ;test top stk, br to err if - .word calog ;call alog function on a, result to fac .word push ;push log(a) onto stack .word $mlr ;calc b*log(a) .word cexp ;calc exp(b*log(a)), result to fac .word fppres jmp oprator revrse: mov (sp)+,r0 ;routine to reverse top 2 mov (sp)+,r1 ;fltpt numbers on stack mov (sp)+,r2 mov (sp)+,r3 mov r1,-(sp) mov r0,-(sp) mov r3,-(sp) mov r2,-(sp) jmp @(r4)+ calog: mov #alog,r3save(r5) jmp funok cexp: mov #exp,r3save(r5) jmp funok errpd4: jmp errpdl .ifndf $nostr errmx1: jmp errmix .endc ;$nostr errsxa: jmp errsx5 fnfn: .ifdf $multi .ifndf $..$ dec exct ;share if a multi-user system bpl fnfn1 mov #$exno,exct jsr pc,nxtusr .endc ;$..$ .ifdf $..$ decb nsr(r5) bpl fnfn1 mov sp,r2 ;see if enough stack space for a regsav sub #12.,r2 cmp r4,r2 bhi errpd4 ;stack exhausted ... can't time share. jsr pc,nxtusr .endc ;$..$ fnfn1: .endc ;$multi movb (r1)+,r2 ;fn evaluating routine cmpb (r1)+,#.lpar ;the 26 def pointers are stred after bne errsxa ;pdl(r5). they point to the .ifdf hvunix add arrays(r5),r2 .iff add pdl(r5),r2 ;statement defining the function. .endc mov (r2),r0 ;r0 now contains the def pointer. beq errufn fneval: mov r0,-(sp) cmp sp,r4 ;too deep on stack blo errpd4 ;yes jsr pc,eval ;evaluate the next variable in the calling stmt .ifndf $nostr bcs fnstr .endc ;$nostr mov (sp)+,r0 ;restore the def pointer. movb (r0)+,r2 ;get the variable from the def. bmi errag1 swab r2 bisb (r0)+,r2 add (r5),r2 .ifndf $nostr cmp (r2),#.svar ;if the def variable is string and beq errmx1 ;the value isnt then its an error. .endc ;$nostr mov fac2(r5),-(sp) ;stack the new value mov fac1(r5),-(sp) ;ditto br fnrepl .ifndf $nostr fnstr: mov (sp)+,r3 ;get new value in r3 mov (sp)+,r0 ;restore the def pointer. movb (r0)+,r2 ;get the variable from the def. bmi errag1 swab r2 bisb (r0)+,r2 add (r5),r2 cmp (r2)+,#.svar ;if the def variable is numeric and bne errmx1 ;the value isnt then its an error. mov r3,-(sp) ;else stack the new value inc r3 ;is it null beq fnrepl ;yes mov sp,r2 ;gotta do this because "mov sp,-(sp)" mov r2,-(sp) ;doesn't work the same on all 11's movb 1(sp),(r3)+ ;no - make an abs back pointer movb (sp)+,(r3)+ .endc ;$nostr fnrepl: cmpb (r0),#.comma bne fnnocom cmpb (r0)+,(r1)+ beq fneval errag1: jmp errarg errufn: trap 0 .ifndf $longer .ascii 'ufn' .endc ;$longer .ifdf $longer .ascii 'undefined function' .endc ;$longer .byte 0 .even errsxb: jmp errsx5 ;syntax error fnnocom:cmpb (r0),#.rpar ;check rpar on lhs of model stmt bne errag1 mov r0,-(sp) mov sp,r3 ;point to def ptr and saved args cmpb (r0)+,(r1)+ ;and on lhs of calling stmt bne errag1 cmpb (r0)+,#.eq ;check = in model stmt bne errag1 mov r1,-(sp) mov r0,-(sp) ;save def ptr after = ; swap argument values with evaluated expressions on stack mov (r3)+,r0 ;point to last argument fnswap: movb -(r0),-(sp) ;point into symbol table movb -(r0),1(sp) mov (sp)+,r2 add (r5),r2 .ifndf $nostr cmp #.svar,(r2)+ ;which type to swap beq fnstsw ;string swap .endc ;$nostr cmp #.scalar,-2(r2) ;array? beq fn01 ;no mov (r2),r2 fn01: mov (r3),-(sp) ;swap numeric value mov (r2),(r3)+ mov (sp)+,(r2)+ fn08: mov (r3),-(sp) ;second word mov (r2),(r3)+ mov (sp)+,(r2)+ br fn09 ;test comma or left paren .ifndf $nostr fnstsw: cmp 2(r2),#-1 ;string array? beq fn02 ;no mov (r2),r2 ;point to element 0 fn02: mov (r3),r1 ;get new value inc r1 ;null? beq fn07 ;yes mov r2,-(sp) ;create an abs back pointer movb 1(sp),(r1)+ movb (sp)+,(r1)+ fn07: mov (r2),r1 ;get old value inc r1 ;null? beq fn08 ;yes - go swap values mov r3,-(sp) ;create an abs back pointer movb 1(sp),(r1)+ movb (sp)+,(r1)+ br fn08 ;go swap values .endc ;$nostr fn09: cmpb #.lpar,-(r0) ;are we done swapping arguments? bne fnswap ;no - go do next mov (sp)+,r1 ;point to expression jsr pc,eval ;evaluate expression in model statement 1 bcs fn03 ;set r3 0 for numeric, pointer for string clr r3 br fn04 fn03: mov (sp)+,r3 fn04: cmpb (r1),#.eol ;check end of model line bne errsxb mov (sp)+,r1 mov (sp)+,r0 fnrlup: movb -(r0),-(sp) movb -(r0),1(sp) mov (sp)+,r2 add (r5),r2 .ifndf $nostr cmp (r2),#.svar beq fnrstr .endc ;$nostr cmp (r2)+,#.scalar beq fn05 mov (r2),r2 fn05: mov (sp)+,(r2)+ mov (sp)+,(r2) br fnchk fnrssc: mov (sp)+,(r2) mov r0,-(sp) mov (r2),r0 sub (r5),r2 inc r2 .ifndf $nostr br fnrcom fnrstr: tst (r2)+ ;pop the model stmt dummy variables back cmp 2(r2),#-1 ;to their orginal values beq fnrssc mov (r2),r2 mov (sp)+,(r2) mov r0,-(sp) mov (r2),r0 .endc ;$nostr fnrcom: inc r0 beq fnrsnul swab r2 movb r2,(r0)+ swab r2 movb r2,(r0)+ fnrsnul:mov (sp)+,r0 fnchk: cmpb -(r0),#.lpar bne fnrlup .ifndf $nostr ;check type of expression and tst r3 ;branch to appropriate beq fnnumer ;'operator' routine mov r3,-(sp) cmp r3,#177777 ;check null string bne fn06 datret: jmp sopratr fn06: jmp stpro .endc ;$nostr ;check type of expression and fnnumer:jmp oprator ; pi "function" pifn: mov #040511,fac1(r5) mov #007733,fac2(r5) br fnnumer ;jmp oprator .ifndf $nostr ; dat$ function datfn: jsr pc,datcom ;compute ascii date mov #datpt,r2 ;string pointer mov #11,-(sp) ;string length jsr pc,makestr ;copy date chars into string br datret ;jmp soprator datpt: .word datest .endc ;$nostr .ifdf $vf ; vf as part of an expression vffn: jsr pc,vffnd ;address file element .ifndf $nostr bit #4000,(r3) ;is it vf $ ? bne vffn2 ;yes .endc ;$nostr clr fac1(r5) bit #2000,(r3) ;is it vf % ? bne vffn1 ;yes mov (r2)+,fac1(r5) ;set fac to data value vffn1: mov (r2)+,fac2(r5) jmp oprator ;return real value .ifndf $nostr vffn2: sub #3,r2 ;create a string of proper length mov r2,-(sp) mov sp,r2 ;(pointer pointer) mov r0,-(sp) ;top of stack is length bmi vffn3 ;- => stg. crosses blk. boundary mov r0,-(sp) mov r0,-(sp) ;necessary for a common stack at vffn5 jsr pc,makest ;create a default string. mov histr(r5),r3 ;set up for the back scan. dec r3 ;point to the length byte. br vffn5 vffn3: clr r0 bisb @r3,r0 ;get the real stg. length mov r0,-(sp) mov r0,-(sp) jsr pc,makest jsr pc,rnb ;now get the rest of the string mov 4(sp),r0 ;calculate the # chars. left mov @sp,r3 ;get the temp. stg. adr. sub r0,r3 ;-<-> add #3,r3 ;= adr.(next valid char. to install) add 2(sp),r0 ;r0 = no. chars. remaining. vffn4: movb (r2)+,(r3)+ ;install the remainder of the stg. dec r0 bne vffn4 vffn5: mov 2(sp),r0 ;now do a back scan of the temp stg. inc r0 ;to locate the 1st non-null char and vffn6: dec r0 ;adjust things accordingly. beq vffn7 ;assume a stg. of all nulls is valid. tstb -(r3) beq vffn6 mov @sp,r3 ;r3 = stg. adr, clrb @r3 ;install the true stg. length bisb r0,@r3 add r0,r3 add #3,r3 clrb @r3 bisb r0,(r3)+ mov r3,histr(r5) br vffnx vffn7: mov (sp)+,histr(r5) cmp (sp)+,(sp)+ mov #177777,(sp) jmp sopratr vffnx: mov (sp)+,r0 cmp (sp)+,(sp)+ mov r0,@sp jmp stpro .endc ;$nostr .endc ;$vf ;-------------------------------------------------- ; subroutine 'fixup' called by jsr pc ; matches types of 0(sp),2(sp) and fac1(r5),fac2(r5) ; r0,r1 unused ; r2 destroyed ; r3,r4 unused ; r5 must point to user area ; sp goes no deeper after jsr fixup: mov (sp)+,r2 tst (sp) beq fixtst tst fac1(r5) bne fixret ;cond codes=nonzero means floating. mov fac2(r5),-(sp) ;**** jsr r4,fppsav .word $ir .word pop .word fppres br fixclz fixtst: tst fac1(r5) beq fixret ;cond codes=0 means integer. tst (sp)+ ;**** jsr r4,fppsav .word $ir .word fppres fixclz: clz ;cond codes=nonzero means floating. fixret: jmp (r2) ;---------------------------------------------------------------- ; subroutine 'fndstr' called by jsr pc ; finds a string expression at (r1) ; and returns with address in r0, ; length in r3. fndstr: .ifndf $nostr jsr pc,eval ;evaluate string expression bcc fndsre mov (sp)+,r0 clr r3 inc r0 ;check null string beq fndsrx ;yes, exit bisb -(r0),r3 ;r3 is length add #3,r0 ;r0 is pointer .endc ;$nostr .ifdf $nostr jsr pc,fndstl .endc ;$nostr fndsrx: rts pc fndsre: jmp errsyn ;--------------------------------------------------------- ; routine 'fppres' called in polish mode ; restores r0 thru r4 saved by fppsav ; and returns in normal exec mode fppres: mov r0save(r5),r0 mov r1save(r5),r1 mov r2save(r5),r2 mov r3save(r5),r3 mov r4save(r5),-(sp) rts r4 ;------------------------------------------------------------- ; routine 'fppsav' called by jsr r4 ; saves r0 thru r4, and returns in ; polish mode fppsav: mov r0,r0save(r5) mov r1,r1save(r5) mov r2,r2save(r5) mov r3,r3save(r5) mov (sp)+,r4save(r5) jmp @(r4)+ ;enter polish mode ;----------------------------------------------------------- ; 'getvar' subroutine ; this subroutine reads a variable name or ; an array element, and addresses that ; variable in core, so that a subsequent 'stovar' ; call will store the fac in the variable. ; destroys fac1 and fac2. ; called by jsr pc,getvar ; r2 addresses the symtab entry for the variable ; getvar: mov r2,varsav(r5) mov #-1,r2 mov r2,ss1sav(r5) mov r2,ss2sav(r5) cmpb (r1),#.lpar bne nosubs inc r1 jsr pc,eval .ifndf $nostr bcs errmx3 .endc ;$nostr jsr pc,int tst fac1(r5) bne errss1 mov fac2(r5),ss1sav(r5) bmi errss1 movb (r1)+,r2 cmpb r2,#.rpar beq nosubs cmpb r2,#.comma bne errsx3 jsr pc,eval .ifndf $nostr bcs errmx3 .endc ;$nostr jsr pc,int tst fac1(r5) bne errss1 mov fac2(r5),ss2sav(r5) bmi errss1 cmpb (r1)+,#.rpar bne errsx3 nosubs: rts pc errsx3: jmp errsx5 .ifndf $nostr errmx3: jmp errmix .endc ;$nostr errss1: jmp errss2 ;-------------------------------------------------- ; subroutine 'int' called by jsr pc ; computes int(fac), converting the result ; to a 1-word integer, if possible int: mov fac1(r5),r0 ;get high order word in r0 beq intrts ;already an integer jsr r4,savreg ;save registers mov r0,r1 bic #100177,r0 ;extract exponent cmp r0,#40200 ;check abs value < 1 blo int7 cmp r0,#46000 ;check integer by truncation bhi intrts ;yes, return clr r2 sub #43600,r0 ;check more than 15 bits integer bgt int5 ;yes, produce flt int answer swab r1 clrb r1 bisb fac2+1(r5),r1 ;r1 is 16 bits of mantissa bis #100000,r1 ;set hidden bit ;'c' bit clr'd by clrb-not chngd by bis ror r1 ;get 15 bits of absolute value tst r0 ;test already integer bge int1a ;yes int1: asr r1 ;shift mantissa 1 right adc r2 ;add carry bit to r2 add #200,r0 ;increment exponent blt int1 ;loop until done int1a: tst fac1(r5) ;original number neg bpl int2 ;no tst r2 ;any bits zeroed? beq int1b inc r1 ;adjust for negative bvs int9 ;overflow int1b: neg r1 int2: mov r1,fac2(r5) int2a: clr fac1(r5) intrts: rts pc int5: cmp r0,#2200 ;check done bge int6 ;yes sec ;set carry bit rol r2 ;create pattern of bits to clear add #200,r0 br int5 int6: mov fac2(r5),r0 ;save old fac2 in case neg arg bic r2,fac2(r5) ;clear bits tst fac1(r5) ;check neg arg bpl intrts ;no, done bit r2,r0 ;check exact integer already beq intrts ;yes, return jsr r4,$polsh ;no, must subtract 1 .word push ;push fac .word push1 ;push floating 1 .word $sbr ;subtract .word pop ;pop answer to fac .word intrts ;and return (out of polish mode) int7: tst r1 ;abs(arg) < 1 bmi int8 clr fac2(r5) ;if + then ans is 0 br int2a int8: mov #177777,fac2(r5) ;if - then ans is -1 br int2a int9: mov #143600,fac1(r5) clr fac2(r5) br intrts push: mov fac2(r5),-(sp) mov fac1(r5),-(sp) jmp @(r4)+ pop: mov (sp)+,fac1(r5) mov (sp)+,fac2(r5) jmp @(r4)+ push1: clr -(sp) mov #40200,-(sp) jmp @(r4)+ ;-------------------------------------------------- ; subroutine 'locget' called by jsr pc ; gets loc of element in array (checks subscripts) ; r0 must contain ss1 gets destroyed ; r1 unused ; r2 must point to var gets set to result ; r3 must contain ss2 gets destroyed ; r4 unused ; r5 must point to user area ; sp goes ?? deeper after jsr locget: cmp (r2),#.scalar ;undimensioned array? beq localoc tst 4(r2) bpl locss1 localoc:mov r2,-(sp) ;must dimension array - mov r4,-(sp) mov r3,-(sp) .ifndf $nostr jsr pc,dnpack ;first move strings down to make room .endc ;$nostr mov #12,r3 mov (sp),r4 bmi loc1 mov r3,r4 loc1: jsr pc,alloc ;alloc allocates, sets to 0 or null mov (sp)+,r3 mov (sp)+,r4 mov (sp)+,r2 locss1: cmp r0,4(r2) bhi errss3 tst r3 bmi locno2 tst 6(r2) bmi errss3 cmp r3,6(r2) bhi errss3 mov 4(r2),-(sp) ;**** inc (sp) ;* * mov r3,-(sp) ;* * mov #20,-(sp) ;* * locloop:asl r3 ;* * asl 2(sp) ;* * multiply ss2 by ss1max bcc loc2 ;* * result in r3 add 4(sp),r3 ;* * loc2: dec (sp) ;* * bgt locloop ;* * cmp (sp)+,(sp)+ ;* * tst (sp)+ ;**** add r3,r0 locno2: inc r0 asl r0 .ifndf $nostr cmp (r2),#.svar ;check for string beq loc3 .endc ;$nostr asl r0 loc3: mov 2(r2),r2 ;numeric elements are twice as long add r0,r2 ;return address in r2 rts pc errsob: errss3: trap 0 .ifndf $longer .ascii \sob\ .endc ;$longer .ifdf $longer .ascii 'subscript out of bounds' .endc ;$longer .byte 0 .even .ifndf $nostr ;-------------------------------------------------- ; subroutine 'makestr' called by jsr pc ; makes a basic string from a string of characters ; r0 destroyed ; r1 unused ; r2 must point to a word which contains 3 less ; than the address of the first character ; r3 destroyed ; r4 unused ; r5 must point to user area ; sp on entry 0(sp) must contain # characters ; on exit 0(sp) contains pointer to the string makestr:jsr pc,maketry ;will new string fit? blos makgot ;yes jsr pc,dnpack ;no, garbage collect jsr pc,maketry ;try again blos makgot ;fits this time errsov: trap 0 .ifndf $longer .ascii \sso\ .endc ;$longer .ifdf $longer .ascii 'string storage overflow' .endc ;$longer .byte 0 .even makgot: mov r0,histr(r5) ;save new high string addr mov 2(sp),r0 ;r0 now contains # chars. mov (r2),r2 add #3,r2 ;r2 now contains address of chars movb r0,(r3)+ ;r3 puts characters in cmpb (r3)+,(r3)+ mak1: movb (r2)+,(r3)+ dec r0 bgt mak1 mov 2(sp),r0 ;insert string length movb r0,(r3) ;at beginning and end of string sub r0,r3 mov sp,r0 tst (r0)+ movb r0,-(r3) ;set backptr:=address of string swab r0 ;to protect it movb r0,-(r3) dec r3 mov r3,2(sp) ;return string pointer rts pc ; subroutine to check room enough for string maketry:mov histr(r5),r0 mov r0,r3 add 4(sp),r0 add #4,r0 cmp r0,hifree(r5) rts pc .endc ;$nostr ;-------------------------------------------------- ; 'stovar' subroutine ; called by jsr pc,stovar ; stores fac1, fac2 in the variable or ; array element last addressed by the ; subroutine 'getvar' stovar: mov varsav(r5),r2 .ifndf $nostr cmp (r2),#.svar beq errmx7 .endc ;$nostr mov ss1sav(r5),r0 bmi stonoss mov ss2sav(r5),r3 jsr pc,locget br stocomm stonoss:cmp (r2)+,#.scalar beq stocomm mov (r2),r2 stocomm:mov fac1(r5),(r2)+ mov fac2(r5),(r2) rts pc .ifndf $nostr errmx7: jmp errmix .endc ;$nostr .ifndf $nostr ;-------------------------------------------------- ; 'stosvar' subroutine ; called by jsr pc,stosvar ; stores a string variable as addressed by ; varsav stosvar:mov varsav(r5),r2 ;get sym tab entry address cmp (r2),#.svar ;make sure its a string variable bne errmx6 mov ss1sav(r5),r0 ;check not subscripted bmi stossno mov ss2sav(r5),r3 jsr pc,locget ;address the variable br stommco stossno:tst (r2)+ cmp 2(r2),#-1 ;is current value a null beq stovtab ;if is, bypass mov (r2),r2 stommco:mov (sp)+,r3 mov (sp)+,r0 mov r0,(r2) br stovcom stovtab:mov (sp)+,r3 mov (sp)+,r0 mov r0,(r2) inc r2 sub (r5),r2 stovcom:inc r0 beq stosx ;check null string add #2,r0 movb r2,-(r0) swab r2 movb r2,-(r0) stosx: jmp (r3) errmx6: jmp errmix .endc ;$nostr ;-------------------------------------------------- ; subroutine 'substk' called by jsr pc ; negates 0(sp),2(sp) then continues in 'addstk' ; r0,r1 unused ; r2,r3 destroyed ; r4 modified to reflect stack usage ; r5 must point to user area ; sp goes ?? deeper after jsr substk: tst 2(sp) beq subint add #100000,2(sp) adstk1: jmp addstk subint: neg 4(sp) bvc adstk1 mov #44000,2(sp) clr 4(sp) br adstk1 ;----------------------------------------------------------------- ; subroutine 'sval' called by jsr pc ; gets a signed value in the fac ; from ascii chars starting at (r0) sval: mov r4,-(sp) ;save regs mov r2,-(sp) mov r1,-(sp) clr -(sp) ;'+' indicator sval0: cmpb (r0)+,#bl ;ignore starting blanks beq sval0 cmpb -(r0),#'+ ;check + sign beq sval1 ;yes, ignore cmpb (r0),#'- ;or minus sign bne sval2 com (sp) ;yes, remember sval1: inc r0 sval2: mov t3(r5),-(sp) ;save t3 clr t3(r5) ;set flag for not line no. jsr pc,val ;input number from (r0) bcs svaler ;illegal number mov (sp)+,t3(r5) ;restore t3 jsr pc,norm bcs svaler ;illegal number mov r4,fac2(r5) ;save it mov r3,fac1(r5) bne sval3 ;go test neg floating pt tst (sp)+ ;neg integer? beq sval4 ;no, done neg fac2(r5) ;yes, negate integer br sval4 sval3: tst (sp)+ ;neg flt pt? beq sval4 ;no, bypass bis #100000,fac1(r5);yes, negate sval4: mov (sp)+,r1 ;restore regs mov (sp)+,r2 mov (sp)+,r4 rts pc svaler: jmp errnob ;illegal number .end b ;illegal number .end