CP/M

home *** CD-ROM | disk | FTP | other *** search

/ CP/M / CPM_CDROM.iso / simtel / cpmug / cpmug030.ark / BASIC.PLM < prev next >

Wrap

Text File | 1984-04-29 | 38.1 KB | 997 lines

BASCOM: DO; /* BASIC - E COMPILER MODIFIED FOR RESIDENT OPERATION BY GARY A. KILDALL, DIGITAL RESEARCH, PACIFIC GROVE, CA. VERSION 1.4 - ORIGINAL DISTRIBUTION BY EUBANKS, NPS, VERSION 1.5 - FIXES UNINITIALIZED STORAGE PROBLEMS WFCB(32) = 0, RFCB(12) = 0, CONT = 0 HASHTABLE = 0...0 ALLOWS $ PARAMETERS IN CALL, RATHER THAN PROGRAM */ DECLARE JMPTOMAIN (3) BYTE DATA(0C3H,0,0); /* FILLED WITH DDT */ /* ********************************************************* * * * BASIC-E COMPILER * * * * U. S. NAVY POSTGRADUATE SCHOOL * * MONTEREY, CALIFORNIA * * * * WRITTEN BY GORDON EUBANKS, JR. * * * * CPM VERSION 1.4 * * * * DECEMBER 1976 * * * ********************************************************* */ /* ********************************************************* * * * THE BASIC-E COMPILER IS DIVIDED INTO THE FOLLOW- * * ING MAJOR SECTIONS: * * (1) GLOBAL DECLERATIONS AND LITERAL * * DEFINITIONS * * (2) SYSTEM INPUT OUTPUT ROUTINES AND * * ASSOCIATED VARIABLE DECLERATIONS * * (3) SCANNER * * (4) SYMBOL TABLE ROUTINES * * (5) PARSER AND CODE GENERATION * * * * BASIC-E REQUIRES A SOURCE PROGRAM AVAILABLE ON * * AN INPUT DEVICE AND WILL WRITE A BINARY OUTPUT * * FILE WHICH MAY BE EXECUTED BY THE RUN TIME * * MONITOR. THE SOURCE MUST BE READ TWICE. * * THE NORMAL OUTPUT DEVICE IS THE CONSOLE. * * * * MODIFICATION OF THE COMPILER FOR OTHER OPERATING * * SYSTEMS WILL REQUIRE MODIFICATIONS TO SECTION * * (2) AND IN SECTION 1 REDEFINITION OF LITERALS IN * * SECTIONS "SYSTEM PARAMETERS WHICH MAY REQUIRE * * MODIFICATION BY USERS" AND "EXTERNAL ENTRY * * POINTS". OTHER CHANGES SHOULD NOT BE REQUIRED * * * ********************************************************* */ /* ********************************************************** * * * **** SECTION 1 **** * * * ********************************************************** */ /* ********************************************************* * * * GLOBAL LITERALS * * * ********************************************************* */ $INCLUDE(:F1:BASCOM.LIT) /* ********************************************************* * * * EXTERNAL ENTRY POINTS * * THESE ENTRY POINTS ALLOW INTERFACING WITH CP/M * * * ********************************************************* */ DECLARE BDOS LIT '05H', /* ENTRY POINT TO CP/M */ PARMS LIT '6DH', /* $ PARAMETERS */ BOOT LIT '0H'; /* RETURN TO SYSTEM */ MON1: PROCEDURE(F,A); DECLARE F BYTE, A ADDRESS; /* PATCHED WITH JMP 0005 */ L: GO TO L; END MON1; MON2: PROCEDURE(F,A) BYTE; DECLARE F BYTE, A ADDRESS; /* PATCHED WITH JMP 0005 */ L: GO TO L; RETURN 0; END MON2; MON3: PROCEDURE PUBLIC; /* USED TO RETURN TO CP/M */ DECLARE A ADDRESS; A = BOOT; CALL A; END MON3; /* ********************************************************* * * * GLOBAL VARIABLES * * * ********************************************************* */ DECLARE PASS1 BYTE PUBLIC INITIAL(TRUE), /* PASS1 FLAG */ PASS2 BYTE PUBLIC INITIAL(FALSE), /* PASS2 FLAG */ /* COMPILER TOGGLES */ LISTPROD BYTE PUBLIC INITIAL(FALSE), LISTSOURCE BYTE PUBLIC INITIAL(FALSE), DEBUGLN BYTE PUBLIC INITIAL(FALSE), LOWERTOUPPER BYTE INITIAL(TRUE), NOINTFILE BYTE INITIAL(FALSE), LSTFLAG BYTE INITIAL(FALSE), /* LST DEVICE IF 'F' */ ERRSET BYTE INITIAL(FALSE), ERRORCOUNT ADDRESS PUBLIC INITIAL(0), COMPILING BYTE PUBLIC, DATACT ADDRESS PUBLIC, /* COUNTS SIZE OF DATA AREA */ /* FLAGS USED DURING CODE GENERATION */ FORSTMT BYTE PUBLIC, RANDOMFILE BYTE PUBLIC, FILEIO BYTE PUBLIC, INPUTSTMT BYTE PUBLIC, GOSUBSTMT BYTE PUBLIC, /* THE FOLLOWING GLOBAL VARIABLES ARE USED BY THE SCANNER */ TOKEN BYTE PUBLIC, /* TYPE OF TOKEN JUST SCANNED */ SUBTYPE BYTE PUBLIC, /* SUBTYPE OF CURRENT TOKEN */ FUNCOP BYTE PUBLIC, /* IF TOKEN FUNC THEN THIS IS FUNC NUMBER */ HASHCODE BYTE PUBLIC, /* HASH VALUE OF CURRENT TOKEN */ NEXTCHAR BYTE PUBLIC, /* CURRENT CHARACTER FROM GETCHAR */ ACCUM(IDENTSIZE) BYTE PUBLIC, /* HOLDS CURRENT TOKEN */ ACCLEN BYTE PUBLIC AT(.ACCUM(0)), /* ACCUM 0 IS LENGTH */ CONT BYTE PUBLIC, /* INDICATES ACCUM WAS FULL, STILL MORE */ COLUMN BYTE INITIAL(0), /* CURRENT COLUMN */ /* ************************************************** * * * THE FOLLOWING LITERAL DEFINITIONS ESTABLISH * * MNEMONIC NAMES FOR THE TOKENS WHICH ARE THE * * OUTPUT OF THE LALR PARSER PROGRAM. * * * ************************************************** */ POUND LIT '12', LPARN LIT '02', RPARN LIT '05', ASTRK LIT '04', TPLUS LIT '03', TMINUS LIT '07', LESST LIT '01', TCOLIN LIT '11', SCOLN LIT '06', EXPON LIT '14', EQUAL LIT '13', GTRT LIT '10', TDATA LIT '99', TAND LIT '24', TCR LIT '23', TELSE LIT '34', TDEF LIT '25', TDIM LIT '26', TFOR LIT '28', TEND LIT '27', TFILE LIT '35', TIF LIT '17', TGOSB LIT '43', TGOTO LIT '36', TNEXT LIT '37', TINPT LIT '44', TLET LIT '29', SLASH LIT '08', TNOT LIT '30', TON LIT '20', TOR LIT '21', TPRNT LIT '45', TREAD LIT '38', TREST LIT '48', TRETN LIT '46', TSTEP LIT '39', TSTOP LIT '40', TTHEN LIT '41', TTO LIT '22', FUNCT LIT '53', TGEQ LIT '15', TSUB LIT '32', TLEQ LIT '18', COMMA LIT '09', TGO LIT '16', TNE LIT '19', TCLOS LIT '42', TXOR LIT '33', TOUT LIT '31', TIRN LIT '51', STRING LIT '50', IDENTIFIER LIT '52', FLOATPT LIT '49', UDFUNCT LIT '54', TREM LIT '0'; /* ********************************************************* * * * **** SECTION 2 **** * * * * SYSTEM DEPENDENT ROUTINES AND VARIABLES * * * * THE FOLLOWING ROUTINES ARE USED * * BY THE COMPILER TO ACCESS DISK * * FILES AND THE CONSOLE. THESE * * ROUTINES ASSUME THE USE OF THE * * CP/M DISK OPERATING SYSTEM. * * * * THE FCB'S ARE USED BY THE SYSTEM TO MAINTAIN * * INFORMATION ON OPEN FILES. THEY ARE ONLY USED * * BY PROCEDURES IN THIS SECTION. THE BUFFERS * * AND POINTERS TO THE BUFFERS ARE USED BY THE * * REMAINDER OF THE PROGRAM BUT THEIR SIZE MAY * * BE VARIED TO SUIT THE DISK SYSTEM BEING USED * * * ********************************************************* */ DECLARE PARMLIST(9) BYTE INITIAL(' '), /* $ PARAMS SAVED HERE */ RFCBADDR ADDRESS INITIAL(5CH), /* NOTE: CP/M PROVIES 5CH AS FCB AREA AND 80H AS A BUFFER FOR PROGRAM USE */ RFCB BASED RFCBADDR(33) BYTE, /* SOURCE FCB */ WFCB(33) BYTE /* INTERMEDIATE FILE FCB */ INITIAL(0,' ','INT',0,0,0,0), SBLOC ADDRESS INITIAL(80H), SOURCEBUFF BASED SBLOC(SOURCERECSIZE)BYTE, /* SOURCE BUFFER */ SOURCEPTR BYTE INITIAL(SOURCERECSIZE), /* BUFFER INDEX */ CURSOURCERECSIZE BYTE INITIAL(SOURCERECSIZE), DISKOUTBUFF(INTRECSIZE) BYTE, BUFFPTR BYTE INITIAL(255), /* BUFFER INDEX */ LINEBUFF(CONBUFFSIZE) BYTE, /* CONSOLE OUT BUFFER */ LINEPTR BYTE INITIAL(0), /* BUFFER INDEX */ LINENO ADDRESS PUBLIC, /* CURRENT LINE NUMBER */ SEPARATOR BYTE PUBLIC INITIAL(COLIN); DECLARE PCHAR LIT '2', /* CHAR TO CONSOLE */ PBUFF LIT '9', /* BUFFER TO CONSOLE */ RCHAR LIT '1', /* CHAR FROM CONSOLE */ RBUFF LIT '10', /* BUFFER FROM CONSOLE */ OFILE LIT '15', /* OPEN FILE */ CFILE LIT '16', /* CLOSE FILE */ DFILE LIT '19', /* DELETE FILE */ RFILE LIT '20', /* READ FILE */ WFILE LIT '21', /* WRITE FILE */ MFILE LIT '22', /* MAKE FILE */ SDMA LIT '26', /* SET DMA */ FILEERR LIT '255', /* ERROR RTN CODE */ FILEEOF LIT '1'; /* EOF RTN CODE */ MOVE: PROCEDURE (SOURCE,DEST,COUNT) PUBLIC; DECLARE SOURCE ADDRESS, DEST ADDRESS, COUNT BYTE, SCHAR BASED SOURCE BYTE, DCHAR BASED DEST BYTE; DO WHILE(COUNT := COUNT -1) <> 255; DCHAR = SCHAR; SOURCE = SOURCE + 1; DEST = DEST + 1; END; RETURN; END MOVE; FILL: PROCEDURE (DEST,CHAR,COUNT) PUBLIC; /* MOVE CHAR TO A N TIMES */ DECLARE DEST ADDRESS, CHAR BYTE, COUNT BYTE, DCHAR BASED DEST BYTE; DO WHILE (COUNT := COUNT -1) <> 255; DCHAR = CHAR; DEST = DEST + 1; END; RETURN; END FILL; CHAROUT: PROCEDURE(CHAR); DECLARE CHAR BYTE; IF LSTFLAG THEN /* GO TO THE LIST DEVICE */ CALL MON1(5,CHAR); ELSE CALL MON1(2,CHAR); END CHAROUT; PRINTCHAR: PROCEDURE(CHAR); DECLARE CHAR BYTE; /* CHECK FOR TABS AND END OF LINE */ IF CHAR = TAB THEN /* EXPAND TO NEXT COLUMN */ DO WHILE ((COLUMN := COLUMN + 1) AND 7) <> 0; CALL CHAROUT(' '); END; ELSE DO; COLUMN = COLUMN + 1; CALL CHAROUT(CHAR); IF CHAR = LF THEN COLUMN = 0; END; END PRINTCHAR; PRINT: PROCEDURE(A) PUBLIC; DECLARE A ADDRESS; DECLARE MSG BASED A BYTE; DO WHILE MSG <> '$'; CALL PRINTCHAR(MSG); A = A + 1; END; END PRINT; DISKERR: PROCEDURE; CALL PRINT(.('DE $')); CALL MON3; /* RETURN TO SYSTEM */ RETURN; END DISKERR; OPEN$SOURCEFILE: PROCEDURE; /* SETS UP THE FCB FOR THE SOURCE PROGRAM WHICH MUST BE OF TYPE 'BAS' AND THEN OPENS THE FILE. CP/M PUTS THE NAME USED AS A PARAMETER WHEN THE COMPILER IS EXECUTED, AT 5CH. */ CALL MOVE(.('BAS'),RFCBADDR+9,3); RFCB(32),RFCB(12) = 0; IF MON2(OFILE,RFCBADDR) = FILEERR THEN DO; CALL PRINT(.('NS $')); CALL MON3; /* RETURN TO SYSTEM */ END; END OPEN$SOURCEFILE; REWIND$SOURCE$FILE: PROCEDURE PUBLIC; /* CP/M DOES NOT REQUIRE ANY ACTION PRIOR TO REOPENING */ RETURN; END REWIND$SOURCE$FILE; CLOSE$INT$FILE: PROCEDURE PUBLIC; IF MON2(CFILE,.WFCB) = FILEERR THEN CALL DISKERR; END CLOSE$INT$FILE; SETUP$INT$FILE: PROCEDURE PUBLIC; /* MAKES A NEW FILE */ IF NOINTFILE THEN /* ONLY MAKE FILE IF THIS TOGGLE IS OFF */ RETURN; CALL MOVE(.RFCB,.WFCB,9); CALL MON1(DFILE,.WFCB); IF MON2(MFILE,.WFCB) = FILEERR THEN CALL DISKERR; WFCB(32) = 0; /* ZERO NEXT RECORD */ END SETUP$INT$FILE; READ$SOURCE$FILE: PROCEDURE BYTE; DECLARE DCNT BYTE; IF(DCNT := MON2(RFILE,RFCBADDR)) > FILEEOF THEN CALL DISKERR; RETURN DCNT; /* ZERO IF READ ELSE 1 IF EOF - ERRORS > 1 */ END READ$SOURCE$FILE; WRITE$INT$FILE: PROCEDURE PUBLIC; IF NOINTFILE THEN RETURN; CALL MON1(SDMA,.DISKOUTBUFF); IF MON2(WFILE,.WFCB) <> 0 THEN CALL DISKERR; CALL MON1(SDMA,80H); /* RESET DMA ADDRESS */ END WRITE$INT$FILE; CRLF: PROCEDURE PUBLIC; CALL PRINTCHAR(EOLCHAR); CALL PRINTCHAR(LF); RETURN; END CRLF; PRINT$DEC: PROCEDURE(VALUE) PUBLIC; /* CONVERTS VALUE TO A DECIMAL NUMBER WHICH IS PRINTED ON THE CONSOLE. USED FOR LINENUMBERING STATEMENTS AND TO PRINT PRODUCTIONS. */ DECLARE VALUE ADDRESS, I BYTE, FLAG BYTE, COUNT BYTE; DECLARE DECIMAL(4) ADDRESS DATA(1000,100,10,1); FLAG = FALSE; DO I = 0 TO 3; COUNT = 30H; DO WHILE VALUE >= DECIMAL(I); VALUE = VALUE - DECIMAL(I); FLAG = TRUE; COUNT = COUNT + 1; END; IF FLAG OR (I >= 3) THEN CALL PRINTCHAR(COUNT); ELSE CALL PRINTCHAR(' '); END; RETURN; END PRINTDEC; SETFLAGS: PROCEDURE PUBLIC; /* RESET COMPILER FLAGS USED DURING PARSING */ RANDOMFILE,FILEIO, INPUTSTMT, FORSTMT, GOSUBSTMT = FALSE; END SETFLAGS; /* ********************************************************* * * * THE FOLLOWING ROUTINE GENERATES THE INTERMEDIATE * * LANGUAGE FILE. EMIT IS THE ONLY ROUTINE TO * * ACTUALLY WRITE TO THE DISK. GENERATE, EMITDAT, * * AND EMITCON CALL EMIT. * * * ********************************************************* */ EMIT: PROCEDURE(OBJCODE) PUBLIC; DECLARE OBJCODE BYTE; IF (BUFFPTR:=BUFFPTR + 1) >= INTRECSIZE THEN /* WRITE TO DISK */ DO; CALL WRITE$INT$FILE; BUFFPTR = 0; END; DISKOUTBUFF(BUFFPTR) = OBJCODE; RETURN; END EMIT; /* ********************************************************* * * * *** SCANNER SECTION *** * * * ********************************************************* */ CLEAR$LINE$BUFF: PROCEDURE; CALL FILL(.LINEBUFF,' ',CONBUFFSIZE); END CLEAR$LINE$BUFF; LIST$LINE: PROCEDURE(LENGTH); DECLARE LENGTH BYTE, I BYTE; CALL PRINT$DEC(LINENO); CALL PRINT$CHAR(SEPARATOR); CALL PRINT$CHAR(' '); DO I = 0 TO LENGTH; CALL PRINT$CHAR(LINEBUFF(I)); END; CALL CRLF; CALL CLEAR$LINE$BUFF; SEPARATOR = COLIN; END LIST$LINE; /* ********************************************************** * * * GETCHAR SETS THE GLOBAL VARIABLE NEXTCHAR TO THE * * NEXT SOURCEFILE CHARACTER AND RETURNS NEXTCHAR TO * * THE CALLING ROUTINE. * * * * TABS ARE REPLACED WITH A BLANK AND IF EITHER * * LISTSOURCE IS TRUE OR AN ERROR HAS OCCURED LINES * * ARE OUTPUT TO THE CONSOLE. * * * ********************************************************** */ GETCHAR: PROCEDURE BYTE PUBLIC; DECLARE ADDEND(*) BYTE DATA ('END',EOLCHAR,LF); /*TO ADD END IF LEFT OFF */ NEXT$SOURCE$CHAR: PROCEDURE BYTE; RETURN SOURCEBUFF(SOURCEPTR); END NEXT$SOURCE$CHAR; CHECKFILE: PROCEDURE BYTE; /* CHECKFILE MAINTAINS THE SOURCE BUFFER FULL AND CHECKS FOR END OF FILE ON THE SOURCE FILE. IF A LINE FEED IS FOUND IT IS SKIPPED. IF END OF FILE IS DETECTED THEN TRUE IS RETURNED ELSE FALSE IS RETURNED. */ DO FOREVER; /* ALLOW US TO SKIP LINE FEEDS */ IF (SOURCEPTR := SOURCEPTR + 1) >= CURSOURCERECSIZE THEN DO; SOURCEPTR = 0; IF READ$SOURCE$FILE = FILEEOF THEN RETURN TRUE; END; IF (NEXTCHAR := NEXT$SOURCE$CHAR) <> LF THEN RETURN FALSE; END; /* OF DO FOREVER */ END CHECKFILE; IF CHECKFILE OR (NEXTCHAR = EOFFILLER) THEN DO; /* EOF REACHED */ CALL MOVE(.ADDEND,SBLOC,5); SOURCEPTR = 0; NEXTCHAR = NEXT$SOURCE$CHAR; END; IF LINEPTR < CONBUFFSIZE THEN LINEBUFF(LINEPTR := LINEPTR + 1) = NEXTCHAR; /* OUTPUT LINE */ IF NEXTCHAR = EOLCHAR THEN DO; LINENO = LINENO + 1; IF LISTSOURCE OR ERRSET THEN CALL LISTLINE(LINEPTR - 1); /* NOT EOLCHAR */ LINEPTR = 0; END; IF NEXTCHAR = TAB THEN NEXTCHAR = ' '; /* ONLY NEED REPLACE WITH 1 BLANK */ RETURN NEXTCHAR; END GETCHAR; GETNOBLANK: PROCEDURE; DO WHILE((GETCHAR = ' ') OR (NEXTCHAR = EOFFILLER)); END; RETURN; END GETNOBLANK; CHECK$CONTINUATION: PROCEDURE; /* CHECK FOR CONTINUATION CHAR. IF FOUND SET NEXTCHAR TO FIRST CHARACTER ON NEXT LINE. IT THEN LOOKS TO THE PARSER AS IF IT WAS ALL ONE LINE. */ IF NEXTCHAR = CONTCHAR THEN DO; DO WHILE GETCHAR <> EOLCHAR; END; CALL GETNOBLANK; END; RETURN; END CHECK$CONTINUATION; /* ********************************************************** * * * ERROR IS THE COMPILER ERROR HANDLING ROUTINE * * IF AN ERROR IS DETECTED WHILE PARSING A STATEMENT * * THE REMAINDER OF THE STATEMENT IS SKIPPED AND THE * * STATEMENT IS WRITTEN ON THE CONSOLE FOLLOWED BY A * * TWO LETTER DISCRIPTION OF THE ERROR. AN UP ARROR * * INDICATES WHERE IN THE LINE THE ERROR WAS DETECTED * * THE PARSER IS RESET AND COMPILATION CONTINUES WITH * * THE NEXT STATEMENT. * * * ********************************************************** */ ERROR: PROCEDURE(ERRCODE) PUBLIC; DECLARE ERRCODE ADDRESS, POINTER BYTE; POINTER = LINEPTR + 2; IF PASS2 THEN ERRSET = TRUE; /* SO SOURCE LINE WILL BE LISTED */ IF TOKEN <> TCR THEN DO; /* SKIP REMAINDER OF LINE */ DO WHILE NEXTCHAR <> EOLCHAR; CALL CHECK$CONTINUATION; NEXTCHAR = GETCHAR; END; CALL GET$NO$BLANK; END; IF PASS2 THEN DO; /* PRINT ERROR MESSAGE */ ERRORCOUNT = ERRORCOUNT + 1; CALL PRINTCHAR(HIGH(ERRCODE)); CALL PRINTCHAR(LOW(ERRCODE)); CALL PRINTCHAR(QUESTIONMARK); DO WHILE(POINTER:=POINTER - 1) >= 1; CALL PRINTCHAR(' '); END; CALL PRINTCHAR(UPARROW); CALL CRLF; END; ERRSET, COMPILING = FALSE; CALL SETFLAGS; RETURN; END ERROR; /* ********************************************************* * * * INITIALIZE$SCANNER SETS NEXTCHAR TO THE FIRST * * NON-BLANK CHARACTER ON THE INPUT FILE AND * * INITIALIZES THE OUTPUTLINE COUNTER AND POINTER * * * * INITIALIZE$SCANNER IS CALLED AT THE BEGINNING OF * * PASS ONE AND PASS TWO. * * * ********************************************************* */ IN$SCANNER: PROCEDURE PUBLIC; DECLARE COUNT BYTE; DECLARE I BYTE; IF PASS1 THEN /* GET PARAMETER LIST */ CALL MOVE(PARMS,.PARMLIST,8); /* LAST BLANK IS LEFT UNFILLED */ CALL OPEN$SOURCEFILE; CONT,COLUMN,LINENO,LINEPTR = 0; CALL CLEAR$LINE$BUFF; SOURCEPTR = SOURCERECSIZE; SEPARATOR = COLIN; CALL GETNOBLANK; IF PARMLIST(0) = '$' THEN DO; I = 0; DO WHILE (COUNT := PARMLIST(I:=I+1)) <> ' '; IF(COUNT := COUNT - 'A') <= 5 THEN DO CASE COUNT; LISTPROD = TRUE; LISTSOURCE = FALSE; NOINTFILE = TRUE; LOWERTOUPPER = FALSE; DEBUGLN = TRUE; LSTFLAG = TRUE; END; /* OF CASE */ END; END; END IN$SCANNER; /* ********************************************************* * * * THE SCANNER ACCEPTS INPUT CHARACTERS FROM THE * * SOURCE FILE RETURNING TOKENS TO THE PARSER. * * CONVERSION TO UPPERCASE IS PERFORMED WHEN SCAN- * * NING IDENTIFIERS UNLESS LOWERTOUPPER IS FALSE. * * BLANKS ARE IGNORED. EACH TOKEN IS PLACED IN * * ACCUM. ACCLEN IS THE LENGTH OF THE TOKEN. * * THE TOKEN IS HASHCODED BY SUMMING EACH ASCII * * CHARACTER MODULO HASHTBLSIZE AND THE RESULT IS * * RETURNED IN HASHCODE. SUBTYPE AND FUNCOP ARE * * SET IF THE TOKEN IS A PREDEFINED FUNCTION. * * REM AND DATA STATEMENTS ARE HANDLED COMPLETELY * * BY THE SCANNER. IF THE RESERVED WORD REM OR * * REMARK IS DETECTED THE INPUT IS SCANNED UNTIL * * THE END OF THE CURRENT INPUT LINE IS LOCATED. * * THE NEXT TOKEN (A CARRIAGE RETURN) IS THEN * * SCANNED AND RTURNED. DATA STATEMENTS ARE SIMILAR * * EXCEPT THE DATA IS WRITTEN OUT USEING EMITDAT * * * ********************************************************* */ SCANNER: PROCEDURE PUBLIC; /* ********************************************************** * * * THE FOLLOWING UTILITY PROCEDURES ARE USED BY THE * * SCANNER. * * * ********************************************************** */ PUTINACCUM: PROCEDURE; IF NOT CONT THEN DO; ACCUM(ACCLEN := ACCLEN + 1) = NEXTCHAR; HASHCODE = (HASHCODE + NEXTCHAR) AND HASHMASK; IF ACCLEN >= (IDENTSIZE - 1) THEN CONT = TRUE; END; RETURN; END PUTINACCUM; PUTANDGET: PROCEDURE; CALL PUTINACCUM; CALL GETNOBLANK; RETURN; END PUTANDGET; PUTANDCHAR: PROCEDURE; CALL PUTINACCUM; NEXTCHAR = GETCHAR; RETURN; END PUTANDCHAR; NUMERIC: PROCEDURE BYTE; RETURN(NEXTCHAR - '0') <= 9; END NUMERIC; LOWERCASE: PROCEDURE BYTE; RETURN (NEXTCHAR >= 61H) AND (NEXTCHAR <= 7AH); END LOWER$CASE; DECIMALPT: PROCEDURE BYTE; RETURN NEXTCHAR = '.'; END DECIMALPT; CONV$TO$UPPER: PROCEDURE; IF LOWERCASE AND LOWERTOUPPER THEN NEXTCHAR = NEXTCHAR AND 5FH; RETURN; END CONV$TO$UPPER; LETTER: PROCEDURE BYTE; CALL CONV$TO$UPPER; RETURN ((NEXTCHAR - 'A') <= 25) OR LOWERCASE; END LETTER; ALPHANUM: PROCEDURE BYTE; RETURN NUMERIC OR LETTER OR DECIMALPT; END ALPHANUM; SPOOLNUMERIC: PROCEDURE; DO WHILE NUMERIC; CALL PUTANDCHAR; END; RETURN; END SPOOLNUMERIC; SETUP$NEXT$CALL: PROCEDURE; IF NEXTCHAR = ' ' THEN CALL GETNOBLANK; CONT = FALSE; RETURN; END SETUP$NEXT$CALL; EMITDAT: PROCEDURE(OBJCODE); /* WRITES DATA STATEMENTS DURING PASS2 AND COUNTS SIZE OF DATA AREA. */ DECLARE OBJCODE BYTE; DATACT = DATACT + 1; IF PASS2 THEN CALL EMIT(OBJCODE); RETURN; END EMITDAT; /* ********************************************************* * * * LOOKUP IS CALLED BY THE SCANNER WITH THE * * PRINTNAME OF THE CURRENT TOKEN IN * * THE ACCUMULATOR. LOOKUP DETERMINES IF THIS * * TOKEN IS A RESERVED WORD AND SETS THE * * VALUE OF TOKEN. IF THE TOKEN IS A PREDEFINED * * FUNCTION THEN THE SUBTYPE AND FUNCOP ARE ALSO * * SET. * * THE RESERVED WORD TABLE IS DIVIDED INTO 7 * * TABLES FOR RESERVED WORDS OF LENGTH 1 TO 7. * * THE FOLLOWING VECTORS ARE ALSO USED: * * TK - TOKEN ASSOCIATED WITH RESERVED WORD * * OFFSET - INDEX INTO LNG VECTOR FOR A GIVEN * * R/W LENGTH * * COUNT - NUMBER OF R/W OF A GIVEN LENGTH * * TKOS - INDEX INTO TK FOR A GIVEN R/W LENGTH * * ST - SPECIAL DATA FOR PREDEFINED FUNCTIONS * * * * PREDEFINED FUNCTIONS HAVE TOKEN VALUES >64. * * THIS NUMBER BECOMES THE FUNCOP AND THE TOKEN * * IS FUNCT. FUNCOP IS THE MACHINE CODE FOR THE * * PARTICULAR PREDEFINED FUNCTION. * * * ********************************************************* */ LOOKUP: PROCEDURE BYTE; DECLARE MAXRWLNG LIT '9'; /* MAX LENGTH OF A RESERVED WORD */ DECLARE LNG1(*) BYTE DATA(EOLCHAR,'<','(','+','*',')','-',',','=','/', ';','>',':',POUNDSIGN,UPARROW), /* 15 */ LNG2(*) BYTE DATA('IF','TO','GO','ON','OR','EQ','LT','GT', 'LE','GE','NE'), /* 11 */ LNG3(*) BYTE DATA('FOR','LET','REM','DIM','DEF','NOT','AND', 'TAN','SIN','COS','SQR','TAB','LOG','LEN', 'FRE','ATN','ABS','EXP','INT','END','POS', 'RND','SGN','INP','ASC','VAL','XOR','SUB', 'OUT'), /* 29 */ LNG4(*) BYTE DATA('THEN','READ','GOTO','ELSE','NEXT', 'STOP','DATA','FILE','CHR$','MID$', 'STEP','STR$','COSH','SINH'), /* 14 */ LNG5(*) BYTE DATA('PRINT','INPUT','GOSUB','CLOSE', 'LEFT$'), /* 5 */ LNG6(*) BYTE DATA('RETURN','RIGHT$','REMARK'), /* 3 */ LNG7(*) BYTE DATA('RESTORE'), /* 1 */ LNG9(*) BYTE DATA('RANDOMIZE'), TK(*) BYTE DATA(0,TCR,LESST,LPARN,TPLUS,ASTRK,RPARN,TMINUS, COMMA,EQUAL,SLASH,SCOLN,GTRT,TCOLIN,POUND, EXPON, /* LNG 1 */ TIF,TTO,TGO,TON,TOR,EQUAL,LESST,GTRT,TLEQ, TGEQ,TNE, /* LNG2 */ TFOR,TLET,TREM,TDIM,TDEF,TNOT,TAND, 72,69,70,73,74,78,84,76,71,65,75, 66,TEND,79,67,68,80,81,88,TXOR,TSUB,TOUT, /* LNG 3 */ TTHEN,TREAD,TGOTO,TELSE,TNEXT,TSTOP,TDATA, TFILE,82,85,TSTEP,87,89,90, /* LNG 4 */ TPRNT,TINPT,TGOSB,TCLOS,83, /* LNG 5 */ TRETN,86,TREM, /* LNG 6 */ TREST,TIRN), OFFSET(*) BYTE DATA(0,0,15,37,124,180,205,223,230,230), COUNT(*) BYTE DATA(0,15,11,29,14,5,3,1,0,1), TKOS(*) BYTE DATA(0,0,15,26,55,69,74,77,78,78), ST(*) BYTE DATA(1,1,0,1,1,1,1,1,1,1,1,0,0,1,0,1, 5,65,70,5,71,70,65,5,1,1); DECLARE PTR ADDRESS, FIELD BASED PTR (1) BYTE, I BYTE; COMPARE: PROCEDURE BYTE; DECLARE I BYTE; I = 0; DO WHILE (FIELD(I) = ACCUM(I := I + 1)) AND I <= ACCLEN; END; RETURN I > ACCLEN; END COMPARE; IF ACCLEN > MAXRWLNG THEN RETURN FALSE; PTR = OFFSET(ACCLEN) + .LNG1; DO I = 1 TO COUNT(ACCLEN); IF COMPARE THEN DO; IF((TOKEN := TK(TKOS(ACCLEN) + I)) > 64) AND (TOKEN <> TDATA) THEN DO; SUBTYPE = ST(TOKEN - 65); FUNCOP = TOKEN; TOKEN = FUNCT; END; RETURN TRUE; END; PTR = PTR + ACCLEN; END; RETURN FALSE; END LOOKUP; DO FOREVER; /* TO HANDLE REM, DAT AND CONTINUATION */ ACCLEN, HASHCODE, TOKEN, SUBTYPE = 0; /* FIRST CASE - IS THIS A STRING OR THE CONTINUATION OF A STRING? (ONLY STRINGS MAY BE CONTINUED) */ IF(NEXTCHAR = STRINGDELIM) OR CONT THEN DO; /* FOUND STRING */ TOKEN = STRING; CONT = FALSE; DO FOREVER; /* ALLOWS "" IN STRING TO BE " */ DO WHILE GETCHAR <> STRINGDELIM; IF NEXTCHAR = EOLCHAR THEN CALL ERROR('US'); CALL PUTINACCUM; IF CONT THEN RETURN; END; CALL GETNOBLANK; IF NEXTCHAR <> STRINGDELIM THEN RETURN; CALL PUT$IN$ACCUM; END; /* OF DO FOREVER */ END; /* OF RECOGNIZING A STRING */ /* NEXT CASE IS A NUMERIC WHICH MUST START WITH A NUMBER OR WITH A PERIOD ONLY FIRST IDENTSIZE CHARACTERS ARE RETAINED */ ELSE IF NUMERIC OR DECIMALPT THEN DO; /* HAVE DIGIT */ TOKEN = FLOATPT; DO WHILE NEXTCHAR = '0'; /* ELIM LEADING ZEROS */ NEXTCHAR = GETCHAR; END; CALL SPOOLNUMERIC; /* GET ALL THE NUMBERS */ IF DECIMALPT THEN DO; CALL PUTANDCHAR; CALL SPOOLNUMERIC; END; CALL CONV$TO$UPPER; IF NEXTCHAR = 'E' THEN DO; /* A FLOATING POINT NUMBER */ CALL PUTANDGET; IF (NEXTCHAR = '+') OR (NEXTCHAR='-') THEN CALL PUTANDGET; IF NOT NUMERIC THEN CALL ERROR('IF'); CALL SPOOL$NUMERIC; END; IF ACCLEN = 0 THEN HASHCODE, ACCUM(ACCLEN := 1) = '0'; CALL SETUP$NEXT$CALL; RETURN; END; /* OF RECOGNIZING NUMERIC CONSTANT */ /* NEXT CASE IS IDENTIFIER. MAY BE RESERVED WORD IN WHICH CASE MAY BE REM, OR DATA. THESE STATEMENTS ARE HANDLED BY THE SCANNER VICE THE PARSER AND THEN ANOTHER LOOP THROUGH THE SCANNER IS MADE. ONLY IDENTSIZE-1 CHARACTERS ARE RETAINED */ ELSE IF LETTER THEN DO; /* HAVE A LETTER */ DO WHILE ALPHANUM; CALL PUTANDCHAR; END; IF NEXTCHAR = '$' THEN DO; SUBTYPE = STRING; CALL PUTANDCHAR; END; ELSE SUBTYPE = FLOATPT; IF NOT LOOKUP THEN DO; IF ACCUM(1) = 'F' AND ACCUM(2) = 'N' AND ACCLEN <> 1 THEN TOKEN = UDFUNCT; ELSE TOKEN = IDENTIFIER; CALL SETUP$NEXT$CALL; RETURN; END; ELSE /* IS A RW */ IF TOKEN = TREM THEN DO WHILE NEXTCHAR <> EOLCHAR; NEXTCHAR = GETCHAR; CALL CHECK$CONTINUATION; END; ELSE IF TOKEN = TDATA THEN DO; DECLARE DAT LIT '51'; CALL EMITDAT(DAT); CALL EMITDAT(NEXTCHAR); DO WHILE GETCHAR <> EOLCHAR; CALL CHECK$CONTINUATION; CALL EMITDAT(NEXTCHAR); END; CALL EMITDAT(','); CALL EMITDAT(0); DATACT = DATACT - 1; END; ELSE DO; CALL SETUP$NEXT$CALL; RETURN; END; END; /* OF RECOGNIZING RW OR IDENT */ /* LAST CASE IS A SPECIAL CHARACTER - IT MAY BE THE CONTINUATION CHARACTER IN WHICH CASE JUST GO TO NEXT LINE AND SCAN SOMEMORE. */ ELSE DO; /* SPECIAL CHARACTER */ IF NEXTCHAR = CONTCHAR THEN CALL CHECK$CONTINUATION; ELSE DO; CALL PUTANDGET; IF NOT LOOKUP THEN CALL ERROR('IC'); RETURN; END; END; /* OF RECOGNIZING SPECIAL CHAR */ END; /* OF DO FOREVER */ END SCANNER; END;