******************************************************************************** TITL 'CONTROL BLOCK 0' CNS EQU >7016 * GROM ADDRESS'S PWRZZ EQU >7492 * LOGZZ EQU >76C2 * EXPZZ EQU >75CA * SQRZZ EQU >783A * COSZZ EQU >78B2 * SINZZ EQU >78C0 * TANZZ EQU >7940 * ATNZZ EQU >797C * GRINT EQU >79EC * ROLOUT EQU >7A90 * ROLIN EQU >7AC4 * CRUNCH EQU >7B88 * PUTCHR EQU >7F6E * * * NOTE RXB CHANGE: All lables with $ changed to Z * LPAR$ is now LPARZ or WARN$$ is now WARNZZ * this was to use same names as GPL source * ******************************************************************************** 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 CZ's string) * * * * A$-------"HELLO" (copy from BZ'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 'FORNEXTS' ************************************************************* * FOR statement * * Builds up a stack entry for the FOR statement. Checks the * * syntax of a FOR statement and also checks to see if the * * loop is executed at all. The loop is not executed if the * * limit of the FOR is > then initial value and the step is * * positive of the limit of the FOR is < then initial value * * and the step is negative. * * * * A stack entry for a 'FOR' statement looks like: * * * * +-------------------------------------------------------+ * * | PTR TO S.T. | >67 | | Value Space | BUFLEV | * * | ENTRY | | | Pointer | | * * | ------------------------------------------------------| * * | FOR line # | FOR line | | * * | table ptr | pointer | | * * |-------------------------------------------------------| * * | Increment Value | * * |-------------------------------------------------------| * * | Limit | * * +-------------------------------------------------------+ * ************************************************************* NFOR MOVB R8,R8 EOL? JGT NFOR1 If symbol name, ok JMP ERRCDT If EOL or Token, error NFOR1 BL @SYM Get pointer to s.t. entry BL @GETV Get 1st byte of symbol DATA FAC entry * ANDI R1,>C700 Check string, function & array JNE BERMUW If andy of the above, error CI R8,EQZ*256 Must have '=' JNE ERRCDT If not, error BL @SMB Get index's value space CLR @FAC2 Dummy entry ID on the stack MOV @BUFLEV,@FAC6 Save buffer level * * Search stack for another FOR entry with the same loop * variable. If one is found, remove it. * MOV @VSPTR,R3 Copy stack pointer * * See if end of stack NFOR1A C R3,@STVSPT Check stack underflow JLE NFOR1E Finished with stack scan * See if FOR entry BL @GET1 Get pointer to s.t. entry MOV R1,R0 Move it to use later MOVB @XVDPRD,R1 Read stack ID CB R1,@CBH67 Is stack entry a FOR? JNE NFOR1B No, 8 byte regular entry * Compare loop variables C R0,@FAC Loop variables match? JEQ NFOR1C Yes AI R3,-32 Skip this FOR entry JMP NFOR1A Loop NFOR1B CB R1,@CCBH6A Hit a subprogram entry? JEQ NFOR1E Yes, don't scan anymore AI R3,-8 Skip 8 byte stack entry JMP NFOR1A Loop * Found matching loop variable, move stack down 32 bytes NFOR1C MOV @VSPTR,R2 Copy stack pointer S R3,R2 Calculate # of bytes to move JEQ NFOR1D 0 bytes, skip move MOV R3,R4 Destination pointer AI R4,-24 Place to move to C8 EQU $+2 AI R3,8 Point at entry above FOR entry NFOR1F BL @GETV1 Get the byte BL @PUTV1 Put the byte INC R3 Inc From pointer INC R4 Inc To pointer DEC R2 Decrement counter JNE NFOR1F Loop if not done NFOR1D S @C32,@VSPTR Adjust top of stack * Now put new FOR entry on stack NFOR1E BL @VPUSH Reserve space for limit BL @VPUSH increment, BL @VPUSH and 2nd info entry MOVB @CBH67,@FAC2 FOR ID on stack BL @PGMCHR Get next character BL @PSHPRS Push symbol I.D. entry BYTE TOZ Parse the initial value CCBH63 BYTE >63 Wasted byte (CBH63) CI R8,TOZ*256 TO? JNE ERRCDT No, error BL @PGMCHR BL @PSHPRS Push initial and get limit BYTE STEPZ CCBH6A BYTE >6A Wasted byte (CBA6A) CB @CCBH63,@FAC2 If a string value JL BERR6 Its an error S @C40,@VSPTR BL @VPUSH Push the limit BL @EOSTMT At the end of statement? JEQ NFOR2 Yes, default incr to 1 CI R8,STEPZ*256 STEP? JNE ERRCDT No, Its an error A @C32,@VSPTR Corrrect stack pointer BL @PGMCHR BL @PARSE Get the increment BYTE TREMZ,0 S @C32,@VSPTR Get stack to needed place MOV @FAC,R0 Can't have zero increment JEQ ERRBV2 If 0, its an error CB @CCBH63,@FAC2 Can't have zero increment JHE NFOR3 If numeric, ok BERR6 B @ERRT * STRING NUMBER MISMATCH BERMUW B @ERRMUV * MULTIPLY USED VARIABLE ERRBV2 B @GOTO90 ERRCDT B @ERRSYN NFOR2 LI R0,FAC MOV @FLTONE,*R0+ Put a floating one in CLR *R0+ CLR *R0+ CLR *R0 NFOR3 BL @VPUSH Push the step LI R1,FAC Optimize to save bytes MOV @EXTRAM,*R1+ Save line # pointer MOV @PGMPTR,*R1 Save ptr w/in the line DEC *R1 Back up so get last character BL @VPUSH Push it too! A @H16,@VSPTR Point to initial value BL @VPOP Get initial value BL @ASSG Assign it A @C8,@VSPTR Restore to top of entry * Check to see if execute loop at all BL @VPOP Get ptr to value BL @MOVFAC Get value S @H16,@VSPTR Point at limit BL @SCOMPB Compare them * VSPTR is now below the FOR entry STST R4 Save the status JEQ NFOR03 IF = MOV @VSPTR,R3 H16 EQU $+2 AI R3,16 BL @GETV1 Check negative step JLT NFOR05 If a decrement SLA R4,1 Check out of limit JGT NFOR07 Out of limit NFOR03 A @C32,@VSPTR Leave the entry on B @CONT <<<<<<< Result is w/in limit NFOR05 SLA R4,1 Check out of limit JGT NFOR03 Result is w/in limit * Initial value is not within the limit. Therefore, the loop * is not executed at all. Must skip the code in the body of * the loop NFOR07 LI R3,1 FOR/NEXT pair counter NFOR09 BL @EOLINE Check end of line JEQ NFOR13 Is end of line BL @PGMCHR Get 1st token on line NFOR10 CI R8,NEXTZ*256 If NEXT JNE NFOR11 If not DEC R3 Decrement counter JNE NFOR12 If NOT matching next BL @PGMCHR Get 1st char of loop variable * Check is added in SYM 5/26/81 * JLT ERRCDT If token BL @SYM Get s.t. pointer to check match MOV @VSPTR,R3 Correct to top of entry C32 EQU $+2 AI R3,32 BL @GET1 Get pointer C R1,@FAC Match? JNE ERRFNN No match B @CONT Continue <<<<<<<< THE WAY ERRFN A @C4,@EXTRAM ERRFNN LI R0,>0B03 FOR NEXT NESTING B @ERR NFOR11 CI R8,SUBZ*256 Hit a SUB? JEQ ERRFNN Yes, can't find matching next CI R8,FORZ*256 FOR? JNE NFOR20 No, Check some more INC R3 Increment depth NFOR20 CI R8,LNZ*256 Line number token? JNE NFOR30 No, Check some more INCT @PGMPTR Skip the line number NFOR30 CI R8,STRINZ*256 String? JNE NFOR12 No, Check end of statement BL @PGMCHR Yes, get string length SWPB R8 Put the length in R8 A R8,@PGMPTR Skip that many length CLR R8 Clear next crunched code NFOR12 BL @PGMCHR Read next crunched code BL @EOSTMT Check EOS (includes EOL) JNE NFOR20 Check for line # or string JMP NFOR09 Is EOS or EOL NFOR13 MOVB @PRGFLG,R0 If imperative w/out match JEQ ERRFNN Its an error S @C4,@EXTRAM Goto next line C @EXTRAM,@STLN Hit end of program? JL ERRFN Yes, can't match the next MOV @EXTRAM,@PGMPTR Set PGMPTR to get new PGMPTR BL @PGMCHR Get MOVB R8,@PGMPTR new MOVB *R10,@PGMPT1 PGMPTR BL @PGMCHR Get next line BL @EOSTMT Check EOS or EOL JEQ NFOR09 Is EOS or EOL JMP NFOR10 Keep looping * NEXT4 and NEXT2A were moved from in-line to here in an * effort to make the "normal" path through the NEXT code as * straight-line as possible. NEXT4 S @C24,@VSPTR LOOP VARIABLES DON'T MATCH JMP NEXT2 NEXT2B BL @VPUSH Keep stack information NEXT2A LI R0,>0C03 NEXT WITHOUT FOR B @ERR ************************************************************* * NEXT statement handler - find the matching FOR statement * * on the stack, add the increment to the current value of * * the index variable and check to see if execute the loop * * again. If loop-variable's value is still within bounds, * * goto the top of the loop, otherwise, flush the FOR entry * * off the stack and continue with the statement following * * the NEXT statement. * ************************************************************* NNEXT BL @SYM GET S.T. I.D. * MOV @FAC,R4 SYM/FBSYMB leaves value in R4 NEXT2 C @VSPTR,@STVSPT CHECK FOR BOTTOM OF STACK JLE NEXT2A IF AT BOTTOM -> NEXT W/OUT FOR BL @VPOP GET 'FOR' ENTRY OFF STACK CB @FAC2,@CBH67 CHECK FOR 'FOR' ENTRY JNE NEXT2B Is not a 'FOR' entry, error C R4,@FAC CHECK IF MATCHING 'FOR' ENTRY JNE NEXT4 Is not a match, so check more MOV @VSPTR,R3 Check BUFLEV for match AI R3,14 Point at the BUFLEV in stack BL @GET1 Read it C R1,@BUFLEV SAME LEVEL? JNE ERRFNN NO, ITS AN ERROR S @C8,@VSPTR BL @MOVFAC GET INDEX VALUE BL @SAVREG SAVE BASIC REGISTERS BL @SADD ADD IN THE INCREMENT BL @SETREG RESTORE BASIC REGS A @C24,@VSPTR BL @ASSG SAVE NEW INDEX VALUE S @H16,@VSPTR POINT TO THE LIMIT BL @SCOMPB TEST W/IN LIMIT STST R4 SAVE RESULT OF COMPARE JEQ NEXT5 IF = DO LAST LOOP MOV @VSPTR,R3 CHECK FOR A DECREMENT AI R3,16 Point at increment/decrement BL @GETV1 Get 1st byte and set condition JLT NEXT6 If was a decrement SLA R4,1 Check if out of limit JGT NEXT8 Out of limit NEXT5 A @C32,@VSPTR Point to 'FOR' I.D. entry MOV @VSPTR,R3 GOTO TOP OF 'FOR' LOOP AI R3,-8 Point to old EXTRAM BL @GET1 Get new EXTRAM MOV R1,@EXTRAM Put it in INCT R3 POINT AT OLD PGMPTR BL @GET1 Get old PGMPTR MOV R1,@PGMPTR Put it in BL @PGMCHR Get 1st token in line NEXT8 B @CONT Continue on * TEST LIMIT FOR DECREMENT NEXT6 SLA R4,1 Check if out of limit JGT NEXT5 If within limit, continue JMP NEXT8 Continue PARSE ******************************************************************************** AORG >72CE TITL 'STRINGS' ************************************************************* * MEMORY CHECK ROUTINE * * It checks to see if there is enough room to insert a * * symbol table entry or a P.A.B. into the VDP between the * * static symbol table/PAB area and the dymamic string area. * * If there is not it attempts to move the string space down * * (to lower address) and then insert the needed area * * between the two. NOTE: it may invoke COMPCT to do a * * garbage collection. If there is not enough space after * * COMPCT then issues *MEMORY FULL* message. * * * * INPUT: # of bytes needed in FAC, FAC+1 * * USES: R0, R12 as temporaries as well as R0 - R6 when * * invoking COMPCT * ************************************************************* MEMCHG BL @MEMCHK GPL entry point DATA SET If NOT enough memory B @RESET If enough memory MEMCHK MOV R11,R12 Save return address MOV @FREPTR,R0 GET BEGINNING OF S.T. FREE SPACE S @STRSP,R0 CALCULATE SIZE OF GAP C @FAC,R0 ENOUGH SPACE ALREADY? JL MEMC08 YES - DONE - RTN BL @COMPCT NO - COMPACITFY STRING SPACE MOV @STREND,R0 GET STRING FREE SPACE S @VSPTR,R0 CALCULATE SIZE OF GAP AI R0,-64 VSPTR OFFSET TOO MOV @FAC,R10 GET TOTAL # NEEDED BACK C R0,R10 ENOUGH ROOM NOW? JL MEMERR NO - *MEMORY FULL* * * Now move the DYNAMIC STRING AREA DOWN IN MEMORY * MOV @STRSP,R0 CALCULATE # OF BYTES MOV @STREND,R2 Beginning of move address S R2,R0 in the total string space S R10,@STREND SET FREE PTR(COPY-TO ADDRESS) MOV R0,R0 NO BYTES TO MOVE? JEQ MEMC04 RIGHT MOV R2,R3 ADDRESS FOR GETV INC R3 MOV @STREND,R4 ADDRESS FOR PUTV INC R4 MEMC03 BL @GETV1 GET THE BYTE BL @PUTV1 PUT THE BYTE INC R3 INC THE FROM INC R4 INC THE TO DEC R0 DEC THE COUNT JGT MEMC03 IF NOT DONE * MOVE IT MEMC04 S R10,@STRSP SET NEW STRIG SPACE PTR * * NOW FIX UP STRING PTRS * MOV @STRSP,R0 GET BEGINNING OF STRING SPACE MEMC05 C @STREND,R0 FINISHED? JHE MEMC08 YES CLR R1 CLEAR LOWER BYTE MOV R0,R3 FOR GETV BL @GETV1 GET LENGTH BYTE SWPB R1 SWAP FOR ADD S R1,R0 POINT AT BEGINNING OF STRING MOV R0,R3 FOR THE GETV1 BELOW AI R3,-3 POINT AT THE BACKPOITER BL @GET1 GET THE BACK POINTER * BOTH BYTES MOV R1,R1 FREE STRING? JEQ MEMC06 YES MOV R0,R6 PTR TO STRING FOR STVDP BL @STVDP SET FORWARD PTR MEMC06 AI R0,-4 NOW POINT AT NEXT LENGTH JMP MEMC05 CONTINUE ON MEMC08 B @2(R12) Return with space allocated MEMERR MOV *R12,R12 Pick up error return address B *R12 * MEMORY FULL(prescan time) ERRMEM B @VPSH23 * MEMORY FULL(execution tiem) ************************************************************* * GETSTR - Checks to see if there is enough space in the * * string area to allocate a string, if there is it * * allocates it. If there is not it does a garbage * * collection and once again checks to see if there * * is enough room. If so it allocates it, if not it * * issues a *MEMORY FULL* message. * * * * INPUT : # of bytes needed in @BYTE * * OUTPUT: Pointer to new string in @SREF * * Both length bytes in place & zeroed Breakpointer * * @STREND points 1st free byte(new) * * * * USES : R0 - R6 Temporaries * * * * Note : COMPCT allows a buffer zone of 8 stack entries * * above what is there when COMPCT is called. This * * should allow enough space to avoid a collision * * between the string space and the stack. If * * garbage begins to appear in the string space * * that can't be accounted for, the buffer zone * * will be increased. * ************************************************************* GETSTR MOV @BYTE,R0 GET # OF BYTES NEEDED MOV R11,R12 SAVE RTN ADDRESS C *R0+,*R0+ ADJUST FOR BACKPTR & 2 LENGTHS * (INCREMENT BY 4) MOV @STREND,R1 CHECK IF ENOUGH ROOM S R0,R1 BY ADVANCING THE FREE PTR MOV @VSPTR,R2 GET VALUE STACK PTR AI R2,64 ALLOW BUFFER ZONE C R1,R2 ENOUGH SPACE? JH GETS10 YES, ALL IS WELL BL @COMPCT NO, COMPACTIFY MOV @VSPTR,R2 GET VALUE STACK POINTER AI R2,64 ALLOW BUFFER ZONE MOV @BYTE,R0 GET # OF BYTES BACK C *R0+,*R0+ INCREMENT BY 4 MOV @STREND,R1 GET NEW END OF STRING SPACE S R0,R1 ADVANCE IT C R1,R2 ENOUGH SPACE NOW? JLE ERRMEM NO, *MEMORY FULL* GETS10 AI R0,-4 GET EXACT LENGTH BACK MOVB @R0LB,R1 STORE ENTRY LENGTH BL @PUTV PUT THE ENDING LENGTH DATA STREND BYTE IN THE STRING S R0,@STREND PT AT FIRST BYTE OF STRING MOV @STREND,@SREF POINT SREF AT THE STRING DEC @STREND POINT AT LEADING LENGTH BYTE BL @PUTV PUT THE LEADING LENGTH BYTE IN DATA STREND THE STRING DECT @STREND POINT AT BACKPOINTER CLR R6 ZERO FOR THE BACKPOINTER MOV @STREND,R1 ADDR OR THE BACKPOINTER BL @STVDP CLEAR THE BACKPOINTER DEC @STREND POINT AT 1ST FREE BYTE B *R12 ALL DONE ************************************************************* * COMPCT - Is the string garbage collection routine. It can * * be invoked by GETSTR or MEMCHK. It copies all * * used strings to the top of the string space * * suppressing out all of the unused strings * * INPUT : None * * OUTPUT: UPDATED @STRSP AND @STREND * * USES : R0-R6 AS TEMPORARIES * ************************************************************* COMPCT MOV R11,R7 Save rtn address MOV @FREPTR,R0 Get pointer to free space MOV @STRSP,R5 Get pointer to string space MOV R0,@STRSP Set new string space pointer INC R5 Compensate for decrement COMP03 DEC R5 Point at length of string C @STREND,R5 At end of string space? JL COMP05 No, check this string for copy MOV R0,@STREND Yes, set end of free space B *R7 Return to caller COMP05 MOV R5,R2 Copy ptr to end in case moved MOV R5,R3 Copy ptr to end in read length BL @GETV1 Read the length byte MOVB R1,R6 Put it in R6 for address SRL R6,8 Need in LSB for word S R6,R5 Point at the string start AI R5,-3 Point at the back pointer MOV R5,R3 Set up for GETV BL @GET1 Get the backpointer MOV R1,R1 Is this string garbage? JEQ COMP03 Yes, just ignore it * PERTINENT REGISTERS AT THIS POINT * R0 - is where the sting will end * R6 - # of bytes to be moved(does not) * include lengths and backpointer * R2 - points at trailing length byte of string * to be moved * IN GENERAL : MOVE (R6) BYTES FROM VDP(R2-R6) TO VDP(R0-R6) * VDP(R0-R6) moving backwards i.e. the last * byte of the entry is moved first, then the * next to the last byte... C *R6+,*R6+ INCR by 4 to include overhead MOV R2,R3 Restore ptr to end of string MOV R0,R4 Get ptr to end of string space COMP10 BL @GETV1 Read a byte BL @PUTV1 Write a byte DEC R3 Decrement source pointer DEC R4 Decrement destination pointer DEC R6 Decrement the counter JGT COMP10 Loop if not finished ANDI R4,>3FFF Delete VDP write-enable & reg MOV R4,R0 Set new free space pointer INC R4 Point at backpointer just moved MOV R4,R3 Copy pointer to read it BL @GET1 Get the backpointer * R1 now contains the address of the forward pointer MOV R3,R6 Address of the string entry AI R6,3 Point at the string itself * R6 now contains the address of the string BL @STVDP Reset the forward pointer JMP COMP03 Loop for next string ************************************************************* * NSTRCN - Nud for string constants * * Copies the string into the string space and sets * * up the FAC with a string entry of the following * * form: * * * * +-------+-----+----+------------+-----------+ * * | >001C | >65 | XX | Pointer | Length of | * * | | | | to string | string | * * +-------+-----+----+------------+-----------+ * * FAC +2 +3 +4 +6 * ************************************************************* NSTRCN SWPB R8 MOV R8,@FAC6 Save length MOV R8,@BYTE For GETSTR SWPB R8 BL @GETSTR Get result string LI R0,>001C Get address of SREF LI R1,FAC Optimize to save bytes MOV R0,*R1+ Indicate temporary string MOVB @CBH65,*R1+ Indicate a string MOVB R0,*R1+ Byte is not used MOV @SREF,*R1 Save pointer to string MOV @BYTE,R2 Get number of bytes to copy in JEQ NSTR20 If none to copy MOV *R1,R4 Get pointer to destination MOV @PGMPTR,R3 Get pointer to source MOVB @RAMFLG,R0 ERAM or VDP? JNE NSTR10 ERAM * Get the string from VDP NSTR05 BL @GETV1 Get a byte BL @PUTV1 Put a byte INC R3 Next in source INC R4 Next in destination DEC R2 1 less to move JNE NSTR05 If more to move, do it JMP NSTR20 Else if done, exit NSTR10 MOVB @R4LB,*R15 Write 2nd byte of VDP address ORI R4,WRVDP Enable VDP write MOVB R4,*R15 Write 1st byte of VDP address NSTR15 MOVB *R3+,@XVDPWD Move byte from ERAM to VDP DEC R2 1 less to move JNE NSTR15 If ont done, loop for more NSTR20 A @FAC6,@PGMPTR Skip the string BL @PGMCHR Get character following string B @CONT And continue on ******************************************************************************** AORG >74AA TITL 'CIFS' ************************************************************* * CIF - Convert integer to floating * * Assume that the value in the FAC is an integer * * and converts it into an 8 byte floating point * * value * ************************************************************* CIF LI R4,FAC Will convert into the FAC MOV *R4,R0 Get integer into register MOV R4,R6 Copy pointer to FAC to clear it CLR *R6+ Clear FAC & FAC+1 CLR *R6+ In case had a string in FAC MOV R0,R5 Is integer equal to zero? JEQ CIFRT Yes, zero result and return ABS R0 Get ABS value of ARG LI R3,>40 Get exponent bias CLR *R6+ Clear words in result that CLR *R6 might not get a value CI R0,100 Is integer less than 100? JL CIF02 Yes, just put in 1st fraction * part CI R0,10000 No, is ARG less then 100^2? JL CIF01 Yes, just 1 division necessary * No, 2 divisions are necessary INC R3 Add 1 to exponent for 1st MOV R0,R1 Put # in low order word for the * divide CLR R0 Clear high order word for the * divide DIV @C100,R0 Divide by the radix MOVB @R1LB,@3(R4) ~@ Move the radix digit in CIF01 INC R3 Add 1 to exponent for divide MOV R0,R1 Put in low order for divide CLR R0 Clear high order for divide DIV @C100,R0 Divide by the radix MOVB @R1LB,@2(R4) ~@ Put next radix digit in CIF02 MOVB @R0LB,@1(R4) ~@ Put highest order radix digit in MOVB @R3LB,*R4 Put exponent in INV R5 Is result positive? JLT CIFRT Yes, sign is correct NEG *R4 No, make it negative CIFRT RT ******************************************************************************** AORG >7502 TITL 'SUBPROGS' CONTAD DATA >A000 Address of a continue stmt GPLIST EQU >A026 GPL subprogram linked list UNQSTZ EQU >C8 Unquoted string token INUSE DATA >8000 In-use flag FNCFLG DATA >4000 User-defined function flag SHRFLG DATA >2000 Shared-value flag * * ERROR CODES * ERRSND EQU >1203 * SUBEND NOT IN SUBPROGRAM ERRREC EQU >0F03 * RECURSIVE SUBPROGRAM CALL ERRIAL EQU >0E03 * INCORRECT ARGUMENT LIST ERROLP EQU >1103 * ONLY LEGAL IN A PROGRAM ************************************************************* * CALL - STATEMENT EXECUTION * * Finds the subprogram specified in the subprogram table, * * evaluates and assigns any arguments to the formal * * parameters, builds the stack block, and transfers control * * into the subprogram. * * General register usage: * * R0 - R6 Temporaries * * R7 Pointer into formals in subprogram name entry * * R8 Character returned by PGMCHR * * R9 Subroutine stack * * R10 Temporary * * R11 Return link * * R12 Temporary * * R13 GROM read-data address * * R14 Interpreter flags * * R15 VDP write-address address * ************************************************************* CALL BL @PGMCHR Skip UNQSTZ & get name length MOVB R8,@FAC15 Save lengthfor FBS MOVB R8,R4 For the copies to be made SRL R4,8 below MOV @PGMPTR,R0 Get pointer to name MOVB @RAMFLG,R1 ERAM or VDP? JEQ CALL04 VDP * ERAM, must copy into VDP MOV R0,R5 Pointer to string in ERAM LI R0,CRNBUF Destination in VDP MOV R4,R3 Length for this move MOVB @R0LB,*R15 Load out the VDP write address ORI R0,WRVDP Enable the VDP write MOVB R0,*R15 Second byte of VDP write CALL02 MOVB *R5+,@XVDPWD Move a byte DEC R3 One less byte to move JNE CALL02 Loop if not done CALL04 A R4,@PGMPTR Skip over the name LI R1,FAC Destination in CPU MOVB @R0LB,*R15 Load out VDP read address ANDI R0,>3FFF Kill VDP write-enable MOVB R0,*R15 Both bytes NOP Don't go to fast for it CALL06 MOVB @XVDPRD,*R1+ Move a byte DEC R4 One less bye to move JNE CALL06 Loop if not done MOV @SUBTAB,R4 Get beginning of subpgm table JEQ SCAL89 If table empty, search in GPL BL @FBS001 Search subprogram table DATA SCAL89 If not found, search in GPL * Pointer to table entry returned in both R4 and FAC BL @PGMCHR Get next token MOV R4,R3 Duplicate pointer for GETV BL @GETV1 Get flag byte JLT SCAL90 If attempted recursive call SLA R1,1 Check for BASIC/GPL program JLT GPLSU GPL subprogram MOVB @PRGFLG,R11 Imperative call to BASIC sub? JNE SCAL01 No, OK-handle BASIC subprogram LI R0,ERROLP Can't call a BASIC sub JMP SCAL91 imperatively * * Handle a GPL subprogram * GPLSU INCT R9 MOV @CONTAD,*R9+ Put address of a cont on stack MOV R13,*R9 Save address for real BASIC AI R3,6 Now set up new environment BL @GET1 Get access address of GPL subpgm MOVB R1,@GRMWAX(R13) Load out the address into GROM SWPB R1 Need to kill time here MOVB R1,@GRMWAX(R13) Next byte also BL @SAVREG Restore registers to GPL B @RESET And enter the routine * * Execute BASIC subprogram * SCAL01 EQU $ *-----------------------------------------------------------* * Fix "An error happened in a CALL statement keeps its * * in-use flag set" bug. 5/12/81 * * Move the following 3 lines after finishing processing * * the parameter list, before entering the subprogram. * * SRL R1,1 Restore mode to original form* * SOCB @INUSE,R1 Set the in-use flag bit * * BL @PUTV1 Put the byte back * * Save the pointer to table entry for setting in-use flag * * later. * * $$$$$$$ USE VDP(0374) 2 BYTES AS TEMPRORARY HERE * LI R4,>0374 R4: address register for PUT1 * MOV R3,R1 R1: data register for PUT1 * BL @PUT1 Save the pointer to table * * entry in VDP temporary * *-----------------------------------------------------------* MOV R3,R12 Save subtable address CLR @FAC2 Indicate non-special entry BL @VPUSH Push subprogram entry on stack MOV R12,R4 Restore sub table address MOV R4,R7 AI R7,6 Point to 1st argument in list MOV R7,R3 Formals' pointer BL @GET1 Check to see if any MOV R1,R1 Any args? JEQ SCAL32 None, jump forward CI R8,LPARZ*256 Must see a left parenthesis JNE SCAL34 If not, error JMP SCAL08 Jump into argument loop SCAL90 LI R0,ERRREC * RECURSIVE SUBPROGRAM CALL JMP SCAL91 SCAL89 LI R0,>000A GPL check for DSR subprogram SCAL91 B @ERR SCAL93 JMP SCAL12 Going down! SCAL05 BL @POPSTK Short stack pop routine MOV @ARG4,R7 To quickly restore R7 INCT R7 To account for SCAL80 SCAL06 CI R8,RPARZ*256 Actual list ended? JEQ SCAL30 Actuals all scanned CI R8,COMMAZ*256 Must see a comma then JNE SCAL12 Didn't, so error * Scan next actual. Check if it is just a name SCAL08 MOV @PGMPTR,@ERRCOD Save text ptr in case of expr BL @PGMCHR Get next character JLT SCAL40 No, so must be an expression MOV R7,R12 Save formals pointer BL @SYM Read name & see if recognized BL @GETV Check function flag DATA FAC MOV R12,R7 Restore formals pointer first CZC @FNCFLG,R1 User-defined function? JNE SCAL40 Yes, pass by value CI R8,LPARZ*256 Complex type? JNE SCAL15 No BL @PGMCHR Check if formal entry CI R8,RPARZ*256 FOO() ? JEQ SCAL14 Yes, handle it as such CI R8,COMMAZ*256 or FOO(,...) ? JNE SCAL35 No, an array element FOO(I... SCAL10 BL @PGMCHR Formal array, scan to end BL @EOSTMT Check if end-of-statement JEQ SCAL12 Premature end of statement CI R8,COMMAZ*256 Another comma? JEQ SCAL10 Yes, continue on to end CI R8,RPARZ*256 End yet? JEQ SCAL14 Yes, merge in below SCAL12 B @ERRONE * SYNTAX ERROR SCAL32 B @SCAL62 Going down! SCAL30 B @SCAL60 SCAL34 B @SCAL88 SCAL35 B @SCAL50 SCAL37 JMP SCAL06 * * Here for Scalers/Arrays by Reference SCAL14 BL @PGMCHR Pass the right parenthesis SCAL15 CI R8,COMMAZ*256 Just a name? JEQ SCAL16 Yes CI R8,RPARZ*256 Start an expression? JNE SCAL40 Yes, name starts an expression SCAL16 BL @GETV Get mode of name DATA FAC Ptr to s.t. entry left by SYM MOVB R1,R2 Save for check below BL @SCAL80 And fetch next formal info MOVB R2,R1 Copy for this check ANDI R1,>C700 for the comparison MOV R6,R0 Use a temporary rgister ANDI R0,>C700 for the comparison C R1,R0 Must be exact match JNE SCAL34 Else can't pass by reference SOC @SHRFLG,R6 Set the shared symbol flag MOVB R6,R1 Load up for PUTV MOV R5,R4 Address to put the flag BL @PUTV1 Set the flag in the s.t. entry ANDI R4,>3FFF Kill VDP write-enable bit * * The following section finds actual's value space address * and puts it in R1. * FAC contains the symbol table's address. * If actual is NOT shared....................... * Symbol table's address+6 will point to the value space * except for numeric ERAM cae. In a numeric ERAM case * GET1 to get pointer to the ERAM value space. * If actual is SHARED........................ * GET1 to get the pointer in symbol table's address+6 * In a numeric ERAM case, GETG to get the indirect point * to the actual's vlaue space pointer after GET1 is call * MOV @FAC,R1 Ptr to actual s.t. entry AI R1,6 Ptr to actuals value space ANDI R6,>8700 Keep info on string or array ANDI R2,>2000 Is actual shared? JEQ SCAL23 No, use it MOV R1,R3 Else look further BL @GET1 Get the true pointer MOVB R6,R6 Array or string? JNE SCAL24 Yes, both are special cases MOVB @RAMTOP,R2 ERAM present? JEQ SCAL24 No ERAM, so skip * Numeric variable, shared, ERAM. MOV R1,R3 Get ptr to original from ERAM BL @GETG2 Get indirect pointer JMP SCAL24 * Shared bit is NOT on. SCAL23 MOVB R6,R6 Check for array or string JNE SCAL24 Yes, take what's in there MOVB @RAMTOP,R2 ERAM exists? JEQ SCAL24 No MOV R1,R3 Numeric and ERAM case BL @GET1 Get ERAM value space address * R4 pointing to value space of SCAL24 AI R4,6 subprogram's symbol table MOVB R6,R6 Array or string case? JNE SCAL26 Yes, so just put ptr in VDP * Here check for ERAM program and if ERAM then copy the * address of shared value space into corresponding value * space in ERAM MOVB @RAMTOP,R6 Get the ERAM flag JEQ SCAL26 If no ERAM, simple case MOV R1,R6 Keep shared value space address MOV R4,R3 Put ptr in value space in ERAM BL @GET1 Get value space address in ERAM MOV R1,R4 Copy address into R4 for PUTG2 MOV R6,R1 Get the value to put in ERAM BL @PUTG2 Write it into ERAM JMP SCAL37 Loop for next argument SCAL26 BL @PUT1 Set symbol indirect link JMP SCAL37 And loop for next arg * * Here to pass an expression by value * SCAL40 MOV @ERRCOD,@PGMPTR Restore text pointer MOV R7,@FAC4 Save formals pointer CLR @FAC2 Don't let VPUSH mess up SCAL42 BL @PGMCHR Set up for the parse * Save formals ptr & SUBTAB ptr and evaluate the expression BL @PSHPRS BYTE RPARZ Stop on an rpar or comma DCBH6A BYTE >6A (CBH6A copy) BL @POPSTK Restore formals pointer A @C16,@VSPTR But keep it on stack BL @VPUSH Save parse result MOV @ARG4,R7 Restore formals pointer BL @SCAL80 And fetch next formal's info MOV R5,@FAC Set up for assignment BL @SMB Get value space S @C16,@VSPTR Get to s.t. info BL @VPUSH Set up for ASSG A @C8,@VSPTR Get back to parse result BL @VPOP Get parse result back BL @ASSG Assign the value to the formal B @SCAL05 And go back for more * * Here for array elements * SCAL50 DEC @PGMPTR Restore text pointer to lpar LI R11,FAC2 Optimize to save CLR *R11+ Don't let VPUSH mess up (FAC2) MOV R7,*R11+ Save formals pointer (FAC4) MOV @ERRCOD,*R11 For save on stack (FAC6) BL @VPUSH Save the info LI R8,LPARZ*256 Load up R8 with the lpar again MOV @FAC,@PAD0 Save ptr to s.t. entry BL @SMB Check if name or expression CI R8,COMMAZ*256 JEQ SCAL54 Name if ended on a comma CI R8,RPARZ*256 JEQ SCAL54 or rpar BL @VPOP Get saved info back MOV @FAC6,@PGMPTR Else expr, Restore test pointer JMP SCAL42 And handle like an expression * * Passing array elements by reference SCAL54 BL @POPSTK Restore symbol pointer MOV @ARG4,R7 BL @SCAL80 Get next formal's info BL @GETV Check actualOs mode DATA PAD0 Get back header information ANDI R1,>C000 Throw away all but string & function CB R6,R1 Check mode match (string/num) JNE JNE88 Don't, so error * Can set bit in R1 since MSB (R1)=MSB (R6) SOCB @SHRFLG,R1 Set the share flag MOV R5,R4 Address for PUTV BL @PUTV1 Put it in the s.t. entry ANDI R4,>3FFF Kill VDP write, enable bit MOV @FAC,R1 Assuming string, ref link=@FAC MOVB R6,R6 Check if it is a string JLT SCAL24 If so, go set ref. link MOV @FAC4,R1 Numeric, ref. link=@FAC4(v.s.) JMP SCAL24 Now set the link and go on * * Here when done parsing actuals * SCAL60 BL @PGMCHR Pass the right parenthesis SCAL62 BL @EOSTMT Must be at end of statement JNE88 JNE SCAL88 If not, error MOV R7,R3 Formals must also have ended INCT R7 MOV R7,@FAC Keep R7, POPSTK destorys R7 BL @GET1 Get the last arg address MOV R1,R1 Formals end? JNE SCAL88 Didn't, so error * * Now set up the stack entry * BL @VPUSH Check if enough room for push S @C8,@VSPTR Get back right pointer BL @POPSTK Retrieve ptr to subprog s.t. LI R12,FAC For code optimization MOV R12,R1 Store following data in FAC MOV *R12,@ARG2 Save new environment pointer * * First push entry. PGMCHR, EXTRAM, SYMTAB and RAM(SYNBOL) * LI R0,PGMPTR Optimize MOV *R0+,*R1+ Text pointer PGMPTR MOV *R0+,*R1+ Line table pointer EXTRAM MOV @SYMTAB,*R1+ Symbol table pointer LI R3,SYMBOL Put address of SYMBOL BL @GET1 Get RAM(SYMBOL) in REG1 MOV R1,@FAC6 Move to FAC area BL @VPUSH Save first entry * * Push second entry. Subprogram table pointer, >6A on warning * bits and @LSUBP in the second stack. MOV R12,R4 Going to build entry in FAC MOV @ARG,*R4+ Subprogram table entry pointer MOVB @DCBH6A,*R4+ >6A = Stack ID MOVB @FLAG,R2 Warning/break bits ANDI R2,>0600 Mask off other bits MOVB R2,*R4+ Put bits in stack entry MOV @LSUBP,@FAC6 Last subprogram block on stack BL @VPUSH Push final entry MOV @VSPTR,@LSUBP Set bottom of stack for the sub * * Now build the new environment by modifying PGMCHR, * EXTRAM and pointer to sub's symbol table. LI R0,PGMPTR Optimization MOVB @ARG3,*R15 2nd byte of address LI R1,XVDPRD Optimize to save bytes MOVB @ARG2,*R15 1st byte of address LI R4,4 Need 4 bytes SCAL70 MOVB *R1,*R0+ Read EXTRAM and PGMPTR DEC R4 JNE SCAL70 MOVB *R1,@SYMTAB New SYMTAB LI R4,SYMBOL MOVB *R1,@SYMTA1 MOV @SYMTAB,R1 BL @PUT1 New RAM(SYMBOL) CLR @ERRCOD Clean up our mess BL @PGMCHR Get the next token into R8 *-----------------------------------------------------------* * Fix "A error happened in a CALL statement keeps it * * "in-use flag set" bug, 5/23/81 * * Insert following lines: * LI R3,>0374 Restore the pointer to table * * entry from VDP temporary, R3: address reg. for GET1 * BL @GET1 * MOV R1,R3 Get flag byte * BL @GETV1 * SOCB @INUSE,R1 Set the in-use flag bit * MOV R3,R4 ?????????????????????????????????????????????????? BL @PUTV1 Put the byte back * *-----------------------------------------------------------* B @NUDEND Enter the subprogram SCAL88 LI R0,ERRIAL * INCORRECT ARGUMENT LIST JMP $+>C6 Jump to B @ERR ************************************************************* * Fetch next formal and prop for adjustment * * Register modification * * R5 Address of s.t. entry (formal's entry) * * R6 Header byte of formal's entry * * R7 Updated formal's pointer * * Destroys: R1, R2, R3, R4, R11, R12 * ************************************************************* SCAL80 MOV R11,R12 Save return address MOV R7,R3 Fetch symbol pointer INCT R7 Point to next formal BL @GET1 Fetch s.t. pointer MOV R1,R3 Set condition & put in place JEQ SCAL88 If to many actuals MOV R1,R4 Save for below MOV R1,R5 Save for return BL @GET1 Get header bytes COC @SHRFLG,R1 Shared? JEQ SCAL82 Yes, reset flag and old value MOV R1,R6 Save for return & test string JLT SCAL81 If it is a string, then SCAL81 B *R12 Return SCAL81 AI R3,6 Is string, point at value ptr BL @GET1 Get the value pointer MOV R1,R4 Null value? JEQ SCAL86 Yes CLR R1 No, must free current string AI R4,-3 Point at the backpointer BL @PUT1 Clear the backpointer MOV R3,R4 SCAL84 CLR R1 Needed for entry from below BL @PUT1 Clear the forward pointer B *R12 Just return SCAL82 ANDI R1,>DFFF Reset the share flag BL @PUTV1 Put it there AI R4,6 Point at ref pointer MOV R1,R6 Set for return JLT SCAL84 If string clear ref pointer SCAL86 B *R12 Return ************************************************************* * Execute a SUBEXIT or SUBEND * ************************************************************* SUBXIT MOV @LSUBP,R5 Check for subprogram on stack JEQ SCAL98 Not one, so error C R5,@VSPTR Extra check on stack pointer JH SCAL98 Pointers are messed up, error SBXT05 BL @VPOP Get stack entry CB @FAC2,@DCBH6A Reached the subprogram entry? JNE SBXT05 Not yet * * Reached the subprogram stack entry. Get information FAC * area has subprograms table pointer, >6A, on warning bits * and LSUBP LI R12,FAC Optimize for the copies MOV R12,R0 For this copy MOV *R0+,R3 Subprogram pointer BL @GETV1 Get header byte in subprogram SZCB @INUSE,R1 Reset the in-use bit MOV R3,R4 BL @PUTV1 Put it back MOV *R0+,R1 On warning bits MOVB @FLAG,R4 Get the current flag ANDI R4,>F900 Trash current warning bits SOCB @R1LB,R4 OR the old ones back in MOVB R4,@FLAG And put flag back INCT R0 There is one word empty MOV *R0+,@LSUBP Last subprogram block on stack * * Second subprogram stack entry. Restore pointers. FAC area * has PGMPTR, EXTRAM, SYMTAB, RAM(SYMBOL) BL @VPOP Get second entry MOV R12,R0 Put FAC in R0. (optimization) LI R1,PGMPTR For optimization MOV *R0+,*R1 Restore text pointer PGMPTR DEC *R1+ Save code to decrement it MOV *R0+,*R1+ Line table pointer EXTRAM MOV *R0+,@SYMTAB Restore symbol table pointer MOV *R0+,R1 Restore permanent s.t. pointer LI R4,SYMBOL Place in VDP BL @PUT1 Put it out there BL @PGMCHR Load R8 with EOS/EOL & go on B @EOL SCAL98 LI R0,ERRSND * SUBEND NOT IN SUBPROGRAM B @ERR ******************************************************************************** TITL 'SUBPROGS2' ************************************************************* * RESOLV - Attempt to resolve all subprograms referenced in * * call statements by first searching the internal subprogram* * table (SUBTAB), then by searching GROMs for GPL * * subprograms. In RESGPL, it builds a subprogram table. * * If, after searching all of the subprogram areas, there * * are any subprograms whose location cannot be determined, * * an error occurs. * ************************************************************* RESOLV INCT R9 Save return address MOV R11,*R9 MOV @CALIST,R5 Pick up call list pointer JEQ RES50 If no subprogram references RES03 MOV @SUBTAB,R6 Pick up subprogram table ptr RES05 JEQ RES15 Try to resolve by checking * * * Compares two names for a match when trying to resolve all * * references to subprograms. * * Register usage is generally as follows: * * R5 - Pointer to CALIST entry to be compared * * R7 - Pointer to entry to be compared to SUBTAB * * Returns as pointer to name if found or zero * * if not found * * R10 - Returned as length of name * MOV R6,R3 Put in place for GETV INC R3 Point at the name length BL @GETV1 Get the name length SRL R1,8 Put in LSB and clear MSB MOV R1,R4 Save it for the move AI R3,3 Point at name pointer BL @GET1 Get the name pointer MOV R1,R7 Save in permanent MOV R1,@PGMPTR Save for compare MOV R5,R3 To get the CALIST entry INC R3 Point at the name length BL @GETV1 Get the name length CB R1,@R4LB Name length match? JNE RES20 No, no match possible MOV R4,R0 Save name length for compare AI R3,3 Point at the name pointer BL @GET1 Get the pointer to the name MOV R1,R3 Set up to get the name COMPTN BL @GETV1 Get a char of CALIST name * Next PGMSUB call is the same as PGMCHR except in skipping * ERAM check BL @PGMSUB Get a char of found name CB R1,R8 Chars match? JNE RES20 No, not same name INC R3 Next character DEC R0 Done with compare? JNE COMPTN No, check the rest * Found the subprogram in GROM and built the table. * Set resolved flag and get back. MOV R5,R4 Set resolved flag now SETO R1 Set up a resolved flag BL @PUTV1 And put the byte in RES15 MOV R5,R3 Get call list pointer INCT R3 Point at link BL @GET1 Get the name link MOV R1,R5 Save and set condition JEQ RESGPL End of call list? Yes JNE RES03 No, go check the next in list RES20 MOV R6,R3 Get next entry in subpgm table INCT R3 Point at the link BL @GET1 Get the link MOV R1,R6 Update subprogram table pointer JMP RES05 And try next entry RES50 CLR R3 Indicate no error return RES51 MOV *R9,R11 Restore return address DECT R9 Restore stack RT All resolved and ok RES52 LI R3,>001C JMP RES51 ************************************************************* * RESGPL routine * * Resolves as a GPL subprogram by comparing names in CALL * * list and GROM link list in EXEC. If name found in GROM * * then turn the resolved flag on and if not found an error * * occurs. Fetch subprogram access address from the link * * list and builds a subprogram table for that call. * ************************************************************* RESGPL MOV @CALIST,R5 Get the call list pointer * Get the next subprogram in the call list that has not been * resolved. GET01 MOV R5,R3 Get pointer in call list JEQ RES50 If end of list BL @GETV1 Get the resolved flag JEQ GPL00 If not resolved GET03 INCT R3 Point at link BL @GET1 Get the link MOV R1,R5 Save it and set condition JNE GET01 If not end of list, go on JMP RES50 Return * Start looking at GROM subprogram link list. GPL00 LI R7,GPLIST Load address of link list MOV R5,R3 Copy CALIST address INC R3 Point to name length BL @GETV1 Get the name length SRL R1,8 Adjust to the right byte MOV R1,R0 Copy for later use CLR R10 Clear for name length AI R3,3 Point to name ptr in call list GPL10 MOVB R7,@GRMWAX(R13) Specify address in link list SWPB R7 Need to kill time here MOVB R7,@GRMWAX(R13) Move next byte SWPB R7 Get R7 in right order MOVB *R13,R8 Read next link address from MOVB *R13,@R8LB linked list INCT R7 Point to name length in GROM MOVB R7,@GRMWAX(R13) Specify name length address SWPB R7 Need to kill time here MOVB R7,@GRMWAX(R13) Move next byte SWPB R7 Get R7 in right order MOVB *R13,@R10LB Get the name length in GROM C R0,R10 Compare name length JEQ GPL25 If matches, compare names GPLNXT MOV R8,R7 Didn't match, get link to next JNE GPL10 Loop if not end of list MOV R5,R3 If end of GPL list, ignore this JMP GET03 entry in CALIST * Start comparing the names GPL25 BL @GET1 Get name ptr form call list * R1 contains address of name MOVB @R1LB,*R15 Get one character from VDP NOP MOVB R1,*R15 Then compare with the one in GPL30 CB *R13,@XVDPRD GROM - R13 points to GROM JNE GPLNXT If no match get next in GROM DEC R10 All matched? JNE GPL30 No, loop for next characters * Found the GPL subprogram. Now start building GPL's * subprogram table. * First put all information in FAC since they might get * destroyed in MEMCHK. * @FAC2 = Set program bit and name length * @FAC4 = Subprogram table link address * @FAC6 = Pointer to name * @FAC8 = Access address in GROM * @FAC10 = Current call list address LI R12,FAC2 Optimize for speed and space MOV R0,*R12 Keep length in FAC2 SOC @FNCFLG,*R12+ Set program bit MOV @SUBTAB,*R12+ Set up subtable link address BL @GET1 Get pointer to name MOV R1,*R12+ Move it to FAC6 MOVB *R13,*R12+ Get access address from GROM NOP MOVB *R13,*R12+ and put it in FAC8 MOV R5,*R12 Save current call list address * Check if ERAM exists or imperative statement. If so then * copy name into appropriate VDP area. MOVB @RAMFLG,R6 ERAM present? JNE GPL40 Yes, then save name in table MOVB @PRGFLG,R6 Imperative call JNE GPL60 No, handle normally * Copy name into table area GPL40 MOV R0,@FAC Copy name length BL @MEMCHK Get the space. FAC = name length DATA RES52 Error return address MOV @FAC6,R3 Get pointer to name S @FAC,@FREPTR New free pointer MOV @FREPTR,R4 New place of name INC R4 MOV R4,@FAC6 New pointer to name MOV @FAC,R2 Counter for the move * Now copy the name, character by character GPL50 BL @GETV1 Get a byte BL @PUTV1 Put a byte INC R3 INC R4 DEC R2 Done? JNE GPL50 No, move the rest * Restore all the information from FAC area and build * subprograms symbol table. GPL60 MOV @C8,@FAC Need 8 bytes BL @MEMCHK Get the bytes. Check the space DATA RES52 Error return address S @C8,@FREPTR Updata the free pointer MOV @FREPTR,R0 Get location to move to INC R0 True pointer MOV R0,@SUBTAB Update subprogram table ptr LI R1,FAC2 Subprograms info starts FAC2 MOVB @R0LB,*R15 Load out address ORI R0,WRVDP Enable VDP write MOVB R0,*R15 LI R0,XVDPWD Optimize to save bytes LI R3,8 Going to move 8 bytes GPL70 MOVB *R1+,*R0 Copy mode, name length, link, DEC R3 ptr to name, ptr to subprogram JNE GPL70 MOV *R1,R3 Restore ptr into call list B @GET03 Check next entry in call list ******************************************************************************** AORG >7ADA TITL 'SCROLLS' FLG EQU 5 * R12 total number of bytes to move * R10 move from * R9 move to * R8 minor counter (buffer counter) * R7 buffer pointer SCROLL LI R12,736 Going to move 736 bytes LI R10,32 Address to move from CLR R9 Address to move to MOV R11,R6 Save return address BL @SCRO1 Scroll the screen LI R5,XVDPWD Optimize for speed later LI R4,>02E0 Addr of bottom line on screen LI R1,>7F80 Edge character and space char ~~~~~~~~~~~~ LI R2,28 28 characters on bottom line BL @PUTV1 Init VDP & put out 1st edge char MOVB R1,*R5 Put out 2nd edge character SWPB R1 Bare the space character SCRBOT MOVB R1,*R5 Write out space character DEC R2 One less to move JNE SCRBOT Loop if more SWPB R1 Bare the edge character again MOVB R1,*R5 Output edge character MOVB R1,*R5 Output edge character B *R6 And return go GPL * Generalized move routine SCRO1 CLR R8 Clear minor counter MOVB @R10LB,*R15 Write out LSB of read-address STWP R7 Get the WorkSpace pointer MOVB R10,*R15 Write out MSB of read-address SCRO2 MOVB @XVDPRD,*R7+ Read a byte INC R10 Inc read-from address INC R8 Inc minor counter DEC R12 Dec total counter JEQ SCRO4 If all bytes read-write them CI R8,12 Filled WorkSpace buffer area? JLT SCRO2 No, read more SCRO4 MOVB @R9LB,*R15 Write LSB of write-address ORI R9,WRVDP Enable the VDP write MOVB R9,*R15 Write MSB of write-address STWP R7 Get WorkSpace buffer pointer SCRO6 MOVB *R7+,@XVDPWD Write a byte INC R9 Increment write-address DEC R8 Decrement counter JNE SCRO6 Move more if not done MOV R12,R12 More on major counter? JNE SCRO1 No, go do another read RT Yes, done ************************************************************* * Decode which I/O utility is being called * * Tag field following the XML IO has the following * * meaning: * * 0 - Line list - utility to search keyword table to * * restore keyword from token * * 1 - Fill space - utility to fill record with space * * when outputting imcomplete records * * 2 - Copy string - utility to copy a string, adding * * the screen offset to each character for display * * purposes * * 3 - Clear ERAM - utility to clear ERAM at the address * * specified by the data word following the IO tag * * and the # of bytes specified by the length * * following the address word. Note that each data * * word is the address of a CPU memory location. * ************************************************************* IO MOVB *R13,R0 Read selector from GROM SRL R0,8 Shift for decoding JEQ LLIST 0 is tag for Line list DEC R0 JEQ FILSPC 1 is tag for Fill space DEC R0 JEQ CSTRIN 2 is tag for Copy string * 3 is tag for CLRGRM string * fall into it * CALGRM * R1 - address of clearing start * R2 - number of bytes to clear CLRGRM LI R1,PAD0 Get CPU RAM offset MOV R1,R2 Need for next read too AB *R13,@R1LB Add address of ERAM pointer MOV *R1,R1 Read the ERAM address AB *R13,@R2LB Read address of byte count MOV *R2,R2 Read the byte count CLR R0 Clear of clearing ERAM CLRGR1 MOVB R0,*R1+ Clear a byte DEC R2 One less to clear, done? JNE CLRGR1 No, loop for rest RT Yes, return * CSTRIN * R0 - MNUM * R1 - GETV/PUTV buffer * R3 - FAC4/GETV address * R5 - return address CSTRIN MOV R11,R5 Save return address MOVB @MNUM,R0 Get MNUM JEQ CSTR1O If no bytes to copy SRL R0,8 Shift to use as counter MOV @CCPADR,R4 Get copy-to address MOV @FAC4,R3 Get copy-from address CSTRO5 BL @GETV1 Get byte AB @DSRFLG,R1 Add screen offset BL @PUTV1 Put the offset byte out INC R3 Increment from address INC R4 Increment to address DEC R0 One less to move JNE CSTRO5 Loop if not done MOV R3,@FAC4 Restore for GPL CSTR07 MOVB R0,@MNUM Clear for GPL CCBHFF EQU $+3 ANDI R4,>BFFF Throw away VDP write enable MOV R4,@CCPADR Restore for GPL FILSZ6 EQU $ CSTR1O B *R5 Return * FILSPC * R0 - MNUM * R1 - Buffer for GETV/PUTV * R2 - MNUM1 * R3 - Pointer for GETV * R4 - CCPADR, pointer for PUTV * R5 - return address FILSPC MOV R11,R5 Save return address MOVB @MNUM1,R2 Get pointer to end of record JNE FILSZ1 If space to fill for sure CB R2,@CCPPTR Any filling to do? JNE FILSZ2 Yes, do it normalling B *R5 No, 255 record already full FILSZ1 CB R2,@CCPPTR Any filling to do? JLE FILSZ6 No, record is complete FILSZ2 SB @CCPPTR,R2 Compute # of bytes to change AB R2,@CCPPTR Point to end MOVB @DSRFLG,R0 Filling with zeroes? JNE FILSZ3 No, fill with spaces MOV @PABPTR,R3 Check if internal files AI R3,FLG 5 byte offset into PAB CLR R1 Initialize to test below BL @GETV1 Get byte from PAB ANDI R1,>0800 Internal? JNE FILSZ4 Yes, zero fill FILSZ3 AI R0,>2000 Add space character for filler FILSZ4 SRL R2,8 Shift count for looping MOV @CCPADR,R4 Get start address to fill MOVB R0,R1 Put filler in place for PUTV FILSZ5 BL @PUTV1 Put out a filler INC R4 Increment filler position DEC R2 One less to fill JNE FILSZ5 Loop if move MOVB R2,@MNUM1 Restore for GPL JMP CSTR07 * LLIST * R0 - FAC - address of keytab in GROM * R1 - keyword length LLIST MOV R11,R12 Save return address BL @PUTSTK Save GROM address MOV @FAC,R0 Get address of keytab MOVB @CHAT,R8 Get token to search for LI R1,1 Assume one character keyword LLISZ4 MOVB R0,@GRMWAX(R13) Load GROM address of table MOVB @R0LB,@GRMWAX(R13) Both bytes MOVB *R13,R3 Read address of x-char table MOVB *R13,@R3LB Both bytes LLISZ5 A R1,R3 Add length of keyword to point * at token MOVB R3,@GRMWAX(R13) Write out new GROM address MOVB @R3LB,@GRMWAX(R13) Which points to token MOVB *R13,R4 Read token value MOVB *R13,R5 Read possible end of x-char * table CB R4,R8 Token value match? JEQ LLISZ6 Yes!!! Found the keyword INC R3 No, so skip token value CB R5,@CCBHFF Reach end of x-char table? JNE LLISZ5 No, so check more in the table INCT R0 Point into x+1 char table INC R1 Try x+1 char table JMP LLISZ4 Loop to check it * Come here when found keyword LLISZ6 S R1,R3 Subtract length to pnt at K.W. MOV R3,@FAC8 Save ptr to KeyWord for GPL MOV R1,@FAC4 Save KeyWord length for GPL MOVB R8,@FAC Save CHAT for GPL BL @GETSTK Restore GROM addres B *R12 And return to GPL ******************************************************************************** AORG >7C56 TITL 'SCANS' RETURZ EQU >88 DEFZ EQU >89 DIMZ EQU >8A ENDZ EQU >8B FORZ EQU >8C INPUTZ EQU >92 DATAZ EQU >93 REMZ EQU >9A ONZ EQU >9B CALLZ EQU >9D OPTIOZ EQU >9E IMAGEZ EQU >A3 SUBXTZ EQU >A7 SUBNDZ EQU >A8 LINPUZ EQU >AA STEPZ EQU >B2 NUMZ EQU >C7 *-----------------------------------------------------------* * Added for "NOPSCAN" feature 6/8/81 * P1 EQU >40 @ P2 EQU >50 P P3 EQU >2B + P4 EQU >2D - P5 EQU >70 p PSCFG EQU >03B7 VDP temporary: PSCAN flag * >00 : no pscan * * >FF : pscan * *-----------------------------------------------------------* *-----------------------------------------------------------* * SCAN routine is changed for implementing "NOPSCAN" * * feature, 6/8/81 * * "!@P+" or "!@p+" is RESUME PSCAN * * "!@P-" or "!@p-" is NO PSCAN * *-----------------------------------------------------------* * * ************************************************************* * SCAN is the main looping structure of the prescan routine.* * Takes care of scanning each statement in a line. Goes * * back to GPL to scan the special cases (DEF, OPTION, DIM, * * SUB, CALL, SUBEND, SUBEXIT) and also goes to GPL to enter * * variables into the symbol table. All statements which are * * not allowed to be imperative are checked directly without * * goting to GPL. The NOCARE label is where a non-special * * statement is scanned, looking for variables to enter them * * into the symbol table. * ************************************************************* PSCAN MOVB *R13,R0 Read Scan code BL @PUTSTK Save GROM address BL @SETREG Set up R8/R9 with CHAT/SUBSTK * First decode the type of XML being executed * Types are: >00 - initial call with program * >01 - resume within a statement after call to * GPL for some reason * >02 - initial call for imperative statement SRL R0,8 Set condition JEQ SCAN05 If calling scan routine w/pgm DEC R0 Returning from call to GPL? JEQ JNCARE Yes, continue w/in line MOV *R9,@RTNADD JMP SCAN10 SCAN05 A @C3,*R9 Skip following XML and select MOV *R9,@RTNADD Set up rtn to common GPL loc CLR @DATA Assume out of data SCAN5A C @LINUM,@EXTRAM End of program yet? JNE SCAN07 No, get next line SCAN5B MOVB @FORNET,R0 Check fornext counter JNE FNERR For/Next error MOVB @XFLAG,R0 Check subprogram bits CBH40 EQU $+1 SLA R0,4 Subprogram encountered? JLT SCAN6A Yes, check subend SCAN06 LI R0,>A000 Initialize data stack MOVB R0,@STACK BL @RESOLV Resolve any subprogram refs B @GPL05 Return SCAN6A SLA R0,4 Subend encountered? JNC ERRMS No, text ended w/out subend LI R3,TABSAV Get main symbol table's ptr BL @GET1 Get it MOV R1,@SYMTAB JMP SCAN06 Merge back in ERRMS LI R3,>18 * MISSING SUBEND JMP GPL05L SCAN07 S @C4,@EXTRAM Go to next line in program MOVB @RAMTOP,R0 ERAM program? JNE SCAN08 Yes, handle ERAM BL @GET No, het new line pointer in VDP DATA EXTRAM JMP SCAN09 SCAN08 BL @GETG Get new line pointer from GRAM DATA EXTRAM SCAN09 MOV R1,@PGMPTR Put new line pointer into perm SZCB @CBH40,@XFLAG Reset IFFLAG only on new line *-----------------------------------------------------------* * Following is changed for adding "nopscan" feature * * SCAN9A @PGMCHR Get 1st token on line * SCAN9A BL @PGMCHR Get 1st token on line * LI R3,PSCFG Check the flag to see which * * mode is in: NOPSCAN (>00) or PSCAN (>FF) * BL @GETV1 Get the flag from VDP * JEQ NPSCAN NOPSCAN mode * *-----------------------------------------------------------* SZCB @CBH94,@XFLAG Reset ENTER, STRFLG, and FNCFLG MOVB @XFLAG,R0 Get flag bits SLA R0,8 Shift to check REMODE JNC SCAN10 If not in REMODE MOVB R8,R8 Check if token JLT SCAN11 If token, look further ERRIBS LI R3,>1E * ILLEGAL BETWEEN SUBPROGRAMS JMP GPL05L Goto error return SCAN11 SETO R6 Set up index into table SCAN12 INC R6 Increment to 1st/next element CB R8,@IBSTAB(R6) legal stmt between subprogdams? JH SCAN12 Not able to tell, check further JL ERRIBS Illegal statement here SCAN10 CLR R6 Offset into special stmt table SCAN15 MOV @SCNTAB(R6),R3 Read entry from special table CB R3,R8 Match this token? JEQ SCAN20 Yes, handle special case JH NOCARE Didn't match but passed in tab INCT R6 Increment offset into table CI R6,TABLEN Reach end of table? JNE SCAN15 No, check further JNCARE JMP NOCARE End of table, not special case SCAN20 SLA R3,8 Look at special case byte JLT SCGPL1 If MSB set, goto GPL SWPB R3 MSB reset, offset into 9900 B @OFFSET(R3) Branch to 9900 special handler SCGPL1 B @SCNGPL FNERR B @FNNERR *-----------------------------------------------------------* * These are added for "nopscan" feature 6/8/81 * SCAN26 MOVB @PRGFLG,R0 In program mode? * JEQ SCAN5B No, check for/next subs&rtn * SCAN28 BL @PGMCHR Yes, check "!@P+" or "!@P-" * CI R8,P1*256 "@" following "!"? * JNE SCAN5A No, goto the next line * BL @PGMCHR Yes, check for "P" * CI R8,P2*256 * JEQ SCAN40 Yes, check for "+" or "-" * CI R8,P5*256 No, try "p" * JNE SCAN5A No, goto the next line * SCAN40 BL @PGMCHR Yes, check for "+" or "-" * CI R8,P3*256 * JEQ SCAN35 "!@P+" is found at the * * beginnning of the line * CI R8,P4*256 * JNE SCAN5A Didn't file what we want, * * goto the next line * LI R1,0 "!@P-" is found, set flag to * * 0 NO PSCAN * SCAN30 LI R4,PSCFG Address register for PUTV1 * BL @PUTV1 Set the flag PSCFG in VDP tem.* JMP SCAN5A Goto the next line * SCAN35 LI R1,>FF00 "!@P+", set flag to be >FF so * * RESUME PSCAN * JMP SCAN30 Use common code to set flag * *-----------------------------------------------------------* *-----------------------------------------------------------* * In NOPSCAN mode, only looking for "!@P+", "!@P-" at the * * beginning of each line 6/8/81 * NPSCAN CI R8,TREMZ*256 First token on line * * is it "!" * JEQ SCAN28 Yes, check "!@P+" or "!@P-" * B @SCAN5A No, ignore the whole line, * * just goto the next line * *-----------------------------------------------------------* OFFSET SCN26A JMP SCAN26 SCAN25 MOVB @PRGFLG,R0 In imperative mode? JEQ SCAN5C Yes, check for/next sub & rtn B @SCAN5A No, check next line SCAN5C B @SCAN5B * 9900 code special handlers IFIF SOCB @CBH40,@XFLAG Indicate scan of "IF" stmt * Special handler for program-only statements IMPER MOVB @PRGFLG,R0 Executing in a program? JNE NXTCHR Yes, proceed in don't char mode ERRIMP LI R3,>12 Illegal imperative return code GPL05L JMP GPL05 Return to GPL with error * Special handler for data-statements DATA1 MOVB @DATA,R0 Data already encountered? JNE IMAGE Yes, don't set pointer MOV @EXTRAM,@LNBUF Save line buffer pointer MOV @PGMPTR,@DATA Set line buffer pointer * Special handler for image-statements IMAGE MOVB @PRGFLG,R0 In program mode? B @SCAN5A Yes, no need to scan line JMP ERRIMP No, illegal imperative * Special handler for for-statements FOR INC @XFLAG Increment the nesting counter MOVB @XFLAG,R0 Fetch the IFFLAG ANDI R0,>4000 Inside an if-statement? JEQ NXTCHR No, continue in don't care mode SNTXER LI R3,>1A * SYNTAX ERROR JMP GPL05 * Special handler for next-statements SNEXT MOV @XFLAG,R0 Get flag and for-next counter ANDI R0,>40FF Get rid of flag bits except IF MOVB R0,R0 IFFLAG set? JNE SNTXER Yes, syntax error DEC R0 Decrement counter by one MOVB @R0LB,@FORNET Move back to the real conter JEQ NXTCHR Returning to top level, ok JGT NXTCHR Still at a secndary level, ok LI R3,>14 For/next nesting return code JMP GPL05 Return to GPL with error ELSE MOVB @XFLAG,R0 Get flag byte ANDI R0,>4000 Inside an if? JEQ SNTXER No, error * Special handler for statement seperator SEPSMT B @SCAN9A Skip the '::' and check next * General don't care scan. Simply looks for variables to * enter into symbol table; stops on end of statement NOCARE CI R8,SSEPZ*256 At a statement separator JEQ SEPSMT Skip and scan next statement CI R8,TREMZ*256 At a tail remark? JEQ SCAN25 Yes, check mode MOVB R8,R8 At an end-of-line or symbol? JEQ SCAN25 EOL, checK mode JGT ENTER Symbol, ENTER in symbol table CI R8,LNZ*256 Special line number token? JEQ SKIPLN Yes, need to skip it CI R8,NUMZ*256 Special numeric token? JEQ STRSKP Yes, need to skip it CI R8,UNQSTZ*256 Special string token? JEQ STRSKP Yes, need to skip it CI R8,THENZ*256 Hit a then-clause? JEQ ELSE Yes, treat like a stmt-sep CI R8,ELSEZ*256 Hit a else-clause? JEQ ELSE Yes, t[eat liek a stmt-sep NXTCHR BL @PGMCHR Get next token JMP NOCARE And continue loop SKIPLN INCT @PGMPTR Skip line number JMP NXTCHR And get next token STRSKP BL @PGMCHR Get length of string/number SWPB R8 Swap for add A R8,@PGMPTR Skip the string of number CLR R8 Clear LSB of character JMP NXTCHR And get next token * Code to return to GPL to handle special case or an * end-of-line return FNNERR LI R3,>16 FOR/NEXT NESTING JMP GPL05 ENTER LI R3,>10 Load return code for ENTER JMP GPL05 Goto GPL SCNGPL ANDI R3,>7F00 Throw away GPL flag SRL R3,8 Shift to use as index for rtn GPL05 MOV @RTNADD,*R9 Make sure right GROM address A R3,*R9 Add offset to old GROM address BL @SAVREG Save R8/R9 in CHAT/SUBSTK BL @GETSTK Restore old GROM address B @RESET Goto GPL w/condition reset ************************************************************* * Table of specially scanned statements * * 2 bytes / special token * * Byte 1 - token value * * Byte 2 - "address" of special handler * * If MSB set then GPL and rest is offset from * * the XML that got us here * * If MSB reset then 9900 code and is offset from * * label OFFSET in this assembly of the special * * case handler * ************************************************************* SCNTAB BYTE ELSEZ,ELSE-OFFSET BYTE SSEPZ,SEPSMT-OFFSET *-----------------------------------------------------------* * Change the following line for searching for !@P- at the * * beginning of line * * BYTE TREMZ,SCAN25-OFFSET * BYTE TREMZ,SCN26A-OFFSET *-----------------------------------------------------------* BYTE IFZ,IFIF-OFFSET BYTE GOZ,IMPER-OFFSET BYTE GOTOZ,IMPER-OFFSET BYTE GOSUBZ,IMPER-OFFSET BYTE RETURZ,IMPER-OFFSET BYTE DEFZ,>82 BYTE DIMZ,>84 BYTE FORZ,FOR-OFFSET BYTE INPUTZ,IMPER-OFFSET BYTE DATAZ,DATA1-OFFSET BYTE NEXTZ,SNEXT-OFFSET BYTE REMZ,SCAN25-OFFSET BYTE ONZ,IMPER-OFFSET BYTE CALLZ,>86 BYTE OPTIOZ,>88 BYTE SUBZ,>8A BYTE IMAGEZ,IMAGE-OFFSET BYTE SUBXTZ,>8C BYTE SUBNDZ,>8E BYTE LINPUZ,IMPER-OFFSET BYTE THENZ,ELSE-OFFSET TABLEN EQU $-SCNTAB IBSTAB BYTE SSEPZ BYTE TREMZ BYTE ENDZ BYTE REMZ BYTE SUBZ BYTE >FF ******************************************************************************** AORG >7EA6 TITL 'GREADS' * (RAM to RAM) * Read data from ERAM * @GSRC : Source address on ERAM * @DEST : Destination address in CPU * Where the data stored after read from ERAM * @BCNT3 : byte count GREAD1 LI R3,BCNT3 # of bytes to move LI R2,GSRC Source in ERAM LI R1,DEST Destination in CPU JMP GRZ1 Jump to common routine * Read data from ERAM to CPU * @ADDR1 : Source address on ERAM * @ADDR2 : Destination address in CPU * Where the data stored after read from ERAM * @BCNT1 : byte count GREAD LI R3,BCNT1 # of bytes to move LI R2,ADDR1 Source in ERAM LI R1,ADDR2 Destination in CPU * Common ERAM to CPU transfer routine GRZ1 MOV *R2,R4 GRZ2 MOVB *R4+,*R1+ Move byte from ERAM to CPU DEC *R3 One less to move, done? JNE GRZ2 No, copy the rest RT ******************************************************************************** AORG >7ECA TITL 'GWRITES' * (RAM to RAM) * Write the data whcih is stored in CPU to ERAM * @GDST : Destination address on ERAM where data is going * to be stored * @CSRC : Soruce address on CPU where data stored * @BCNT2 : byte count GWITE1 LI R3,BCNT2 Count LI R2,GDST Destination LI R1,CSRC Source JMP GWZ1 * Write the data which is stored in CPU to ERAM * @ADDR1 : Destination address on ERAM where data is going * to be stroed * @ADDR2 : Source address on CPU where dta is stored * @BCNT1 : byte count GWRITE LI R3,BCNT1 Count LI R2,ADDR1 Destination LI R1,ADDR2 Source * Common routine to copy from CPU to ERAM GWZ1 EQU $ MOV *R2,R4 Get distination address MOV *R1,R1 Get CPU RAM address AI R1,PAD0 Add in CPU offset GWZ2 MOVB *R1+,*R4+ Move a byte DEC *R3 One less to move, done? JNE GWZ2 No, more to move RT ******************************************************************************** AORG >7EF4 TITL 'DELREPS' * Delete the text in crunched program on VDP or ERAM * point to the line # (to be deleted) in the line # table * RAMTOP 0 if no ERAM * ENLN Last location used by the line # table * STLN First location used by the line # table * DELREP MOV R11,R8 Save return INCT @EXTRAM Point to line ptr in table MOV @EXTRAM,R3 Prepare to read it MOV @RAMTOP,R7 Check ERAM flag & get in reg JNE DE01 ERAM, get from it BL @GET1 Get line ptr from VDP JMP DE02 DE01 BL @GETG2 Get line ptr from ERAM DE02 DEC R1 Point to line length MOV R1,R3 Prepare to read length MOV R1,R9 Save copy for use later MOV R7,R7 Editing in ERAM? JNE DE03 ERAM, get length from it BL @GETV1 Get line length from VDP JMP DE04 DE03 MOVB *R3,R1 DE04 MOVB R1,R2 Move text length for use SRL R2,8 Need as a word INC R2 Text length = length + length * byte MOV @ENLN,R3 Get end of line # table INC R3 Adjust for inside loop * UPDATE THE LINE # TABLE DEREA DECT R3 Point to line pointer MOV R7,R7 Editing in ERAM? JNE DE05 ERAM, read it as such BL @GET1 Get line pointer from VDP JMP DE06 DE05 BL @GETG2 Get line pointer from ERAM DE06 MOV R1,R5 Move for use DEC R5 Point to length byte C R9,R5 Compare location of delete * line & this line JLE DEREB This line won't move , * don't fix pointer A R2,R1 Add distance to move to pointer MOV R3,R4 Write it to same place MOV R7,R7 Editing in ERAM? JNE DE10 Yes BL @PUT1 Put back into line # table JMP DEREB DE10 BL @PUTG2 Put back into line # table DEREB DECT R3 Point at the line # C R3,@STLN At last line in table? JNE DEREA No, loop for more * UPDATA OF LINE # TABLE IS COMPLETE, NOW DELETE TEXT * R9 still contains pointer to length byte of text to delete * R2 still contains text length DEC R9 MOV R9,R3 MOV R9,R5 A R2,R5 Point to 1st token MOV R3,R1 Save for later use S @STLN,R1 VDP, calculate # of bytes to move INC R1 Correct offset by one BL @MVDN2 Delete the text * NOW SET UP POINTERS TO LINE TABLE DE18 LI R1,EXTRAM Start with EXTRAM A R2,*R1+ Update EXTRAM A R2,*R1+ Update STLN A R2,*R1 Update ENLN B *R8 And return ******************************************************************************** AORG >7F7E TITL 'MVDNS' * (VDP to VDP) or (RAM to RAM) * WITHOUT ERAM : Move the contents in VDP RAM from a lower * address to a higher address avoiding a * possible over-write of data * >835C ARG : byte count * >8300 VAR0 : source address * >8306 VARY2 : destination address * WITH ERAM Same as above except moves ERAM to ERAM MVDN MOV @ARG,R1 Get byte count MOV @VARY2,R5 Get destination MOV @VAR0,R3 Get source MVDN2 MOV @RAMTOP,R7 ERAM or VDP? JNE MV01 ERAM, so handle it JMP MV05 VDP, so jump into loop MVDN1 DEC R5 DEC R3 MV05 EQU $ MOVB @R3LB,*R15 Write out read address MOVB R3,*R15 MOVB @XVDPRD,R7 Read a byte MOVB @R5LB,*R15 Write out write address ORI R5,WRVDP Enable VDP write MOVB R5,*R15 MOVB R7,@XVDPWD Write the byte DEC R1 One less byte to move JNE MVDN1 Loop if more to move RT MV01 EQU $ MVDNZ1 MOVB *R3,*R5 Move a byte DEC R3 Decrement destination DEC R5 Decrement source DEC R1 One less byte to move JNE MVDNZ1 Loop if more to move RT ******************************************************************************** AORG >7FC0 TITL 'VGWITES' * (VDP to RAM) >834C=ADDR1,>8350=ADDR2,>834E=BCNT1 * Move data from VDP to ERAM * @ADDR1 : Source address where the data stored on VDP * @ADDR2 : Destination address on ERAM * @BCNT1 : byte count VGWITE EQU $ MOVB @ADDR11,*R15 LSB of VDP address MOV @ADDR2,R2 Address in ERAM MOVB @ADDR1,*R15 MSB of VDP address NOP VGZ1 MOVB @XVDPRD,*R2+ Move a byte DEC @BCNT1 One less to move JNE VGZ1 If not done, loop for more RT Return ******************************************************************************** AORG >7FDA TITL 'GVWITES' * Move data from ERAM to VDP (RAM to VDP) * @GSRC : Source address where the data stored on ERAM * @DEST : Destination address on VDP * @BCNT3 : byte count GVWITE MOV @DEST,R2 VDP address MOVB @R2LB,*R15 LSB of VDP address ORI R2,WRVDP Enable VDP write MOVB R2,*R15 MSB of VDP address MOV @GSRC,R3 ERAM address GVZ1 MOVB *R3+,@XVDPWD Move a byte DEC @BCNT3 One less to move JNE GVZ1 If not done, loop for more RT Return AORG >7FFE DATA >9226 ******************************************************************************** END