home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
ftp.barnyard.co.uk
/
2015.02.ftp.barnyard.co.uk.tar
/
ftp.barnyard.co.uk
/
cpm
/
walnut-creek-CDROM
/
SIMTEL
/
CPMUG
/
CPMUG030.ARK
/
BASIC.PLM
< prev
next >
Wrap
Text File
|
1984-04-29
|
39KB
|
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;
