******************************************************************************** TITL 'CONTROL BLOCK 0' CIF EQU >74AA * GROM ADDRESS'S CALL EQU >750A * COMPCT EQU >73D8 * DELREP EQU >7EF4 * GETSTR EQU >736C * GREAD EQU >7EB4 * GREAD1 EQU >7EA6 * GVWITE EQU >7FDA * GWITE1 EQU >7ECA * GWRITE EQU >7ED8 * IO EQU >7B48 * MEMCHG EQU >72CE * MEMCHK EQU >72D8 * MVDN EQU >7F7E * MVDN2 EQU >7F8A * NFOR EQU >7000 * NNEXT EQU >7230 * NSTRCN EQU >7442 * PSCAN EQU >7C56 * RESOLV EQU >7946 * SCROLL EQU >7ADA * SUBXIT EQU >78D2 * VGWITE EQU >7FC0 * * ******************************************************************************** TITL 'EQUATES' * LWCNS EQU >6000 * WRVDP EQU >4000 Write enable for VDP XVDPRD EQU >8800 Read VDP data XVDPWD EQU >8C00 Write VDP data XGRMRD EQU >9800 Read GROM data GRMWAX EQU >9C02->9800 Write GROM address GRMRAX EQU >9802->9800 Read GROM address GRMWDX EQU >9C00->9800 GROM write data * KEYTAB EQU >CB00 ADDRESS OF KEYWORD TABLE * NEGPAD EQU >7D00 PAD0 EQU >8300 PAD1 EQU >8301 PAD5F EQU >835F PADC2 EQU >83C2 * VAR0 EQU >8300 MNUM EQU >8302 MNUM1 EQU >8303 PABPTR EQU >8304 CCPPTR EQU >8306 CCPADR EQU >8308 RAMPTR EQU >830A CALIST EQU RAMPTR BYTE EQU >830C PROAZ EQU >8310 VAR5 EQU PROAZ PZ EQU >8312 LINUM EQU PZ OEZ EQU >8314 QZ EQU >8316 XFLAG EQU QZ VAR9 EQU QZ DSRFLG EQU >8317 FORNET EQU DSRFLG STRSP EQU >8318 CZ EQU >831A STREND EQU CZ WSM EQU CZ SREF EQU >831C * Temporary string pointer WSM2 EQU SREF * Temporary string pointer WSM4 EQU >831E * Start of current statement SMTSRT EQU WSM4 * Start of current statement WSM6 EQU >8320 * Screen address VARW EQU WSM6 * Screen address VARW1 EQU >8321 ERRCOD EQU >8322 * Return error code from ALC WSM8 EQU ERRCOD * Return error code from ALC ERRCO1 EQU >8323 STVSPT EQU >8324 * Value-stack base RTNADD EQU >8326 NUDTAB EQU >8328 VARA EQU >832A * Ending display location PGMPTR EQU >832C * Program text pointer PGMPT1 EQU >832D EXTRAM EQU >832E * Line number table pointer EXTRM1 EQU >832F STLN EQU >8330 * Start of line number table ENLN EQU >8332 * End of line number table DATA EQU >8334 * Data pointer for READ LNBUF EQU >8336 * Line table pointer for READ INTRIN EQU >8338 * Add of intrinsic poly constant SUBTAB EQU >833A * Subprogram symbol table SYMTAB EQU >833E * Symbol table pointer SYMTA1 EQU >833F FREPTR EQU >8340 * Free space pointer CHAT EQU >8342 * Current charater/token BASE EQU >8343 * OPTION BASE value PRGFLG EQU >8344 * Program/imperative flag FLAG EQU >8345 * General 8-bit flag BUFLEV EQU >8346 * Crunch-buffer destruction level LSUBP EQU >8348 * Last subprogram block on stack FAC EQU >834A * Floating-point ACcurmulator FAC1 EQU >834B FAC2 EQU >834C FAC4 EQU >834E FAC5 EQU >834F FAC6 EQU >8350 FAC7 EQU >8351 FAC8 EQU >8352 FAC9 EQU >8353 FAC10 EQU >8354 FLTNDX EQU FAC10 FDVSR EQU FAC10 FAC11 EQU >8355 SCLEN EQU FAC11 FDVSR1 EQU FAC11 FAC12 EQU >8356 FDVSR2 EQU FAC12 FAC13 EQU >8357 FAC14 EQU >8358 FAC15 EQU >8359 FAC16 EQU >835A FDVSR8 EQU >835C * Floating-point ARGument ARG EQU FDVSR8 * Floating-point ARGument ARG1 EQU >835D ARG2 EQU >835E ARG3 EQU >835F ARG4 EQU >8360 ARG8 EQU >8364 ARG9 EQU >8365 ARG10 EQU >8366 FAC33 EQU >836B TEMP2 EQU >836C FLTERR EQU TEMP2 TYPE EQU >836D VSPTR EQU >836E * Value stack pointer VSPTR1 EQU >836F STKDAT EQU >8372 STKADD EQU >8373 STACK EQU >8373 PLAYER EQU >8374 KEYBRD EQU >8375 SIGN EQU KEYBRD JOYY EQU >8376 * Exponent in floating-point EXP EQU JOYY JOYX EQU >8377 RANDOM EQU >8378 TIME EQU >8379 MOTION EQU >837A VDPSTS EQU >837B STATUS EQU >837C CHRBUF EQU >837D YPT EQU >837E XPT EQU >837F RAMFLG EQU >8389 * ERAM flag STKEND EQU >83BA STND12 EQU STKEND-12 CRULST EQU >83C0 SAVEG EQU >83CB SADDR EQU >83D2 RAND16 EQU >83D4 * WS EQU >83E0 R0LB EQU >83E1 R1LB EQU >83E3 R2LB EQU >83E5 R3LB EQU >83E7 R4LB EQU >83E9 R5LB EQU >83EB R6LB EQU >83ED R7LB EQU >83EF R8LB EQU >83F1 R9LB EQU >83F3 R10LB EQU >83F5 R11LB EQU >83F7 R12LB EQU >83F9 R13LB EQU >83FB R14LB EQU >83FD R15LB EQU >83FF * GDST EQU >8302 AAA11 EQU >8303 GDST1 EQU >8303 VARY EQU >8304 VARY2 EQU >8306 BCNT2 EQU >8308 CSRC EQU >830C ADDR1 EQU >834C ADDR11 EQU >834D BCNT1 EQU >834E ADDR2 EQU >8350 ADDR21 EQU >8351 GSRC EQU >8354 DDD11 EQU >8355 GSRC1 EQU >8355 BCNT3 EQU >8356 DEST EQU >8358 DEST1 EQU >8359 RAMTOP EQU >8384 * VDP variables SYMBOL EQU >0376 * Saved symbol table pointer ERRLN EQU >038A * On-error line pointer TABSAV EQU >0392 * Saved main symbol table ponter VROAZ EQU >03C0 * Temporary VDP Roll Out Area FPSIGN EQU >03DC CRNBUF EQU >0820 * CRuNch BUFfer address CRNEND EQU >08BE * CRuNch buffer END ******************************************************************************** AORG >6000 TITL 'XML359' * PAGE SELECTOR FOR PAGE 1 PAGE1 EQU $ >6000 C2 DATA 2 0 * PAGE SELECTOR FOR PAGE 2 PAGE2 EQU $ >6002 C7 BYTE >00 CBH7 BYTE >07 2 CBHA BYTE >0A CBH94 BYTE >94 4 C40 DATA 40 6 C100 DATA 100 8 C1000 DATA >1000 A DATA 0 C FLTONE DATA >4001 E ************************************************************* * XML table number 7 for Extended Basic - must have * * it's origin at >6010 * ************************************************************* * 0 1 2 3 4 5 6 DATA COMPCG,GETSTG,MEMCHG,CNSSEL,PARSEG,CONTG,EXECG * 7 8 9 A B C D DATA VPUSHG,VPOP,PGMCH,SYMB,SMBB,ASSGNV,FBSYMB * E F DATA SPEED,CRNSEL ************************************************************* * XML table number 8 for Extended Basic - must have * * it's origin at >6030 * ************************************************************* * 0 1 2 3 4 5 6 7 DATA CIF,CONTIN,RTNG,SCROLL,IO,GREAD,GWRITE,DELREP * 8 9 A B C D E DATA MVDN,MVUP,VGWITE,GVWITE,GREAD1,GWITE1,GDTECT * F DATA PSCAN * Determine if and how much ERAM is present GDTECT MOVB R11,@PAGE1 First enable page 1 ROM *-----------------------------------------------------------* * Replace following line 6/16/81 * * (Extended Basic must be made to leave enough space at * * top of RAM expansion for the "hooks" left by the 99/4A * * for TIBUG.) * * SETO R0 Start at >FFFF * * with LI R0,>FFE7 Start at >FFE7 *-----------------------------------------------------------* MOVB R11,*R0 Write a byte of data CB R11,*R0 Read and compare the data JEQ DTECT2 If matches-found ERAM top *-----------------------------------------------------------* * Change the following line 6/16/81 * * AI R0,->2000 Else drop down 8K * LI R0,>DFFF Else drop down 8K *-----------------------------------------------------------* MOVB R11,*R0 Write a byte of data CB R11,*R0 Read and compare the data JEQ DTECT2 If matches-found ERAM top CLR R0 No match so no ERAM DTECT2 MOV R0,@RAMTOP Set the ERAM top RT And return to GPL CNSSEL LI R2,CNS JMP PAGSEL CRNSEL LI R2,CRUNCH * Select page 2 for CRUNCH and CNS PAGSEL INCT @STKADD Get space on subroutine stack MOVB @STKADD,R7 Get stack pointer SRL R7,8 Shift to use as offset MOVB R11,@PAD0(R7) Save return addr to GPL interpeter MOVB @R11LB,@PAD1(R7) MOVB R11,@PAGE2 Select page 2 BL *R2 Do the conversion MOVB R11,@PAGE1 Reselect page 1 MOVB @STKADD,R7 Get subroutine stack pointer DECT @STKADD Decrement pointer SRL R7,8 Shift to use as offset MOVB @PAD0(R7),R11 Restore return address MOVB @PAD1(R7),@R11LB RT Return to GPL interpeter GETCH MOVB @R6LB,*R15 NOP MOVB R6,*R15 INC R6 MOVB @XVDPRD,R8 GETCH1 SRL R8,8 RT GETCHG MOVB R6,@GRMWAX(R13) MOVB @R6LB,@GRMWAX(R13) INC R6 MOVB *R13,R8 JMP GETCH1 GETCGR MOVB *R6+,R8 JMP GETCH1 * CBHFF EQU $+2 POPSTK LI R5,-8 MOVB @VSPTR1,*R15 LI R6,ARG MOVB @VSPTR,*R15 A R5,@VSPTR STKMOV MOVB @XVDPRD,*R6+ INC R5 JNE STKMOV RT * PUTSTK INCT @STKADD MOVB @STKADD,R4 SRL R4,8 MOVB @GRMRAX(13),@PAD0(R4) MOVB @GRMRAX(13),@PAD1(R4) DEC @PAD0(R4) RT * GETSTK MOVB @STKADD,R4 SRL R4,8 DECT @STKADD MOVB @PAD0(R4),@GRMWAX(R13) MOVB @PAD1(R4),@GRMWAX(R13) RT ******************************************************************************** AORG >6126 TITL 'REFS359' ROUNUP EQU >0F64 Uses XML >01 Rounding of floating point numbers SCOMPB EQU >0D42 Set SCOMP with direct return without GPL status CFI EQU >12B8 CFI (XML >12) SMULT EQU >0E8C SMUL (XML >0D) FDIV EQU >0FF4 FDIV (XML >09) OVEXP EQU >0FC2 Overflow (XML >04) FMULT EQU >0E88 FMUL (XML >08) SSUB EQU >0D74 SSUB (XML >0C) FADD EQU >0D80 FADD (XML >06) SDIV EQU >0FF8 SDIV (XML >0E) FSUB EQU >0D7C FSUB (XML (>07) SADD EQU >0D84 SADD (XML >0B) ROUNU EQU >0FB2 Rounding with digit number in >8354 (XML >02) RESET EQU >006A Clear condition bit in GPL status (GPL interpreter) NEXT EQU >0070 GPL interpreter CSN01 EQU >11B2 CSN (XML >10) (Without R3 loaded with >1FC8) FCOMP EQU >0D3A FCOMP (XML >0A) FCOMPB MOV R11,R3 B @FCOMP+22 GETV EQU >187C Read 1 byte from VDP, Entry over data address pointer GETV1 EQU >1880 Same >187C but does not fetch address, is preloaded first SAVREG EQU >1E8C Set substack pointer and Basic byte SAVRE2 EQU >1E90 Same >1E8C but does not set R8 into >8342 SETREG EQU >1E7A Substack pointer in R9 and actual Basic byte in R8 STVDP3 EQU >18AA Write R6 in VDP (R1=Address+3), * used for variable table and string pointer STVDP EQU >18AE Write R6 in VDP (R1=Address+3), * used for variable table and string pointer. (R3 Preloaded) FBS EQU >15E0 Pointer fetch var list FBS001 EQU >15E6 Fetch length byte ******************************************************************************** AORG >612C TITL 'CPT' * * The CHARACTER PROPERTY TABLE * There is a one-byte entry for every character code * in the range LLC(lowest legal character) to * HLC(highest legal character), inclusive. LLC EQU >20 CPNIL EQU >00 " $ % ' ? CPDIG EQU >02 digit (0-9) CPNUM EQU >04 digit, period, E CPOP EQU >08 1 char operators(!#*+-/<=>^ ) CPMO EQU >10 multiple operator ( : ) CPALPH EQU >20 A-Z, @, _ CPBRK EQU >40 ( ) , ; CPSEP EQU >80 space CPALNM EQU CPALPH+CPDIG alpha-digit *-----------------------------------------------------------* * Following lines are for adding lowercase character set in * * 99/4A, 5/12/81 * CPLOW EQU >01 a-z * CPULNM EQU CPALNM+CPLOW Alpha(both upper and lower)+ * * digit-legal variable characters CPUL EQU CPALPH+CPLOW Alpha(both upper and lower) * *-----------------------------------------------------------* CPTBL EQU $-LLC BYTE CPSEP SPACE BYTE CPOP ! EXCLAMATION POINT BYTE CPNIL " QUOTATION MARKS BYTE CPOP # NUMBER SIGN BYTE CPNIL $ DOLLAR SIGN BYTE CPNIL % PERCENT BYTE CPOP & AMPERSAND BYTE CPNIL ' APOSTROPHE BYTE CPBRK ( LEFT PARENTHESIS BYTE CPBRK ) RIGHT PARENTHESIS BYTE CPOP * ASTERISK BYTE CPOP+CPNUM + PLUS BYTE CPBRK , COMMA BYTE CPOP+CPNUM - MINUS BYTE CPNUM . PERIOD BYTE CPOP / SLANT BYTE CPNUM+CPDIG 0 ZERRO BYTE CPNUM+CPDIG 1 ONE BYTE CPNUM+CPDIG 2 TWO BYTE CPNUM+CPDIG 3 THREE BYTE CPNUM+CPDIG 4 FOUR BYTE CPNUM+CPDIG 5 FIVE BYTE CPNUM+CPDIG 6 SIX BYTE CPNUM+CPDIG 7 SEVEN BYTE CPNUM+CPDIG 8 EIGHT BYTE CPNUM+CPDIG 9 NINE LBCPMO BYTE CPMO : COLON BYTE CPBRK : SEMICOLON BYTE CPOP < LESS THAN BYTE CPOP = EQUALS BYTE CPOP > GREATER THAN BYTE CPNIL ? QUESTION MARK BYTE CPALPH @ COMMERCIAL AT BYTE CPALPH A UPPERCASE A BYTE CPALPH B UPPERCASE B BYTE CPALPH C UPPERCASE C BYTE CPALPH D UPPERCASE D BYTE CPALPH+CPNUM E UPPERCASE E BYTE CPALPH F UPPERCASE F BYTE CPALPH G UPPERCASE G BYTE CPALPH H UPPERCASE H BYTE CPALPH I UPPERCASE I BYTE CPALPH J UPPERCASE J BYTE CPALPH K UPPERCASE K BYTE CPALPH L UPPERCASE L BYTE CPALPH M UPPERCASE M BYTE CPALPH N UPPERCASE N BYTE CPALPH O UPPERCASE O BYTE CPALPH P UPPERCASE P BYTE CPALPH Q UPPERCASE Q BYTE CPALPH R UPPERCASE R BYTE CPALPH S UPPERCASE S BYTE CPALPH T UPPERCASE T BYTE CPALPH U UPPERCASE U BYTE CPALPH V UPPERCASE V BYTE CPALPH W UPPERCASE W BYTE CPALPH X UPPERCASE X BYTE CPALPH Y UPPERCASE Y BYTE CPALPH Z UPPERCASE Z BYTE CPALPH [ LEFT SQUARE BRACKET BYTE CPALPH \ REVERSE SLANT BYTE CPALPH ] RIGHT SQUARE BRACKET BYTE CPOP ^ CIRCUMFLEX BYTE CPALPH _ UNDERLINE *-----------------------------------------------------------* * Following "`" and lowercase characters are for * * adding lowercase character set in 99/4A, 5/12/81 * *-----------------------------------------------------------* BYTE CPNIL ` GRAVE ACCENT BYTE CPALPH+CPLOW a LOWERCASE a BYTE CPALPH+CPLOW b LOWERCASE b BYTE CPALPH+CPLOW c LOWERCASE c BYTE CPALPH+CPLOW d LOWERCASE d BYTE CPALPH+CPLOW e LOWERCASE e BYTE CPALPH+CPLOW f LOWERCASE f BYTE CPALPH+CPLOW g LOWERCASE g BYTE CPALPH+CPLOW h LOWERCASE h BYTE CPALPH+CPLOW i LOWERCASE i BYTE CPALPH+CPLOW j LOWERCASE j BYTE CPALPH+CPLOW k LOWERCASE k BYTE CPALPH+CPLOW l LOWERCASE l BYTE CPALPH+CPLOW m LOWERCASE m BYTE CPALPH+CPLOW n LOWERCASE n BYTE CPALPH+CPLOW o LOWERCASE o BYTE CPALPH+CPLOW p LOWERCASE p BYTE CPALPH+CPLOW q LOWERCASE q BYTE CPALPH+CPLOW r LOWERCASE r BYTE CPALPH+CPLOW s LOWERCASE s BYTE CPALPH+CPLOW t LOWERCASE t BYTE CPALPH+CPLOW u LOWERCASE u BYTE CPALPH+CPLOW v LOWERCASE v BYTE CPALPH+CPLOW w LOWERCASE w BYTE CPALPH+CPLOW x LOWERCASE x BYTE CPALPH+CPLOW y LOWERCASE y BYTE CPALPH+CPLOW z LOWERCASE z EVEN ******************************************************************************** AORG >6188 TITL 'BASSUP' * General Basic support routines (not includeing PARSE) * ERRBS EQU >0503 BAD SUBSCRIPT ERROR CODE ERRTM EQU >0603 ERROR STRING/NUMBER MISMATCH * STCODE DATA >6500 C6 DATA >0006 * * Entry to find Basic symbol table entry for GPL * FBSYMB BL @FBS Search the symbol table DATA RESET If not found - condition reset SET SOCB @BIT2,@STATUS Set GPL condition B @NEXT If found - condition set * GPL entry for COMPCT to take advantage of common code COMPCG LI R6,COMPCT Address of COMPCT JMP SMBB10 Jump to set up * GPL entry for GETSTR to take advantage of common code GETSTG LI R6,GETSTR Address of MEMCHK JMP SMBB10 Jump to set up * GPL entry for SMB to take advantage of common code SMBB LI R6,SMB Address of SMB routine JMP SMBB10 Jump to set up * GPL entry for ASSGNV to take advantage of common code ASSGNV LI R6,ASSG Address of ASSGNV routine JMP SMBB10 Jump to set up * GPL entry for SMB to take advantage of common code SYMB LI R6,SYM Address of SYM routine JMP SMBB10 Jump to set up * GPL entry for SMB to take advantage of common code VPUSHG LI R6,VPUSH Address of VPUSH routine SMBB10 MOV R11,R7 Save return address BL @PUTSTK Save current GROM address BL @SETREG Set up Basic registers INCT R9 Get space on subroutine stack MOV R7,*R9 Save the return address BL *R6 Branch and link to the routine MOV *R9,R7 Get return address DECT R9 Restore subroutine stack BL @SAVREG Save registers for GPL BL @GETSTK Restore GROM address B *R7 Return to GPL ************************************************************* * Subroutine to find the pointer to variable space of each * * element of symbol table entry. Decides whether symbol * * table entry pointed to by FAC, FAC+1 is a simple variable * * and returns proper 8-byte block in FAC through FAC7 * ************************************************************* SMB INCT R9 Get space on subroutine stack MOV R11,*R9 Save return address MOV @FAC,@FAC4 Copy pointer to table entry A @C6,@FAC4 Add 6 so point a value space BL @GETV Get 1st byte of table entry DATA FAC Pointer is in FAC * MOV R1,R4 Copy for later use. MOV R1,R2 Copy for later use. SLA R1,2 Check for UDF entry JOC BERMUV If UDF - then error MOV R4,R4 Check for string. JLT SMB02 Skip if it is string. CLR @FAC2 Clear for numeric case. * * In case of subprogram call check if parameter is shared by * it's calling program. * SMB02 SLA R1,1 Check for the shared bit. JNC SMB04 If it is not shared skip. BL @GET Get the value space pointer DATA FAC4 in the symbol table. MOV R1,@FAC4 Store the value space address. * * Branches to take care of string and array cases. * Only the numeric variable case stays on. * SMB04 MOVB R4,R4 R4 has header byte information. JLT SMBO50 Take care of string. SMB05 SLA R4,5 Get only the dimension number. SRL R4,13 JNE SMBO20 go to array case. * * Numeric ERAM cases are special. * If it is shared get the actual v.s. address from ERAM. * Otherwise get it from VDP RAM. * MOVB @RAMTOP,R4 Check for ERAM. JEQ SMBO10 Yes ERAM case. SLA R2,3 R2 has a header byte. JNC SMB06 Shared bit is not ON. BL @GETG Get v.s. pointer from ERAM DATA FAC4 JMP SMB08 SMB06 BL @GET Not shared. DATA FAC4 Get v.s. address from VDP RAM. * SMB08 MOV R1,@FAC4 Store it in FAC4 area. * * Return from the SMB routine. * SMBO10 MOV *R9,R11 Restore return address DECT R9 Restore stack RT And return BERMUV B @ERRMUV * INCORRECT NAME USAGE * * Start looking for the real address of the symbol. * SMBO50 CI R8,LPARZ*256 String - now string array? JEQ SMB05 Yes, process as an array SMB51 MOV @STCODE,@FAC2 String ID code in FAC2 MOV @FAC4,@FAC Get string pointer address BL @GET Get exact pointer to string DATA FAC * MOV R1,@FAC4 Save pointer to string MOV R1,R3 Was it a null? JEQ SMB57 Length is 0 - so is null DEC R3 Otherwise point at length byte BL @GETV1 Get the string length SRL R1,8 Shift for use as double SMB57 MOV R1,@FAC6 Put into FAC entry JMP SMBO10 And return * * Array cases are taken care of here. * SMBO20 MOV R4,@FAC2 Now have a dimension counter * that is initilized to maximum. * *FAC+4,FAC+5 already points to 1st dimension maximum in * in symbol table. CLR R2 Clear index accumulator SMBO25 MOV R2,@FAC6 Save accumulator in FAC BL @PGMCHR Get next character BL @PSHPRS PUSH and PARSE subscript BYTE LPARZ,0 Up to a left parenthesis or less * CB @FAC2,@STCODE Dimension can't be a string JHE ERRT It is - so error * Now do float to interger conversion of dimension CLR @FAC10 Assume no error BL @CFI Gets 2 byte integer in FAC,FAC1 MOVB @FAC10,R4 Error on conversion? JNE ERR3 Yes, error BAD SUBSCRIPT MOV @FAC,R5 Save index just read BL @VPOP Restore FAC block BL @GET Get next dimension maximum DATA FAC4 FAC4 points into symbol table * C R5,R1 Subscript less-then maximum? JH ERR3 No, index out of bounds BIT2 EQU $+1 Constant >20 (Opcode is >D120) MOVB @BASE,R4 Fetch option base to check low JEQ SMBO40 If BASE=0, INDEX=0 is ok DEC R5 Adjust BASE 1 index JLT ERR3 If subscript was =0 then error JMP SMBO41 Accumulate the subscripts SMBO40 INC R1 Adjust size if BASE=0 SMBO41 MPY @FAC6,R1 R1,R2 has ACCUM*MAX dimension A R5,R2 Add latest to accumulator INCT @FAC4 Increment dimension max pointer DEC @FAC2 Decrement remaining-dim count JEQ SMBO70 All dimensions handled ->done CI R8,COMMAZ*256 Otherwise, must be at a comma JEQ SMBO25 We are, so loop for more ERR1 B @ERRSYN Not a comma, so SYNTAX ERROR * * At this point the required number of dimensions have been * scanned. * R2 Contains the index * R4 Points to the first array element or points to the * address in ERAM where the first array element is. SMBO70 CI R8,RPARZ*256 Make sure at a right parenthesis JNE ERR1 Not, so error BL @PGMCHR Get nxt token BL @GETV Now check string or numeric DATA FAC array by checking s.t. * JLT SMB71 If MSB set is a string array SLA R2,3 Numeric, multiply by 8 MOVB @RAMTOP,R3 Does ERAM exist? JEQ SMBO71 No BL @GET Yes, get the content of value DATA FAC4 pointer * MOV R1,@FAC4 Put it in FAC4 SMBO71 A R2,@FAC4 Add into values pointer JMP SMBO10 And return in the normal way SMB71 SLA R2,1 String, multiply by 2 A R2,@FAC4 Add into values pointer JMP SMB51 And build the string FAC entry ERR3 LI R0,ERRBS Bad subscript return vector ERRX B @ERR Exit to GPL ERRT LI R0,ERRTM String/number mismatch vector JMP ERRX Use the long branch ************************************************************* * Subroutine to put symbol name into FAC and to call FBS to * * find the symbol table for the symbol * ************************************************************* SYM CLR @FAC15 Clear the caharacter counter LI R2,FAC Copying string into FAC MOV R11,R1 Save return address *-----------------------------------------------------------* * Fix "A long constant in a variable field in INPUT, * * ACCEPT, LINPUT, NEXT and READ etc. may crash the * * sytem" bug, 5/22/81 * Insert the following 2 lines MOVB R8,R8 JLT ERR1 If token SYM1 MOVB R8,*R2+ Save the character INC @FAC15 Count it BL @PGMCHR Get next character JGT SYM1 Still characters in the name BL @FBS Got name, now find s.t. entry DATA ERR1 Return vector if not found * B *R1 Return to caller if found ************************************************************* * ASSGNV, callable from GPL or 9900 code, to assign a value * * to a symbol (strings and numerics) . If numeric, the * * 8 byte descriptor is in the FAC. The descriptor block * * (8 bytes) for the destination variable is on the stack. * * There are two types of descriptor entries which are * * created by SMB in preparation for ASSGNV, one for * * numerics and one for strings. * * NUMERIC * * +-------------------------------------------------------+ * * |S.T. ptr | 00 | |Value ptr | | * * +-------------------------------------------------------+ * * STRING * +-------------------------------------------------------+ * * |Value ptr| 65 | |String ptr|String length | * * +-------------------------------------------------------+ * * * * CRITICAL NOTE: Becuase of the BL @POPSTK below, if a * * string entry is popped and a garbage collection has taken * * place while the entry was pushed on the stack, and the * * entry was a permanent string the pointer in FAC4 and FAC5 * * will be messed up. A BL @VPOP would have taken care of * * the problem but would have taken a lot of extra code. * * Therefore, at ASSG50-ASSG54 it is assumed that the * * previous value assigned to the destination variable has * * been moved and the pointer must be reset by going back to * * the symbol table and getting the correct value pointer. * ************************************************************* ASSG MOV R11,R10 Save the retun address BL @ARGTST Check arg and variable type STST R12 Save status of type BL @POPSTK Pop destination descriptor * into ARG SLA R12,3 Variable type numeric? JNC ASSG70 Yes, handle it as such * Assign a string to a string variable MOV @ARG4,R1 Get destination pointer * Dest have non-null value? JEQ ASSG54 No, null->never assigned * Previously assigned - Must first free the old value BL @GET Correct for POPSTK above DATA ARG Pointer is in ARG * MOV R1,@ARG4 Correct ARG+4,5 too *-----------------------------------------------------------* * Fix "Assigning a string to itself when memory is full can * * destroy the string" bug, 5/22/81 * * Add the following 2 lines and the label ASSG80 * C R1,@FAC4 Do not do anything in assign- * * ing a string to itself case * JEQ ASSG80 Detect A$=A$ case, exit * *-----------------------------------------------------------* CLR R6 Clear for zeroing backpointer BL @STVDP3 Free the string ASSG54 MOV @FAC6,R4 Is source string a null? JEQ ASSG57 Yes, handle specially MOV @FAC,R3 Get address of source pointer CI R3,>001C Got a temporay string? JNE ASSG56 No, more complicated MOV @FAC4,R4 Pick up direct ptr to string * Common string code to set forward and back pointers ASSG55 MOV @ARG,R6 Ptr to symbol table pointer MOV R4,R1 Pointer to source string BL @STVDP3 Set the backpointer ASSG57 MOV @ARG,R1 Address of symbol table ptr MOV R4,R6 Pointer to string BL @STVDP Set the forward pointer ASSG80 B *R10 Done, return * Symbol-to-symbol assigments of strings * Must create copy of string ASSG56 MOV @FAC6,@BYTE Fetch length for GETSTR * NOTE: FAC through FAC+7 cannot be destroyed * address^of string length^of string BL @VPUSH So save it on the stack MOV R10,@FAC Save return link in FAC since * GETSTR does not destroy FAC BL @GETSTR Call GPL to do the GETSTR MOV @FAC,R10 Restore return link BL @VPOP Pop the source info back * Set up to copy the source string into destination MOV @FAC4,R3 R3 is now copy-from MOV @SREF,R5 R5 is now copy-to MOV R5,R4 Save for pointer setting * Registers to be used in the copy * R1 - Used for a buffer * R3 - Copy-from address * R2 - # of bytes to be moved * R5 - copy-to address MOV @FAC6,R2 Fetch the length of the string ORI R5,WRVDP Enable the VDP write ASSG59 BL @GETV1 Get the character MOVB @R5LB,*R15 Load out destination address INC R3 Increment the copy-from MOVB R5,*R15 1st byte of address to INC R5 Increment for next character MOVB R1,@XVDPWD Put the character out DEC R2 Decrement count, finished? JGT ASSG59 No, loop for more JMP ASSG55 Yes, now set pointers * Code to copy a numeric value into the symbol table ASSG70 LI R2,8 Need to assign 8 bytes MOV @ARG4,R5 Destination pointer(R5) * from buffer(R4), (R2)bytes MOV @RAMTOP,R3 Does ERAM exist? JNE ASSG77 Yes, write to ERAM * No, write to VDP MOVB @R5LB,*R15 Load out 2nd byte of address ORI R5,WRVDP Enable the write to the VDP MOVB R5,*R15 Load out 1st byte of address LI R4,FAC Source is FAC ASSG75 MOVB *R4+,@XVDPWD Move a byte DEC R2 Decrement the counter, done? JGT ASSG75 No, loop for more B *R10 Yes, return to the caller ASSG77 LI R4,FAC Source is in FAC ASSG79 MOVB *R4+,*R5+ Move a byte DEC R2 Decrement the counter, done? JGT ASSG79 No, loop for more B *R10 Yes, return to caller * Check for required token SYNCHK MOVB *R13,R0 Read required token * CB R0,@CHAT Have the required token? JEQ PGMCH Yes, read next character BL @SETREG Error return requires R8/R9 set B @ERRSYN * SYNTAX ERROR * PGMCH - GPL entry point for PGMCHR to set up registers PGMCH MOV R11,R12 Save return address BL @PGMCHR Get the next character MOVB R8,@CHAT Put it in for GPL B *R12 Return to GPL RT And return to the caller PUTV MOV *R11+,R4 MOV *R4,R4 PUTV1 MOVB @R4LB,*R15 ORI R4,WRVDP MOVB R4,*R15 NOP MOVB R1,@XVDPWD RT * MOVFAC - copies 8 bytes from VDP(@FAC4) or ERAM(@FAC4) * to FAC MOVFAC MOV @FAC4,R1 Get pointer to source LI R2,8 8 byte values LI R3,FAC Destination is FAC MOV @RAMTOP,R0 Does ERAM exist? JNE MOVFA2 Yes, from ERAM * No, from VDP RAM SWPB R1 MOVB R1,*R15 Load 2nd byte of address SWPB R1 MOVB R1,*R15 Load 1st byte of address LI R5,XVDPRD MOVF1 MOVB *R5,*R3+ Move a byte DEC R2 Decrement counter, done? JGT MOVF1 No, loop for more RT Yes, return to caller MOVFA2 MOVB *R1+,*R3+ DEC R2 JNE MOVFA2 RT RT And return to caller ******************************************************************************** AORG >6464 TITL 'PARSES' * BASIC PARSE CODE * REGISTER USAGE * RESERVED FOR GPL INTERPRETER R13, R14, R15 * R13 contains the read address for GROM * R14 is used in BASSUP/10 for the VDPRAM pointer * RESERVED IN BASIC SUPPORT * R8 MSB current character (like CHAT in GPL) * R8 LSB zero * R10 read data port address for program data * ALL EXITS TO GPL MUST GO THROUGH "NUDG05" * * ~~~TOKENS~~~ ELSEZ EQU >81 ELSE SSEPZ EQU >82 STATEMENT SEPERATOR TREMZ EQU >83 TAIL REMARK IFZ EQU >84 IF GOZ EQU >85 GO GOTOZ EQU >86 GOTO GOSUBZ EQU >87 GOSUB BREAKZ EQU >8E BREAK NEXTZ EQU >96 NEXT SUBZ EQU >A1 SUB ERRORZ EQU >A5 ERROR WARNZ EQU >A6 WARNING THENZ EQU >B0 THEN TOZ EQU >B1 TO COMMAZ EQU >B3 COMMA RPARZ EQU >B6 RIGHT PARENTHESIS ) LPARZ EQU >B7 LEFT PARENTHESIS ( ORZ EQU >BA OR ANDZ EQU >BB AND XORZ EQU >BC XOR NOTZ EQU >BD NOT EQZ EQU >BE EQUAL (=) GTZ EQU >C0 GREATER THEN (>) PLUSZ EQU >C1 PLUS (+) MINUSZ EQU >C2 MINUS (-) DIVIZ EQU >C4 DIVIDE (/) EXPONZ EQU >C5 EXPONENT STRINZ EQU >C7 STRING LNZ EQU >C9 LINE NUMBER ABSZ EQU >CB ABSOLUTE SGNZ EQU >D1 SIGN * C24 DATA 24 CONSTANT 24 EXRTNA DATA EXRTN RETURN FOR EXEC * ERRSO LI R0,>0703 Issue STACK OVERFLOW message B @ERR * * GRAPHICS LANGUAGE ENTRY TO PARSE * PARSEG BL @SETREG Set up registers for Basic MOVB @GRMRAX(R13),R11 Get GROM address MOVB @GRMRAX(R13),@R11LB DEC R11 * * 9900 ENTRY TO PARSE * PARSE INCT R9 Get room for return address CI R9,STKEND Stack full? JH ERRSO Yes, too many levels deep MOV R11,*R9 Save the return address P05 MOVB R8,R7 Test for token beginning JLT P10 If token, then look it up B @PSYM If not token is a symbol P10 BL @PGMCHR Get next character SRL R7,7 Change last character to offset AI R7,->B7*2 Check for legal NUD CI R7,NTABLN Within the legal NUD address? JH CONT15 No, check for legal LED MOV @NTAB(R7),R7 Get NUD address JGT B9900 If 9900 code P17 EQU $ R7 contains offset into nudtab ANDI R7,>7FFF If GPL code, get rid of MSB A @NUDTAB,R7 Add in table address NUDG05 BL @SAVREG Restore GPL pointers MOVB R7,@GRMWAX(R13) Write out new GROM address SWPB R7 Bare the LSB MOVB R7,@GRMWAX(R13) Put it out too B @RESET Go back to GPL interpreter P17L JMP P17 * * CONTINUE ROUTINE FOR PARSE * CONTG BL @SETREG GPL entry-set Basic registers CONT MOV *R9,R6 Get last address from stack JGT CONT10 9900 code if not negative MOVB R6,@GRMWAX(R13) Write out new GROM address SWPB R6 Bare the second byte MOVB R6,@GRMWAX(R13) Put it out too MOV R13,R6 Set up to test precedence CONT10 CB *R6,R8 Test precedence JHE NUDNDL Have parsed far enough->return SRL R8,7 Make into table offset AI R8,->B8*2 Minimum token for a LED (*2) CI R8,LTBLEN Maximum token for a LED (*2) CONT15 JH NOLEDL If outside legal LED range-err MOV @LTAB(R8),R7 Pick up address of LED handler CLR R8 Clear 'CHAT' for getting new BL @PGMCHR Get next character B9900 B *R7 Go to the LED handler NUDE10 DECT R9 Back up subroutine stack INC R7 Skip over precedence JMP NUDG05 Goto code to return to GPL NOLEDL B @NOLED NUDNDL JMP NUDND1 * Execute one or more lines of Basic EXECG EQU $ GPL entry point for execution BL @SETREG Set up registers CLR @ERRCOD Clear the return code MOVB @PRGFLG,R0 Imperative statement? JEQ EXEC15 Yes, handle it as such * Loop for each statement in the program EXEC10 EQU $ MOVB @FLAG,R0 Now test for trace mode SLA R0,3 Check the trace bit in FLAG JLT TRACL If set->display line number EXEC11 MOV @EXTRAM,@PGMPTR Get text pointer DECT @PGMPTR Back to the line # to check * break point BL @PGMCHR Get the first byte of line # STST R0 Save status for breakpnt check INC @PGMPTR Get text pointer again BL @PGMCHR Go get the text pointer SWPB R8 Save 1st byte of text pointer BL @PGMCHR Get 2nd byte of text pointer SWPB R8 Put text pointer in order MOV R8,@PGMPTR Set new text pointer CLR R8 Clean up the mess SLA R0,2 Check breakpoint status JLT EXEC15 If no breakpoint set - count JNC BRKPNT If breakpoint set-handle it EXEC15 EQU $ <**************** C3 EQU $+2 Constant data 3 < CB3 EQU $+3 Constant byte 3 < LIMI 3 Let interrupts loose < C0 EQU $+2 Constant data 0 < LIMI 0 Shut down interrupts < CLR @>83D6 Reset VDP timeout < CRU LI R12,>24 Load console KBD address in CRU < KEY LDCR @C0,3 Select keyboard section < SCAN LI R12,6 Read address < SECTION STCR R0,8 SCAN the keyboard < MUST CZC @C1000,R0 Shift-key depressed? < BE JNE EXEC16 No, execute the Basic statement < PATCHED LI R12,>24 Test column 3 of keyboard < TO LDCR @CB3,3 Select keyboard section < WORK LI R12,6 Read address < ON STCR R0,8 SCAN the keyboard < A CZC @C1000,R0 Shift-C depressed? < GENEVE JEQ BRKP1L Yes, so take Basic breakpoint < COMPUTER EXEC16 MOV @PGMPTR,@SMTSRT Save start of statement INCT R9 Get subroutine stack space MOV @EXRTNA,*R9 Save the GPL return address BL @PGMCHR Now get 1st character of stmt JEQ EXRTN3 If EOL after EOS EXEC17 JLT EXEC20 If top bit set->keyword B @NLET If not->fake a 'LET' stmt EXEC20 MOV R8,R7 Save 1st token so can get 2nd INC @PGMPTR Increment the perm pointer MOVB *R10,R8 Read the character SRL R7,7 Convert 1st to table offset AI R7,->AA*2 Check for legal stmt token JGT ERRONE Not in range -> error MOV @STMTTB(R7),R7 Get address of stmt handler JLT P17L If top bit set -> GROM code B *R7 If 9900 code, goto it! EXRTN BYTE >83 Unused bytes for data constant CBH65 BYTE >65 since NUDEND skips precedences CI R8,SSEPZ*256 EOS only? JEQ EXEC15 Yes, continue on this line EXRTN2 MOVB @PRGFLG,R0 Did we execute an imperative JEQ EXEC50 Yes, so return to top-level S @C4,@EXTRAM No, so goto the next line C @EXTRAM,@STLN Check to see if end of program JHE EXEC10 No, so loop for the next line JMP EXEC50 Yes, so return to top-level * * STMT handler for :: * SMTSEP MOVB R8,R8 EOL? JNE EXEC17 NO, there is another stmt EXRTN3 DECT R9 YES JMP EXRTN2 Jump back into it * Continue after a breakpoint CONTIN BL @SETREG Set up Basic registers EXC15L JMP EXEC15 Continue execution BRKP1L JMP BRKPN1 TRACL JMP TRACE * Test for required End-Of-Statement EOL MOVB R8,R8 EOL reached? JEQ NUDND1 Yes CI R8,TREMZ*256 Higher then tail remark token? JH ERRONE Yes, its an error CI R8,ELSEZ*256 Tail, ssep or else? JL ERRONE No, error * * Return from call to PARSE * (entered from CONT) * NUDND1 MOV *R9,R7 Get the return address JLT NUDE10 If negative - return to GPL DECT R9 Back up the subroutine stack B @2(R7) And return to caller * (Skip the precedence word) NUDEND MOVB R8,R8 Check for EOL JEQ NUDND1 If EOL NUDND2 CI R8,STRINZ*256 Lower than a string? JL NUDND4 Yes CI R8,LNZ*256 Higher than a line #? JEQ SKPLN Skip line numbers JL SKPSTR Skip string or numeric NUDND3 BL @PGMCHR Read next character JEQ NUDND1 If EOL JMP NUDND2 Continue scan of line NUDND4 CI R8,TREMZ*256 Higher than a tail remark? JH NUDND3 Yes CI R8,SSEPZ*256 Lower then stmt sep(else)? JL NUDND3 Yes JMP NUDND1 TREM or SSEP SKPSTR BL @PGMCHR SWPB R8 Prepare to add A R8,@PGMPTR Skip it CLR R8 Clear lower byte SKPS01 BL @PGMCHR Get next token JMP NUDEND Go on SKPLN INCT @PGMPTR Skip line number JMP SKPS01 Go on * * Return from "CALL" to GPL RTNG BL @SETREG Set up registers again JMP NUDND1 And jump back into it! ************************************************************* * Handle Breakpoints BRKPNT MOVB @FLAG,R0 Check flag bits SLA R0,1 Check bit 6 for breakpoint JLT EXC15L If set then ignore breakpoint BRKPN2 LI R0,BRKFL JMP EXIT Return to top-level BRKPN1 MOVB @FLAG,R0 Move flag bits SLA R0,1 Check bit 6 for breakpoint JLT EXEC16 If set then ignore breakpoint JMP BRKPN2 Bit not set * * Error handling from 9900 code * ERRSYN EQU $ These all issue same message ERRONE EQU $ NONUD EQU $ NOLED EQU $ LI R0,ERRSN *SYNTAX ERROR return code EXIT EQU $ ERR MOV R0,@ERRCOD Load up return code for GPL * General return to GPL portion of Basic EXEC50 MOV @RTNADD,R7 Get return address B @NUDG05 Use commond code to link back * Handle STOP and END statements STOP END DECT R9 Pop last call to PARSE JMP EXEC50 Jump to return to top-level * Error codes for return to GPL ERRSN EQU >0003 ERROR SYNTAX ERROM EQU >0103 ERROR OUT OF MEMORY ERRIOR EQU >0203 ERROR INDEX OUT OF RANGE ERRLNF EQU >0303 ERROR LINE NOT FOUND ERREX EQU >0403 ERROR EXECUTION * >0004 WARNING NUMERIC OVERFLOW BRKFL EQU >0001 BREAKPOINT RETURN VECTOR ERROR EQU >0005 ON ERROR UDF EQU >0006 FUNCTION REFERENCE BREAK EQU >0007 ON BREAK CONCAT EQU >0008 CONCATENATE (&) STRINGS WARN EQU >0009 ON WARNING * Warning routine (only OVERFLOW) WARNZZ MOV @C4,@ERRCOD Load warning code for GPL LI R11,CONT-2 To optimize for return * Return to GPL as a CALL CALGPL INCT R9 Get space on subroutine stack MOV R11,*R9 Save return address JMP EXEC50 And go to GPL * Trace a line (Call GPL routine) TRACE MOV @C2,@ERRCOD Load return vector LI R11,EXEC11-2 Set up for return to execute JMP CALGPL Call GPL to display line # * Special code to handle concatenate (&) CONC LI R0,CONCAT Go to GPL to handle it JMP EXIT Exit to GPL interpeter ************************************************************* * NUD routine for a numeric constant * * NUMCON first puts pointer to the numeric string into * * FAC12 for CSN, clears the error byte (FAC10) and then * * converts from a string to a floating point number. Issues * * warning if necessary. Leaves value in FAC * ************************************************************* NUMCON MOV @PGMPTR,@FAC12 Set pointer for CSN SWPB R8 Swap to get length into LSB A R8,@PGMPTR Add to pointer to check end CLR @FAC10 Assume no error BL @SAVRE2 Save registers LI R3,GETCH Adjustment for ERAM in order MOVB @RAMFLG,R4 to call CSN JEQ NUMC49 LI R3,GETCGR NUMC49 BL @CSN01 Convert String to Number BL @SETREG Restore registers C @FAC12,@PGMPTR Check to see if all converted JNE ERRONE If not - error BL @PGMCHR Now get next char from program MOVB @FAC10,R0 Get an overflow on conversion? JNE WARNZZ Yes, have GPL issue warning B @CONT Continue the PARSE * * ON ERROR, ON WARNING and ON BREAK ONERR LI R0,ERROR ON ERROR code JMP EXIT Return to GPL code ONWARN LI R0,WARN ON WARNING code JMP EXIT Return to GPL code ONBRK LI R0,BREAK ON BREAK code JMP EXIT Return to GPL code * * NUD routine for "GO" * GO CLR R3 Dummy "ON" index for common JMP ON30 Merge into "ON" code * * NUD ROUTINE FOR "ON" * ON CI R8,WARNZ*256 On warning? JEQ ONWARN Yes, goto ONWARN CI R8,ERRORZ*256 On error? JEQ ONERR Yes, got ONERR CI R8,BREAKZ*256 On break? JEQ ONBRK Yes, goto ONBRK * * Normal "ON" statement * BL @PARSE PARSE the index value BYTE COMMAZ Stop on a comma or less CBH66 BYTE >66 Unused byte for constant BL @NUMCHK Ensure index is a number CLR @FAC10 Assume no error in CFI BL @CFI Convert Floating to Integer MOVB @FAC10,R0 Test error code JNE GOTO90 If overflow, BAD VALUE MOV @FAC,R3 Get the index JGT ON20 Must be positive GOTO90 LI R0,ERRIOR Negative, BAD VALUE GOTO95 JMP ERR Jump to error handler ON20 EQU $ Now check GO TO/SUB CI R8,GOZ*256 Bare "GO" token? JNE ON40 No, check other possibilities BL @PGMCHR Yes, get next token ON30 CI R8,TOZ*256 "GO TO" ? JEQ GOTO50 Yes, handle GO TO like GOTO CI R8,SUBZ*256 "GO SUB" ? JMP ON50 Merge to common code to test ON40 CI R8,GOTOZ*256 "GOTO" ? JEQ GOTO50 Yes, go handle it CI R8,GOSUBZ*256 "GOSUB" ? ON50 JNE ERRONE No, so is an error BL @PGMCHR Get next token JMP GOSUB2 Goto gosub code ERR1B JMP ERRONE Issue error message * NUD routine for "GOSUB" GOSUB CLR R3 Dummy index for "ON" code * Common GOSUB code GOSUB2 EQU $ Now build a FAC entry LI R1,FAC Optimize to save bytes MOV R3,*R1+ Save the "ON" index * in case of garbage collection MOVB @CBH66,*R1+ Indicate GOSUB entry on stack INC R1 Skip FAC3 MOV @PGMPTR,*R1 Save current ptr w/in line INCT *R1+ Skip line # to correct place MOV @EXTRAM,*R1 Save current line # pointer BL @VPUSH Save the stack entry MOV @FAC,R3 Restore the "ON" index JMP GOTO20 Jump to code to find the line * NUD routine for "GOTO" GOTO CLR R3 Dummy index for "ON" code * Common (ON) GOTO/GOSUB THEN/ELSE code to fine line * * Get line number from program GOTO20 CI R8,LNZ*256 Must have line number token JNE ERR1B Don't, so error GETL10 BL @PGMCHR Get MSB of the line number MOVB R8,R0 Save it BL @PGMCHR Read the character DEC R3 Decrement the "ON" index JGT GOTO40 Loop if not there yet * * Find the program line * MOV @STLN,R1 Get into line # table MOVB @RAMFLG,R2 Check ERAM flag to see where? JEQ GOTO31 From VDP, go handle it MOV R1,R2 Copy address GOT32 C R1,@ENLN Finished w/line # table? JHE GOTO34 Yes, so line doesn't exist MOVB *R2+,R3 2nd byte match? ANDI R3,>7FFF Reset possible breakpoint CB R3,R0 Compare 1st byte of #, Match? JNE GOT35 Not a match, so move on CB *R2+,R8 2nd byte match? JEQ GOTO36 Yes, line is found! GOT33 INCT R2 Skip line pointer MOV R2,R1 Advance to next line in table JMP GOT32 Go back for more GOT35 MOVB *R2+,R3 Skip 2nd byte of line # JMP GOT33 And jump back in GOTO31 MOVB @R1LB,*R15 Get the data from the VDP LI R2,XVDPRD Load up to read data MOVB R1,*R15 Write out MSB of address GOTO32 C R1,@ENLN Finished w/line # table JHE GOTO34 Yes, so line doesn't exist MOVB *R2,R3 Save in temporary place for * breakpoint checking ANDI R3,>7FFF Reset possible breakpoint CB R3,R0 Compare 1st byte of #, Match? JNE GOTO35 Not a match, so move on CB *R2,R8 2nd byte match? JEQ GOTO36 Yes, line is found! GOTO33 MOVB *R2,R3 Skip 1st byte of line pointer AI R1,4 Advance to next line in table MOVB *R2,R3 Skip 1nd byte of line pointer JMP GOTO32 Go back for more GOTO35 MOVB *R2,R3 Skip 2nd byte of line # JMP GOTO33 And jump back in GOTO34 LI R0,ERRLNF LINE NOT FOUND error vector JMP GOTO95 Jump for error exit GOTO36 INCT R1 Adjust to line pointer MOV R1,@EXTRAM Save for execution of the line DECT R9 Pop saved link to goto B @EXEC10 Reenter EXEC code directly GOTO40 BL @PGMCHR Get next token BL @EOSTMT Premature end of statement? JEQ GOTO90 Yes =>BAD VALUE for index CI R8,COMMAZ*256 Comma next ? JNE ERR1C No, error GOTO50 BL @PGMCHR Yes, get next character JMP GOTO20 And check this index value ERR1C JMP ERR1B Linking becuase long-distance ERR51 LI R0,>0903 RETURN WITHOUT GOSUB JMP GOTO95 Exit to GPL * NUD entry for "RETURN" RETURN C @VSPTR,@STVSPT Check bottom of stack JLE ERR51 Error -> RETURN WITHOUT GOSUB BL @VPOP Pop entry CB @CBH66,@FAC2 Check ID for a GOSUB entry JNE RETU30 Check for ERROR ENTRY * * Have a GOSUB entry * BL @EOSTMT Must have EOS after return JNE RETURN Not EOS, then error return? MOV @FAC4,@PGMPTR Get return ptr w/in line MOV @FAC6,@EXTRAM Get return line pointer B @SKPS01 Go adjust it and get back * Check ERROR entry RETU30 CB @CBH69,@FAC2 ERROR ENTRY? JEQ RETU40 Yes, take care of error entry CB @CBH6A,@FAC2 Subprogram entry? JNE RETURN No, look some more BL @VPUSH Push it back. Keep information JMP ERR51 RETURN WITHOUT GOSUB error * * Have an ERROR entry * RETURN, RETURN line #, RETURN or RETURN NEXT follows. * RETU40 CLR R3 In case of a line number CI R8,LNZ*256 Check for a line number JEQ GETL10 Yes, treat like GOTO MOV @FAC4,@PGMPTR Get return ptr w/in line MOV @FAC6,@EXTRAM Get return line pointer BL @EOSTMT EOL now? JEQ BEXC15 Yes, treat like GOSUB rtn. CI R8,NEXTZ*256 NEXT now? JNE ERR1C No, so its an error B @SKPS01 Yes, so execute next statement BEXC15 B @EXEC15 Execute next line CBH6A BYTE >6A Subprogram call stack ID EVEN ************************************************************* * EOSTMT - Check for End-Of-STateMenT * * Returns with condition '=' if EOS * * else condition '<>' if not EOS * ************************************************************* EOSTMT MOVB R8,R8 EOL or non-token? JEQ EOSTM1 EOL-return condition '=' JGT EOSTM1 Non-token return condition '<>' CI R8,TREMZ*256 In the EOS range (>81 to >83)? JH EOSTM1 No, return condition '<>' C R8,R8 Yes, force condition to '=' EOSTM1 RT ************************************************************* * EOLINE - Tests for End-Of-LINE; either a >00 or a * * '!' * * Returns with condition '=' if EOL else condition * * '<>' if not EOL * ************************************************************* EOLINE MOVB R8,R8 EOL? JEQ EOLNE1 Yes, return with '=' set CI R8,TREMZ*256 Set condition on a tall remark EOLNE1 RT And return SYMB20 LI R0,UDF Long distance B @GOTO95 * NUD for a symbol (variable) PSYM BL @SYM Get symbol table entry BL @GETV Get 1st byte of entry DATA FAC SYM left pointer in FAC * SLA R1,1 UDF reference? JLT SYMB20 Yes, special code for it BL @SMB No, get value space pointer CB @FAC2,@CBH65 String reference? JEQ SYMB10 Yes, special code for it BL @MOVFAC No, numeric ->copy into FAC SYMB10 B @CONT And continue the PARSE * Statement entry for IF statement IF BL @PARSE Evaluate the expression BYTE COMMAZ Stop on a comma CBH67 BYTE >67 Unused byte for a constant BL @NUMCHK Ensure the value is a number CLR R3 Create a dummy "ON" index CI R8,THENZ*256 Have a "THEN" token JNE ERR1C No, error NEG @FAC Test if condition true i.e. <>0 JNE IFZ10 True - branch to the special # BL @PGMCHR Advance to line number token CI R8,LNZ*256 Have the line # token? JNE IFZ20 No, must look harder for ELSE INCT @PGMPTR Skip the line number BL @PGMCHR Get next token IFZ5 CI R8,ELSEZ*256 Test if token is ELSE JEQ IFZ10 We do! So branch to the line # B @EOL We don't, so better be EOL GETL1Z B @GETL10 Get 1st token of clause IFZ10 BL @PGMCHR Get 1st token of clause CI R8,LNZ*256 Line # token? JEQ GETL1Z Yes, go there BL @EOSTMT EOS? JEQ1C JEQ ERR1C Yes, its an error LI R8,SSEPZ*256 Cheat to do a continue DEC @PGMPTR Back up to get 1st character B @CONT Continue on * * LOOK FOR AN ELSE CLAUSE SINCE THE CONDITION WAS FALSE * IFZ20 LI R3,1 IF/ELSE pair counter BL @EOLINE Trap out EOS following THEN/ELSE JEQ JEQ1C error IFZ25 CI R8,ELSEZ*256 ELSE? JNE IFZ27 If not DEC R3 Matching ELSE? JEQ IFZ10 Yes, do it JMP IFZ35 No, go on IFZ27 CI R8,IFZ*256 Check for it JNE IFZ28 Not an IF INC R3 Increment nesting level JMP IFZ35 And go on IFZ28 CI R8,STRINZ*256 Lower than string? JL IFZ30 Yes CI R8,LNZ*256 Higher or = to a line # JEQ IFZ40 = line # JL IFZ50 Skip strings and numerics IFZ30 BL @EOLINE EOL? JEQ IFZ5 Yes, done scanning IFZ35 BL @PGMCHR Get next character JMP IFZ25 And go on * * SKIP LINE #'s * IFZ40 INCT @PGMPTR Skip the line # JMP IFZ35 Go on * * SKIP STRINGS AND NUMERICS * IFZ50 BL @PGMCHR Get # of bytes to skip SWPB R8 Swap for add A R8,@PGMPTR Skip it CLR R8 Clear LSB of R8 JMP IFZ35 ******************************************************************************** TITL 'PARSES2' ************************************************************* * 'LET' statement handler * * Assignments are done bye putting an entry on the stack * * for the destination variable and getting the source value * * into the FAC. Multiple assignments are handled by the * * stacking the variable entrys and then looping for the * * assignments. Numeric assignments pose no problems, * * strings are more complicated. String assignments are done * * by assigning the source string to the last variable * * specified in the list and changing the FAC entry so that * * the string assigned to the next-to-the-last variable * * comes from the permanent string belonging to the variable * * just assigned. * * e.g. A$,B$,C$="HELLO" * * * * C$-------"HELLO" (source string) * * * * B$-------"HELLO" (copy from C$'s string) * * * * A$-------"HELLO" (copy from B$'s string) * ************************************************************* NLET CLR @PAD0 Counter for multiple assign's NLET05 BL @SYM Get symbol table address *-----------------------------------------------------------* * The following code has been taken out for checking is * * inserted in SMB 5/22/81 * * BL @GETV Get first byte of entry * * DATA FAC SYM left pointer in FAC * * SLA R1,1 Test if a UDF * * JLT ERRMUV Is a UDF - so error * *-----------------------------------------------------------* BL @SMB Get value space pointer BL @VPUSH Push s.t. pointer on stack INC @PAD0 Count the variable CI R8,EQZ*256 Is the token an '='? JEQ NLET10 Yes, go into assignment loop CI R8,COMMAZ*256 Must have a comma now JNE ERR1CZ Didn't - so error BL @PGMCHR Get next token JGT NLET05 If legal symbol character JMP ERR1CZ If not - error ERRMUV LI R0,>0D03 MULTIPLY USED VARIABLE B @ERR NLET10 BL @PGMCHR Get next token BL @PARSE PARSE the value to assign BYTE TREMZ Parse to the end of statement STCOD2 BYTE >65 Wasted byte (STCODE copy) * Loop for assignments NLET15 BL @ASSG Assign the value to the symbol DEC @PAD0 One less to assign, done? JEQ LETCON Yes, branch out CB @FAC2,@STCOD2 String or numeric? JNE NLET15 Numeric, just loop for more MOV R6,@FAC4 Get pointer to new string MOV @ARG,@FAC Get pointer to last s.t. entry JMP NLET15 Now loop to assign more LETCON B @EOL Yes, continue the PARSE ERR1CZ B @ERR1C For long distance jump DATA NONUD (SPARE) >80 DATA NONUD ELSE >81 DATA SMTSEP :: >82 DATA NUDND1 ! >83 DATA IF IF >84 DATA GO GO >85 DATA GOTO GOTO >86 DATA GOSUB GOSUB >87 DATA RETURN RETURN >88 DATA NUDEND DEF >89 DATA NUDEND DIM >8A DATA END END >8B DATA NFOR FOR >8C DATA NLET LET >8D DATA >8002 BREAK >8E DATA >8004 UNBREAK >8F DATA >8006 TRACE >90 DATA >8008 UNTRACE >91 DATA >8016 INPUT >92 DATA NUDND1 DATA >93 DATA >8012 RESTORE >94 DATA >8014 RANDOMIZE >95 DATA NNEXT NEXT >96 DATA >800A READ >97 DATA STOP STOP >98 DATA >8032 DELETE >99 DATA NUDND1 REM >9A DATA ON ON >9B DATA >800C PRINT >9C DATA CALL CALL >9D DATA NUDEND OPTION >9E DATA >8018 OPEN >9F DATA >801A CLOSE >A0 DATA STOP SUB >A1 DATA >8034 DISPLAY >A2 DATA NUDND1 IMAGE >A3 DATA >8024 ACCEPT >A4 DATA NONUD ERROR >A5 DATA NONUD WARNING >A6 DATA SUBXIT SUBEXIT >A7 DATA SUBXIT SUBEND >A8 DATA >800E RUN >A9 STMTTB DATA >8010 LINPUT >AA NTAB DATA NLPR LEFT PARENTHISIS >B7 DATA NONUD CONCATENATE >B8 DATA NONUD SPARE >B9 DATA NONUD AND >BA DATA NONUD OR >BB DATA NONUD XOR >BC DATA O0NOT NOT >BD DATA NONUD = >BE DATA NONUD < >BF DATA NONUD > >C0 DATA NPLUS + >C1 DATA NMINUS - >C2 DATA NONUD * >C3 DATA NONUD / >C4 DATA NONUD ^ >C5 DATA NONUD SPARE >C6 DATA NSTRCN QUOTED STRING >C7 DATA NUMCON UNQUOTED STRING/NUMERIC >C8 DATA NONUD LINE NUMBER >C9 DATA >8026 EOF >CA DATA NABS ABS >CB DATA NATN ATN >CC DATA NCOS COS >CD DATA NEXP EXP >CE DATA NINT INT >CF DATA NLOG LOG >D0 DATA NSGN SGN >D1 DATA NSIN SIN >D2 DATA NSQR SQR >D3 DATA NTAN TAN >D4 DATA >8036 LEN >D5 DATA >8038 CHRZ >D6 DATA >803A RND >D7 DATA >8030 SEGZ >D8 DATA >802A POS >D9 DATA >802C VAL >DA DATA >802E STR >DB DATA >8028 ASC >DC DATA >801C PI >DD DATA >8000 REC >DE DATA >801E MAX >DF DATA >8020 MIN >E0 DATA >8022 RPTZ >E1 NTABLN EQU $-NTAB LTAB DATA CONC & >B8 DATA NOLED SPARE >B9 DATA O0OR OR >BA DATA O0AND AND >BB DATA O0XOR XOR >BC DATA NOLED NOT >BD DATA EQUALS = >BE DATA LESS < >BF DATA GREATR > >C0 DATA PLUS + >C1 DATA MINUS - >C2 DATA TIMES * >C3 DATA DIVIDE / >C4 DATA LEXP ^ >C5 LTBLEN EQU $-LTAB ************************************************************* * Relational operators * * Logical conparisons encode the type of comparison and use * * common code to PARSE the expression and set the status * * bits. * * * * The types of legal comparisons are: * * 0 EQUAL * * 1 NOT EQUAL * * 2 LESS THAN * * 3 LESS OR EQUAL * * 4 GREATER THAN * * 5 GREATER THAN OR EQUAL * * * * This code is saved on the subroutine stack * ************************************************************* LESS LI R2,2 LESS-THAN code for common rtn CI R8,GTZ*256 Test for '>' token JNE LT10 Jump if not DECT R2 Therefore, NOT-EQUAL code JMP LT15 Jump to common C4 EQU $+2 Constant 4 GREATR LI R2,4 GREATER-THEN code for common LT10 CI R8,EQZ*256 Test for '=' token JNE LTST01 Jump if '>=' LT15 BL @PGMCHR Must be plain old '>' or '<' JMP LEDLE Jump to test EQUALS SETO R2 Equal bit for common routine LEDLE INC R2 Sets to zero LTST01 INCT R9 Get room on stack for code MOV R2,*R9 Save status matching code BL @PSHPRS Push 1st arg and PARSE the 2nd BYTE GTZ Parse to a '>' CBH69 BYTE >69 Used in RETURN routine MOV *R9,R4 Get the type code from stack DECT R9 Reset subroutine stack pointer MOVB @LTSTAB(R4),R12 Get address bias to baranch to SRA R12,8 Right justify BL @ARGTST Test for matching arguments JEQ LTST20 Handle strings specially BL @SCOMPB Floating point comparison LTST15 B @LTSTXX(R12) Interpret the status by code LTSTXX EQU $ LTSTGE JGT LTRUE Test if GREATER or EQUAL LTSTEQ JEQ LTRUE Test if EQUAL LFALSE CLR R4 FALSE is a ZERO JMP LTST90 Put it into FAC LTSTNE JEQ LFALSE Test if NOT-EQUAL LTRUE LI R4,>BFFF TRUE is a minus-one LTST90 LI R3,FAC Store result in FAC MOV R4,*R3+ Exp & 1st byte of manitissa CLR *R3+ ZERO the remaining digits CLR *R3+ ZERO the remaining digits CLR *R3+ ZERO the remaining digits JMP LEDEND Jump to end of LED routine LTSTLE JEQ LTRUE Test LESS-THAN or EQUAL LTSTLT JLT LTRUE Test LESS-THEN JMP LFALSE Jump to false LTSTGT JGT LTRUE Test GREATER-THAN JMP LFALSE Jump to false * Data table for offsets for types LTSTAB BYTE LTSTEQ-LTSTXX EQUAL (0) BYTE LTSTNE-LTSTXX NOT EQUAL (1) BYTE LTSTLT-LTSTXX LESS THEN (2) BYTE LTSTLE-LTSTXX LESS or EQUAL (3) BYTE LTSTGT-LTSTXX GREATER THEN (4) BYTE LTSTGE-LTSTXX GREATER or EQUAL (5) LTST20 MOV @FAC4,R10 Pointer to string1 MOVB @FAC7,R7 R7 = string2 length BL @VPOP Get LH arg back MOV @FAC4,R4 Pointer to string2 MOVB @FAC7,R6 R6 = string2 length MOVB R6,R5 R5 will contain shorter length CB R6,R7 Compare the 2 lengths JLT CSTR05 Jump if length2 < length1 MOVB R7,R5 Swap if length1 > length2 CSTR05 SRL R5,8 Shift for speed and test zero JEQ CSTR20 If ZERO-set status with length CSTR10 MOV R10,R3 Current character location INC R10 Increment pointer BL @GETV1 Get from VDP MOVB R1,R0 And save for comparison MOV R4,R3 Current char location in ARG INC R4 Increment pointer BL @GETV1 Get from VDP CB R1,R0 Compare the characters JNE LTST15 Return with status if <> DEC R5 Otherwise, decrement counter JGT CSTR10 And loop for each character CSTR20 CB R6,R7 Status set by length compare JMP LTST15 Return to do test of status * ARITHMETIC FUNCTIONS PLUS BL @PSHPRS Push left arg and PARSE right BYTE MINUSZ,0 Stop on a minus!!!!!!!!!!!!!!! LI R2,SADD Address of add routine LEDEX CLR @FAC10 Clear error code BL @ARGTST Make sure both numerics JEQ ARGT05 If strings, error BL @SAVREG Save registers BL *R2 Do the operation BL @SETREG Restore registers MOVB @FAC10,R2 Test for overflow JNE LEDERR If overflow ->error LEDEND B @CONT Continue the PARSE LEDERR B @WARNZZ Overflow - issue warning MINUS BL @PSHPRS Push left arg and PARSE right BYTE MINUSZ,0 Parse to a minus LI R2,SSUB Address of subtract routine JMP LEDEX Common code for the operation TIMES BL @PSHPRS Push left arg and PARSE right BYTE DIVIZ,0 Parse to a divide!!!!!!!!!!!!! LI R2,SMULT Address of multiply routine JMP LEDEX Common code for the operation DIVIDE BL @PSHPRS Push left arg and PARSE right BYTE DIVIZ,0 Parse to a divide LI R2,SDIV Address of divide routine JMP LEDEX Common code for the operation ************************************************************* * Test arguments on both the stack and in the FAC * * Both must be of the same type * * CALL: * * BL @ARGTST * * JEQ If string * * JNE If numeric * ************************************************************* ARGTST MOV @VSPTR,R6 Get stack pointer INCT R6 MOVB @R6LB,*R15 Load 2nd byte of stack address NOP Kill some time MOVB R6,*R15 Load 1st byte of stack address NOP Kill some time CB @XVDPRD,@CBH65 String in operand 1? JNE ARGT10 No, numeric CB @FAC2,@CBH65 Yes, is other the same? JEQ ARGT20 Yes, do string comparison ARGT05 B @ERRT Data types don't match NUMCHK ARGT10 CB @FAC2,@CBH65 2nd operand can't be string JEQ ARGT05 If so, error ARGT20 RT Ok, so return with status * VPUSH followed by a PARSE PSHPRS INCT R9 Get room on stack CI R9,STKEND Stack full? JH VPSH27 Yes, error MOV R11,*R9 Save return on stack LI R11,P05 Optimize for the parse * Stack VPUSH routine VPUSH LI R0,8 Pushing 8 byte entries A R0,@VSPTR Update the pointer MOV @VSPTR,R1 Now get the new pointer MOVB @R1LB,*R15 Write new address to VDP chip ORI R1,WRVDP Enable the write MOVB R1,*R15 Write 1st byte of address LI R1,FAC Source is FAC VPSH15 MOVB *R1+,@XVDPWD Move a byte DEC R0 Decrement the count, done? JGT VPSH15 No, more to move MOV R11,R0 Save the return address CB @FAC2,@CBH65 Pushing a string entry? JNE VPSH20 No, so done MOV @VSPTR,R6 Entry on stack AI R6,4 Pointer to the string is here MOV @FAC,R1 Get the string's owner CI R1,>001C Is it a tempory string? JNE VPSH20 No, so done VPSH19 MOV @FAC4,R1 Get the address of the string JEQ VPSH20 If null string, nothing to do BL @STVDP3 Set the backpointer VPSH20 MOV @VSPTR,R1 Check for buffer-zone C16 EQU $+2 AI R1,16 Correct by 16 C R1,@STREND At least 16 bytes between stack * and string space? JLE VPOP18 Yes, so ok INCT R9 No, save return address MOV R0,*R9 on stack BL @COMPCT Do the garbage collection MOV *R9,R0 Restore return address DECT R9 Fix subroutine stack pointer MOV @VSPTR,R1 Get value stack pointer AI R1,16 Buffer zone C R1,@STREND At least 16 bytes now? JLE VPOP18 Yes, so ok VPSH23 LI R0,ERROM No, so MEMORY FULL error VPSH25 BL @SETREG In case of GPL call B @ERR VPSH27 B @ERRSO STACK OVERFLOW * Stack VPOP routine VPOP LI R2,FAC Destination in FAC MOV @VSPTR,R1 Get stack pointer C R1,@STVSPT Check for stack underflow JLE VPOP20 Yes, error MOVB @R1LB,*R15 Write 2nd byte of address LI R0,8 Popping 8 bytes MOVB R1,*R15 Write 1st byte of address S R0,@VSPTR Adjust stack pointer VPOP10 MOVB @XVDPRD,*R2+ Move a byte DEC R0 Decrement the counter, done? JGT VPOP10 No, finish the work MOV R11,R0 Save return address CB @FAC2,@CBH65 Pop a string? JNE VPOP18 No, so done CLR R6 For backpointer clear MOV @FAC,R3 Get string owner CI R3,>001C Pop a temporary? JEQ VPSH19 Yes, must free it BL @GET1 No, get new pointer from s.t. MOV R1,@FAC4 Set new pointer to string VPOP18 B *R0 And return VPOP20 LI R0,ERREX * SYNTAX ERROR JMP VPSH25 * The returned status reflects the character * RAMFLG = >00 | No ERAM or imperative statements * >FF | With ERAM and a program is being run PGMCHR MOVB @RAMFLG,R8 Test ERAM flag JNE PGMC10 ERAM and a program is being run * Next label is for entry from SUBPROG. PGMSUB MOVB @PGMPT1,*R15 Write 2nd byte of address LI R10,XVDPRD Read data address MOVB @PGMPTR,*R15 Write 1st byte of address INC @PGMPTR Increment the perm pointer MOVB *R10,R8 Read the character RT And return PGMC10 MOV @PGMPTR,R10 INC @PGMPTR MOVB *R10+,R8 Write 2nd byte of a address RT ******************************************************************************** AORG >6C9A TITL 'GETPUTS' * (VDP to VDP) or (RAM to RAM) * GET,GET1 : Get two bytes of data from VDP * : R3 : address in VDP * : R1 : where the one byte data stored * PUT1 : Put two bytes of data into VDP * : R4 : address on VDP * : R1 : data * GETG,GETG2 : Get two bytes of data from ERAM * : R3 : address on ERAM * : R1 : where the two byte data stored * PUTG2 : Put two bytes of data into ERAM * : R4 : address on ERAM * : R1 : data * PUTVG1 : Put one byte of data into ERAM * : R4 : address in ERAM * : R1 : data * Get two bytes from RAM(R3) into R1 GET MOV *R11+,R3 MOV *R3,R3 GET1 MOVB @R3LB,*R15 MOVB R3,*R15 NOP MOVB @XVDPRD,R1 MOVB @XVDPRD,@R1LB RT * Put two bytes from R1 to RAM(R4) PUT1 MOVB @R4LB,*R15 ORI R4,WRVDP MOVB R4,*R15 NOP MOVB R1,@XVDPWD MOVB @R1LB,@XVDPWD RT * Get two bytes from ERAM(R3) to R1 GETG MOV *R11+,R3 MOV *R3,R3 GETG2 EQU $ MOVB *R3+,R1 MOVB *R3,@R1LB DEC R3 RT * Put two bytes from R1 to ERAM(R4) PUTG2 EQU $ MOVB R1,*R4+ MOVB @R1LB,*R4 DEC R4 Preserve R4 RT ******************************************************************************** AORG >6CE2 TITL 'NUD359' LEXP CB @FAC2,@CBH63 Must have a numeric JH ERRSNM Don't, so error BL @PSHPRS Push 1st and parse 2nd BYTE EXPONZ,0 Up to another wxpon or less BL @STKCHK Make sure room on stack LI R2,PWRZZ Address of power routine JMP COMM05 Jump into common routine * ABS NABS CI R8,LPARZ*256 Must have a left parenthesis JNE SYNERR If not, error BL @PARSE Parse the argument BYTE ABSZ Up to another ABS CBH63 BYTE >63 Use the wasted byte CB @FAC2,@CBH63 Must have numeric arg JH ERRSNM If not, error ABS @FAC Take the absolute value BCONT B @CONT And continue * ATN NATN LI R2,ATNZZ Load up arctan address JMP COMMON Jump into common rountine * COS NCOS LI R2,COSZZ Load up cosine address JMP COMMON Jump into common routine * EXP NEXP LI R2,EXPZZ Load up exponential address JMP COMMON Jump into common routine * INT NINT LI R2,GRINT Load up greatest integer address JMP COMMON Jump into common routine * LOG NLOG LI R2,LOGZZ Load up logarithm code JMP COMMON Jump to common routine * SGN NSGN CI R8,LPARZ*256 Must have left parenthesis JNE SYNERR If not, error BL @PARSE Parse the argument BYTE SGNZ,0 Up to another SGN CB @FAC2,@CBH63 Must have a numeric arg JH ERRSNM If not, error LI R4,>4001 Floating point one MOV @FAC,R0 Check status JEQ BCONT If 0, return 0 JGT BLTST9 If positive, return +1 B @LTRUE If negative, return -1 BLTST9 B @LTST90 Sets up the FAC w/R4 and 0s ERRSNM B @ERRT STRING-NUMBER MISMATCH SYNERR B @ERRONE SYNTAX ERROR * SIN NSIN LI R2,SINZZ Load up sine address JMP COMMON Jump into common routine * SQR NSQR LI R2,SQRZZ Load up square-root address JMP COMMON Jump into common routine * TAN NTAN LI R2,TANZZ Load up tangent address COMMON BL @STKCHK Make sure room on stacks CI R8,LPARZ*256 Must have left parenthesis JNE SYNERR If not, error INCT R9 Get space on subroutine stack MOV R2,*R9 Put address of routine on stack BL @PARSE Parse the argument BYTE >FF,0 To end of the arg MOV *R9,R2 Get address of function back DECT R9 Decrement subroutine stack COMM05 CB @FAC2,@CBH63 Must have a numeric arg JH ERRSNM If not, error CLR @FAC10 Assume no error or warning BL @SAVREG Save Basic registers MOV R2,@PAGE2 Select page 2 BL *R2 Evaluate the function MOV R2,@PAGE1 Reselect Page 1 BL @SETREG Set registers up again MOVB @FAC10,R0 Check for error or warning JEQ BCONT If not error, continue SRL R0,9 Check for warning JEQ PWARN Warning, issue it LI R0,>0803 BAD ARGUMENT code B @ERR PWARN B @WARNZZ Issue the warning message STKCHK CI R9,STND12 Enough room on the subr stack? JH BSO No, memory full error MOV @VSPTR,R0 Get the value stack pointer AI R0,48 Buffer-zone of 48 bytes C R0,@STREND Room between stack & strings JL STKRTN Yes, return INCT R9 Get space on subr stack MOV R11,*R9+ Save return address MOV R2,*R9+ Save COMMON function code MOV R0,*R9 Save v-stack pointer+48 BL @COMPCT Do a garbage collection C *R9,@STREND Enough space now? JHE BMF No, MEMORY FULL error DECT R9 Decrement stack pointer MOV *R9,R2 Restore COMMON function code DECT R9 Decrement stack pointer RETRN MOV *R9,R11 Restore return address DECT R9 Decrement stack pointer STKRTN RT BMF B @VPSH23 * MEMORY FULL BSO B @ERRSO * STACK OVERFLOW ************************************************************* * LED routine for AND, OR, NOT, and XOR * ************************************************************* O0AND BL @PSHPRS Push L.H. and PARSE R.H. BYTE ANDZ,0 Stop on AND or less BL @CONVRT Convert both to integers INV @FAC Complement L.H. SZC @FAC,@ARG Perform the AND O0AND1 MOV @ARG,@FAC Put back in FAC O0AND2 BL @CIF Convert back to floating B @CONT Continue O0OR BL @PSHPRS Push L.H. and PARSE R.H. BYTE ORZ,0 Stop on OR or less BL @CONVRT Convert both to integers SOC @FAC,@ARG Perform the OR JMP O0AND1 Convert to floating and done O0NOT BL @PARSE Parse the arg BYTE NOTZ,0 Stop on NOT or less CB @FAC2,@CBH63 Get a numeric back? JH ERRSN1 No, error CLR @FAC10 Clear for CFI BL @CFI Convert to Integer MOVB @FAC10,R0 Check for an error JNE SYNERR Error INV @FAC Perform the NOT JMP O0AND2 Convert to floating and done O0XOR BL @PSHPRS Push L.H. and PARSE R.H. BYTE XORZ,0 Stop on XOR or less BL @CONVRT Convert both to integer MOV @ARG,R0 Get R.H. into register XOR @FAC,R0 Do the XOR MOV R0,@FAC Put result back in FAC JMP O0AND2 Convert and continue ************************************************************* * NUD for left parenthesis * ************************************************************* NLPR CI R8,RPARZ*256 Have a right paren already? JEQ ERRSY1 If so, syntax error BL @PARSE Parse inside the parenthesises BYTE LPARZ,0 Up to left parenthesis or less CI R8,RPARZ*256 Have a right parenthesis now? JNE ERRSY1 No, so error BL @PGMCHR Get next token BCON1 B @CONT And continue ************************************************************* * NUD for unary minus * ************************************************************* NMINUS BL @PARSE Parse the expression BYTE MINUSZ,0 Up to another minus NEG @FAC Make it negative NMIN10 CB @FAC2,@CBH63 Must have a numeric JH ERRSN1 If not, error JMP BCON1 Continue ************************************************************* * NUD for unary plus * ************************************************************* NPLUS BL @PARSE Parse the expression BYTE PLUSZ,0 JMP NMIN10 Use common code ************************************************************* * CONVRT - Takes two arguments, 1 form FAC and 1 from the * * top of the stack and converts them to integer * * from floating point, issuing appropriate errors * ************************************************************* CONVRT INCT R9 MOV R11,*R9 SAVE RTN ADDRESS BL @ARGTST ARGS MUST BE SAME TYPE JEQ ERRSN1 AND NON-STRING CLR @FAC10 FOR CFI ERROR CODE BL @CFI CONVERT R.H. ARG MOVB @FAC10,R0 ANY ERROR OR WARNING? JNE ERRBV YES MOV @FAC,@ARG MOVE TO GET L.H. ARG BL @VPOP GET L.H. BACK BL @CFI CONVERT L.H. MOVB @FAC10,R0 ANY ERROR OR WARNING? JEQ RETRN No, get rtn off stack and rtn * Yes, issue error ERRBV B @GOTO90 BAD VALUE ERRSN1 B @ERRT STRING NUMBER MISMATCH ERRSY1 B @ERRONE SYNTAX ERROR ******************************************************************************** AORG >6ED6 TITL 'SPEEDS' BSYNCH B @SYNCHK BERSYN B @ERRSYN BERSNM B @ERRT SPEED MOVB *R13,R0 Read XML code SRL R0,8 Shift for word value JEQ BSYNCH 0 is index for SYNCHK DEC R0 Not SYNCHK, check further JEQ PARCOM 1 is index for PARCOM DEC R0 Not PARCOM, check further JEQ RANGE 2 is index for RANGE * All otheres assumed to be SEETWO ************************************************************* * Find the line specified by the number in FAC * * Searches the table from low address (high number) to * * high address (low number). * ************************************************************* SEETWO LI R10,SET Assume number will be found LI R7,GET1 Assume reading from the VDP MOVB @RAMTOP,R0 But correct JEQ SEETW2 If LI R7,GETG2 ERAM is present SEETW2 MOV @ENLN,R3 Get point to start from AI R3,-3 Get into table SEETW4 BL *R7 Read the number from table ANDI R1,>7FFF Throw away possible breakpoint C R1,@FAC Match the number needed? JEQ SEETW8 Yes, return with condition set JH SEETW6 No, and also passed it =>return AI R3,-4 No, but sitll might be there C R3,@STLN Reached end of table? JHE SEETW4 No, so check further MOV @STLN,R3 End of table, default to last SEETW6 LI R10,RESET Indicate not found SEETW8 MOV R3,@EXTRAM Put pointer in for GPL B *R10 Return with condition RANGE MOV R11,R12 Save return address CB @FAC2,@CBH63 Have a numeric JH BERSNM Otherwise string number mismatch CLR @FAC10 Assume no conversion error BL @CFI Convert from float to integer MOVB @FAC10,R0 Get an error? JNE RANERR Yes, indicate it MOVB *R13,R0 Read lower limit SRL R0,8 Shift for word compare MOVB *R13,R1 Read 1st byte of upper limit SWPB R1 Kill time MOVB *R13,R1 Read 2nd byte of upper limit SWPB R1 Restore upper limit MOV @FAC,R2 Get the value JLT RANERR If negative, error C R2,R0 Less then low limit? JLT RANERR Yes, error C R2,R1 Greater then limit? JH RANERR Yes, error B *R12 All ok, so return RANERR BL @SETREG Set up registers for error B @GOTO90 * BAD VALUE * Make sure at a left parenthesis LPAR CB @CHAT,@LBLPZ At a left parenthesis JNE BERSYN No, syntax error * Parse up to a comma and insure at a comma PARCOM BL @PUTSTK Save GROM address BL @SETREG Set up R8/R9 BL @PARSE Parse the next item BYTE COMMAZ Up to a comma LBLPZ BYTE LPARZ CI R8,COMMAZ*256 End on a comma? JNE BERSYN No, syntax error BL @PGMCHR Yes, get character after it BL @SAVREG Save R8/R9 for GPL BL @GETSTK Restore GROM address B @RESET Return to GPL reset ******************************************************************************** AORG >6F98 TITL 'MVUPS' * (RAM to RAM) * WITH ERAM : Move the contents in ERAM FROM a higher * address to a lower address * ARG : byte count * VAR9 : source address * VAR0 : destination address MVUP MOV @ARG,R1 Get byte count MOV @VAR9,R3 Get source MOV @VAR0,R5 Get destination MVUP05 MOVB *R3+,*R5+ Move a byte DEC R1 Decrement the counter JNE MVUP05 Loop if more to move RT ******************************************************************************** AORG >6FAC TITL 'GETNBS' * Get a non-space character GETNB MOV R11,R0 Save return address GETNB1 BL @GETCHR Get next character CI R1,' '*256 Space character? JEQ GETNB1 Yes, get next character B *R0 No, return character condition * Get the next character GETCHR C @VARW,@VARA End of line? JH GETCH2 Yes, return condition MOVB @VARW1,*R15 No, write LSB of VDP address LI R1,>A000 Negative screen offset (->60) MOVB @VARW,*R15 Write MSB of VDP address INC @VARW Increment read-from pointer AB @XVDPRD,R1 Read and remove screen offset CI R1,>1F00 Read an edge character? JEQ GETCHR Yes, skip it RT Return GETCH2 CLR R1 Indicate end of line RT Return *-----------------------------------------------------------* * Remove this routine from CRUNCH because CRUNCH is running * * out of space 5/11/81 * *-----------------------------------------------------------* * Calculate and put length of string/number into * * length byte * LENGTH MOV R11,R3 Save retun address MOV @RAMPTR,R0 Save current crunch pointer MOV R0,R8 Put into r8 for PUTCHR below S R5,R8 Calculate length of string DEC R8 RAMPTR is post-incremented MOV R5,@RAMPTR Address of length byte BL @PUTCHR Put the length in MOV R0,@RAMPTR Restore crunch pointer B *R3 And return * FILL IN BYTES OF MODULE WITH COPY OF ORIGINAL? DATA >0000 DATA >EF71 ????? ******************************************************************************** AORG >7000 TITL 'CNS359' * * CONVERT THE NUMBER IN THE FAC TO A STRING * CALL : FAC NUMBER * R0 0 for free format(R1 & R2 are ignored) * Bit 0 on for fixed format * Bit 1 on for an explicit sign * Bit 2 on to output the sign of a positive * NO. as a plus sign ('+') instead of a space * (bit 1 must also be on) * Bit 3 on for E-notation output * Bit 4 also on for extended E-notation * R1 and R2 specify the field size. * R1 Number of places in the field to the left of * the decimal point including an explicit sign * and excluding the dicimal point. * R2 Number of places in the field to the right of * the decimal point. * R1 and R2 exclude ths 4 positions for the exponent * if bit 3 is on. * ERRORS: The field has more than 14 significant digits if * the number is too big to fit in the field. The * field is filled with asterisks. * The original contents of the FAC are lost. LWCNP DATA >0004 LWCNE DATA >0008 LWCNF DATA >0010 * Integer power of ten table CNSITT DATA 10000 DATA 1000 LW100 BYTE 0 LB100 BYTE 100 LW10 BYTE 0 LB10 BYTE 10 DATA 1 LBSPC BYTE ' ' LBAST BYTE '*' LBPER BYTE '.' LBE BYTE 'E' LBZER BYTE '0' EVEN CNS MOV R11,R10 In ROLOUT: use R10 to return BL @ROLOUT INCT R9 MOV R13,*R9 LI R6,FAC11 Optimize for space and speed MOVB *R6+,R0 @FAC11=0 if free format output SRL R0,8 Put in LSB MOVB *R6+,R1 @FAC12 places to left of dec SRL R1,8 Put in LSB MOVB *R6+,R2 @FAC13 places to right of dec SRL R2,8 Put in LSB MOVB @LBSPC,*R6+ Put extra space at beginning * for CNSCHK LI R3,'-'*256 Assume number is negative ABS @FAC Is number negative? JLT CNS01 Yes, its sign is known LI R3,' '*256 No, assume a space will be used CZC @LWCNP,R0 Do positive numbers get a plus * sign? JEQ CNS01 No, use a space LI R3,'+'*256 Yes, get a plus sign CNS01 MOVB R3,*R6+ Put sign in buffer MOV R0,@WSM Is free fomat output specified JNE CNSX No, use fix format output * FREE FORMAT FLOATING OUTPUT MOV @FAC,R4 Is it 0? JNE CNSF1 No DEC R6 LI R4,' 0' Yes, convert to a '0' and quit MOVB R4,*R6+ MOVB @R4LB,*R6+ CLR R4 Put 0 at end of string MOVB R4,*R6 LI R4,>5902 Put the beginning of string * in FAC11, LENGTH in FAC12 * FAC15=59, LENGTH=2 MOVB R4,@FAC11 MOVB @R4LB,@FAC12 B @ROLIN RT in ROLIN CNSF1 BL @CNSTEN Get base ten exponent, is NO. * less then one? JLT CNSF02 Yes, it can't be printed as an * integer CI R13,9 No, is number to big to print JGT CNSF02 Yes, round NO. for E-notataion * output MOVB @FAC,@R0LB No, check if the number is an * integer, get exponent, high * byte is still zero AI R0,PAD0 R0=PAD+FAC+2-64 AI R0,>C Get pointer to first * fractional byte CNSF01 CLR R1 MOVB *R0+,R1 Is next byte of fraction zero? JNE CNSF02 No, print NO. in fixed point * format CI R0,FAC8 Yes, reached end of number? JL CNSF01 No, continue looking at * fractional bytes CLR R10 Yes, number is an integer, * set integer flag JMP CNSF05 Go print the number, * no rounding is necessary CNSF02 LI R1,5 Assume rounding for E-notation CI R13,9 Is NO. too big for fixed point * output? JGT CNSF04 Yes, round for E-notataion CI R13,-4 No, is number to small for * fixed point output? JLT CNSF04 Yes, round for E-notation output C *R1+,*R1+ Force R1 to =9 CI R13,-2 No, will NO. be printed with * maximum number for fixed * format significant digits? JGT CNSF04 Yes, round accordingly INC R1 No, round number for maximum * significant digits (R1=10) A R13,R1 That can be printed for this * number CNSF04 BL @CNSRND Round NO. accordingly, * rounding can change the * exponent and so the print * format to be used SETO R10 Set non-integer flag CNSF05 CI R13,9 Decide which print format to JGT CNSG use, too big for fixed format CI R13,-6 Use E-notation number in range * for max fixed point digits? JGT CNSF08 Yes, use fixed format output CI R13,-10 No, NO. too small for fixed * format? JLT CNSG Yes, use E-notation ouput * No, the NO. of significant * digits will determine fixed * format ouput or not LI R0,FAC8 Get pointer to last byte * of FAC1 CLR R1 Clear low byte of least * significant byte regester LI R3,4 4=15-11 Get NO. of * digits+2-exponent scale factor A R7,R3 Take into acccount a leading * zero in FAC1 CNSF06 DECT R3 Decrement sig digit count for * last zero byte DEC R0 Point to next higher byte of FAC MOVB *R0,R1 Is next byte all zero? JEQ CNSF06 Yes, continue looking for LSB * No, found the LSB, this loop * will always terminate since * FAC1 never 0 CLR R0 Take into account if the LSB is * divisible by ten SWPB R1 Is divisible by ten DIV @LW10,R0 Divide LSB by ten MOV R1,R1 Is the remainder zero? JNE CNSF07 No, significant digit count is * correct DEC R3 Yes, LSB has a trailing zero CNSF07 C R3,R13 Too many significant digits for * fixed format? JGT CNSG Yes, use E-notation * FREE FORMAT FIXED POINT AND INTEGER FLOATING OUTPUT CNSF08 S R7,R13 Make the exponent even JLT CNSF12 are there digits to left of * decimal point? Jump if not * Yes, print decimal point with * the number LI R4,3 Figure out where the decimal * point goes in A R13,R4 The number's digits CNSF10 LI R3,12 Convert the maximum number of * decimal digits, leading and * trailing zeros are suppressed * later BL @CNSDIG Convert number to decimal digits BL @CNSUTR Remove trailing zeros JMP CNSG01 Suppress leading zeros and CNSF12 SETO R0 figure out how many zeros * there are S R13,R0 Between decimal point and * first digit BL @CNSPER Put decimal point and zeros * in buffer CLR R4 Don't print another decimal * point in the number JMP CNSF10 Convert NO. to decimal digits * finish up * FREE FORMAT E-NOTATION FLOATING OUTPUT CNSG LI R3,8 Get maximum NO. of digits to * print LI R4,3 Figure out where to put decimal * point S R7,R4 Take a leading zero into account BL @CNSDIG Convert NO. to decimal digits BL @CNSUTR Suppress trailing zeros BL @CNSEXP Put exponent into buffer CNSG01 B @CNSMLS Suppress leading zeros and * finish up * FIXED FORMAT OUTPUT * WSM R0 format specifications * WSM2 R1 format specifications * WSM4 R2 format specifications * WSM6 Number of digit places to left of decimal point * WSM8 Number of digit places to right of decimal point CNSX MOV R1,@WSM2 Save R1 format specifications MOV R2,@WSM4 Save R2 format specifications CZC @LWCNE,R0 Is E-notation to be used? JNE CNSX01 Yes, remove place for sign from * left of DP count CI R3,'-'*256 No, is number negative? JEQ CNSX01 Yes, remove sign from digit count CZC @LWCNS,R0 No, is explicit sign specified? JEQ CNSX02 No, digit count correct as is CNSX01 DEC R1 Remove place for sign form left * of DP digit count JGT CNSX02 Any places for digits left? CI R3,'-'*256 No, is number negative? JEQ CNSX02 Yes, can't do anything about it CLR R1 No, see if NO. digits to left * of DP will work CNSX02 MOV R1,@WSM6 Save number of digits to left * of DP JLT CNSJ04 Field to small if there are * negative places DEC R2 Take decimal point from right * of DP count JGT CNSX03 Are there still places left? CLR R2 No, don't print any digits there CNSX03 MOV R2,@WSM8 Save right of DP digit count MOV R1,R4 Compute how many significant * digits are to be printed A R2,R4 JEQ CNSJ04 None, error * FALL INTO NO-TO FIXED FORMAT FLOATING OUTPUT * * Fixed format floating output BL @CNSTEN Get base ten exponent of the FAC CZC @LWCNE,R0 Is E-format call for? JNE CNSK Yes, go do it * FIXED FORMAT FLOATING F-FORMAT OUTPUT C R13,@WSM6 Are there too many digits in * the number for the field size? JLT CNSJ00 No, ok CNSJ04 B @CNSAST CNSJ00 MOV R13,R1 No, get exponent A R2,R1 Compute where rounding should * take place CI R1,-1 Is the NO. too small for the * field? JLT CNSVZR Yes, result is zero BL @CNSRND No, round NO. to the proper * place S R7,R13 Convert exponent to an even * number JLT CNSJ01 Any digits to left of DP? SETO R0 Yes, compute how many zero are * needed before the number to * fill out the field to the * proper size A @WSM6,R0 S R13,R0 BL @CNSZER Put zeros in the buffer if * needed LI R3,3 Compute the number of digits to * convert A R13,R3 Take into account the number's * size MOV R3,R4 Yes, compute where the DP will * go A @WSM8,R3 Take into account the NO. of * decimal palces JMP CNSJ02 Go convert the number CNSJ01 MOV @WSM8,R3 Number is less then one JEQ CNSVZR NO. decimal places, print zero MOV @WSM6,R0 Get size of field to right of DP INC R0 Add one for CNSZER BL @CNSZER Fill field with zeros, they * will be suppressed MOV R6,R12 Save pointer to DP SETO R0 Compute NO. of zeros after DP S R13,R0 And before the number BL @CNSPER Put them and a DP into the * buffer A R13,R3 Figure out how many digits to * convert AI R3,3 Scale accordingly CLR R4 Do not print a decimal point CNSJ02 BL @CNSDIG Convert the NO. decimal digits MOV @WSM4,R0 Is a decimal point required? JNE CNSJ03 Yes, it is already there MOVB R0,*R12 No, overwrite it with zero CNSJ03 B @CNSCHK Go finish up * FIXED FORMAT OUTPUT OF ZERO CNSVZR MOV @WSM6,R0 Get left of DP field size INC R0 Adjust it for CNSZER BL @CNSZER Put in correct amount of zeros MOV R6,R12 Save pointer to where DP will * go MOV @WSM4,R0 Is a DP called for? JEQ CNSV01 No, don't print one BL @CNSPER Yes, print it & some zeros * after if needed CNSV01 MOV @WSM,R0 Get R0 format specification CZC @LWCNE,R0 Is E-format called for? JEQ CNSJ03 No, finish up JMP CNSK01 Yes, print an exponent * FIXED FORMAT FLOATING E-FORMAT OUTPUT CNSK MOV @FAC,R5 Is it zero? JNE CNSK1 No, go to CNSK1 CLR R7 Yes, do it differently: CLR R13 R7,R13 set to be 0 and jump JMP CNSVZR to CNSVZR CNSK1 A R2,R1 Get total number of digits to * print DEC R1 Compute where rounding should * occur BL @CNSRND Round number for E-format output MOV @WSM6,R3 Get number of digits to left * of DP S R3,R13 Compute what exponent should be * printed INC R13 Scale properly S R7,R3 Consider only even exponents INCT R3 Compute number of digits to * print & where to put the * decimal point MOV R3,R4 A @WSM8,R3 Take digits to right of DP * into account BL @CNSDIG Convert number to decimal digits MOV @WSM4,R0 Is a decimal point needed? JNE CNSK01 Yes, leave it alone DEC R6 No, overwrite it with exponent CNSK01 BL @CNSEXP Put exponent into the buffer JMP CNSJ03 Finish up and zero suppress * ROUND THE NUMBER IN FAC * CALL R1 Number of decimal digits to right of most * significant digit to round to * R13 Base ten exponent * R7 0 if R13 is even, 1 if R13 is odd * BL CNSRND * STATUS Bits reflect exponent * R13 Base ten exponent of rounded result * R7 0 if R13 is even, 1 if R13 is odd * DESTORYS: R0-R3,R12,R10 * ASSUMES R12 GE -1 CNSRND INCT R9 Save return address MOV R11,*R9 S R1,R13 Compute base ten exponent of * place to round to S R7,R1 Take position of first digit * into account SRA R1,1 Compute address in FAC of byte * to be looked at INCT R1 To determine if rounding occurs LI R3,49*256 Assume 50 will be added to that * byte SRA R13,1 Rounding to an even ten's place? JNC CNSR01 Yes, assumption was correct LI R3,4*256 No,add 5 to byte to be looked at CNSR01 CI R1,7 Is all of FAC significant? JGT CNSR05 Yes, no need to round LI R7,FAC No, get pointer into FAC CLR R12 The number is positive MOVB *R7,R13 Get current FAC exponent MOVB R13,R10 Save it to see if it will change SRL R13,8 Put exponent in the low byte A R1,R7 Get address of byte to look at AB R3,*R7 Add NO. to add to round-1 into * correct byte MOV R3,R11 In ROUNUP: Change R3 value MOV R10,R4 In ROUNUP: Use R10 to return LI R10,CNSROV MOVB @FAC,R5 In ROUNUP: Get the exponent value * from EXP and EXP+1, so * now provide SRL R5,8 MOV R5,@EXP MOVB R5,@SIGN Clear sign which is used in ROUNUP MOV R9,R5 In ROUNUP: R9 value may be * changed B @ROUNUP Propigate carry upwards in FAC CNSROV MOV R4,R10 MOV R11,R3 MOV R5,R9 CLR R1 Label prevents getting an * overflow warning CI R7,FAC1 Did rounding occur at first * byte of FAC? JNE CNSR02 No, go clear rest of FAC CB @FAC,R10 Yes, did exponent change? JNE CNSR03 Yes, FAC is correctly zeroed * as is CNSR02 CI R3,4*256 Did rounding occur on a byte * boundry? JNE CNSR04 Yes, clear rest of bytes in FAC CLR R0 No, make this digit divisible * by ten MOVB *R7,@R1LB Get byte where rounding occured DIV @LW10,R0 Divide by ten to get quotient MPY @LW10,R0 Pack quotient back in, ignore MOVB @R1LB,*R7 Put the byte back into the FAC CNSR03 INC R7 Point to next byte of FAC CNSR04 MOVB R1,*R7+ Zero next byte of FAC CI R7,FAC8 Done zeroing the rest of the * FAC? JL CNSR04 No, continue to do it CNSR05 MOV *R9,R11 Yes, restore return address DECT R9 Get new base ten exponent of FAC * * GET BASE TEN EXPONENT OF THE NUMBER IN THE FAC * CALL BL CSNTEN * STATUS Status bits reflect exponent * R13 Base ten exponent * R7 0 if R13 is even, 1 it R13 is odd CNSTEN LI R13,->4000 Negative bias AB @FAC,R13 Get base 1 hundred exponent of * FAC SRA R13,7 Multiply it by two and put it * in the low byte CLR R7 High bit of FAC1 is always off CB @FAC1,@CBHA Is first digit of FAC one * decimal digit? JLT CNST01 Yes, base ten exponent is even INC R13 No, take this into account in * base ten exponent INC R7 This makes the base ten * exponent odd CNST01 MOV R13,R13 Set stauts bits to reflect * base ten exponent RT * * CONVERT FACTION OF FLOATING NUMBER IN FAC TO ASCII DIGITS * CALL R3 Number of decimal digits+1 to convert * R4 Number of digits the decimal point is to * the left of * R6 Text pointer to where to put result * BL CNSDIG * R3(MB) 0 * R6 Updated to point to end of digits * R12 Pointer to decimal point * DESTORYS: R0-R2,R4 * CNSDIG INCT R9 Save return address MOV R11,*R9 CLR @FAC8 Clear guard digits in case they * are printed CLR R1 Clear high byte of current byte * of FAC register LI R2,FAC1 Get pointer to first byte of FAC BL @CNSD03 Check for a leading dec point CNSD01 CLR R0 Clear high word of this byte * of FAC for divide MOVB *R2+,@R1LB Get next byte of FAC DIV @LW10,R0 Separate the two decimal digits BL @CNSD02 Put the first one in the buffer MOV R1,R0 Get the one's place digit LI R11,CNSD01 Set up return addressto loop and * get the next byte of the FAC * after this digit is printed CNSD02 AI R0,'0' Convert this decimal digit to * ASCII MOVB @R0LB,*R6+ Put this ASCII digit into buffer CNSD03 DEC R4 Is it time for decimal point? JNE CNSD04 No, check for end of number MOV R6,R12 Yes, save ptr to decimal point MOVB @LBPER,*R6+ Put decimal point in buffer * VSPTR (Value stack pointer) at CPU >6E, make sure not to * destroy it here CNSD04 CI R6,FAC33 Field overflow? JHE CNSD06 Yes, put a zero byte at the * end and return DEC R3 No, all digits been printed? JGT CNSDRT No, return & print next digit CNSD06 MOVB R3,*R6 Yes, put a zero byte at the end * of the number CNSD05 MOV *R9,R11 Restore return address DECT R9 CNSDRT RT ******************************************************************************** TITL 'CNS3592' * PUT EXPONENT INTO THE BUFFER * CALL R6 Text pointer into buffer * R13 Exponent * BL CNSEXP * R6 Updated to point after exponent * DESTORYS: R0,R13 * CNSEXP INCT R9 Save return address MOV R11,*R9+ MOV R12,*R9 Save contents of registers MOVB @LBE,*R6+ Put an "E" into the buffer LI R0,'-'*256 Assume the exponent is negative ABS R13 Is exponent negative? JLT CNSE01 Yes, sign is correct LI R0,'+'*256 No, get sign for positive exp CNSE01 MOVB R0,*R6+ Put the exponent's sign into * buffer CI R13,100 Is the exponent to big? JLT CNSE02 No, convert it to ASCII MOV @WSM,R0 Is free format output? JEQ CNSE04 Yes, get the asterisk CZC @LWCNF,R0 No, is extended exp specified? JNE CNSE02 Yes, convert it to ASCII CNSE04 LI R0,'*'*256 No, get an asterisk MOVB R0,*R6+ Put two asterisks in the buffer * for the exponent MOVB R0,*R6+ Because it is too big JMP CNSE03 Go finish up CNSE02 BL @CNSINT Convert the exp to ASCII digit AI R6,-5 Point back to start of exp MOV @WSM,R0 Is free format output? JEQ CNSE05 Yes CZC @LWCNF,R0 No, is extended exp specified? JEQ CNSE05 No MOVB @2(R6),*R6+ Yes, move 3(instead of 2) * significant MOVB @2(R6),*R6+ digits of exponent up pass the MOVB @2(R6),*R6+ leading zeros from CNSINT JMP CNSE03 CNSE05 MOVB @3(R6),*R6+ Move significant digits of * exponent up pass the leading * zeros from MOVB @3(R6),*R6+ CNSINT CNSE03 MOVB @LW10,*R6 Put a zero byte at the end of * the number MOV *R9,R12 Restore original contents of * R12 DECT R9 JMP CNSD05 POP address and return * CONVERT AN UNSIGNED INTEGER INTO A STRING OF 5 ASCII DIGITS * CALL R6 Text pointer * R13 Integer * BL CNSINT * R6 Updated to point after number * DESTROYS: R0,R12,R13 CNSINT LI R0,CNSITT Get pointer to integer power of * ten table CNSI01 CLR R12 Clear high word of integer for * divide DIV *R0+,R12 Divide by next power of ten AI R12,'0' Convert quotient to ASCII MOVB @R12LB,*R6+ Put next digit into the buffer CI R0,CNSITT+10 Divided by all the powers of ten? JL CNSI01 No, compute the next digit of * the NO. MOVB R12,*R6 Yes, put a zero byte at the * end of the number RT * PUT SOME ZEROS IN THE BUFFER AND MAYBE A DECIMAL POINT * CALL R0 Number of zeros+1 * R6 Text pinter into buffer * BL CNSPER : To put in a decimal point before zeros * BL CNSZER : Updated to point after the zeros * DESTROYS: R0 CNSPER MOVB @LBPER,*R6+ Put a decimal point in the buffer JMP CNSZER Then some zeros CNSZ01 MOVB @LBZER,*R6+ Put a zero in the buffer CNSZER DEC R0 Are there more zeros to put in? JGT CNSZ01 Yes, go put in another zero MOVB R0,*R6 No, put a null byte after the * zeros RT * SUPPRESS LEADING ZEROS AND FLOAT THE SIGN * CALL * JMP CNSMLS : Entry to finish up after zero suppressing * BL CNSLEA : Entry to return afterwards * R1 ASCII sign in high byte * R6 Pointer to start of number * DESTROYS: R0-R1 CNSMLS LI R11,CNSSTR Entry to finish up number * afterward CNSLEA LI R6,FAC15 Get pointer to sign MOVB *R6,R1 Get sign CNSL01 MOVB @LBSPC,*R6+ Put a space where the zero * or sign was CB *R6,@LBZER Is the next byte zero? JEQ CNSL01 Yes, suppress it MOVB *R6,R0 No, is this the end of * the number? JEQ CNSL02 Yes, put the zero back in, * NO. is 0 CB R0,@LBE No, is this the start of * the exponent? JEQ CNSL02 Yes, put the zero back in, * NO. is 0 CB R0,@LBPER No, is this the decimal point? JNE CNSL03 No, put the sign back in MOV @WSM,R0 Yes, is free format output? JNE CNSL03 No, then put the sign * back in fix fomat output MOVB @1(R6),R0 Yes, any digits to right of DP? JEQ CNSL02 No, put the sign back CB R0,@LBE Does exponent start after DP? JNE CNSL03 No, put the sign back CNSL02 DEC R6 Yes, point back to where the * zero was MOVB @LBZER,*R6 Put the zero back in, the NO. * is 0 CNSL03 DEC R6 Point back to where the sign * will go MOVB R1,*R6 Put the sign back in the buffer RT * REMOVE TRAILING ZEROS * CALL R3 0 * R6 Pointer to one past end of number * R12 Pointer to decimal point * R10 Zero if an integer is being printed * BL CNSUTR * R6 Pointer to new end of number * DESTROYS: NONE CNSU01 DEC R6 Point back to next digit in * the NO. CNSUTR CB @-1(R6),@LBZER Is the last digit in the NO. 0? JEQ CNSU01 Yes, look back for a non-zero * digit MOV R10,R10 No, is an integer being printed? JNE CNSU02 No, put a null at the end of * the NO. MOV R12,R6 Yes, end of number is where DP * is all digits after the * decimal point should be zero CNSU02 MOVB R3,*R6 Put a zero byte at the end of * the number RT * SET UP A POINTER TO THE BEGINNING OF A FIXED FORMAT FIELD * AND SEE IF THE FIELD IS LARGE ENOUGH AND FINISH UP * CALL R12 Pointer to decimal point or where it * would go * JMP CNSCHK * R6 Pointer to beginning of number * DESTROYS: R0,R1 CNSCHK BL @CNSLEA Suppress leading zeros and fix * up the sign MOV R12,R6 Point to decimal point S @WSM2,R6 Point to where the beginning of * the field is CB @-1(R6),@LBSPC Does number extend before the * field beginning? JNE CNSAST Yes, error MOV @WSM,R0 No, get R0 format specification CZC @LWCNS,R0 Is an explicit sign required? JEQ CNSSTR No, finish up and return CB *R6,@LBSPC Yes, is first character of * number a space? JEQ CNSSTR Yes, finish up and return CB *R6,R1 No, is first character of * number the sign? JEQ CNSSTR Yes, finish up and return * No, error * ASTRISK FILL A FIXED FORMAT FIELD AND FINISH UP * CALL * JMP CNSAST * R6 Pointer to the beginning of the string * DESTROYS: R0,R1 CNSAST LI R6,WSM Optimize for speed and space MOV *R6+,R0 Get R0 format spacification MOV *R6+,R1 Get left of decimal point size A *R6+,R1 Compute length of field CZC @LWCNE,R0 Is E-format being used? JEQ CNSA01 No, field length is correct C *R1+,*R1+ Yes, increase field length for * the exponent (Increments R1 * by 4) CZC @LWCNF,R0 Is extended E-format being used? JEQ CNSA01 No, field length is correct INC R1 Yes, increase field length for * the exponent (Increments R1 * by 1) CNSA01 LI R6,FAC15 Get pointer to beginning of buffer MOV R6,R0 Get a pointer to put asterisks * in the buffer CNSA02 MOVB @LBAST,*R0+ Put an asterisk into the buffer DEC R1 Is the field filled yet? JGT CNSA02 No, continue asterisk filling it MOVB R1,*R0 Yes, put a zero byte at the end * of string * Finish up and return * FINSH UP -- COMPUTE THE LENGTH OF THE STRING AND RETURN * CALL R6 Pointer to first character in the string, * the string ends with a zero byte * DESTROYS: R0-R1 CNSSTR MOV R6,R0 Get pointer to beginning of the * string CNSS01 MOVB *R0+,R1 Look for end of string, * found it? JNE CNSS01 No, keep looking DEC R0 Yes, point to back to the * zero byte S R6,R0 Compute length of string MOVB @R0LB,@FAC12 Put length of string in FAC12 LI R0,PAD0 S R0,R6 Put beginning of string * in FAC11 MOVB @R6LB,@FAC11 MOV *R9,R13 Restore GROM address DECT R9 Off the stack B @ROLIN In ROLIN return ******************************************************************************** AORG >748E TITL 'TRINSICS' CBH411 DATA >4101 CBH3F BYTE >3F CBH44 BYTE >44 EVEN * * VROAZ EQU >03C0 VDP roll out area * FPSIGN EQU >03DC * PROAZ EQU PAD0+>10 Processor roll out area * PZ EQU PAD0+>12 * QZ EQU PAD0+>16 * CZ EQU PAD0+>1A * SGNZ EQU PAD0+>75 * EXPZ EQU PAD0+>76 * OEZ EQU PAD0+>14 EXC127 EQU >00 FHALF EQU >08 SQRTEN EQU >10 LOG10E EQU >18 LN10 EQU >20 PI2 EQU >28 RPI2 EQU >30 PI4 EQU >38 TANPI8 EQU >40 TAN3P8 EQU >48 SQRP EQU >50 SQRQ EQU >6A FPOS1 EQU >6A EXPP EQU >7C EXPQ EQU >96 LOGP EQU >B8 LOGQ EQU >E2 SINP EQU >010C ATNP EQU >014E ************************************************************* * INVOLUTION * * FAC - exponent * * Top of stack - Base * * If integer Base and integer exponent do multiplies to * * keep result exact, otherwise, use logarithm to calculate * * value. * ************************************************************* PWRZZ MOV R11,R10 BL @SAVRTN Save return BL @POPSTK Get Base into ARG MOV @FAC,R0 If exponent=0 JEQ PWRG01 Then result = 1 MOV @ARG,R0 If Base=0 JEQ PWRG02 Then return 0 or warning A @C8,@VSPTR Use Base on stack BL @PUSH Check to see if E is floating * integer BL @GRINT Convert 1 copy of exp to int MOVB @C8,@SIGN Assume sign is positive BL @XTFACZ FAC=ARG STACK=INT(ARG) BL @SCOMPB Integer exponent? JNE PWRZZ3 No, try floating code * COMPUTE INTEGER POWER B^E BL @PUSH Put Exp above Base on stack MOVB @C8,@FAC10 Assume no error BL @CFI Try to convert E to integer CCBH7 ABS @FAC Absolute value of exponent MOV @FAC,R12 Save integer exponent BL @POP Return E to FAC; B on stack MOVB @FAC10,R0 If E>32767 JNE PWRZZ1 Return to floating point code BL @XTFACZ Get Base in accumulator BL @PUSH Put E on stack for later sign * check DEC R12 Reduce exponent by one since * accumulator starts with Base JEQ PWRJ40 If 0 then done already PWRJ30 SRL R12,1 Check l.s. bit JNC PWRJ10 If 0, skip the work BL @SMULT Multiply in this power A @C8,@VSPTR Restore stack PWRJ10 MOV R12,R12 Finished? JEQ PWRJ40 Yes BL @XTFACZ No, exchange: B in FAC, * accumulator on stack BL @PUSH Copy B onto stack BL @SMULT Square it for new B BL @XTFACZ Restore order: B on stack * accumulator in FAC JMP PWRJ30 Loop for next bit PWRJ40 S @C16,@VSPTR Done, clean up MOV @VSPTR,R3 Get stack pointer AI R3,8 Test exponent sign now BL @GETV1 Get it JLT PWRJ41 If negative, compute negative PWRRTN B @ROLIN2 Use commone code to return PWRJ41 MOVB @FAC10,R0 If overflow has occured JNE PWRJ45 Go make it zero BL @MOVROM Get a floating point one DATA FPOS1 into ARG * BL @FDIV Compute the inverse JMP PWRRTN And return PWRJ45 CLR @FAC If overflow, the result=0 MOVB @FAC,@FAC10 Indicate no error JMP PWRRTN And return PWRG02 MOVB @FAC,R0 Is Exp negative? JLT PWRG05 Yes, divide by 0 =>put in overflow JMP PWRJ45 No, result is zero and return PWRG01 LI R0,FAC Need to put floating 1 in FAC BL @MOVRM1 Get the floating 1 DATA FPOS1 into FAC * JMP PWRRTN And return PWRZZ3 BL @GETV Check for negative DATA VSPTR On the stack * JGT PWRZZ2 If ok MOVB @ERRNIP,@FAC10 Else error code S @C8,@VSPTR Throw away entry on stack JMP PWRRTN And return * INTEGER EXPONENT OUT OF INTEGER RANGE PWRZZ1 BL @GETV Positive or negative Base? DATA VSPTR * JGT PWRZZ2 Positive Base * NEGATIVE BASE - So see if exponent is even or odd to set * the sign of the result PWRZZ4 CLR R1 For double MOVB @FAC,R1 Get exponent ABS R1 Work with positive CI R1,>4600 Too big to have one's byte? JGT PWRZZ2 Yes, assume number is even SWPB R1 Get in low order byte AI R1,>830B No, get one's radix digit * location in FAC MOVB *R1,R1 Get the digit SLA R1,7 If last bit set, set top bit PWRZZ2 LI R4,FPSIGN Save sign of result BL @PUTV1 in a permanent place BL @XTFACZ Base in FAC; Exponent on stack ABS @FAC Must work with positive BL @LOGZZ Compute LOG(B) in FAC BL @SMULT Compute E*LOG(B) in FAC BL @EXPZZ Let exp give error on warning LI R3,FPSIGN Check sign of result BL @GETV1 JLT PWRZZ5 If E is negative JMP PWRRTN If E is positive ERRNIP EQU $ PWRZZ5 NEG @FAC Make it negative JMP PWRRTN PWRG05 BL @OVEXP Return overflow JMP PWRRTN And return ************************************************************* * EXPONENTIAL FUNCTION * * FAC = EXP(FAC) * * CALL BL @EXPZZ * * WARNING: WRNOV Overflow * * STACK LEVELS USED: * * X : = FAC * LOG10(E) * * So EXP(FAC) = 10^X * * Make sure X is in range LOG100(X) = LOG10(X)/2 * * N : = INT(X) * * R : = X-N, 0 <= R < 1 * * IF R < .5 THEN R : = R * * ELSE S : = R-5 * * A rational function approximation is used for 10^S * * (HART EXPD 1444) * * EXP : = IF R .LT. .5 THEN 10^N * 10^S * * ELSE 10^N * 10^.5 * 10^S * ************************************************************* EXPZZ MOV R11,R10 BL @ROLOUT Get workspace and save return BL @MOVROM Get LOG10(E) DATA LOG10E into ARG * BL @FMULT X : = FAC * LOG10(E) BL @PUSH Save X BL @GRINT Compute N : = INT(X) BL @MOVROM Get floating 127 DATA EXC127 into ARG * BL @FCOMPB Is N > 127? JEQ EXP03 If = 127 JLT EXP01 If > 127 NEG @ARG Check negative range BL @FCOMPB Is N < -127? JLT EXP03 N > -127 JEQ EXP03 N = -127 * N is out of range EXP01 S @C8,@VSPTR Pop X off stack MOV @FAC,@EXP Recall exponent sign MOVB @C8,@SIGN Result is positive BL @OVEXP Take over or underflow action JMP BROLIN Restore CPU RAM and return EXP03 BL @PUSH Save value on stack BL @CFI Convert to integer exponent MOV @FAC,R12 Get it in REG to mpy by 2 SLA R12,1 Compute 2*N BL @POP Restore value BL @SSUB Compute R = X - N BL @MOVROM Get a floating .5 DATA FHALF into ARG * BL @FCOMPB Is .5 > R? JGT EXP04 Yes, S=R NEG @ARG -.5 BL @FADD Compute S : = R - .5 INC R12 Remember R >= .5, (2*N+1) * save a copy of S EXP04 BL @PUSH Save a copy of S BL @POLYW Compute S * P(S^2) DATA EXPP Poly to evaluate * BL @XTFACZ FAC = S, stack = S * P(S^2) BL @POLYX Compute Q(S^2) DATA EXPQ Poly to evaluate * BL @POPSTK S * P(S^2) -> ARG A @C8,@VSPTR BL @PUSH Save comp of Q(S^2) BL @FADD Q(S^2) + S * P(S^2) LI R3,FAC Save FAC in a temp LI R4,CZ MOV *R3+,*R4+ 1st two bytes MOV *R3+,*R4+ 2nd two bytes MOV *R3+,*R4+ 3rd two bytes MOV *R3,*R4 Last two bytes BL @POP FAC = Q(S^S), stack = S*P(S^2) BL @XTFACZ Revese same BL @SSUB Compte Q(S^2)-S*P*(S^2) LI R3,CZ Get fac back from temp LI R4,ARG MOV *R3+,*R4+ 1st two bytes MOV *R3+,*R4+ 2nd two bytes MOV *R3+,*R4+ 3rd two bytes MOV *R3,*R4 Last rwo bytes BL @FDIV Compute Q-P/Q-P EXPSQT SRA R12,1 Check flag that was set above JNC EXPSQ5 If not set BL @MOVROM Get SQR(10) DATA SQRTEN into ARG * BL @FMULT Multipy by SQU(10) if N odd EXPSQ5 BL @MOVROM Need a floating 1 DATA FPOS1 into ARG * SRA R12,1 Check odd power of ten JNC EXPSQ8 If not odd power MOVB @CBHA,@ARG1 Odd power of ten (>0A) EXPSQ8 AB @R12LB,@ARG Add in power of 100 to Exp BL @FMULT BROLIN B @ROLIN ************************************************************* * LOGARITHM FUNCTION * * FAC : = LOG(FAC) * * ERRORS : ERRLOG LOG of negative number or zero * * attempted. * * STACK LEVELS USED: * * IF FAC <= 0 THEN ERRLOG * * LOG(FAC)=LN(FAC)=LOG10(FAC)*LN(10) * * FAC : = A * 10^N, .1 <= A < 1 * * S : = A * SQR(10), 1/SQR(10) <= S < SQR(10) * * LOG10(A) : = LOG10(S/SQR(10)) * * : = LOG10(S) - LOG10(SQR(10)) * * : = LOG10(S) - .5 * * LOG : = (N - .5 + LOG10(S)) * LN(10) * * : = (N - .5 * LN(10) + LN(S) * * A rational function approximation is used for LN(S) * * (HART LOGE 2687) * ************************************************************* LOGZZ MOV R11,R10 BL @ROLOUT Get workspace and save return MOV @FAC,R0 Check for negative or zero JGT LOGZZ3 If positive MOVB @ERRLOG,@FAC10 Load error code JMP BROLIN Restore CPU and return ERRLOG EQU $ LOGZZ3 BL @TENCNS Get base 10 exponent JNE LOGZZ5 BL @MOVROM Get a floating 1 DATA FPOS1 into ARG * Make it a floating 10 MOVB @CBHA,@ARG1 by putting in >0A BL @FMULT Multipy FAC by 10 BL @TENCNS Get new exponent of 10 JMP LOGZ5A Compensate for Mult LOGZZ5 INC @EXP Compenstat for where radix * point is LOGZ5A MOVB @CBH3F,@FAC Put A in proper range * by putting in >3F MOV @EXP,R12 BL @MOVROM Get SQR(10) DATA SQRTEN into ARG * BL @FMULT S : = A * SQR(10) BL @FORMA Z : = (S-1) / (S+1) BL @PUSH Push Z BL @POLYW Compute Z * P(Z^2) DATA LOGP * BL @XTFACZ BL @POLYX Compute Q(Z^2) DATA LOGQ Poly to evaluate * BL @SDIV Compute Z*P(Z^2)/Q(Z^2) BL @PUSH Push it LI R0,ARG Build entry in ARG MOV R12,*R0+ Put in exponent CLR *R0+ and CLR *R0+ clear the CLR *R0 rest * STATUS WAS SET BY THE MOVE ABOVE JEQ LOGZZ7 If zero exponent ABS @ARG Work with ABS value MOV @ARG,R0 in register CI R0,99 Too large? JGT LOGZZ9 Yes MOVB @FLTONE,@ARG Exponent = >40 LOGZZ6 MOVB R12,R12 Exponent positive? JEQ LOGZZ7 Yes NEG @ARG No, make it negative LOGZZ7 BL @MOVRM5 Need a floating .5 DATA FHALF in FAC * BL @FSUB Compute N - .5 BL @MOVROM Need LN(10) DATA LN10 into ARG * BL @FMULT Compute (N - .5) * LN(10) BL @SADD Add to LN(S) JMP BROLIN Restore CPU and return LOGZZ9 S @C100,@ARG Subtract first 100 MOVB @ARG1,@ARG2 MOV @CBH411,@ARG Load exponent and * leading digit of >4101 JMP LOGZZ6 ************************************************************* * EVALUATE X * P(X^^2) * * ON CALL : PZ Pointer to polynomial coefficients * * : FAC Contains X * * BL @POLYW * * : FAC Returns X * P(X^^2) * ************************************************************* POLYW MOV *R11+,@PZ Get the poly to evaluate MOV R11,R10 BL @SAVRTN Save return address BL @PUSH Push the argument BL @POLYX1 Compute P(X^^2) BL @SMULT Compute X*P(X^^2) JMP PWRTN2 And return POLY MOV *R11+,@PZ MOV R11,R10 BL @SAVRTN Save return address JMP POLY01 And merge in below POLYX MOV *R11+,@PZ POLYX1 MOV R11,R10 BL @SAVRTN Save return address BL @PUSH Need to copy FAC * into ARG to square it BL @SMULT Square X (SMULT pops into ARG) POLY01 BL @PUSH Push the argument MOV @PZ,R3 Get the poly to evaluate LI R0,FAC into FAC BL @MOVRM2 JMP POLY03 POLY02 BL @POPSTK Get X back A @C8,@VSPTR Keep it on stack BL @FMULT Multiply previous result by X MOV @PZ,R3 LI R0,ARG Get polynomial to evaluate BL @MOVRM2 into ARG BL @FADD Add in this coefficient POLY03 A @C8,@PZ Point to next coefficient * and get first two bytes * into ARG CB *R13,@CBH80 Read first byte * and test it to see if done JNE POLY02 No, continue computing poly S @C8,@VSPTR Pop X off stack JMP PWRTN2 Return with poly in FAC * FORMA MOV R11,R10 BL @SAVRTN Save return address BL @PUSH Save X on stack BL @FORMA2 BL @FORMA2 BL @XTFACZ Swap (X-1) and X BL @MOVROM Get a floating 1 DATA FPOS1 into ARG * BL @FADD X+1 BL @SDIV (X-1)/(X+1) JMP PWRTN2 And return FORMA2 MOV R11,R10 BL @SAVRTN Save return address BL @MOVROM Get a floating .5 DATA FHALF int ARG * NEG @ARG BL @FADD X - .5 PWRTN2 B @ROLIN2 ************************************************************* * SQUARE ROOT FUNCTION * * Reference for scientific function approximations. * * JOHN F. HART ET AL, Comper approximations, * * JOHN WILEY & SONS, 1968 * * FAC : = SQR(FAC) * * ERRORS : ERRSQR Square root of negative number * * attempted * * STACK LEVELS USED: * * IF FAC = 0 THEN SQR : = 0 * * IF FAC < 0 THEN ERRSQR * * FAC : = A * 100^N, .01 <= A < 1 * * SQR : = 10^N * SQR(A) * * Newton's method with a fixed number of iterations is used * * to approximate SQR(A): * * A rational function approximation is used for Y(0) * * (HART SQRT 0231) * * Y(N+1) = (Y(n))/2 * ************************************************************* SQRZZ MOV R11,R10 BL @ROLOUT Get workspace and save return MOV @FAC,R12 Check exponent JEQ SQR03 FAC is zero, return zero JLT SQR02 FAC is < 0, error MOVB @CBH3F,@FAC Create A in range .01 <= A <1 * by loading >3F AI R12,>C100 Remove bias (-63) SRA R12,8 Sign extend SLA R12,1 Save 2 * N BL @PUSH Save A BL @PUSH Save A again BL @POLY Compute P(A) DATA SQRP Poly to evaluate * BL @XTFACZ Stack : = P(A), FAC : = A BL @POLY Compute Q(A) DATA SQRQ Poly to evaluate * BL @SDIV Compute P(A)/Q(A) MOV @CC3,@PZ Save in permanent SQR01 BL @POPSTK Pop into ARG A @C8,@VSPTR But keep it on stack BL @PUSH Push Y(N) BL @FDIV Compute A/Y(N) BL @SADD Compute A/Y(N) + Y(N) BL @MOVROM Nead a floating .5 DATA FHALF into ARG * BL @FMULT Compute .5 * (A/Y(N) + Y(N)) DEC @PZ Decrement loop counter JNE SQR01 Loop three times S @C8,@VSPTR Pop off stack B @EXPSQT To finish up SQR02 MOVB @ERRSQR,@FAC10 Load error code for return ERRSQR EQU $ SQR03 B @ROLIN Restore CPU RAM and return ************************************************************* * COSINE FUNCTION * * FAC : = COS(FAC) * * COS(FAC) : = SIN(FAC + PI/2) * ************************************************************* COSZZ MOV R11,R12 BL @MOVROM Need to get PI/2 DATA PI2 into ARG * BL @FADD Compute FAC + PI/2 MOV R12,R11 And fall into SIN code ******************************************************************************** TITL 'TRINSICS2' ************************************************************* * SINE FUNCTION * * FAC : = SIN(FAC) * * STACK LEVELS USED: * * IF FAC < 0 THEN SIN(FAC) : = -SIN(-FAC) * * X : = 2/PI*FAC * * K : = INT(X) * * R : = X-K, 0 <= R < 1 * * Q : = K MOD 4 * * SO K : = 4*N+Q * * FAC : = PI/2 * K + PI/2 * R * * : = 2*PI*N + PI/2*Q + PI/2*R * * SIN(FAC) : = SIN(P/2*Q+PI/2*R) * * QUADRANT Q Identity * * I 0 SIN(FAC) : = SIN(PI/2*R) * * II 1 SIN(FAC) : = SIN(PI/2+PI/2*R * * : = SIN(PI-*(PI/2+PI/2R)) * * : = SIN(PI/2*(1-R)) * * III 2 SIN(FAC) : = SIN(PI+PI/2*R) * * : = SIN(PI-(PI+PI/2*R)) * * : = SIN(PI/2 * (R-1)) * * IV 3 SIN(FAC) : = SIN(3*PI/2 + PI/2*R * * : = SIN(3*PI/2 + PI/2*R-2*PI) * * : = SIN(PI/2 * (R-1)) * * QUADRANT Q ARGUMENT TO APPROXIMATION POLYNOMIAL * * I 0 R = R 0 <= R < 1 * * II 1 1-R = 1-R 0 < 1-R <= 1 * * III 2 -R = -R -1 < -R <= 0 * * IV 3 R-1 = -(1-R) -1 <= R-1 < 0 * * * * A polynomial approximation is used for SIN(P/2*R) * * -1 <= R < 1 * * (HART SIN 3344) * ************************************************************* SINZZ MOV R11,R10 BL @ROLOUT Get workspace and save return BL @MOVROM Get 2/PI DATA RPI2 into ARG * BL @FMULT X : = 2/PI*FAC MOVB @FAC,R12 Save sign ABS @FAC Consider positive numbers CB @FAC,@CBH44 Check exponent range * by checking with >44 JGT TRIERR ERR in range of exponent BL @PUSH Save X BL @GRINT K : = INT(K) CLR R1 Assume Q is zero CLR R0 MOVB @FAC,R0 Is FAC zero? JEQ SIN02 Yes, Q is zero AI R0,>BA00 Bias exponent (->46 byte) * is K too big for (K MOD 4) * to have a significance? JGT SIN01 Yes, defualt Q to zero AI R0,>51*256 (FAC+7-PAD0)*256 CBH80 EQU $+1 CONSTANT >80 SRL R0,8 AI R0,PAD0 MOVB *R0,@R1LB No, get 10's and 1's place of K CC3 EQU $+2 SIN01 ANDI R1,3 Q : = (K MOD 4) SIN02 MOV R1,@QZ BL @SSUB R : = X-K MOV @QZ,R1 SRL R1,1 Is Q even? MOV R1,@QZ JNC SIN03 Yes BL @MOVROM Get a floating 1 DATA FPOS1 into ARG * BL @FSUB Compute 1-R SIN03 MOV @QZ,R1 Quadrant III or IV? JEQ SIN04 No INV R12 Yes, change sign or result SIN04 BL @POLYW Evaluate it DATA SINP get poly P's coefficients * JMP ATNSGN and set sign TRIERR MOVB @CCBH7,@FAC10 TRIG error (>7 in FAC10) JMP ATNSG3 ************************************************************* * TANGENT FUCTION * * FAC : = TAN(FAC) * * TAN(FAC) : = SIN(FAC)/COS(FAC) * ************************************************************* TANZZ MOV R11,R10 BL @SAVRTN Save return address BL @PUSH Save FAC on stack BL @SINZZ Compute SIN BL @XTFACZ BL @COSZZ Compute COS BL @POPSTK Pop stack into ARG CB @FAC10,@CCBH7 Check for error JEQ PWRTN3 If error MOV @FAC,R0 Is COS = zero? JEQ TAN01 Yes BL @FDIV No, TAN : = SIN(ARG)/COS(ARG) PWRTN3 B @ROLIN2 TAN01 MOVB @ARG,@SIGN BL @OVEXP Issue overflow message JMP PWRTN3 Clean up and exit ************************************************************* * INVERSE TANGENT FUCTION * * FAC : = ATN(FAC) * * STACK LEVELS USED: * * IF FAC < 0 THEN ARCTAN(FAC) = -ARCTAN(-FAC) * * IF 0 <= FAC <= TAN(PI/8) * * THEN T = FAC, ARCTAN(FAC) : = ARCTAN(T) * * IF TAN(PI/8) < FAC < TAN(3*PI/8) * * THEN T = (FAC-1) / (FAC+1), * * ARCTAN(FAC) : = PI/4 + ARCTAN(T) * * IF TAN(3*PI/8) <= FAC * * THEN T = -1/FAC, * * ARCTAN(FAC) : = PI/2 + ARCTAN(T) * * * * A polynomial approximation is used for ARCTAN(T), * * -TAN(PI/8) <= T <= TAN(PI/8) * * (HART ARCTN 4967) * ************************************************************* ATNZZ MOV R11,R10 BL @ROLOUT Get workspace and save return MOVB @FAC,R12 Save sign ABS @FAC Use ABS(FAC) CLR @QZ Assume ARG is in range BL @MOVROM Need TAN(PI/8) DATA TANPI8 into ARG * BL @FCOMPB Is TAN(3*PI/8) >= ARG? JEQ ATN02 If = JGT ATN02 If > BL @MOVROM Need TAN(3*PI/8) DATA TAN3P8 into ARG * BL @FCOMPB Is TAN(3*PI/8) > ARG? JGT ATN01 Yes, use case 2 BL @MOVROM Get a floating 1 DATA FPOS1 into ARG * NEG @ARG Use case 3 to compute BL @FDIV T = -1/ARG LI R3,PI2 Get PI/2 JMP ATN02A Add it in at the end ATN01 BL @FORMA Case 2 : T : = (ARG-1)/(ARG+1) LI R3,PI4 Get PI/4 ATN02A MOV R3,@QZ Set up to evaluate ATN02 BL @POLYW ATN(T) : = T * P(T^^2) DATA ATNP Poly to evlauate * MOV @QZ,R3 Case 1? JEQ ATNSGN Yes, don't add anything in LI R0,ARG BL @MOVRM2 BL @FADD Add in the constant ATNSGN INV R12 Check sign of result JLT ATNSG3 If sign is already on NEG @FAC else negate it ATNSG3 B @ROLIN And return ************************************************************* * GREATEST INTEGER FUNCTION * ************************************************************* GRINT MOV R11,R7 Save return address MOVB @FAC,@SIGN Save result sign ABS @FAC Absolute value MOVB @FAC,R5 Get exponent SRL R5,8 Make it into word MOV R5,@EXP For rounding CI R5,>40 Exponent < 0? JLT BITINT Yes, handle it CI R5,>45 Exponent > 10^5 ? JGT INT02 Yes, handle it AI R5,->46 Locate position MOVB @R5LB,@FAC10 Save for rounding CLR R2 LI R3,FAC8 A R5,R3 Point to 1st fractional digit INT01 SOCB *R3,R2 Remember if non-zero MOVB @R2LB,*R3+ Clear the digit INC R5 JNE INT01 MOVB @SIGN,R0 Get the sign JGT INT03 If non-negative(i.e. Positive) MOVB R2,R2 JEQ INT02 AB @CCBH7,@FAC10 Where to round up BL @ROUNU Do the rounding JMP INT03 INT02 MOVB @SIGN,R0 Check the sign JGT INT03 If positive don't negate NEG @FAC Make result negative INT03 CLR @FAC10 Indicate no error B *R7 <<<< Return from here BITINT LI R0,FAC Zero or -1 LI R1,>BFFF Default to -1 MOVB @SIGN,R2 Negative or Positive? JLT INT04 If really negative put in -1 CLR R1 If Positive put in a 0 INT04 MOV R1,*R0+ Copy in 0 or -1 CLR *R0+ and CLR *R0+ clear CLR *R0 the JMP INT03 rest * MOVE 8 BYTES FROM ROM(R3) TO CPU AT R0 MOVRM5 LI R0,FAC Move to FAC JMP MOVRM1 Merge into common code MOVROM LI R0,ARG Move to ARG MOVRM1 MOV *R11+,R3 Constant to load MOVRM2 LI R2,8 Constants are 8 bytes long A @INTRIN,R3 Add in GROM offset <<<<<<<<<< MOVB R3,@GRMWAX(R13) Write MSB of address SWPB R3 Bare the LSB MOVB R3,@GRMWAX(R13) Write the LSB MOVRM4 MOVB *R13,*R0+ Read a byte DEC R2 Moved them all yet? JNE MOVRM4 No, copy the next one RT Yes, return * ROLL OUT CPU AREA FOR WORKSPACE ROLOUT LI R1,PROAZ Processor roll out area CVROAZ EQU $+2 LI R3,VROAZ VDP roll out area MOVB @R3LB,*R15 ORI R3,WRVDP MOVB R3,*R15 LI R0,26 ROLOT1 MOVB *R1+,@XVDPWD DEC R0 JNE ROLOT1 CLR @FAC8 And save return address * SAVE RETURN ADDRESS SAVRTN INCT @STKADD MOVB @STKADD,R9 SRL R9,8 AI R9,PAD0 MOV R10,*R9 RT * ROLL IN CPU AREA AFTER WORK IS DONE ROLIN LI R1,PROAZ Processor roll out area MOVB @CVROAZ+1,*R15 LSB of address MOVB @CVROAZ,*R15 MSB of address LI R0,26 Number of bytes rolled out ROLIN1 MOVB @XVDPRD,*R1+ DEC R0 JNE ROLIN1 CLR @FAC8 ROLIN2 MOVB @STKADD,R9 SRL R9,8 AI R9,PAD0 MOV *R9,R11 DECT @STKADD RT * PUSH FAC ONTO STAK C8 EQU $+2 PUSH LI R0,8 Number to push A R0,@VSPTR Bump stack pointer MOV @VSPTR,R1 Get stack poiter MOVB @R1LB,*R15 ORI R1,WRVDP MOVB R1,*R15 LI R1,FAC PUSH1 MOVB *R1+,@XVDPWD DEC R0 JGT PUSH1 RT * POP VALUE OFF STACK INTO FAC POP LI R2,FAC MOVB @VSPTR1,*R15 LSB of address LI R0,8 MOVB @VSPTR,*R15 MSB of address S R0,@VSPTR POP1 MOVB @XVDPRD,*R2+ DEC R0 JGT POP1 RT * EXCHANGE TOP OF STACK AND FAC XTFACZ MOV R11,R10 Save return address BL @PUSH Put FAC on top LI R3,8 Working with 8 byte entries MOV R3,R5 Need another copy for below S R3,@VSPTR Point back to old top BL @POP Put it in FAC A R3,@VSPTR Restore pointer to old top MOV @VSPTR,R4 Place to move to A R4,R3 Place to move from XTFAC1 BL @GETV1 Get a byte BL @PUTV1 Put a byte INC R3 INC R4 DEC R5 Done? JNE XTFAC1 No B *R10 Yes, retrun * GET BASE 10 EXPONENT OF THE NUMBER IN FAC * EXP: Gets the base 10 exponent * OEZ: 0 if exp is even and 1 if exp is odd TENCNS CLR R0 Get base 100 exponent MOVB @FAC,R0 Put in MSB AI R0,>C000 Remove bias (SUBT >64 from MSB) SLA R0,1 Multiply it by 2 SRA R0,8 Sign fill high order byte CLR R3 and put in LSB CB @FAC1,@CBHA 1st digit of FAC one decimal * digit? JLT CNST10 Yes, base 10 exponent is even INC R0 No, take this into account in * exponent INC R3 This makes base 10 exp odd CNST10 MOV R0,@EXP MOV R3,R3 Set condition for return RT ************************************************************* * MISCELLANEOUS CONSTANTS: * CBH411 * EXC127 BYTE >41,1,27,0,0,0,0,0 127 * FHALF BYTE >3F,50 .5 * ZER3 BYTE 0,0,0,0,0,0 * SQRTEN BYTE >40,3,16,22,77,66,01,69 SQR(10) * LOG10E BYTE >3F,43,42,94,48,19,03,25 LOG10(E) * LN10 BYTE >40,2,30,25,85,09,29,94 LN(10) * CBH7 EQU $+3 * PI2 BYTE >40,1,57,7,96,32,67,95 PI/2 * RPI2 BYTE >3F,63,66,19,77,23,67,58 2/PI * PI4 BYTE >3F,78,53,98,16,33,97,45 PI/4 * CBHA EQU $+7 * CBH3F * TANPI8 BYTE >3F,41,42,13,56,23,73,10 TAN(PI/8)=SQR(2)-1 * TAN3P8 BYTE >40,2,41,42,13,56,23,73 TAN(3*PI/8)=SQR(2)+1 ** SQR POLYNOMIALS (HART SQRT 0231) * SQRP BYTE >3F,58,81,22,90,00,00,00 P02=.58812 29E+00 * BYTE >3F,52,67,87,50,00,00,00 P01=.52678 75E+00 * BYTE >3E,58,81,20,00,00,00,00 P00=.58812 E-02 * DATA SGNBIT * FLTONE * FPOS1 * SQRQ BYTE >40,01,00,00,00,00,00,00 Q01=.1 E+01 * BYTE >3F,09,99,99,80,00,00,00 Q00=.99999 8 E-01 * DATA SGNBIT ** EXPPONENT POLYNOMIALS (HART EXPD 1444) ** P02 = .18312 36015 92753 84761 54 E+02 * EXPP BYTE >40,18,31,23,60,15,92,75 ** P01 = .83140 67212 93711 03487 3446 E+03 * BYTE >41,08,31,40,67,21,29,37 * P00 = .51780 91991 51615 35743 91297 E+04 * BYTE >41,51,78,09,19,91,51,62 * DATA SGNBIT ** Q03 = .1 E+01 * EXPQ BYTE >40,1,0,0,0,0,0,0 ** Q02 = .15937 41523 60306 52437 552 E+03 * BYTE >41,01,59,37,41,52,36,03 ** Q01 = .27093 16940 85158 99126 11636 E+04 * BYTE >41,27,09,31,69,40,85,16 ** Q00 = .44976 33557 40578 41762 54723 E+04 * BYTE >41,44,97,63,35,57,40,58 * DATA SGNBIT ** LOG POLYNOMIALS (HART LOGE 2687) ** P04 = .35670 51030 88437 69 E+00 * LOGP BYTE >3F,35,67,05,10,30,88,44 ** P03 = -.11983 03331 36876 1464 E+02 * BYTE >BF,>F5,98,30,33,31,36,88 ** P02 = .63775 48228 86166 05782 E+02 * BYTE >40,63,77,54,82,28,86,17 ** P01 = -.10883 71223 55838 3228 E+03 * BYTE >BE,>FF,08,83,71,22,35,58 ** P00 = .57947 38138 44442 78265 7 E+02 * BYTE >40,57,94,73,81,38,44,44 * DATA SGNBIT * LOGQ ** Q04 = .1 E+01 * BYTE >40,01,0,0,0,0,0,0 ** Q03 = -.13132 59772 88464 0339 E+02 * BYTE >BF,>F3,13,25,97,72,88,46 ** Q02 = .47451 82236 02606 00365 E+02 * BYTE >40,47,45,18,22,36,02,61 ** Q01 = -.64076 45807 52556 00596 E+02 * BYTE >BF,>C0,07,64,58,07,52,56 ** Q00 = .28973 69069 22217 71601 9 E+02 * BYTE >40,28,97,36,90,69,22,22 * DATA SGNBIT ** SIN POLYNOMIAL (HART SIN 3344) * SINP ** REFLECTS CHANGE IN 99/4 CONSTANT TO CORRECT VALUES ** OF SIN AND COS >1 ** P07 = -.64462 13674 9 E-09 ** BYTE >C4,>FA,44,62,13,67,49,00 ** P07 = -.64473 16000 0 E-09 * BYTE >C4,>FA,44,73,16,00,00,00 ** P06 = .56882 03332 688 E-07 * CBH44 EQU $+2 * BYTE >3C,05,68,82,03,33,26,88 ** P05 = -.35988 09117 03133 E-05 * BYTE >C2,>FD,59,88,09,11,70,31 ** P04 = .16044 11684 69828 31 E-03 * BYTE >3E,01,60,44,11,68,46,98 ** P03 = -.46817 54131 06023 168 E-02 * BYTE >C1,>D2,81,75,41,31,06,02 ** P02 = .79692 62624 56180 0806 E-01 * BYTE >3F,07,96,92,62,62,45,62 ** P01 = -.64596 40975 06219 07082 E+00 * BYTE >C0,>C0,59,64,09,75,06,22 ** P00 = .15707 96323 79489 63959 E+01 * BYTE >40,01,57,07,96,32,67,95 * DATA SGNBIT ** ATN POLYNOMIAL (HART ARCTN 4967) * ATNP ** P09 = -.25357 18798 82 E-01 * BYTE >C0,>FE,53,57,18,79,88,20 ** P08 = .50279 13843 885 E-01 * BYTE >3F,05,02,79,13,84,38,85 ** P07 = -.65069 99940 1396 E-01 * BYTE >C0,>FA,50,69,99,94,01,40 ** P06 = .76737 12439 1641 E-01 * BYTE >3F,07,67,37,12,43,91,64 ** P05 = -.90895 47919 67196 E-01 * BYTE >C0,>F7,08,95,47,91,96,72 ** P04 = .11111 04992 50526 62 E+00 * BYTE >3F,11,11,10,49,92,50,53 ** P03 = -.14285 71269 75961 157 E+00 * BYTE >C0,>F2,28,57,12,69,75,96 ** P02 = .19999 99997 89961 5228 E+00 * BYTE >3F,19,99,99,99,97,89,96 ** P01 = -.33333 33333 32253 4275 E+00 * BYTE >C0,>DF,33,33,33,33,32,25 ** P00 = .99999 99999 99999 08253 E+00 * BYTE >40,01,0,0,0,0,0,0 * DATA SGNBIT ******************************************************************************** AORG >7B88 TITL 'CRUNCHS' QUOTE EQU >22 COMMA EQU >2C LISTZ EQU >02 OLDZ EQU >05 SAVEZ EQU >07 MERGEZ EQU >08 RETURZ EQU >88 UNBRKZ EQU >8F DATAZ EQU >93 RESTOZ EQU >94 REMZ EQU >9A CALLZ EQU >9D IMAGEZ EQU >A3 RUNZ EQU >A9 COLONZ EQU >B5 QUOTEZ EQU >C7 UNQSTZ EQU >C8 USINGZ EQU >ED MAXKEY EQU 10 * * CRUNCH copies a line (normally in LINBUF) to CRNBUF in the * process, it turns the line number (if any) binary, and * converts all reserved words to tokens. CALL is a GPL XML * followed by a single byte which indicates the type of * crunch to be done. Possible types include: * >00 - Normal crunch * >01 - crunch as a data statement (input stmt) * REGISGERS: * R0 - R1 Scratch * R2 - R3 Scratch * R4 Points to R8LB * R5 Points to length byte of string/numeric * R6 Indicates numeric copy mode (numeric/line #) * R7 Mode of copy (strings, names, REMs, etc) * R8 Character buffer * R9 Points to name during keyword scan * R11 - R12 Links * R13 GROM read data pointer * R15 VDP write address pointer * CRUNCH MOV R11,R12 Save return link MOVB *R13,R3 Read call code BL @PUTSTK Save GROM address CLR @FAC Assume no line number LI R4,R8LB Set up W/S low-byte pointer CLR R8 Initialize character buffer BL @GETNB Scan line for 1st good char MOVB R1,*R4 Save character JEQ CRU28 If empty line, return * Now check crunch call mode, normal or input statement SRL R3,8 Normal curnch call? JEQ CRU01 Yes, crunch the statement * Initialize for input statement crunch LI R2,CRU84 No, must be crunch input stmt LI R10,CRU83 so set up move indicators LI R7,CRU80 JMP CRU10 And jump into it * Initialize for normal line crunch CRU01 INC @BUFLEV Indicate CRNBUF is destroyed CLR @ARG4 Assume no symbol MOVB R8,@PRGFLG Clear program flag BL @GETINT Try to read a line number MOV R0,@FAC Put line number into final JEQ CRU02 If no line number BL @GETNB Skip all leading spaces MOVB R1,*R4 Save character in R8LB JEQ CRU28 If nothing left in line CRU02 LI R7,CRU16 Set normal scan move LI R6,CRU96 Set normal numeric scan mode JMP CRU10 Merge into normal scan code * Main loop of the input copy routine. Sets R8LB to next * character, R0 to its character property byte * R7 indicates dispatch mode. CRU04 LI R6,CRU96 Set normal numeric mode CRU05 LI R7,CRU16 Set normal scan mode CRU06 BL @PUTCHR Copy into crunch buffer CRU08 BL @GETCHR Get next input character CLR R0 Assume nil property MOVB R1,*R4 Copy to crunch buffer JEQ CRU12 Finish up if we reach a null *-----------------------------------------------------------* * Replace following line for adding lowercase character * * set to 99/4A 5/12/81 * * * CRU10 MOVB @CPTBL(R8),R0 Fetch char's prop table vec * CRU10 CB *R4,@ENDPRO Higher then "z" * JHE CRU09 Yes, give CPNIL property * MOVB @CPTBL(R8),R0 Fetch char's prop table value * B *R7 Dispatch to appropriate code * CRU09 MOVB CPNIL,R0 Don't go to CPT, just take * * CPNIL prop * *-----------------------------------------------------------* CRU12 B *R7 Dispatch to appropriate code CRU14 MOV R8,R8 End of line? JNE CRU06 Not yet CRU15 MOV @RAMPTR,R3 Now check for trailing spaces DEC R3 Backup to read last character BL @GETV1 Go read it CB R1,@CBH20 Last character a space? JNE CRU28 No, so end of line, exit DEC @RAMPTR Yes, backup pointer to delete JMP CRU15 And test new last character *-----------------------------------------------------------* * The following two lines are added for adding lowercase * * character set for 99/4A 5/13/81 * ENDPRO BYTE >7B ASCII code for char after "z" * EVEN * *-----------------------------------------------------------* * * Normal scan mode -- figures out what to do with this char CRU16 MOVB *R4,*R4 At end of line? JEQ CRU28 Yes, clean up and return MOVB R0,R0 Set condition on char prop JLT CRU08 Ignore separators (spaces) MOV @RAMPTR,R9 Save crunch pointer SLA R0,2 Scan property bits 1 and 2 JOC CRU32 Break chars are 1 char tokens JLT CRU18 Alpha, prepare to pack name SLA R0,2 Scan property bits 3 and 4 JNC CRU20 Jump if not multi-char oper BL @GETCHR Check next char to see if we SRL R1,8 have a 2 char operator JEQ CRU32 If read end of line-single oper BL @BACKUP Backup read pointer CB @CPTBL(R1),@LBCPMO Next char also a multi-oper? JNE CRU32 No, want single-char oper BL @PUTCHR Copy in first char to oper JMP CRU36 And scan keyword table * Set name copy mode CRU18 LI R7,CRU76 Alphabetic: set name copy mode *-----------------------------------------------------------* * Insert following 2 lines for adding lowercase character * * set in 99/4A 5/12/81 * SRL R0,2 Adjust R0 for LOWUP routine * BL @LOWUP Translate lowercase to upper * * if necessary * *-----------------------------------------------------------* JMP CRU06 And resume copy * Handle single character operators CRU20 JLT CRU32 Bit 4: single character oper SLA R0,2 Scan property bits 5 and 6 JOC CRU24 If numeric JLT CRU26 If digit only CI R8,QUOTE Is it a string quote? JNE ERRIVN No, unknown char so error MOV R7,R10 Yes, save current mode CRU22 LI R8,QUOTEZ Convert char to quote token BL @PUTCHR Put in token LI R7,CRU68 Set string, copy mode MOV @RAMPTR,R5 Save pointer to length byte JMP CRU06 Continue copy w/quote token CRU24 CI R8,'.' A decimal point JNE CRU26 No, decode as numeric/line # LI R6,CRU96 Yes, decode as numeric CRU26 B *R6 Handle numeric or line # BERRSY B @CERSYN Long distance SYNTAX ERROR CRU27 BL @PUTCHR Put out last char before end INC @VARW Skip last character * Here for successful completion of scan CRU28 SWPB R8 Mark end of line with a null BL @PUTCHR Put the end of line in CRNADD EQU $+2 LI R0,CRNBUF Get start of crunch buffer NEG R0 Negate for backwards add A @RAMPTR,R0 Calculate line length MOVB @R0LB,@CHAT Save length for GPL BL @GETSTK Restore GROM address B *R12 Return with pointer beyond null * Keyword table scanning routine. Name has already been * copied into crunch area starting at R9; RAMPTR point just * beyond name in input line. * R3 is name length, R1 indexes into the table CRU32 BL @BACKUP Fix pointer for copy(next line) CRU36 BL @GETCHR Read last character MOVB R1,*R4 Put into output buffer BL @PUTCHR Copy into crunch buffer CRU38 MOV @RAMPTR,R3 Get end pointer S R9,R3 Sub start to get length of name CI R3,MAXKEY Is longer than any keyword? JH CRU61 Yes, can't be a keyword MOV R3,R2 Get name length and DEC R2 corremt 0 length name indexing SLA R2,1 Turn it into an index AI R2,KEYTAB Add in address of table list MOVB R2,@GRMWAX(R13) Load address to GROM SWPB R2 MOVB R2,@GRMWAX(R13) MOVB *R13,R2 Read address of correct table MOVB *R13,@R2LB Both bytes * R2 now contains the address of the correct table CRU40 MOVB R2,@GRMWAX(R13) Load address of table MOV R3,R0 Copy of length for compare MOVB @R2LB,@GRMWAX(R13) MOVB @R9LB,*R15 Source is in VDP A R3,R2 Address of next keyword in table MOVB R9,*R15 INC R2 Skip token value CRU42 CB @XVDPRD,*R13 Compare the character JL CRU61A If no match possible JNE CRU40 No match, but match possible DEC R0 Compared all? JNE CRU42 No, check next one MOV R9,@RAMPTR Name matched so throw out name MOVB *R13,*R4 Read the token value CLR @ARG4 Indicate keyword found * Check for specially crunched statements LI R7,CRU14 Assume a REM statement LI R0,SPECTB-1 Now check for special cases *********************************************************** < * For GRAM KRACKER XB or RichGKXB or SXB substitute with: * < * CI R8,>000B * < *********************************************************** < * CI R8,MERGEZ Is this a command? < CI R8,>000B For COPY, MOVE and DEL JH CRU47 No, continue on MOV @FAC,R3 Yes, attempt to put in program? JNE ERRCIP Yes, *COMMAND ILLEGAL IN PROGRAM* CI R9,CRNBUF Command 1st token in line? JNE BERRSY No, *SYNTAX ERROR* CRU47 INC R0 Skip offset value CB *R4,*R0+ In special table? JEQ CRU53A Yes, handle it JH CRU47 If still possible match *********************************************************** < * For GRAM KRACKER XB or RichGKXB or SXB substitute with: * < * CI R8,>000C * < *********************************************************** < * CI R8,MERGEZ A specially scanned command? < CI R8,>000C For COPY, MOVE and DEL JL CRU27 Yes, exit crunch LI R0,LNTAB Now check for line number CRU48 CB *R4,*R0+ In table? JEQ CRU52 Yes, change to line # crunch JH CRU48 May still be in table CI R8,COMMAZ Just crunch a comma? JEQ CRU50 Yes, so retain current numeric CI R8,TOZ Just crunch a TO? JNE CRU53 No, so reset to normal numeric CRU50 B @CRU05 Yes, resume normal copy CRU52 LI R6,CRU100 Set line number scan mode JMP CRU50 Set normal scan mode ERRIVN INC @ERRCOD *ILLEGAL VARIABLE NAME ERRCIP INC @ERRCOD *COMMAND ILLEGAL IN PROGRAM ERRNQT INC @ERRCOD *NONTERMINATED QUOTED STING CBH20 EQU $+1 ERRNTL A @C4,@ERRCOD *NAME TO LONG JMP CRU28 Exit back to GPL OFFSET EQU $ CRU53 B @CRU04 Stmt sep resets to normal scan CRU53A MOVB *R0,R1 Pick up offset from table SRL R1,8 Make into offset B @OFFSET(R1) Goto special case handler * Process a LIST statement CRU57 BL @PUTCHR Put the list token in BL @GETNB Get next character CI R1,QUOTE*256 Device name available? JNE CRU28 No, no more to crunch, exit LI R10,CRU106 Yes, set after string scan mode B @CRU22 Crunch the device name * Process an IMAGE statement CRU54 LI R10,CRU83B Image after, string copy mode JMP CRU59 Handle similar to data stmt * Process a DATA statement CRU58 LI R10,CRU83 After-datum skip spaces CRU59 C @RAMPTR,@CRNADD Image & data must be 1st on line JNE JNESY1 If not, error LI R2,CRU84 (non)quote string copy mode CRU60 LI R7,CRU80 Now set check-for-quote mode CRU74 B @CRU06 And copyin statement token * Here when don't find something in the keyword table CRU61 CI R3,15 Is it longer than name can be? JH ERRNTL Yes, name to long CRU61A MOV @ARG4,R0 Symbol name last time too? JNE JNESY1 Yes, can't have 2 in a row DEC @ARG4 Indicate symbol noe CRU62 LI R7,CRU16 No keyword,; leave in CRNBUF LI R6,CRU96 Assume normal numeric scan CRU64 B @CRU08 And continue to scan line * Process a SUB statement CRU65 MOV @RAMPTR,R3 Get the current crunch pointer DEC R3 Point at last character put in BL @GETV1 Read it CB R1,@GOZTOK Was it a GO? JEQ CRU52 Yes, SUB is part of GO SUB * Process a CALL SUB statement CRU66 LI R7,CRU93 Set name copy JMP CRU74 And get next character CRU32L B @CRU32 * Now the various mode copy routines; string, names, image, * and data statements CRU68 MOV R8,R8 Premature end of line? JEQ ERRNQT Yes, *NONTERMINATED QUOTED STRING CI R8,QUOTE Reach end of string? JNE CRU74 No, continue copying BL @GETCHR Get next character MOVB R1,R1 Read end of line? JEQ CRU70 Yes, can't be double quote CI R1,QUOTE*256 Is it two quotes in a row? JEQ CRU74 Yes, copy in a normal quote BL @BACKUP No, backup & rtn to normal scan CRU70 MOV R10,R7 Needed for image/data stmts CRU72 BL @LENGTH Calculate length of string JMP CRU64 Resume scan * Names *-----------------------------------------------------------* * Replace following two lines for adding lowercase * * character set in 99/4A 5/12/81 * * CRU76 ANDI R0,CPALNM*256 Is this char alpha or digit * * JEQ CRU74 Yes, continue packing * CRU76 ANDI R0,CPULNM*256 Is this char alpha (both are * * upper and lower) or a digit? * JNE CRU78 Yes, continue packing * *-----------------------------------------------------------* * No, finish w/name packing CI R8,'$' Does name end with a $? JEQ CRU32L Yes, include it in name MOVB *R4,*R4 At an end of line? JEQ CRU79 Yes, don't back up pointer BL @BACKUP Backup for next char CRU79 B @CRU38 Jump to name/keyword check CRU82 B @CRU22 *-----------------------------------------------------------* * Add following 2 lines for adding lowercase character set * * for 99/4A 5/12/81 * CRU78 BL @LOWUP Translate lower to upper if * * necessary * JMP CRU74 Continue packing * *-----------------------------------------------------------* * DATA: Scan spaces after a quoted string datum CRU83 CI R8,COMMA Hit a comma? JEQ CRU85A Yes, get back into scan * IMAGE: Scan spaces after a quoted string datum CRU83B MOVB R0,R0 At a space? JLT CRU64 Yes, ignore it MOV R8,R8 At end of line? JEQ CRU62 Yes, exit scan JNESY1 JMP JNESYN No, unknown character * DATA: Scan imbedded blanks and check trailing blanks CRU83A MOV @VARW,@ARG2 Save input pointer BL @GETNB Look for next non-blank MOVB R1,R1 At end of line? JEQ CRU92 Yes, end string and exit CI R10,CRU83B Scanning an image? JEQ CRU83C Yes, commas are not significant CI R1,COMMA*256 Hit a comma? JEQ CRU85 Yes, ignore trailing spaces CRU83C MOV @ARG2,@VARW No, restore input pointer JMP CRU74 and include imbedded space * DATA: Scan unquoted strings CRU84 JLT CRU83A If hit a space-end of string MOV R8,R8 At end-of-line? JEQ CRU92 Yes, put in length and exit CI R8,COMMA Reached a comma? JNE CRU74 No, scan unquoted string CI R10,CRU83B Scanning an IMAGE stmt? JEQ CRU74 Commas are not significant CRU85 BL @LENGTH Yes, end the string CRU85A LI R8,COMMAZ Load a comma token INC @VAR5 Count comma for input stmt JMP CRU60 And resume in string mode * IMAGE/DATA: Check for leading quote mark CRU80 JLT CRU64 Ignore leading separators CI R8,QUOTE Quotoed string? JEQ CRU82 Yes, like any string, R10 ok MOV R8,R8 End of line? JEQ BCRU28 Yes, end it CI R10,CRU83B Scanning an IMAGE? JEQ CRU88 Yes, ignore commas CI R8,COMMA At a comma? JEQ CRU85A Yes, put it in directly CRU88 MOV R2,R7 No, set unquote string copy mode * IMAGE & DATA: Scan unquoted strings CRU86 LI R8,UNQSTZ Load unquoted string token BL @PUTCHR Put the token in MOV @RAMPTR,R5 Save current crunch pointer BL @BACKUP Back up to scan again CRU87 JMP CRU74 Resume scan * CALL and SUB statements *-----------------------------------------------------------* * Replace following 2 lines for adding lowercase character * * set for 99/4A 5/12/81 * * CRU94 ANDI R0,CPALNM*256 Still an alpha-numeric * * JNE CRU74 Yes, include in name * CRU94 ANDI R0,CPULNM*256 Still an alpha(U & L)-numeric * JNE CRU91 Yes, transfer L to U, then * * include in name * *-----------------------------------------------------------* MOV R8,R8 At end of line? JEQ CRU92 Yes, get out now CRU90 BL @BACKUP No, reset read pointer CRU92 LI R7,CRU16 Normal scanning mode JMP CRU72 Calculate & put in string length *-----------------------------------------------------------* * Add following lines for adding lowercase character set * * for 99/4A 5/12/81 * CRU91 BL @LOWUP Transfer lowercase char to * * uppercase char if necessary * B @CRU74 Include in name * *-----------------------------------------------------------* * CALL and SUB statements before hit name CRU93 JLT CRU64 If a space, ignore it MOV R0,R0 Premature EOL or NIL char, prop? JEQ CERSYN Yes, *SYNTAX ERROR *-----------------------------------------------------------* * Replace following line for adding lowercase character set * * for 99/4A 5/12/81 * * ANDI R0,CPALPH*256 An alphabetic to start name?* ANDI R0,CPUL*256 An alphabetic (both U & L) to * * start name? * *-----------------------------------------------------------* JEQ CERSYN No, syntax error LI R7,CRU94 Set up to copy name JMP CRU86 Put in the unqst token * Numerics CRU96 LI R7,CRU98 Set after-initialize scan CLR @ARG Clear the 'E' flag JMP CRU86 Set up for the numeric CRU98 MOV R8,R8 At end of line? JEQ CRU92 Yes end the number SLA R0,2 Scan property bit 2 JLT CRU99A If alpha, might ge 'E' SLA R0,3 Scan property bits 4 and 5 JNC CRU99 Bit 4=oper, if not oper, jmp MOV @ARG,R0 If operator, follow an 'E'? CRU99 CLR @ARG Previous char no longer an 'E' JLT CRU87 If still numeric JMP CRU90 No longer numeric CRU99A CI R8,'E' 'E' to indicate an exponent? JNE CRU90 No, so end the numeric MOV @ARG,R0 An 'E' already encountered? JNESYN JNE CERSYN Yes, so error SETO @ARG No, indicated 1 encountered now JMP CRU87 And include it in the number * Line numbers CRU100 MOV R8,R8 At end of line? JEQ BCRU28 Yes, exit crunch BL @GETINT Try to get a line number MOV R0,R0 Get a line number? JEQ CRU105 No, back to normal numeric mode LI R8,LNZ Load a line number token BL @PUTCHR Put it out MOV R0,R8 Set up to put out binary # SWPB R8 Swap to put MSB of # 1st BL @PUTCHR Put out 1st byte of line # SRL R8,8 Bare the 2nd byte of line # JMP CRU87 Jump back into it CRU105 B @CRU04 Back to normal numeric mode * Handle a list statement CRU106 JLT CRU93 If space, ignore it MOV R8,R8 At end of line? JEQ BCRU28 Yes, exit crunch CI R8,':' Get a colon? JNE CERSYN No, *SYNTAX ERROR LI R8,COLONZ Need to put colon in B @CRU27 And exit crunch * Error handling routine ERRLTL INC @ERRCOD * LINE TO LONG 3 DECT @RAMPTR Backup so can exit to GPL ERRBLN INC @ERRCOD * BAD LINE NUMBER 2 CERSYN INC @ERRCOD * SYNTAX ERROR 1 BCRU28 B @CRU28 Exit back to GPL * Back up pointer in input line to rescan last character BACKUP DEC @VARW Back up the pointer MOVB @VARW1,*R15 Write LSB of address NOP MOVB @VARW,*R15 Write MSB of address LI R0,>7F00 >7F is an edge character <<<<<<<<<< SB @XVDPRD,R0 At an edge chracter? JEQ BACKUP Yes, back up one more RT And return to caller * Put a character into the crunch buffer PUTCHR MOV @RAMPTR,R1 Fetch the current pointer CI R1,CRNEND At end of buffer? JH ERRLTL Yes, LINE TO LONG MOVB @R1LB,*R15 Put out LSB of address ORI R1,WRVDP Enable VDP write MOVB R1,*R15 Put out MSB of address INC @RAMPTR Increment the pointer MOVB *R4,@XVDPWD Write out the byte RT And return *-----------------------------------------------------------* * Move LENGTH to GETNB, becuase CRUNCH is running out of * * space, 1/21/81 * * Calculate and put length of string/number into length * * byte * * LENGTH MOV R11,R3 Save return address * * MOV @RAMPTR,R0 Save current crunch pointer * * MOV R0,R8 Put into R8 for PUTCHR below* * S R5,R8 Calculate length of string * * DEC R8 RAMPTR is post-incremented * * MOV R5,@RAMPTR Address of length byte * * BL @PUTCHR Put the length in * * MOV R0,@RAMPTR Restore crunch pointer * * B *R3 And return * *-----------------------------------------------------------* * * Get a small non-negative integer * CALL: VARW - TEXT POINTER, points to second character * R8 - First character in low byte * BL @GETINT * R0 - NUMBER * VARW - Text pointer, if there is a number, points to * character after number. If there is not a * number, unchanged. * R8 - 0 in high byte * DESTROYS: R1, R2 GETINT MOV R11,R3 Save return address MOV R8,R0 Get possible digit LI R2,10 Get radix in register for speed AI R0,-'0' Convert from ASCII to binary C R0,R2 Is the character a digit? JL GETI02 Yes, there is a number! CLR R0 No, indicate no number B *R3 Done, no number GETI01 MPY R2,R0 Multiply previous by radix MOV R0,R0 Overflow? JNE ERRBLN Yes, bad line number MOV R1,R0 Get low order word of product A R8,R0 Add in next digit JLT ERRBLN If number went negative, error GETI02 BL @GETCHR Get next character MOVB R1,*R4 Put into normal position JEQ GETI03 If read end of line AI R8,-'0' Convert from ASCII to binary C R8,R2 Is this character a digit? JL GETI01 Yes, try to pack it in DEC @VARW No point to 1st char after number GETI03 CLR R8 Clean up our mess MOV R0,R0 Hit a natural zero? JEQ ERRBLN Yes, its an error B *R3 And return * The LINE NUMER TABLE * All tokens which appear in the table must have numerics * which follow them crunched as line numbers. LNTAB BYTE ELSEZ GOZTOK BYTE GOZ <<<<<<<<<< BYTE GOTOZ BYTE GOSUBZ BYTE RETURZ BYTE BREAKZ BYTE UNBRKZ BYTE RESTOZ BYTE ERRORZ BYTE RUNZ BYTE THENZ BYTE USINGZ BYTE >FF Indicate end of table EVEN ************************************************************* * Table of specially crunched statements * * 2 bytes - special token * * Byte 1 - token value * * Byte 2 - "address" of special handler * * Offset from label OFFSET in this assembly of * * the special case handler * ************************************************************* SPECTB BYTE LISTZ,CRU57-OFFSET BYTE OLDZ,CRU58-OFFSET BYTE SAVEZ,CRU58-OFFSET BYTE MERGEZ,CRU58-OFFSET BYTE SSEPZ,CRU53-OFFSET BYTE TREMZ,CRU74-OFFSET BYTE DATAZ,CRU58-OFFSET BYTE REMZ,CRU74-OFFSET BYTE CALLZ,CRU66-OFFSET BYTE SUBZ,CRU65-OFFSET BYTE IMAGEZ,CRU54-OFFSET BYTE >FF EVEN * * TRANSFER LOWERCASE CHARACTER TO UPPERCASE CHARACTER * R0 - Last digit indicates whether this character is a * lowercase character LOWUP ANDI R0,CPLOW*256 Is lowercase prop set? JEQ LU01 No, just return SB @CBH20,*R4 Change lower to upper LU01 RT AORG >7FFE DATA >C68C ******************************************************************************** END