LEX 'PILEXTLX' * TITLE PILEXT LEX, Ver<860830>, J Baker * *********************************************************** * CON(2) #5E last scratch, see JRBTOKEN for asnmt CON(2) #41 low token, in hex CON(2) #42 high token REL(5) LEX#2 link to second LEX file NIBHEX F no speed table REL(4) (TxTbSt)+1 offset to TEXT Table CON(4) 0 no message table REL(5) POLHND offset to poll handler * *********************************************************** * EQUATES * DDL EQU #06B25 send DDL frame DDT EQU #06B34 send DDT frame PRMSGA EQU #00CB9 send bytes from C SEEKA EQU #04232 seek to a record PUTD EQU #06AAE put a data byte TSTAT EQU #041FE check tape status PUTARL EQU #00E25 put bytes from A DROPDC EQU #05470 decompile FILDC* EQU #05759 decompile a filespec NTOKEN EQU #0493B fetch next parse token GETDID EQU #06D84 fetch device info during Stmt exec EXPEX- EQU #0F178 collapse then evaluate COLLAP EQU #091FB collapse math to for stack WRITE# EQU #0453F write a massmem record STMTR0 EQU #2F871 Statement scratch FSPECp EQU #03CC5 parse for file spec, polls pil SYNTXe EQU #02E2B parse syntax error tCOMMA EQU #000F1 comma token OUT1TK EQU #02CEB output token STRNGP EQU #0379D parse string READR# EQU #044FF read a mass memory record ENDTAP EQU #044D9 rewind, unt, unl AVMEMS EQU #2F594 available memory start GETD EQU #067C8 read a data frame DEVPAR EQU #01BF0 parse device spec from stack EXPEXC EQU #0F186 the expression execution controller XYEX EQU #0C697 exchange AB/CD uRES12 EQU #0C994 pack 15 form in AB to 12 form in C MP2-15 EQU #0C43A multiply two 15s BF2STK EQU #18663 push string to stack FNRTN1 EQU #0F216 push C(W) to stack at bottom TRFMBF EQU #2F8C5 REV$ EQU #1B38E reverse string on stack VAL00 EQU #1AD8F convert string to number, ST10=1 for rtn GETMBX EQU #03B62 set D0 to ^MBOX value SCRTCH EQU #2F901 scratch ram, 64d nibs FNRTN4 EQU #0F238 pushes C(W) at D1, assumes D1 ready SPLITA EQU #0C6BF split A(W) to AB SPLITC EQU #0C940 split C(W) to CD DV2-15 EQU #0C4AC divide two 15s, AB=AB/CD LGT15 EQU #0D1AE AB=LOGbase10(AB) POP1N EQU #0BD1C pop number to A(W) FLTDH EQU #1B223 convert 12 form to hex integer SNAPBF EQU #2F7F0 the snapshot buffer bLEX EQU #00BFC the LEX buffer ID # I/OFND EQU #118BA finds an I/O buffer given the ID # LEXPIL EQU #000FF the HPIL ROM ID # eXWORD EQU #00023 mainframe error # for XWORD BSERR EQU #0939A the BASIC error reporting routine WRDSCN EQU #02C2A scan table for token match & output tON EQU #000E0 the ON token tOFF EQU #000E1 the OFF token MSPARe EQU #02E5C parse error for missing parm TRACDC EQU #052FC decompile for ON/OFF OUTELA EQU #05303 keyword only decompile eIVARG EQU #0000B Invalid Argument error START EQU #007E8 searchs the loop for a device MTYL EQU #00C83 make me talk, device listen PRASCI EQU #00FEA send bytes to setup device UTLEND EQU #007CC untalk, unlisten the loop NXTSTM EQU #08A48 BASIC Statement return EXPR EQU #0F23C expression execution reentry READSU EQU #0663D read bytes from loop, sends sot frame FUNCR0 EQU #2F89B Function scratch RAM YTML EQU #00C9B make device talk, 71 listen NUMCK EQU #0369D parse numeric expression RESPTR EQU #03172 restore parse input pointer FIXDC EQU #05493 decompile numeric expression PUTE EQU #06AC0 put a frame to the mailbox from C 5:0 POP1S EQU #0BD38 pop a string on stack STRGCK EQU #036BA parse a string expression REVPOP EQU #0BD31 reverse a string then pop eNOFND EQU #0FF20 device not found error eCHSUM EQU #0FF1A bad checksum on medium error SWPBYT EQU #17A24 swap A(3:2) and A(1:0) FNDCHK EQU #00B86 find mailbox & check status GLOOP# EQU #02D5A fetch loop# at D0 during execution LOOP#p EQU #076A7 parse loop # LOOP#d EQU #07CAA decompile loop # OUTEL1 EQU #05300 decompile exit * *********************************************************** STITLE Language tables * CON(3) (TxEn02)-(TxTbSt) REL(5) STATUS CON(1) #F * CON(3) (TxEn01)-(TxTbSt) REL(5) SETSOT CON(1) #D * ************************************************************ * STITLE TEXT Table * TxTbSt TxEn01 CON(1) (TxEn02)-(*)-4 NIBASC 'SETSOT' CON(2) #42 * TxEn02 CON(1) (TxEnTm)-(*)-4 NIBASC 'SST$' CON(2) #41 * ******************************** TxEnTm NIBHEX 1FF TEXT Table terminator * STITLE Poll Handler * POLHND ?B=0 B VER$ poll ? GOYES POLL10 yes RTNSXM no, return * POLL10 A=R2 read AVMEMS C=R3 read stack pointer D1=C D1=D1- (Ve)-(Vs)-2 decrement for our string CD1EX ?A>C A will AVMEMS and the stack collide ? GOYES POLL20 yes, error exit D1=C no, restore stack pointer R3=C also save copy for next LEX file Vs LCASC ' PILEX:b' Ve DAT1=C (Ve)-(Vs)-2 add our response * POLL20 RTNSXM exit poll * *********************************************************** * STITLE HPIL JUMPER * * * JUMPER: a routine for accessing the HPIL ROM * * * this routine is transparent to the CPU except for SB * * (assembly code) * (setup CPU for call) * GOSUB JUMPER * CON(5) (target routine offset) * (resume assembly code) * *********************************************************** * JUMPER RSTK=C CD1EX D1=(5) SNAPBF DAT1=C A write D1 @ SNAPBF D1=(2) (SNAPBF)+5 C=RSTK DAT1=C W write C(W) @ SNAPBF + 5 D1=(4) (SNAPBF)+21 DAT1=A W write A(W) @ SNAPBF + 21 D1=(2) (SNAPBF)+37 C=B A CPEX 5 save P @ SNAPBF + 42 P= 6 C=0 P GONC JUMP05 C:6='0' means carry clear C=C-1 P C:6#'0' means carry set JUMP05 P= 7 C=0 P C=C-1 P C:7='9' means decimal mode DAT1=C 8 write B(A),P,Carry,mode @ SNAPBF + 37 SETHEX set hex mode for I/OFND ************ * now A(W), B(A), C(W), and D1 are available for use * P= 0 LC(3) bLEX find the LEX buffer GOSBVL I/OFND GONC JUMP90 if not there, error exit ************ * LEX buffer found; D1 points to it * search the LEX buffer for the HPIL ROM entry * LC(2) LEXPIL C(B)=HPIL ROM ID # B=C A A=0 A A=A+1 A A(B)=Token # within HPIL ROM JUMP10 C=DAT1 6 ?C=0 B is this the end of the LEX buffer ? GOYES JUMP90 yes, then error exit ?B#C B is this the right ID ? GOYES JUMP20 no, try the next one ************ * LEX ID matches; see if token # is in range * CSR W CSR A C 3:0 is now the token range ?AC A crash? GOYES pilerr yes... CD1EX no, swap back DAT1=C B else..., write byte to stack GOTO STAT03 one more round on the loop please! * pilerr GOTO PILERR * STAT02 GOSUB utlend clean loop P= 0 C=0 W A=R0 fetch stack start (high) to A(A) CD1EX swap end (low) to C(A) D1=C restore stack pointer, to low D1=D1- 16 point to string header CD1EX swap ?D>C A would adding the header crash ? GOYES pilerr yes CD1EX no, swap back C=A-C A compute actual string length CSL W CSL W C=C-1 P create string header tag DAT1=C W write string header STAT04 D0=(5) (FUNCR0)+32 A=DAT0 A read D0 D0=A restore D0 GOVLNG EXPR exit * * *********************************************************** * * this is LEX file #2 * LEX#2 CON(2) #5E last scratch, see JRBTOKEN for asnmt CON(2) #47 low token CON(2) #4A high token CON(5) 0 no links NIBHEX F no speed table REL(4) (TXTbSt)+1 CON(4) 0 no message table CON(5) 0 no poll handler * ************************************************************ * MAIN table * CON(3) (TXEn04)-(TXTbSt) REL(5) VOL CON(1) #D * CON(3) (TXEn03)-(TXTbSt) REL(5) VOL$ CON(1) #F * CON(3) (TXEn02)-(TXTbSt) REL(5) VERIFY CON(1) #D * CON(3) (TXEn01)-(TXTbSt) REL(5) BURN CON(1) #D * ************************************************************ * TEXT table * TXTbSt TXEn01 CON(1) (TXEn02)-(*)-4 NIBASC 'BURN' CON(2) #4A * TXEn02 CON(1) (TXEn03)-(*)-4 NIBASC 'VERIFY' CON(2) #49 * TXEn03 CON(1) (TXEn04)-(*)-4 NIBASC 'VOLUME$' CON(2) #48 * TXEn04 CON(1) (TXEnTm)-(*)-4 NIBASC 'VOLUME' CON(2) #47 * TXEnTm NIBHEX 1FF end of TEXT table * ************************************************************ * STITLE VOLUME$ keyword execution *********************************************************** ** ** Name: VOLUME$ ** ** Purpose: read & return the volume label of a medium ** ** Entry: D1 at device specifier on stack ** ** Exit: through EXPR to resume expression execution ** ** Calls: DEVPAR, READR#, ENDTAP, REV$, ** ** Uses: everything available to expressions ** ** Levels: ** ** Notes: always returns a 6 byte string ** *********************************************************** * NIBHEX C11 VOL$ GOSUB FNDDEV parse spec, search loop, collap stk GOSUB RDREC0 read record 0 D1=D1+ 4 point to volume label A=DAT1 12 read label C=R0 D1=C collapse stack D1=D1- 12 allow for label DAT1=A 12 write label D1=D1- 16 allow for header C=0 W LCHEX C0F create proper header DAT1=C W write header GOSBVL REV$ reverse string GOTO STAT04 exit * ************************************************************ * RDREC0 D1=(5) AVMEMS A=DAT1 A read memory start to A(A) LC(5) 256*2 load record length B=B-C A compute new stack with record C=B A ?C ** ** Uses: ** ** Levels: 7 during getdid call ** ** Notes: does not work for 82161A ** errors to BSERR if verify bad ** *********************************************************** * VERpar GOSBVL FSPECp parse device specifier RTNNC GOTO VOLper * VERdcm GOSBVL FILDC* decompile device specifier GOVLNG OUTEL1 exit * * REL(5) VERdcm REL(5) VERpar VERIFY GOSUB getdid fetch device info GOSUB start see if it is good GOSUB JUMPER CON(5) TSTAT read and ignore first error P= 7 GOSUB ddt ask for max rec LCHEX 800002 GOSUB pute start 2 byte transfer GOSUB getd fetch high byte A=C B save in A GOSUB getd fetch low byte ASL A ASL A A=C B low to A A=A-1 A now A(3:0)= # of recs to verify GOSBVL SWPBYT reverse order R0=A save GOSUB mtyl make 71 talk, device listen P= 4 GOSUB ddl set seek A=0 W P= 2 GOSUB putarl seek to record zero GOSUB tstat wait GOSUB mtyl reestablish 71 talk, device listen P= 11 GOSUB ddl set verify mode A=R0 P= 2 GOSUB putarl send # of records to verify, & start GOSUB tstat wait GOTO VOL03 exit if done ok * ************************************************************ * STITLE BURN keyword execution *********************************************************** ** ** Name: BURN ** ** Purpose: sends bytes to an eprom burner with GETs ** ** Entry: D0 at device spec ** ** Exit: through NXTSTM ** ** Calls: START, EXPEX-, REVPOP, GETMBX, MTYL, PUTD, PUTE ** UTLEND, ** ** Uses: ** ** Levels: 7 during getdid call ** ** Notes: designed for SC for mountain burner ** *********************************************************** * REL(5) VOLdcm REL(5) VOLpar BURN GOSUB getdid get device id GOSUB DEVSET check device, evaluate string B=0 W B=A A BSRB convert length to bytes ?B#0 A null ? GOYES BURN01 no, continue GOTO PILERR yes, error BURN01 D0=(5) STMTR0 C=DAT0 A D=C A restore device address GOSUB JUMPER CON(5) GETMBX restore D0 to mailbox GOSUB mtyl 71 talk, device listen BURN02 C=DAT1 B read byte D1=D1+ 2 step past GOSUB putd send to loop P= 0 LCHEX 140800 load GET frame GOSUB pute trigger device B=B-1 A decrement count ?B#0 A done ? GOYES BURN02 no, loop GOSUB utlend yes, clean loop GOTO VOL04 exit * ************************************************************ * STITLE SETSOT keyword execution *********************************************************** ** ** Name: SETSOT ** ** Purpose: set diamond sot response as a device ** ** Entry: D0 at response type ** ** Exit: through NXTSTM ** ** Calls: EXPEXC, REVPOP, EXPEX-, GETMBX, PUTE, ** ** Uses: ** ** Levels: ** ** Notes: type... D=sdi, A=sai, S=sst ** *********************************************************** * SOTpar GOSUB JUMPER CON(5) LOOP#p parse optional loop number GOSBVL STRNGP parse type GOTO VOLp01 go parse response * SOTdcm GOSUB JUMPER CON(5) LOOP#d decompile optional loop # GOVLNG FIXDC decompile type and response * REL(5) SOTdcm REL(5) SOTpar SETSOT GOSUB JUMPER CON(5) GLOOP# check for optional loop number CD0EX R0=C save pc GOSUB fndchk check diamond mode, set ^MBOX C=R0 D0=C restore pc GOSBVL EXPEX- evaluate type GOSBVL REVPOP pop C=DAT1 B read type byte D1=(5) STMTR0 DAT1=C B save D0=D0+ 2 skip comma GOSBVL EXPEX- evaluate response GOSBVL REVPOP pop ?A#0 A null response ? GOYES SOT01 no, continue SOT02 LC(4) eIVARG yes, show lousy argument GOTO bserr * SOT01 C=A A C=C-1 A this puts acceptable length into 1 nib P=C 0 C=0 W C=DAT1 WP read response from stack, 8 bytes max P= 0 R0=C save response ASRB convert length to bytes R1=A save response length D1=(5) STMTR0 A=DAT1 B fetch type LCASC 'A' ?A#C B is it SAI ? GOYES SOT03 no, test for SDI GOTO SOTSAI yes, process SAI response SOT03 LCASC 'D' ?A#C B is it SDI ? GOYES SOT02 no, * yes, process SDI response * SOTSDI GOSUB JUMPER CON(5) GETMBX point D0 to mailbox C=R1 fetch response length CSL W CSL W LC(2) #10 create SDI length opcode P= 3 LC(3) #F30 finish SDI opcode creation GOSUB pute write to diamond A=R1 fetch response length A=A-1 P zero base (i.e. 0-7) LC(1) 7 A=A&C P mask out high bit ASRC put response length in A(S) B=0 S set B(S) as byte counter C=R0 D=C W put response string in D(W) SDI01 B=B+1 S increment byte count to set LCHEX #F30010 load opcode "shell" CSRC CSRC C=D B insert response value CSLC C=B S insert byte number CSLC GOSUB pute set this byte DSR W DSR W align next byte value A=A-1 S decrement count GONC SDI01 loop if not done GOTO VOL04 else exit * SOTSAI GOSUB JUMPER CON(5) GETMBX set D0 to mailbox C=R0 fetch response byte CSL W CSL W LC(2) #21 set SAI byte 1 P= 4 LC(2) #F3 finish creating opcode GOSUB pute write diamond GOTO VOL04 exit * ************************************************************ * END