seppdroid/Digital-Research-Source-Code
1
0
Fork 0
mirror of https://github.com/SEPPDROID/Digital-Research-Source-Code.git synced 2025-10-24 08:54:17 +00:00
Code Issues Actions Packages Projects Releases Wiki Activity

Upload

Browse Source 
Digital Research
This commit is contained in:
Sepp J Morris
2020-11-06 18:50:37 +01:00
parent 621ed8ccaf
commit 31738079c4
8481 changed files with 1888323 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1
ASSEMBLY & COMPILE TOOLS/Basic-E/readme.md Normal file
View File

@@ -0,0 +1 @@
Developed by Gordon Eubanks for his master's thesis, it was based on a BASIC compiler originally written by Gary Kildall. It's the predecessor of CBASIC.

30
ASSEMBLY & COMPILE TOOLS/Basic-E/source/BASCOM.LIT Normal file
View File

@@ -0,0 +1,30 @@
DECLARE
LIT LITERALLY 'LITERALLY',
TRUE LIT '1',
FALSE LIT '0',
FOREVER LIT 'WHILE TRUE',
INDEXSIZE LIT 'ADDRESS',
STATESIZE LIT 'ADDRESS',
LF LIT '0AH',
QUESTIONMARK LIT '3FH',
POUNDSIGN LIT '23H',
UPARROW LIT '5EH',
TAB LIT '09H',
COLIN LIT '3AH',
ASTRICK LIT '2AH',
PERCENT LIT '25H',
IDENTSIZE LIT '32', /* MAX IDENTIFIER SIZE + 1 */
VARCSIZE LIT '100', /* SIZE OF VARC STACK */
PSTACKSIZE LIT '32', /* SIZE OF PARSE STACKS */
EOLCHAR LIT '0DH', /* END OF SOURCE LINE INDICATOR */
EOFFILLER LIT '1AH', /* PAD CHAR FOR LAST REC ON FILE */
SOURCERECSIZE LIT '128', /* SIZE OF SOURCE FILE REC */
/* NOTE: THIS IS MAX SIZE OF SOURCE FILE RECORDS
IF SOURCE FILE CONSISTS OF VAR LNG REC */
INTRECSIZE LIT '128', /* INTERMEDIATE FILE REC SIZE */
CONBUFFSIZE LIT '82', /* SIZE OF CONSOLE BUFFER */
HASHTBLSIZE LIT '64', /* SIZE OF HASHTABLE */
HASHMASK LIT '63', /* HASHTBLSIZE - 1 */
STRINGDELIM LIT '22H', /* CHAR USED TO DELIM STRINGS */
CONTCHAR LIT '5CH', /* CONTINUATION CHARACTER */
MAXONCOUNT LIT '15'; /* MAX NUMBER ON STATEMENTS */

BIN
ASSEMBLY & COMPILE TOOLS/Basic-E/source/BASIC.COM Normal file
View File

Binary file not shown.

996
ASSEMBLY & COMPILE TOOLS/Basic-E/source/BASIC.PLM Normal file
View File

@@ -0,0 +1,996 @@
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;

312
ASSEMBLY & COMPILE TOOLS/Basic-E/source/BASPAR.PLM Normal file
View File

@@ -0,0 +1,312 @@
BASPAR:
DO;
/* PARSER MODULE FOR THE BASIC - E COMPILER */
$INCLUDE (:F1:BASCOM.LIT)
/* GLOBAL PROCEDURES */
PRINT: PROCEDURE(A) EXTERNAL;
DECLARE A ADDRESS;
END PRINT;
CRLF: PROCEDURE EXTERNAL;
END CRLF;
IN$SYMTBL: PROCEDURE EXTERNAL;
END IN$SYMTBL;
IN$SCANNER: PROCEDURE EXTERNAL;
END IN$SCANNER;
IN$SYN: PROCEDURE EXTERNAL;
END IN$SYN;
SCANNER: PROCEDURE EXTERNAL;
END SCANNER;
SYNTHESIZE: PROCEDURE(PROD) EXTERNAL;
DECLARE PROD BYTE;
END SYNTHESIZE;
ERROR: PROCEDURE(ERR) EXTERNAL;
DECLARE ERR ADDRESS;
END ERROR;
/* GLOBAL VARIABLES */
DECLARE
/* SCANNER PARAMETERS USED IN PARSING */
TOKEN BYTE EXTERNAL,
SUBTYPE BYTE EXTERNAL,
HASHCODE BYTE EXTERNAL,
ACCLEN BYTE EXTERNAL,
ACCUM(IDENTSIZE) BYTE EXTERNAL,
/* PASS CONTROLS */
LISTSOURCE BYTE EXTERNAL,
(PASS1, PASS2) BYTE EXTERNAL;
/* LOCAL VARIABLES AND PROCEDURES */
INITIALIZE: PROCEDURE;
CALL IN$SYMTBL;
CALL IN$SYN;
CALL IN$SCANNER;
END INITIALIZE;
DECLARE
I INDEXSIZE,
J INDEXSIZE,
K INDEXSIZE,
INDEX BYTE;
GETIN1: PROCEDURE INDEXSIZE;
RETURN INDEX1(STATE);
END GETIN1;
GETIN2: PROCEDURE INDEXSIZE;
RETURN INDEX2(STATE);
END GETIN2;
INCSP: PROCEDURE;
IF (SP := SP + 1) = LENGTH(STATESTACK) THEN
CALL ERROR('SO');
RETURN;
END INCSP;
LOOKAHEAD: PROCEDURE;
IF NOLOOK THEN
DO;
CALL SCANNER;
NOLOOK = FALSE;
END;
RETURN;
END LOOKAHEAD;
SET$VARC$I: PROCEDURE(I);
DECLARE I BYTE;
/* SET VARC AND INCREMENT VARINDEX */
VARC(VARINDEX) = I;
IF (VARINDEX := VARINDEX + 1) > LENGTH(VARC) THEN
CALL ERROR('VO');
END SET$VARC$I;
DECLARE /* PARSE TABLES AND RELATED VARIABLES */
EXTERN LITERALLY 'EXTERNAL',
COMPILING BYTE EXTERN,
STATE STATESIZE EXTERN, /* CURRENT STATE OF FSM */
STATESTACK(PSTACKSIZE) STATESIZE EXTERN,/* HOLDS STATES DURING PARSE */
HASH(PSTACKSIZE) BYTE EXTERN, /* HASH CODE OF CURRENT SYMBOL */
SYMLOC(PSTACKSIZE) ADDRESS EXTERN, /* CURRENT SYMBOL LOCATION */
SRLOC(PSTACKSIZE) ADDRESS EXTERN,
VAR(PSTACKSIZE) BYTE EXTERN, /* INDEX TO VARC */
TYPE(PSTACKSIZE) BYTE EXTERN, /* TYPE OF CURRENT SYMBOL */
STYPE(PSTACKSIZE) BYTE EXTERN, /* SUBTYPE OF CURRENT SYMBOL */
VARC(VARCSIZE) BYTE EXTERN, /* CHARACTERS FOR CURRENT SYMBOL */
VARINDEX BYTE EXTERN, /* CURRENT TOP OF VARC */
SP BYTE EXTERN, /* CURRENT TOP OF STACKS */
MP BYTE EXTERN, /* CURRENT "FRONT" OF PRODUCTIONS */
MPP1 BYTE EXTERN, /* MP + 1 */
NOLOOK BYTE EXTERN; /* TRUE IF NOT LOOKED-AHEAD */
DECLARE MAXRNO LITERALLY '120',/* MAX READ COUNT */
MAXLNO LITERALLY '175',/* MAX LOOK COUNT */
MAXPNO LITERALLY '189',/* MAX PUSH COUNT */
MAXSNO LITERALLY '341',/* MAX STATE COUNT */
STARTS LITERALLY '121',/* START STATE */
PRODNO LITERALLY '152';/* NUMBER OF PRODUCTIONS */
DECLARE READ1(*) BYTE
DATA(0,49,10,13,2,49,50,52,53,54,49,13,22,32,2,3,7,27,30
,49,50,52,53,54,2,3,7,30,49,50,52,53,54,54,52,12,52,2,3,7,49,50,52
,53,54,12,52,49,49,50,2,3,7,12,30,49,50,52,53,54,2,2,2,9,5,9,49,4,8
,49,16,20,28,29,31,35,36,37,38,40,42,43,44,45,46,48,49,51,52,49,14,6
,22,13,52,9,52,9,23,9,21,33,41,16,21,33,36,43,9,21,33,5,9,21,33,5,21
,33,5,9,21,33,5,9,21,33,6,9,21,33,21,33,39,21,33,41,5,21,33,6,21,33
,9,6,9,16,17,20,25,26,27,28,29,31,35,36,37,38,40,42,43,44,45,46,48
,51,52,2,16,20,28,29,31,35,36,37,38,40,42,43,44,45,46,48,51,52,52,13
,24,11,34,9,2,1,3,7,10,13,15,18,19,3,7,9,0);
DECLARE LOOK1(*) BYTE
DATA(0,49,0,10,13,0,13,0,11,23,34,0,52,0,12,52,0,49,50,0,6
,9,11,23,34,0,2,0,2,0,9,0,4,8,0,4,8,0,4,8,0,4,8,0,4,8,0,11,23,34,0
,14,0,14,0,14,0,9,0,9,0,9,0,9,0,9,0,21,33,0,21,33,0,21,33,0,21,33,0
,21,33,39,0,21,33,0,21,33,0,21,33,0,23,0,21,33,0,21,33,0,9,0,9,0,6,9
,0,52,0,11,23,0,11,23,34,0,2,0,11,23,0,52,0,24,0,24,0,11,0,23,0,11,0
,9,0,2,0,1,3,7,10,13,15,18,19,0,3,7,0,9,0);
DECLARE APPLY1(*) BYTE
DATA(0,0,0,0,55,105,0,19,0,0,32,47,0,0,3,4,12,14,16,17,20
,21,22,26,27,34,36,38,40,98,100,102,103,114,116,0,0,46,0,28,0,33,0
,63,0,5,6,8,9,0,7,10,0,23,0,13,19,32,35,47,55,99,101,105,106,0,0,0,0
,0,39,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,11,0,0,0,0,0,0,0,99
,106,0,0,0,0,0,40,0,0,0,0,0,0,62,0,0,74,0,74,0,0,0,0,0,0,0,0,0);
DECLARE READ2(*) ADDRESS DATA
(0,191,264,260,3,255,256,129,254,253,326,258,329,331,3
,5,8,31,33,255,256,129,254,253,3,5,8,33,255,256,129,254,253,279,42
,21,129,3,5,8,255,256,129,254,253,20,129,273,255,256,3,5,8,20,33,255
,256,129,254,253,247,294,4,335,280,283,320,7,10,327,24,26,268,32,34
,285,328,125,126,338,38,330,127,128,337,340,275,341,129,325,23,302
,27,220,130,17,131,13,190,14,223,224,277,24,223,224,328,330,12,223
,224,246,248,223,224,244,223,224,249,252,223,224,293,295,223,224,316
,16,223,224,223,224,36,223,224,37,288,223,224,317,223,224,15,318,319
,24,25,26,29,30,339,268,32,34,285,328,125,126,338,38,330,127,128,337
,340,341,129,251,24,26,268,32,34,285,328,125,126,338,38,330,127,128
,337,340,341,129,45,22,28,124,276,286,282,122,6,9,123,257,259,261
,265,6,9,11,0);
DECLARE LOOK2(*) ADDRESS DATA
(0,1,176,2,2,263,18,262,177,177,177,19,334,333,35,35
,178,39,39,179,180,180,180,180,180,40,41,245,43,181,44,332,49,49,231
,50,50,234,51,51,235,52,52,232,53,53,233,182,182,182,55,57,236,58
,237,59,238,66,308,68,300,69,299,70,301,72,296,76,76,297,77,77,309
,78,78,219,84,84,312,85,85,85,183,87,87,336,88,88,298,89,89,310,278
,91,93,93,313,94,94,269,95,321,96,322,97,97,184,99,185,186,186,101
,314,314,314,102,104,250,187,187,105,106,188,109,221,110,222,111,193
,274,112,113,272,115,284,117,189,118,118,118,118,118,118,118,118,229
,119,119,230,120,290);
DECLARE APPLY2(*) ADDRESS DATA
(0,0,161,71,169,170,168,199,198,200,218,267,201,98,80
,90,151,152,92,155,83,86,154,74,150,75,156,146,147,148,149,153,82,79
,81,73,46,167,166,226,225,228,227,174,173,133,135,134,136,132,139
,140,138,240,239,305,64,64,304,64,64,304,64,64,304,241,114,243,116
,163,60,242,63,202,61,47,266,194,271,164,137,197,172,108,107,204,65
,171,287,196,175,292,291,103,205,145,206,210,165,143,144,142,207,159
,141,307,100,160,162,208,213,56,62,158,157,209,323,48,324,54,203,67
,216,212,211,195,214,215);
DECLARE INDEX1(*) ADDRESS DATA
(0,1,2,24,24,4,4,4,4,4,4,34,24,36,24,10,24,24,11,168
,24,24,24,4,12,14,24,24,24,33,34,35,36,37,24,45,24,47,24,48,50,60,61
,62,63,64,24,36,66,67,67,67,67,67,69,70,89,90,90,90,91,92,89,37,93
,94,95,96,97,97,97,98,99,100,103,108,100,100,100,111,115,118,122,126
,100,130,133,100,100,100,136,100,139,100,100,142,142,143,24,36,24
,145,24,24,167,168,36,186,187,188,188,189,189,189,24,191,24,192,193
,201,203,1,3,6,8,12,14,17,20,26,28,30,32,35,38,41,44,47,51,53,55,57
,59,61,63,65,67,70,73,76,79,83,86,89,92,94,97,100,102,104,107,109
,112,116,118,121,123,125,127,129,131,133,135,137,146,149,192,217,306
,303,311,289,217,270,315,306,217,217,306,281,1,2,2,3,3,3,3,3,4,4,7,7
,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,9,10,13,14,14,36,36,37,37,39,39,41
,41,43,43,43,43,43,45,45,45,50,50,53,53,53,53,55,55,66,66,67,67,68
,68,69,69,70,70,72,72,72,72,72,72,72,72,72,73,74,75,76,76,77,77,77
,78,78,79,80,81,82,83,83,84,84,85,86,86,87,88,88,89,90,90,91,93,93
,94,95,95,96,96,97,98,98,99,99,99,102,102,103,103,103,104,104,105
,105,106,106,108,108,109,110,110,111,112,113,113,115,116,116,118,118
,120,120,121,121,122,123,124,125,126,127);
DECLARE INDEX2(*) BYTE
DATA(0,1,2,9,9,6,6,6,6,6,6,1,9,1,9,1,9,9,1,18,9,9,9,6,2
,10,9,9,9,1,1,1,1,8,9,2,9,1,9,2,10,1,1,1,1,2,9,1,1,2,2,2,2,2,1,19,1
,1,1,1,1,1,1,8,1,1,1,1,1,1,1,1,1,3,5,3,2,2,2,4,3,4,4,4,2,3,3,2,2,2,3
,2,3,2,2,1,1,2,9,1,9,22,9,9,1,18,1,1,1,1,1,1,2,1,9,1,9,1,8,2,1,2,3,2
,4,2,3,3,6,2,2,2,3,3,3,3,3,4,2,2,2,2,2,2,2,2,3,3,3,3,4,3,3,3,2,3,3,2
,2,3,2,3,4,2,3,2,2,2,2,2,2,2,2,9,3,2,1,19,35,39,40,43,55,85,97,99
,101,105,106,117,2,0,0,0,0,0,0,0,0,2,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
,0,0,1,1,1,0,2,0,0,0,2,0,1,0,2,0,2,2,1,1,0,2,2,0,2,0,0,0,2,0,2,1,2,2
,0,1,2,0,0,0,0,0,1,0,1,0,0,0,1,0,3,1,0,1,0,0,1,5,1,1,2,2,3,1,2,0,0,2
,1,0,2,1,2,0,1,0,2,2,1,2,1,0,2,2,1,2,1,0,0,2,0,2,2,0,2,0,0,2,0,0,2,4
,0,0,1,1,1,2,2,0,2,1,0,1,0,1,1,0,0,2,3,0,0,0,0,0);
/*
*********************************************************
* *
* EXECUTION OF THE COMPILER BEGINS HERE *
* *
* THE OUTPUT FILE IS CREATED AND THE *
* SYMBOLTABLE, SYNTHESIZE AND SCANNER *
* ARE INITIALIZED. THEN THE PARSER *
* BEGINS PROCESSING THE SOURCE PROGRAM. *
* PROCESSING CONTINUES UNTIL AN END *
* STATEMENT IS INCOUNTERED OR UNTIL THE *
* END OF THE SOURCE FILE IS DETECTED. *
* AT THIS TIME THE THREE MAIN PROCEDURES *
* ARE INITIALIZED FOR PASS 2 AND THE *
* PARSER PROCESSES THE SOURCE FILE A *
* SECOND TIME. AT THE END OF EACH STATE- *
* MENT (WHICH TO THE PARSER IS A PROGRAM) *
* AND IF AN ERROR IS DETECTED THE PARSER *
* VARIABLES ARE REINITIALIZED BY SETTING *
* COMPILING FALSE. *
* *
*********************************************************
*/
CALL PRINT(.('BASIC-E COMPILER VER 2.1$'));
CALL CRLF;
CALL INITIALIZE; /* INITIALIZE MAJOR SYSTEMS PRIOR TO PARSING */
DO FOREVER; /* THIS LOOP CONTROLS THE 2 PASSES OF THE COMPILER */
DO WHILE (PASS1 OR PASS2);/* THIS LOOP REINITIALIZES ON ERR OR OOC */
/* INITIALIZE VARIABLES */
COMPILING,NOLOOK=TRUE; STATE=STARTS;
SP=255;
VARINDEX, VAR(0) = 0;
DO WHILE COMPILING;
IF STATE <= MAXRNO THEN /* READ STATE */
DO;
CALL INCSP;
STATESTACK(SP) = STATE;
I = GETIN1;
CALL LOOKAHEAD;
J = I + GETIN2 - 1;
DO I = I TO J;
IF READ1(I) = TOKEN THEN /* SAVE TOKEN */
DO;
VAR(SP) = VARINDEX;
DO INDEX = 0 TO ACCLEN;
CALL SET$VARC$I(ACCUM(INDEX));
END;
HASH(SP) = HASHCODE;
STYPE(SP) = SUBTYPE;
STATE = READ2(I);
NOLOOK = TRUE;
I = J;
END;
ELSE
IF I = J THEN
CALL ERROR('NP');
END;
END;
ELSE
IF STATE > MAXPNO THEN /* APPLY PRODUCTION STATE */
DO;
MP = SP - GETIN2;
MPP1 = MP + 1;
CALL SYNTHESIZE(STATE - MAXPNO);
IF COMPILING THEN
DO;
SP = MP;
I = GETIN1;
VARINDEX = VAR(SP);
J = STATESTACK(SP);
DO WHILE (K := APPLY1(I)) <> 0
AND J <> K;
I = I + 1;
END;
IF(STATE := APPLY2(I)) = 0 THEN
COMPILING = FALSE;
END;
END;
ELSE
IF STATE<= MAXLNO THEN /* LOOKAHEAD STATE */
DO;
I = GETIN1;
CALL LOOKAHEAD;
DO WHILE (K := LOOK1(I)) <> 0 AND
TOKEN <> K;
I = I + 1;
END;
STATE = LOOK2(I);
END;
ELSE /* PUSH STATE */
DO;
CALL INCSP;
STATESTACK(SP) = GETIN2;
STATE = GETIN1;
END;
END; /* OF WHILE COMPILING */
END; /* OF WHILE PASS1 OR PASS2 */
LISTSOURCE = TRUE;
CALL INITIALIZE;
PASS2 = TRUE;
END; /* OF DO FOREVER */
END; /* OF PARSER MODULE */

1639
ASSEMBLY & COMPILE TOOLS/Basic-E/source/BASSYN.PLM Normal file
View File

File diff suppressed because it is too large Load Diff

426
ASSEMBLY & COMPILE TOOLS/Basic-E/source/BUILD.PLM Normal file
View File

@@ -0,0 +1,426 @@
BASBUILD:
DO; /* ORIGINALLY ORG'ED AT 2D00H ABOVE INTERP */
/*
********************************************************
* *
* BASIC-E BUILD PROGRAM *
* *
* U. S. NAVY POSTGRADUATE SCHOOL *
* MONTEREY, CALIFORNIA *
* *
* WRITTEN BY GORDON EUBANKS, JR. *
* *
* CPM VERSION 1.3 *
* *
* DECEMBER 1976 *
* *
********************************************************
*/
/*
********************************************************
* *
* THE BUILD PROGRAM GAINS CONTROL WHEN THE *
* RUN TIME MONITOR IS EXECUTED. THE INT FILE *
* FOR THE PROGRAM TO BE EXECUTED IS OPENED *
* AND THE BASIC-E MACHINE IS BUILT. *
* *
* BUILD PERFORMS THE FOLLOWING FUNCTIONS: *
* *
* (1) THE NUMERIC CONSTANTS ARE READ FROM *
* THE INT FILE, CONVERTED TO INTERNAL REP- *
* RESENTATION, AND STORED IN THE FSA. *
* *
* (2) THE SIZE OF THE CODE AREA, DATA AREA *
* AND NUMBER OF PRT ENTRIES ARE READ FROM *
* THE INT FILE. BUILD THEN DETERMINES THE *
* ABSOLUTE ADDRESS OF EACH SECTION OF THE *
* BASIC-E MACHINE. THESE ADDRESSES ARE *
* PASSED TO THE INTERP PROGRAM VIA FIXED *
* ADDRESSES IN THE FLOATING POINT SCRATCH *
* PAD. *
* *
* (3) FINALLY INSTRUCTIONS ARE READ FROM *
* THE FILE AND PLACED IN EITHER THE DATA *
* AREA OR THE CODE AREA. IN THE CASE OF BRS *
* BRC, PRO, CON, AND DEF OPERATORS THE *
* ADDRESS FOLLOWING THE INSTRUCTION IS RE- *
* LOCATED TO REFLECT ACTUAL MACHINE ADDRESSES *
* (MINUS 1 BECAUSE PROGRAM COUNTER GETS *
* INCREMENTED PRIOR TO USE (EXCEPT FOR CON)!!) *
* AFTER (REPEAT AFTER) THE MACHINE HAS BEEN *
* REPOSITIONED BY INTERP. THE END OF THE INT *
* FILE IS INDICATED BY A MACHINE INSTRUCTION *
* 7FH. *
* REPOSITIONED BY INTERP. *
* *
********************************************************
*/
/*
********************************************************
* *
* GLOBAL LITERALS *
* *
********************************************************
*/
DECLARE
LIT LITERALLY 'LITERALLY',
TRUE LIT '1',
FALSE LIT '0',
CR LIT '0DH',
LF LIT '0AH';
/*
********************************************************
* *
* SYSTEM PARAMETERS WHICH MAY *
* REQUIRE MODIFICATION BY USERS *
* *
********************************************************
*/
DECLARE
/* OP CODES FOR BASIC-E MACHINE INSTRUCTIONS */
DAT LIT '51',
ILS LIT '28',
DEF LIT '94',
BRS LIT '54',
BRC LIT '55',
PRO LIT '30',
CON LIT '46';
/*
********************************************************
* *
* EXTERNAL ENTRY POINTS *
* THESE ENTRY POINTS ALLOW INTERFACEING WITH CP/M *
* *
********************************************************
*/
DECLARE
BDOSBEGIN ADDRESS INITIAL(06H), /* PTR TO BOTTOM CP/M */
MAX BASED BDOSBEGIN ADDRESS,
/* OFFSET IS THE SIZE OF THIS MODULE */
OFFSET ADDRESS EXTERNAL, /* INITIALIZED BELOW */
/* START IS THE ADDRESS TO START INTERPRETATION */
START LABEL EXTERNAL,
/* BEGIN HOLDS THE VALUE OF .MEMORY FOR INTERP */
BEGIN ADDRESS EXTERNAL,
/* PARAMETER PASSING LOCATIONS */
PARAM1 ADDRESS EXTERNAL ,
PARAM2 ADDRESS EXTERNAL ,
PARAM3 ADDRESS EXTERNAL ,
PARAM4 ADDRESS EXTERNAL ;
/*
********************************************************
* *
* GLOBAL VARIABLES *
* *
********************************************************
*/
DECLARE
MCD LIT 'PARAM1',
MDA LIT 'PARAM2',
MPR LIT 'PARAM3',
SB LIT 'PARAM4',
MBASE ADDRESS, /* PTR TO NEXT POSTION IN DATA AREA */
MF BASED MBASE BYTE,
BASE ADDRESS, /* PTR TO NEXT POSITION IN CODE AREA */
CURCHAR BYTE, /* HOLDS CHAR BEING ANALYZED */
B BASED BASE BYTE,
BV BASED BASE(1) BYTE, /* VECTOR VERSION OF B */
A BASED BASE ADDRESS,
AP BYTE, /* ACCUMULATOR INDEX */
ACCUM(16) BYTE, /* HOLDS CONSTANTS PRIOR TO CONV */
TEMP ADDRESS,
T BASED TEMP BYTE;
/*
********************************************************
* *
* FLOATING POINT INTERFACE ROUTINES *
* *
********************************************************
*/
FLTOP: PROCEDURE(FUNCTION,LOCATION) EXTERNAL;
DECLARE FUNCTION BYTE, LOCATION ADDRESS;
END FLTOP;
DECLARE FPN LITERALLY 'FLTOP';
FLTRET: PROCEDURE(FUNCTION,LOCATION) EXTERNAL;
DECLARE FUNCTION BYTE, LOCATION ADDRESS;
END FLTRET;
DECLARE FP LITERALLY 'FLTRET';
FLTINP: PROCEDURE(COUNT,LOCATION) EXTERNAL;
DECLARE COUNT BYTE, LOCATION ADDRESS;
END FLTINP;
DECLARE FPINP LITERALLY 'FLTINP';
/*
********************************************************
* *
* CP/M INTERFACE ROUTINES *
* *
********************************************************
*/
DECLARE
DISKBUFFLOC LIT '80H',
FCBLOC LIT '5CH',
DISKBUFFEND LIT '100H',
/* IF OPERATING SYSTEM READS VARIABLE LENGTH RECORDS
THIS MUST BE ADDRESS OF ACTUAL END OF RECORD */
BUFF ADDRESS INITIAL(DISKBUFFEND), /* INPUT BUFFER */
CHAR BASED BUFF BYTE, /* INPUTBUFF POINTER */
FILENAME ADDRESS INITIAL (FCBLOC),
FNP BASED FILENAME(33) BYTE; /* FILE CONTROL BLK */
MON1:PROCEDURE(FUNCTION,PARAMETER) EXTERNAL;
DECLARE
FUNCTION BYTE,
PARAMETER ADDRESS;
END MON1;
MON2: PROCEDURE(FUNCTION,PARAMETER) BYTE EXTERNAL;
DECLARE
FUNCTION BYTE,
PARAMETER ADDRESS;
END MON2;
MON3: PROCEDURE EXTERNAL;
END MON3;
PRINTCHAR: PROCEDURE(CHAR) EXTERNAL;
DECLARE CHAR BYTE;
END PRINTCHAR;
PRINT: PROCEDURE(BUFFER) EXTERNAL;
/*
PRINT A LINE ON CONSOLE FOLLOWED BY A
CARRIAGE RETURN AND LINEFEED
*/
DECLARE
BUFFER ADDRESS;
END PRINT;
PRINTF: PROCEDURE(BUFFER);
DECLARE BUFFER ADDRESS;
CALL PRINT(BUFFER);
CALL PRINTCHAR(CR); CALL PRINTCHAR(LF);
END PRINTF;
OPEN$INT$FILE: PROCEDURE;
FNP(9) = 'I';
FNP(10) = 'N';
FNP(11) = 'T';
IF MON2(15,FILENAME) = 255 THEN
DO;
CALL PRINTF(.('NI $'));
CALL MON3;
END;
END OPEN$INT$FILE;
READ$INT$FILE: PROCEDURE BYTE;
/*
NEXT RECORD IS READ FROM INT FILE
DISKBUFFEND MUST REFLECT THE ADDRESS
OF THE END OF THE RECORD PLUS ONE
FOR FIXED SIZE RECORDS THIS IS A CONSTANT
RETURNS ZERO IF READ IS SAT, AND 1 IF EOF
*/
RETURN MON2(20,FILENAME);
END READ$INT$FILE;
/*
********************************************************
* *
* GLOBAL PROCEDURES *
* *
********************************************************
*/
INCBUF: PROCEDURE;
IF(BUFF := BUFF + 1) >= DISKBUFFEND THEN
DO;
BUFF = DISKBUFFLOC;
IF READ$INT$FILE <> 0 THEN
CHAR = 7FH;
END;
END INCBUF;
STO$CHAR$INC: PROCEDURE;
/*
GET NEXT CHAR FROM INT FILE AND
PLACE IN CODE AREA. THEN INCREMENT
PTR INTO CODE AREA.
*/
B=CHAR;
BASE=BASE+1;
END STO$CHAR$INC;
NEXT$CHAR: PROCEDURE BYTE;
CALL INCBUF;
RETURN CURCHAR := CHAR;
END NEXT$CHAR;
GET$TWO$BYTES: PROCEDURE;
/*
GET NEXT TWO BYTES FROM THE INT FILE
AND PLACE THEM IN THE CODE AREA IN REVERSE ORDER.
*/
BV(1) = NEXT$CHAR;
B = NEXT$CHAR;
RETURN;
END GET$TWO$BYTES;
INC$BASE$TWO: PROCEDURE;
BASE = BASE + 1 + 1;
RETURN;
END INC$BASE$TWO;
GETPARM: PROCEDURE ADDRESS;
/*
READ A 16 BIT PARAMETER FROM INT FILE
AND CONVERT IT TO AN 8080 ADDRESS QUANTITY
*/
RETURN SHL(DOUBLE(NEXT$CHAR),8) + NEXT$CHAR;
END GETPARM;
/*
********************************************************
* *
* EXECUTION BEGINS HERE *
* *
********************************************************
*/
BUILD:
CALL PRINTF(.('BASIC-E INTERPRETER - VER 2.2$'));
CALL OPEN$INT$FILE;
BASE = (.MEMORY + 100H) AND 0FF00H; /* BEGINNING OF MACHINE AND FDA */
OFFSET = BASE - BEGIN; /* SIZE OF THE BUILD MODULE */
CALL FPN(0,0); /* INITIALIZE FLOATING POINT PACKAGE */
/*
PROCESS CONSTANTS
EACH CONSTANT IS SEPARATED BY A $
LAST CONSTANT FOLLOWED BY A *
*/
DO WHILE(ACCUM(0) := NEXT$CHAR) <> '*'; /* * INDICATES END OF CONST */
AP = 0; /* COUNTER FOR LENGTH OF THIS CONSTANT */
DO WHILE(ACCUM(AP:=AP+1) := NEXT$CHAR) <> '$';
/* GET CONSTANT INTO THE ACCUM */
END;
CALL FPINP(AP,.ACCUM); /* CONVERT IT TO INTERNAL FORM */
CALL FP(9,BASE); /* LOAD INTO FDA FROM F/P ACCUM */
BASE = BASE + 4; /* NEXT LOCATION */
END; /* OF LOOKING FOR * */
/*
SETUP MACHINE ADDRESS
BASE WILL NOW BE NEXT POSITION IN CODE AREA
MBASE WILL BE NEXT POSTION IN DATA AREA
ACTUAL ADDRESSES OF CODE AREA, DATA AREA
PRT, AND STACK ARE PASSED TO INTERPRETER
USING FIXED LOCATIONS
*/
MBASE = GETPARM + BASE;
MDA = MBASE - OFFSET; /* ACTUAL DATA AREA ADDR */
MCD = BASE - OFFSET; /* ACTUAL CODE AREA ADDR */
MPR = GETPARM + MDA; /* ACTUAL BEGINNING OF PRT */
IF MPR >= MAX THEN /* INSURE THERE IS ENOUGH MEMORY */
DO;
CALL PRINTF(.('NM $'));
CALL MON3;
END;
SB = SHL(GETPARM,2) + MPR; /* NUMBER OF ENTRIES IN PRT * 4=SIZE PRT */
/*
BUILD MACHINE - ATLAST
AS OPCODES ARE READ THEY MAY BE:
(1) DAT - WHICH MEANS ALL CHARACTERS
FOLLOWING DAT GO INTO DATA AREA UNTIL
A BINARY ZERO IS INCOUNTERED
(2) GREATER THAN 127 - WHICH IS A LIT
OR A LIT. TREAT THIS AS 16 BIT OPCODE
AND PUT IN CODE AREA IN ORDER THEY ARE
ON INT FILE
(3) ILS - WHICH MEANS ALL CHARACTERS
FOLLOWING GO INTO CODE AREA UNTIL A
BINARY ZERO IS INCOUNTERED - BUT FIRST
PUT A ILS IN CODE AREA AND THE NEXT
BYTE IS SET TO ZERO AND INCREMENTED
FOR EACH CHARACTER IN THE STRING. IE
A STRING CONSTANT IS A ILS OPCODE,
A LENGTH AND THE STRING.
(4) A NORMAL OP CODE - PUT IN CODE
AREA - BUT IF IT IS A BRS OR BRC OR
DEF OR PRO THEN THE NEXT TWO BYTES
ARE AN ADDRESS WHICH MUST BE RELOCATED
TO THE ACTUAL CODE AREA MINUS 1;
OR IT COULD BE A CON WHICH IS
RELOCATED TO THE FDA.
*/
DO WHILE NEXT$CHAR <> 7FH; /* BUILD MACHINE */
IF CURCHAR = DAT THEN /* PROCESS DATA STATEMENT */
DO WHILE(MF := NEXT$CHAR) <> 0; /* LOOK FOR END */
MBASE = MBASE + 1;
END;
ELSE
IF CURCHAR >= 128 THEN /* PROCESS LIT OR LID */
DO;
CALL STO$CHAR$INC;
CALL INCBUF;
CALL STO$CHAR$INC;
END;
ELSE
IF CURCHAR = ILS THEN /* PROCESS INLINE STRING */
DO;
CALL STO$CHAR$INC;
TEMP = BASE;
CHAR = 0; /* TO SET LENGTH TO 0 INITIAL */
CALL STO$CHAR$INC;
DO WHILE NEXT$CHAR <> 0;
CALL STO$CHAR$INC;
T = T + 1;
END;
END;
ELSE
DO;
CALL STO$CHAR$INC;
IF (CURCHAR = BRS) OR (CURCHAR = BRC) OR
(CURCHAR = DEF) OR (CURCHAR = PRO) THEN
DO;
CALL GET$TWO$BYTES;
A = A + MCD - 1;
CALL INC$BASE$TWO;
END;
ELSE
IF CURCHAR = CON THEN
DO;
CALL GET$TWO$BYTES;
A = SHL(A,2) + BEGIN;
CALL INC$BASE$TWO;
END;
END;
END; /* LOOKING FOR 7FH */
GO TO START; /* RETURNS TO BASE MODULE FOR FURTHER PROCESSING */
END;

304
ASSEMBLY & COMPILE TOOLS/Basic-E/source/FPCONV.SRC Normal file
View File

@@ -0,0 +1,304 @@
NAME FPCNV
CSEG
PUBLIC FFLOAT,FFIX,FINP,FOUT
EXTRN FSTOR,FZERO,FABS,FTEST,FLOAD,FMUL
EXTRN FDIV,FADD,ADD10,LSH,RSH,FCOMP
EXTRN OVER,ACCE,ACCS,ACC1,ACC2,ACC3,SF
EXTRN FTEN,RND0
EXTRN ADRL,ADRH,TMP1,TMP2,TMP3,VALE,VAL1,VAL2,VAL3,TMP4
; 8080 BINARY FLOATING POINT SYSTEM
; FORMAT CONVERSION PACKAGE
; PROGRAMMER CAL OHME
; DATE 26 DECEMBER 1973
; SUBROUTINE TO CONVERT FROM FIXED
; POINT TO FLOATING POINT FORMAT.
FFLOAT: MOV L,E; INPUT EXPONENT
MOV E,D; 4TH INPUT FRACTION
MOV D,C; 3RD INPUT FRACTION
MOV C,B; 2ND INPUT FRACTION
MOV B,A; 1ST INPUT FRACTION
MOV A,L; INPUT EXPONENT
XRI 80H; APPLY EXPONENT BIAS
LXI H,ACCE; TO ADDR ACCUM EXPONENT
MOV M,A; ACCUMULATOR EXPONENT
INR L; TO ADDRESS ACCUM SIGN
MVI M,80H; SET ACCUM SIGN POSITIVE
INR L; TO ADDR ACCUM 1ST FRCTN
MOV A,B; 1ST INPUT FRACTION
ANA A ; SET SIGN BIT
RAL ; INPUT SIGN TO CARRY
JMP ADD10; COMPLETE CONVERSION
; SUBROUTINE TO CONVERT FROM FLOATING
; POINT TO FIXED POINT FORMAT.
FFIX: LXI H,ACCE; TO ADDRESS SCRATCH BANK
MOV A,M; ACCUMULATOR EXPONENT
ANA A ; SET CONTROL BITS
JZ FIX1; IF ACCUMULATOR IS ZERO
MOV A,E; INPUT EXPONENT
ADI 7FH; APPLY BIAS - 1
SUB M; SHIFT COUNT - 1
RC ; RETURN IF ACCUM TOO LARGE
CPI 1FH; COMPARE TO LARGE SHIFT
JNC FIX1; IF ACCUMULATOR TOO SMALL
ADI 1; SHIFT COUNT
MVI L,LOW(ACC1); TO ADDR ACCUM 1ST FRCTN
MOV B,M; ACCUMULATOR 1ST FRACTION
INR L; TO ADDR ACCUM 2ND FRCTN
MOV C,M; ACCUMULATOR 2ND FRCTN
INR L; TO ADDR ACCUM 3RD FRCTN
MOV D,M; ACCUMULATOR 3RD FRCTN
CALL RSH; POSITION THE FRACTION
MVI L,LOW(ACCS); TO ADDR ACCUM SIGN
MOV A,M; ACCUMULATOR SIGN
ANA A ; SET CONTROL BITS
CP FCOMP; COMPLEMENT FRCTN IF NEG
MVI A,1; NON-ZERO
ORA B; SET CONTROL BITS FOR EXIT
MOV A,B; 1ST RESULT
MOV B,C; 2ND RESULT
MOV C,D; 3RD RESULT
MOV D,E; 4TH RESULT
RET ; RETURN TO CALLER
FIX1: XRA A; ZERO
MOV B,A; ZERO
MOV C,A; ZERO
MOV D,A; ZERO
RET ; RETURN TO CALLER
DB 0; CHECKSUM WORD
; INP SUBROUTINE ENTRY POINT.
; INITIALIZE TEMPORARY STORAGE.
FINP: MOV E,M; FIRST CHARACTER OF STRING
CALL SVAD; SET CHAR ADDR, PNT FLG, EXP
INR L; TO ADDRESS VALUE SIGN
MVI M,80H; SET VALUE SIGN POSITIVE
LXI H,ACCE; TO ADDR ACCUM EXPONENT
MOV M,D; SET ACCUM TO ZERO
MOV A,E; FIRST CHARACTER
CPI 0F0H; COMPARE TO SPACE
JZ INP1; IF SPACE CHARACTER
CPI 0FBH; COMPARE CHAR TO PLUS
JZ INP1; IF PLUS SIGN
CPI 0FDH; COMPARE TO MINUS
JNZ INP2; IF NOT MINUS SIGN
LXI H,TMP3; TO ADDR VALUE SIGN
MOV M,D; SET VALUE SIGN NEGATIVE
; ANALYZE NEXT CHARACTER IN STRING.
INP1: CALL CHAD; CALL CHAR ADDR SBRTN
MOV A,M; NEXT CHARACTER
INP2: MVI B,0; DIGIT 2ND WD OR DEC EXP
CPI 0FEH; COMPARE TO DECIMAL POINT
JZ INP3; IF DECIMAL POINT
CPI 15H; COMPARE TO EXPONENT SIGN
JZ INP4; IF EXPONENT SIGN
CPI 0AH; SET CARRY IF CHAR IS DIGIT
JNC INP8; IF CHAR IS NOT A DIGIT
LXI H,TMP4; TO ADDR CURRENT DIGIT
MOV M,A; SAVE CURRENT DIGIT
LXI H,FTEN; TO ADDR FLOATING TEN
CALL FMUL; MULTIPLY BY TEN
MVI L,LOW(VALE); TO ADDR VALUE
CALL FSTOR; STORE OLD VALUE TIMES TEN
INR L; TO ADDR CURRENT DIGIT
MOV A,M; CURRENT DIGIT
MVI B,0; CLEAR 2ND WORD OF DIGIT
MOV C,B; CLEAR 3RD WORD OF DIGIT
MOV D,B; CLEAR 4TH WORD OF DIGIT
MVI E,8; INDICATE DIGIT IS IN REG A
CALL FFLOAT; CONVERT DIGIT TO FLOATING PNT
MVI L,LOW(VALE); TO ADDR VALUE
CALL FADD ; ADD OLD VALUE TIMES TEN
MVI L,LOW(TMP2); TO ADDR DEC PNT FLAG
MOV A,M; DECIMAL POINT FLAG
ANA A ; SET CONTROL BITS
JZ INP1; IF NO DEC PNT ENCOUNTERED
DCR L; TO ADDR INPUT EXPONENT
MOV B,M; INPUT EXPONENT
DCR B; DECREMENT INPUT EXPONENT
MOV M,B; UPDATE INPUT EXPONENT
JMP INP1; TO GET NEXT CHARACTER
INP3: LXI H,TMP2; TO ADDR DEC PNT FLAG
XRA M; ZERO IF FLAG SET
MOV M,A; SET DEC PNT FLAG
JNZ INP1; IF FLAG NOT ALREADY SET
JMP INP8; IF 2ND DEC PNT
; PROCESS DECIMAL EXPONENT.
INP4: CALL CHAD; CALL CHAR ADDR SBRTN
MOV A,M; NEXT CHARACTER OF STRING
MOV B,A; CURRENT CHARACTER
SUI 0FDH; COMPARE TO MINUS CHAR
MOV E,A; CHAR - MINUS SIGN
JZ INP5; IF MINUS SIGN
ADI 2; COMPARE TO PLUS CHAR
MOV A,B; CURRENT CHARACTER
JNZ INP6; IF NOT PLUS SIGN
INP5: INR L; TO ADDRESS NEXT CHAR
MOV A,M; NEXT CHARACTER OF STRING
INP6: MVI B,0; POSSIBLE DEC EXPONENT
CPI 0AH; SET CARRY IF CHAR IS DIGIT
JNC INP8; IF CHAR IS NOT A DIGIT
MOV B,A; DEC EXP EQUAL DIGIT
INR L; TO ADDRESS NEXT CHAR
MOV A,M; NEXT CHARACTER OF STRING
CPI 0AH; SET CARRY IF CHAR IS DIGIT
JNC INP7; IF CHAR IS NOT A DIGIT
; FORM COMPLETE DECIMAL EXPONENT.
MOV C,A; LS DIGIT OF DEC EXP
MOV A,B; MS DIGIT OF DEC EXP
ADD A; 2 * MS DIGIT
ADD A; 4 * MS DIGIT
ADD B; 5 * MS DIGIT
ADD A; 10 * MS DIGIT
ADD C; 10 * MS + LS DIGIT
MOV B,A; DECIMAL EXPONENT
INP7: MOV A,E; SIGN OF DEC EXPONENT
ANA A ; SET CONTROL BITS
JNZ INP8; IF SIGN PLUS
SUB B; COMPLEMENT DEC EXP
MOV B,A; DECIMAL EXPONENT
INP8: LXI H,TMP3; TO ADDRESS SCRATCH BANK
MOV C,M; INPUT SIGN
LXI H,ACCS; TO ADDRESS ACCUM SIGN
MOV M,C; ACCUMULATOR SIGN
MOV A,B; DECIMAL EXPONENT
; CONVERT DECIMAL EXPONENT TO BINARY.
INP9: LXI H,TMP1; TO ADDRESS DEC EXPONENT
ADD M; ADJUST DECIMAL EXPONENT
JZ FTEST; IN DEC EXP IS ZERO
MOV M,A; CURRENT DECIMAL EXPONENT
LXI H,FTEN; TO ADDR FLOATING TEN
JP INP10; IF MULTIPLY REQUIRED
CALL FDIV; DIVIDE BY TEN
MVI A,1; TO INCREMENT DEC EXP
JMP INP9; TO TEST FOR COMPLETION
INP10: CALL FMUL; MULTIPLY BY TEN
RC ; RETURN IF OVERFLOW
MVI A,0FFH; TO DECREMENT DEC EXP
JMP INP9; TO TEST FOR COMPLETION
; OUT SUBROUTINE ENTRY POINT.
; SAVE CHARACTER ADDRESS AND ACCUMULATOR.
FOUT: DCR L; DECREMENT CHARACTER ADDRESS
CALL SVAD; SET CHAR ADDR, DIG CNT, DEC EXP
CALL FTEST; LOAD ACCUM TO REGISTERS
LXI H,VALE; TO ADDR ACCUM SAVE AREA
CALL FSTOR; CALL REG STR SUBROUTINE
; OUTPUT SIGN CHARACTER.
CALL CHAD; CALL CHAR ADDR SBRTN
MVI M,0F0H; STORE SPACE CHARACTER
ANA A ; SET CONTROL BITS
JZ OUT3; IF ACCUMULATOR IS ZERO
MOV E,A; ACCUMULATOR EXPONENT
MOV A,B; ACCUM SIGN AND 1ST FRCTN
ANA A ; SET CONTROL BITS
MOV A,E; ACCUMULATOR EXPONENT
JP OUT1; IF ACCUM IS POSITIVE
MVI M,0FDH; CHANGE SIGN TO MINUS
; SCALE ACCUMULATOR TO .1 - 1. RANGE.
OUT1: CPI 7EH; COMPARE TO SMALL EXPONENT
OUT2: LXI H,FTEN; TO ADDR FLOATING TEN
JC OUT4; IF EXPONENT TOO SMALL
CPI 81H; COMPARE TO LARGE EXP
JC OUT5; IF EXP SMALL ENOUGH
CALL FDIV; DIVIDE BY TEN
OUT3: LXI H,TMP2; TO ADDRESS SCRATCH BANK
MOV E,M; DECIMAL EXPONENT
INR E; INCREMENT DECIMAL EXPONENT
MOV M,E; DECIMAL EXPONENT
JMP OUT2; TO TEST FOR SCALING COMPLETE
OUT4: CALL FMUL; MULTIPLY BY TEN
LXI H,TMP2; TO ADDR DECIMAL EXPONENT
MOV E,M; DECIMAL EXPONENT
DCR E; DECREMENT DECIMAL EXPONENT
MOV M,E; DECIMAL EXPONENT
JMP OUT1; TO TEST FOR SCALING COMPLETE
; ROUND THE VALUE BY ADDING .00000005.
OUT5: CALL FABS; SET ACCUM POSITIVE
LXI H,RND0; TO ADDRESS ROUNDER
CALL FADD; ADD THE ROUNDER
CPI 81H; CHECK FOR OVERFLOW
JNC OUT2; IF EXP TOO LARGE
; SET DIGIT COUNTS.
LXI H,TMP2; TO ADDR DECIMAL EXPONENT
MOV A,M; DECIMAL EXPONENT
MOV E,A; DIGITS BEFORE DEC POINT
CPI 8; COMPARE TO LARGE EXP
JC OUT6; IF EXPONENT IN RANGE
MVI E,1; DIGITS BEFORE DEC POINT
OUT6: SUB E; ADJUST DEC EXPONENT
MOV M,A; DECIMAL EXPONENT
MVI A,7; TOTAL NUMBER OF DIGITS
SUB E; DIGITS AFTER DECIMAL PNT
INR L; TO ADDR 2ND DIGIT CNT
MOV M,A; DIGITS AFTER DECIMAL POINT
DCR E; DECREMENT DIGIT COUNT
MOV A,E; DIGITS BEFORE DEC PNT
; OUTPUT SIGNIFICANT DIGITS.
OUT7: LXI H,TMP1; TO ADDR DIGIT COUNT
ADD M; ADJUST DIGIT COUNT
MOV M,A; NEW DIGIT COUNT
JM OUT8; IF COUNT RUN OUT
LXI H,FTEN; TO ADDR FLOATING TEN
CALL FMUL; MULTIPLY BY TEN
MVI E,8; TO PLACE DIGIT IN REG A
CALL FFIX; CONVERT TO FIXED FORMAT
CALL CHAD; CALL CHAR ADDR SBRTN
MOV M,A; OUTPUT DECIMAL DIGIT
XRA A; CLEAR CURRENT DIGIT
MVI E,8; BINARY SCALING FACTOR
CALL FFLOAT; RESTORE VALUE MINUS DIGIT
MVI A,0FFH; TO ADJUST DIGIT CNT
JMP OUT7; LOOP FOR NEXT DIGIT
OUT8: LXI H,TMP3; TO ADDR 2ND DIGIT CNT
MOV A,M; DIGITS AFTER DECIMAL PNT
MVI M,0FFH; SET 2ND COUNT NEG
ANA A ; SET CONTROL BITS
JM OUT9; IF 2ND COUNT RAN OUT
CALL CHAD; CALL CHAR ADDR SBRTN
MVI M,0FEH; STORE DECIMAL POINT
JMP OUT7; LOOP FOR NEXT DIGIT
OUT9: DCR L; TO ADDR DECIMAL EXP
ANA M ; DECIMAL EXPONENT
JZ OUT13; IF DECIMAL EXPONENT IS ZERO
; OUTPUT DECIMAL EXPONENT.
MVI B,0FBH; PLUS CHARACTER
JP OUT10; IF EXPONENT IS POSITIVE
MVI B,0FDH; CHANGE SIGN TO MINUS
MOV C,A; NEGATIVE EXPONENT
XRA A; ZERO
SUB C; COMPLEMENT EXPONENT
OUT10: MVI C,0FFH; EMBRYO TENS DIGIT
OUT11: MOV D,A; UNITS DIGIT
INR C; INCREMENT TENS DIGIT
SUI 0AH; REDUCE REMAINDER
JNC OUT11; IF MORE TENS
MVI A,15H; EXPONENT SIGN
OUT12: CALL CHAD; CALL CHAR ADDR SBRTN
CALL FSTOR; STORE LAST 4 CHARACTERS
LXI H,VALE; TO ADDRESS ACCUM SAVE AREA
JMP FLOAD; RESTORE ACCUM AND EXIT
; OUTPUT 4 SPACES IF EXPONENT IS ZERO.
OUT13: MVI A,0F0H; SPACE CHARACTER
MOV B,A; SPACE CHARACTER
MOV C,A; SPACE CHARACTER
MOV D,A; SPACE CHARACTER
JMP OUT12; TO STORE CHARACTERS
; SUBROUTINE TO SAVE CHARACTER STRING ADDR.
SVAD: MOV A,L; CHARACTER STRING WORD
MOV B,H; CHARACTER STRING BANK
MVI C,0; INPUT EXP OR DIGIT CNT
MOV D,C; DEC PNT FLAG OR DEC EXP
LXI H,ADRL; TO ADDR CHAR STRING WORD
CALL FSTOR; STORE A, B, C, AND D
RET ; RETURN TO CALLER
; SUBROUTINE TO OBTAIN NEXT CHARACTER ADDR.
CHAD: LXI H,ADRL; TO ADDRESS SCRATCH BANK
MOV E,M; CHARACTER STRING WORD
INR E; TO ADDR NEXT CHARACTER
MOV M,E; UPDATE CHAR STRING WORD
INR L; TO ADDR CHAR STRING BANK
MOV H,M; CHARACTER STRING BANK
MOV L,E; CHARACTER STRING WORD
RET ; RETURN TO CALLER
END

80
ASSEMBLY & COMPILE TOOLS/Basic-E/source/FPDATA.SRC Normal file
View File

@@ -0,0 +1,80 @@
; DATA SEGMENT
CSEG INPAGE
PUBLIC IDVT
PUBLIC FSQRN,FSQRX
PUBLIC FMACX,FMACS,FMACT,FMACG
PUBLIC FSINX
PUBLIC FATNT,FATNU
PUBLIC FCSHD
PUBLIC FSNHD,FEXOV,FSNHX
PUBLIC FLOGE,FLOGX
PUBLIC SEED
PUBLIC ACCUM
;
PUBLIC FONE,FPIV2,FLN2,FTEN,RND0
;
; FPPKG VARIABLES
PUBLIC OVER,PREX,ACCE,ACCS,ACC1,ACC2,ACC3,SF
; FPCONV VARIABLES
PUBLIC ADRL,ADRH,TMP1,TMP2,TMP3,VALE,VAL1,VAL2,VAL3,TMP4
;
;
IDVT EQU T00
FSQRN EQU T00
FSQRX EQU T04
FMACX EQU T00
FMACS EQU T04
FMACT EQU T08
FMACG EQU T0C
FSINX EQU T10
FATNT EQU T10
FATNU EQU T14
FCSHD EQU T0E
FSNHD EQU T0E
FEXOV EQU T0F
FSNHX EQU T10
FLOGE EQU T0E
FLOGX EQU T10
;
; VARIABLES FOR FLOATING POINT PACKAGE
OVER: DS 1
PREX: DS 1
ACCE: DS 1
ACCS: DS 1
ACC1: DS 1
ACC2: DS 1
ACC3: DS 1
SF: DS 1
;
; VARIABLES FOR FLOATING POINT CONVERSION
ADRL: DS 1
ADRH: DS 1
TMP1: DS 1
TMP2: DS 1
TMP3: DS 1
VALE: DS 1
VAL1: DS 1
VAL2: DS 1
VAL3: DS 1
TMP4: DS 1
ACCUM: DS 31 ;WORKING BUFFER
;
; VARIABLES FOR TRANSCENDENTAL FUNCTIONS, RANDOM NUMBER GEN
T00: DS 4
T04: DS 4
T08: DS 4
T0C: DS 2
T0E: DS 1
T0F: DS 1
T10: DS 4
T14: DS 4
SEED: DS 2 ;RANDOM NUMBER SEED
;
FONE: DB 81H,0,0,0 ;1.0
FPIV2: DB 81H,49H,0FH,0DCH;PI/2
FLN2: DB 80H,31H,72H,18H ;LN 2
FTEN: DB 84H,20H,0,0 ;10.0
RND0: DB 68H,56H,0BFH,0ADH ;.00000005
;
END

315
ASSEMBLY & COMPILE TOOLS/Basic-E/source/FPINT.SRC Normal file
View File

@@ -0,0 +1,315 @@
NAME FPINT ;FLOATING POINT INTERFACE PACKAGE
CSEG ;CODE SEGMENT
;
; NOTE: THE JMP 0000 TO BUILD MUST BE PATCHED
; JMP 0000 TO INTERP MUST BE PATCHED
;
;
; EQUATES FOR CP/M SYSTEM
BDOS EQU 0005H ;PRIMARY ENTRY POINT TO CP/M
BOOT EQU 0000H ;REBOOT ENTRY POINT
;
; PUBLIC SYMBOLS FOR MAIN PROGRAM
;
PUBLIC BEGIN,START ;BEGINNING OF BUILD, START OF INTERP
PUBLIC MON1 ;FUNC,PARM INPUT, NO OUTPUT
PUBLIC MON2 ;FUNC,PARM INPUT, BYTE OUTPUT
PUBLIC MON3 ;SYSTEM REBOOT
;
PUBLIC MOVEA ;.SOURCE,DEST,N, MOVES BYTES
PUBLIC MOVE4 ;SOURCE,DEST, MOVES 4 BYTES
;
PUBLIC CBIN ;CONVERT TO BINARY
PUBLIC CFLT ;CONVERT TO FLOAT
PUBLIC FLTINP ;FLOATING POINT INPUT
PUBLIC FLTOUT ;FLOATING POINT OUTPUT
PUBLIC FPOUT ;EQUIVALENT TO FLTOUT
PUBLIC FLTRET ;FLOATING POINT OPERATOR RETURN
PUBLIC FLTOP ;FLOATING POINT OPERATOR
;
; SPECIAL PURPOSE SUBROUTINES
PUBLIC INPUT ;PORT, RETURNS BYTE
PUBLIC OUTPUT ;PORT, BYTE
PUBLIC RANDOM
;
; EXTERNAL SYMBOLS
EXTRN FSTOR,FLOAD,FADD,FSUB,FMUL,FDIV,FABS,FZERO,FTEST,FCHS
EXTRN OVER
EXTRN FINP,FOUT,FFLOAT,FFIX
EXTRN FSQRT,FCOS,FSIN,FATAN,FCOSH,FSINH,FEXP,FLOG
EXTRN RAND
EXTRN ACCUM
;
; SUBROUTINES FOR MONITOR INTERFACE
; START OF BASIC COMPILER
JMP 0000 ;PATCHED TO BUILD ENTRY POINT
START:
JMP 0000 ;GO TO THE INTERPRETER
BEGIN: DW 0000 ;FILLED IN WHEN WE FIGURE OUT MEMORY MAP
;
MON1: JMP BDOS
MON2: JMP BDOS
MON3: JMP BOOT
;
; SPECIAL PURPOSE SUBROUTINE ENTRY POINTS
;
; SUBROUTINES FOR STORAGE MOVE OPERATIONS
MOVEA: ;.SOURCE,DESTINATION,COUNT ADDRESSED BY B,C
MOV H,B
MOV L,C
MOV C,M ;LS SOURCE
INX H
MOV B,M ;MS SOURCE
INX H
MOV E,M ;LS DEST
INX H
MOV D,M ;MS DEST
INX H
MOV A,M ;LS COUNT
INX H
MOV H,M ;MS COUNT
MOV L,A ;LS COUNT
; SOURCE IN B,C DEST IN D,E COUNT IN H,L
MOVER: MOV A,L ;CHECK FOR ZERO COUNT
ORA H ;BOTH ZERO?
RZ
; MOVE NEXT BYTE FROM SOURCE TO DESTINATION
DCX H ;COUNT = COUNT - 1
LDAX B ;BYTE TO REGISTER A
STAX D ;TO DESTINATION
INX B ;SOURCE = SOURCE + 1
INX D ;DEST = DEST + 1
JMP MOVER ;FOR THE NEXT BYTE
;
MOVE4: ;SOURCE IN B,C DEST IN D,E
LXI H,4
JMP MOVER
;
; FPINT IS AN INTERFACE PROGRAM BETWEEN THE
; INTERPRETER AND THE FLOATING POINT PACKAGE
; THE FLOATING POINT PACKAGE IS LOCATED AT
;
; THERE ARE SIX ENTRY POINTS INTO FPINT:
;
; (1) FLTINP - CONVERTS ASCII NUMERIC
; STRING TO FLOATING POINT
;
; (2) FLTOUT - CONVERTS FLOATING POINT
; NUMBER TO AN ASCII STRING
;
; (3) CBIN - CONVERTS FLOATING POINT
; NUMBER TO A BINARY NUMBER
;
; (4) CFLT - CONVERST BINARY NUMBER
; TO A FLOATING POINT NUMBER
;
; (5) FLTRET - PERFORMS FP ARITHMETIC
; OPERATION AND STORES RESULT BACK INTO
; AREA SPECIFIED BY THE INTERPRETER
;
; (6) FLTOP - PERFORMS FP ARITHMETIC
; OPERATION BUT DOES NOT STORE RESULT
; BACK INTO INTERPRETER
;
;
;
;
; ENTRY POINT FOR INP CALL (FUNCTION)
; REG C CONTAINS NUMBER OF CHARACTERS TO CONVERT
; REG D,E POINT TO CHAR STRING TO BE CONVERTED
; TO FLOATING POINT REPRESENTATION. FIRST IT IS
; MOVED TO ACCUM AND THEN CONVERTED. THIS IS DONE
; BECAUSE FP PKG REQUIRES ALL ADDRESSES BE ON ONE PAGE
;
FLTINP:
MOV A,C
ORA A
JNZ FLTI1
MVI C,8
JMP FLTOP
FLTI1: LXI H,ACCUM ;POINTER TO ACCUM
INP1: LDAX D ;LOAD A CHAR
SUI 30H ;CONVERT TO INTERFACE CODE
MOV M,A ;STORE CHAR INTO ACCUM
INX D ;POINT TO NEXT CHAR
INX H ;POINT TO NEXT ACCUM LOC
DCR C ;DECREMENT COUNTER
JNZ INP1 ;LOOP
MVI A,011H ;END OF STRING INDICATOR
MOV M,A
LXI H,ACCUM ;THIS IS WHERE STRING IS NOW
CALL FINP ;CALL FP PKG
RET ;RETURN TO INTERP
;
; ENTRY POINT FOR OUT CALL (FUNCTION 12)
; CONVERT NUMBER IN FP ACCUM TO STRING AND PLACE IT
; IN THE ADDRESS IN REG B,C. ACCUM USED AS INTERM.
; STORAGE OF STRING.
;
FPOUT:
FLTOUT:
PUSH B
LXI H,ACCUM ;TEMP STORE STRING HERE
CALL FOUT ;CONVERT TO ASCII
LXI D,ACCUM+9 ;IS IT IN EXP FORM?
LDAX D ;IF SO THIS IS LETTER E
LXI D,ACCUM+13 ;SETUP REG D,E
CPI 'E' - 30H ;IS IT AN E?
JZ FP2 ;YES LEAVE STRING AS IS
FP1:
; OTHERWISE REMOVE TRAILING BLANKS, ZEROS
DCX D ;NEXT LOCATION
LDAX D ;GET CHAR
CPI 0 ;A ZERO?
JZ FP1 ;YES, SKIP IT
CPI 0F0H ;A BLANK?
JZ FP1 ;YES, SKIP IT
; FOUND NON BLANK, NON ZERO CHAR
CPI 0FEH ;IS IT TRAILING .
JNZ FP3 ;IF SO ELIM
FP2:
DCX D ;IT WAS . SO ELIM
FP3:
POP H ;ADDRESS TO STORE STRING
MOV B,E ;SAVE RIGHT END OF STRING
LXI D,ACCUM ;BEGINNING
FP4:
LDAX D ;GET CHAR
ADI 30H ;CONV TO ASCII
CPI ' ' ;IF A BLANK DO NOT PASS
JZ FP5 ;TO MAIN PROGRAM IE SKIP IT
MOV M,A ;NOT BLANK MOVE IT
INX H ;NEXT LOCATION
FP5:
MOV A,E ;CURRENT POS
INX D ;SETUP FOR NEXT CHAR
CMP B ;COMPLETE?
JNZ FP4 ;NO - CONTINUE
MVI M,' ' ;LEAVE TRAILING BLANK
RET
;
; ENTRY POINT FOR CONVERSION FROM F/P TO BINARY
; REG B,C CONTAINS ADDRESS OF F/P NUMBER
; BINARY NUMBER IS MOVED BACK TO REPLACE F/P NUMBER
;
CBIN: PUSH B ;SAVE ADDRESS
POP D ;NOW ADDRESS IN D,E
PUSH D ;SAVE AGAIN
MVI C,2 ;LOAD FUNCTION NUMBER
CALL FLTOP ;GET F/P NUMBER INTO REG A-D
MVI E,32 ;SET SCALING FACTOR
CALL FFIX ;CALL CONV ROUTINE
JMP EMPTY ;MOVE BACK AND RETURN
;
; ENTRY POINT FOR CONVERSION FROM BINARY TO F/P
; REG B,C CONTAIN ADDRESS OF NUMBER TO CONV
;
CFLT: PUSH B
POP H ;NOW ADDR IN H,L
PUSH H ;ALSO SAVE IT
CALL FETCH ;GET NUMBER TO REG A - D
MVI E,32
CALL FFLOAT ;CALL CONV TO BINARY ROUTINE
JMP EMPTY ;MOVE BACK AND RET
;
; BUILD JUMP TABLE FOR USE BY STORE AND ENTER
;
JUMPT:
DW INITP ;FUNC = 0 INITIALIZE
DW FSTOR ;FUNC = 1 STORE ACCUM
DW FLOAD ;FUNC = 2 LOAD ACCUM
DW FADD ;FUNC = 3 ADD TO ACCUM
DW FSUB ;FUNC = 4 SUB FROM ACCUM
DW FMUL ;FUNC = 5 MULT ACCUM
DW FDIV ;FUNC = 6 DIV ACCUM
DW FABS ;FUNC = 7 ABSOLUTE VALUE
DW FZERO ;FUNC = 8 ZERO ACCUM
DW FTEST ;FUNC = 9 TEST FOR ZERO
DW FCHS ;FUNC = 10 COMPLEMENT ACCUM
DW FSQRT ;FUNC = 11 SQUARE ROOT
DW FCOS ;FUNC = 12 COSINE
DW FSIN ;FUNC = 13 SINE
DW FATAN ;FUNC = 14 ARCTAN
DW FCOSH ;FUNC = 15 COSH
DW FSINH ;FUNC = 16
DW FEXP ;FUNC = 17
DW FLOG ;FUNC = 18
;
; ENTRY POINT WHEN RESULT IE FP ACCUM IS STORED
; BACK INTO ADDRESS PASSED IN D,E.
; REG C IS A FUNCTION
; REG D,E IS ADDRESS OF PARAMETER
;
FLTRET: ;PERFORM OPERATION AND RETURN RESULT
PUSH D ;SAVE RETURN PARAMETER ADDRESS
CALL FLTOP ;RETURNS TO THIS ADDRESS
EMPTY: POP H ;RETURN PARAMETER ADDRESS
MOV M,A
INX H
MOV M,B
INX H
MOV M,C
INX H
MOV M,D
RET
;
;
; ENTRY POINT WHEN NO STORE BACK IS DESIRED
; REG C IS FUNCTION
; REG D,E IS A PARAMETER
;
; GET PROPER FUNCTION BY ADDIING FUNCTION NUMBER IN B
; REGISTER TO THE FIRST FUNCTION ADDRESS SETUP AS A DW
;
FLTOP:
LXI H,JUMPT
MVI B,0
DAD B
DAD B
;
MOV C,M
INX H
MOV B,M
LXI H,JMPIN+1 ;CHANGE ADDRESS FIELD
MOV M,C
INX H
MOV M,B
; JMP INSTRUCTION CHANGED (CANNOT USE PCHL BECAUSE OF H,L PARAMETER)
XCHG ;PARM TO H,L READY FOR CALL
JMPIN: JMP 0000 ;ADDRESS FIELD ALTERED ABOVE
;
;
INITP: XRA A
STA OVER
RET
;
;
INPUT: ;PORT NUMBER, RETURN VALUE IN A
LXI H,INP+1
MOV M,C ;IN XX CHANGED
INP: IN 00 ;CHANGED ABOVE
RET
;
OUTPUT: ;PORT NUMBER, VALUE
LXI H,OUTP+1
MOV M,C ;OUT INSTRUCTION CHANGED
MOV A,E ;VALUE TO SEND
OUTP: OUT 00 ;CHANGED ABOVE
RET
;
RANDOM: JMP RAND
;
; THE FOLLOWING SUBROUTINE MOVES A FOUR BYTE
; QUANTITY FROM MEMORY TO REG A - D
;
FETCH:
MOV A,M
INX H
MOV B,M
INX H
MOV C,M
INX H
MOV D,M
RET
;
END

648
ASSEMBLY & COMPILE TOOLS/Basic-E/source/FPPKG.SRC Normal file
View File

@@ -0,0 +1,648 @@
NAME FLPT
CSEG
PUBLIC OVERF,FLOAD,FSTOR,FADD,FSUB,FMUL,FDIV,FTEST
PUBLIC FCHS,FABS,RSH,LSH,ADD10,FZERO,FCOMP,FSTR0
EXTRN OVER,PREX,ACCE,ACCS,ACC1,ACC2,ACC3,SF
; 8008 BINARY FLOATING POINT SYSTEM
; ARITHMETIC AND UTILITY PACKAGE
; PROGRAMMER CAL OHME
; DATE 26 DECEMBER 1973
; FSTOR SUBROUTINE ENTRY POINT.
FSTR0: MOV M,E; STORE ZEROETH WORD
INR L; TO ADDRESS FIRST WORD
FSTOR: MOV M,A; STORE FIRST WORD
STR1: INR L; TO ADDRESS SECOND WORD
MOV M,B; STORE SECOND WORD
INR L; TO ADDRESS THIRD WORD
MOV M,C; STORE THIRD WORD
INR L; TO ADDRESS FOURTH WORD
MOV M,D; STORE FOURTH WORD
RET ; RETURN TO CALLER
; FLOATING POINT ZERO SUBROUTINE ENT. PNT.
FZERO: LXI H,ACCE; TO ADDRESS ACCUM EXPONENT
XRA A; ZERO
MOV M,A; CLEAR ACCUMULATOR EXPONENT
RET ; RETURN TO CALLER
; FLOATING POINT CHS SUBROUTINE ENT. PNT.
FCHS: MVI A,80H; MASK FOR SIGN BIT
DB 00EH; LBI INST TO SKIP NEXT WD
; FLOATING POINT ABS SUBROUTINE ENT. PNT.
FABS: XRA A; ZERO
LXI H,ACCS; TO ADDRESS ACCUM SIGN
ANA M ; COMPLEMENT OF SIGN
XRI 80H; COMPLEMENT THE SIGN BIT
MOV M,A; ACCUMULATOR SIGN
; FLOATING POINT TEST ENTRY POINT.
FTEST: LXI H,ACCE; TO ADDR ACCUM EXPONENT
MOV A,M; ACCUMULATOR EXPONENT
ANA A ; SET CONTROL BITS
JZ FZERO; IF ACCUMULATOR IS ZERO
MOV E,A; ACCUMULATOR EXPONENT
INR L; TO ADDR ACCUMULATOR SIGN
MOV A,M; ACCUMULATOR SIGN
INR L; TO ADDR ACCUM 1ST FRCTN
XRA M; ACCUM SIGN AND 1ST FRCTN
INR L; TO ADDR ACCUM 2ND FRCTN
MOV C,M; ACCUMULATOR 2ND FRACTION
INR L; TO ADDR ACCUM 3RD FRCTN
MOV D,M; ACCUMULATOR 3RD FRCTN
JMP ADD12; TO SET EXIT CONDITIONS
; FLOATING POINT LOAD ENTRY POINT.
FLOAD: MOV A,M; OPERAND EXPONENT
ANA A ; SET CONTROL BITS
JZ FZERO; IF OPERAND IS ZERO
MOV E,A; OPERAND EXPONENT
INR L; TO ADDR OP SIGN AND 1ST
MOV A,M; OPERAND SIGN AND 1ST FRCTN
INR L; TO ADDRESS OPERAND 2ND FRACTION
MOV C,M; OPERAND 2ND FRACTION
INR L; TO ADDRESS OPERAND 3RD FRACTION
MOV D,M; OPERAND 3RD FRACTION
; STORE THE OPERAND IN THE ACCUMULATOR.
MOV L,A; OPERAND SIGN AND 1ST FRCTN
FLOAD1: ORI 80H; ACCUMULATOR 1ST FRACTION
MOV B,A; ACCUMULATOR 1ST FRACTION
XRA L; ACCUMULATOR SIGN
LXI H,ACCE; TO ADDR ACCUM EXPONENT
CALL FSTR0; SET THE ACCUMULATOR
XRA B; ACCUM SIGN AND 1ST FRCTN
; SET CONTROL BITS AND EXIT
MOV B,A; ACCUM SIGN AND 1ST FRACTION
ORI 1; SET SIGN BIT FOR EXIT
MOV A,E; ACCUMULATOR EXPONENT
RET ; RETURN TO CALLER
; FLOATING POINT MUL SUBROUTINE ENT. PNT.
FMUL: MOV A,M; OPERAND EXPONENT
ANA A ; SET CONTROL BITS
CNZ MDEX; READ OPERAND IF NOT ZERO
JZ FZERO; IF ZERO OR UNDERFLOW
JC OVERF; IF OVERFLOW
CALL MULX; CALL FIXED MULT SUBRTN
; NORMALIZE IF NECESSARY.
MOV A,B; 1ST PRODUCT
ANA A ; SET CONTROL BITS
JM RNDA; IF NO NORMALIZATION REQUIRED
LXI H,ACCE; TO ADDR ACCUM EXPONENT
MOV A,M; ACCUMULATOR EXPONENT
SBI 1; DECREMENT ACCUMULATOR EXPONENT
MOV M,A; ACCUMULATOR EXPONENT
RZ ; RETURN TO CALLER IF UNDERFLOW
CALL LSH; CALL LEFT SHIFT SUBROUTINE
; ROUND IF NECESSARY.
RNDA: CALL ROND; CALL ROUNDING SUBROUTINE
JC OVERF; IF OVERFLOW
MOV B,A; ACCUM SIGN AND 1ST FRACTION
ORI 1; SET SIGN BIT
MOV A,E; ACCUMULATOR EXPONENT
RET ; RETURN TO CALLER
; FLOATING POINT DIV SUBROUTINE ENT. PNT.
FDIV: XRA A; ZERO
SUB M; COMPLEMENT OF DIVISOR EXPONENT
CPI 1; SET CARRY IF DIVISION BY ZERO
CNC MDEX; READ OPERAND IF NOT ZERO
JC OVERF; IF OVERFLOW OR DIVISION BY ZERO
JZ FZERO; IF UNDERFLOW OR ZERO
MOV C,A; DIVISOR 1ST FRACTION
CALL DIVX; CALL FIXED DIV SUBRTN
JC RNDA; IF NO OVERFLOW
; SET OVERFLOW FLAG.
OVERF: LXI H,OVER; TO ADDR OVERFLOW FLAG
MVI A,0FFH; OVERFLOW FLAG
MOV M,A; OVERFLOW FLAG
RLC ; SET CARRY BIT FOR EXIT
RET ; RETURN TO CALLER
DB 0; CHECK SUM WORD
; FLOATING POINT SUB SUBROUTINE ENT. PNT.
FSUB: MVI A,80H; MASK TO CHANGE OP SIGN
DB 0EH; LBI INST TO SKIP NEXT WD
; FLOATING POINT ADD SUBROUTINE ENT. PNT.
FADD: XRA A; ZERO
; LOAD THE OPERAND.
MOV E,M; OPERAND EXPONENT
INR L; TO ADDR OP SIGN, 1ST FRCTN
XRA M; OPERAND SIGN AND 1ST FRCTN
MOV B,A; OPERAND SIGN AND 1ST FRCTN
INR L; TO ADDR OPERAND 2ND
MOV C,M; OPERAND 2ND FRACTION
INR L; TO ADDR OPERAND 3RD FRCTN
MOV D,M; OPERAND 3RD FRACTION
; SAVE INITIAL EXPONENT.
LXI H,ACCE; TO ADDR ACCUM EXPONENT
MOV A,M; ACCUMULATOR EXPONENT
DCR L; TO ADDR INITIAL EXPONENT
MOV M,A; INITIAL EXPONENT
; CHECK FOR ZERO OPERAND.
MOV A,E; OPERAND EXPONENT
ANA A ; SET CONTROL BITS
JZ FTEST; IF OPERAND IS ZERO
; GENERATE SUBTRACTION FLAG, RESTORE
; SUPPRESSED FRACTION BIT.
MOV L,B; OPERAND SIGN AND 1ST FRCTN
MOV A,B; OPERAND SIGN AND 1ST FRACTION
ORI 80H; OPERAND 1ST FRACTION
MOV B,A; OPERAND 1ST FRACTION
XRA L; OPERAND SIGN
MVI L,LOW(ACCS); TO ADDRESS ACCUMULATOR SIGN
XRA M; SUBTRACTION FLAG
MVI L,LOW(SF); TO ADDRESS SUBTRACTION FLAG
MOV M,A; SUBTRACTION FLAG
; DETERMINE RELATIVE MAGNITUDES OF
; OPERAND AND ACCUMULATOR.
MVI L,LOW(ACCE); TO ADDRESS ACCUMULATOR EXPONENT
MOV A,M; ACCUMULATOR EXPONENT
ANA A ; SET CONTROL BITS
JZ ADD17; IF ACCUMULATOR IS ZERO
SUB E; DIFFERENCE IN EXPONENTS
JC ADD2; IF ACCUM SMALLER THAN OP
; CHECK FOR INSIGNIFICANT OPERAND.
JM FTEST; IF THE OPERAND IS INSIGNIFICANT
CPI 25; COMPARE SHIFT COUNT TO 25
JC ADD3; JOIN EXCH PATH IF OP SIGNIF
JMP FTEST; OPERAND IS INSIGNIFICANT
; CHECK FOR INSIGNIFICANT ACCUMULATOR
ADD2: JP ADD17; IF ACCUM IS INSIGNIFICANT
CPI 0E7H; COMPARE SHIFT COUNT TO MINUS 25
JC ADD17; IF ACCUM IS INSIGNIFICANT
MOV M,E; OPERAND EXPONENT
MOV E,A; SHIFT COUNT
LXI H,SF; TO ADDRESS THE SUBTRACTION FLAG
MOV A,M; SUBTRACTION FLAG
MVI L,LOW(ACCS); TO ADDRESS THE ACCUMULATOR SIGN
XRA M; OPERAND SIGN
MOV M,A; ACCUMULATOR SIGN
XRA A; ZERO
SUB E; COMPLEMENT SHIFT COUNT
; EXCHANGE ACCUMULATOR AND OPERAND.
INR L; TO ADDR ACCUM 1ST FRACTION
MOV E,M; ACCUMULATOR 1ST FRACTION
MOV M,B; OPERAND 1ST FRACTION
MOV B,E; ACCUMULATOR 1ST FRACTION
INR L; TO ADDR ACCUM 2ND FRACTION
MOV E,M; ACCUMULATOR 2ND FRACTION
MOV M,C; OPERAND 2ND FRACTION
MOV C,E; ACCUMULATOR 2ND FRACTION
INR L; TO ADDR ACCUM 3RD FRACTION
MOV E,M; ACCUMULATOR 3RD FRACTION
MOV M,D; OPERAND 3RD FRACTION
MOV D,E; ACCUMULATOR 3RD FRACTION
; POSITION THE OPERAND.
ADD3: CALL RSH; POSITION THE OPERAND
LXI H,SF; TO ADDRESS SUBTRACTION FLAG
MOV A,M; SUBTRACTION FLAG
ANA A ; SET CONTROL BITS
MVI L,LOW(ACC3); TO ADDR ACCUM 3RD FRCTN
JM ADD9; IF SUBTRACTION REQUIRED
; ADD ADDEND TO AUGEND.
MOV A,M; AUGEND 3RD FRACTION
ADD D; ADDEND 3RD FRACTION
MOV D,A; SUM 3RD FRACTION
DCR L; TO ADDRESS AUGEND 2ND FRACTION
MOV A,M; AUGEND 2ND FRACTION
ADC C; ADDEND 2ND FRACTION
MOV C,A; SUM 2ND FRACTION
DCR L; TO ADDRESS AUGEND 1ST FRACTION
MOV A,M; AUGEND 1ST FRACTION
ADC B; ADDEND 1ST FRACTION
MOV B,A; SUM 1ST FRACTION
JNC ADD11; IF NO CARRY FROM 1ST FRCTN
; RIGHT SHIFT SUM TO NORMALIZED POSITION.
RAR ; RIGHT SHIFT SUM 1ST FRACTION
MOV B,A; SUM 1ST FRACTION
MOV A,C; SUM 2ND FRACTION
RAR ; RIGHT SHIFT SUM 2ND FRACTION
MOV C,A; SUM 2ND FRACTION
MOV A,D; SUM 3RD FRACTION
RAR ; RIGHT SHIFT SUM 3RD FRACTION
MOV D,A; SUM 3RD FRACTION
RAR ; 4TH FRCTN = LOW BIT OF 3RD
MOV E,A; SUM 4TH FRACTION
MVI L,LOW(ACCE); TO ADDRESS ACCUMULATOR EXPONENT
MOV A,M; ACCUMULATOR EXPONENT
ADI 1; INCREMENT ACCUMULATOR EXPONENT
JC OVERF; IF OVERFLOW
MOV M,A; ACCUMULATOR EXPONENT
JMP ADD11; TO ROUND FRACTION
; SUBTRACT SUBTRAHEND FROM MINUEND.
ADD9: XRA A; MINUEND 4TH FRCTN IS ZERO
SUB E; SUBTRAHEND 4TH FRACTION
MOV E,A; DIFFERENCE 4TH FRACTION
MOV A,M; MINUEND 3RD FRACTION
SBB D; SUBTRAHEND 3RD FRACTION
MOV D,A; DIFFERENCE 3RD FRACTION
DCR L; TO ADDRESS MINUEND 2ND FRACTION
MOV A,M; MINUEND 2ND FRACTION
SBB C; SUBTRAHEND 2ND FRACTION
MOV C,A; DIFFERENCE 2ND FRACTION
DCR L; TO ADDRESS MINUEND 1ST FRACTION
MOV A,M; MINUEND 1ST FRACTION
SBB B; SUBTRAHEND 1ST FRACTION
MOV B,A; DIFFERENCE 1ST FRACTION
ADD10: CC FCOMP; COMPLEMENT IF NEGATIVE
CP NORM; NORMALIZE IF NECESSARY
JP FZERO; IF UNDERFLOW OR ZERO
ADD11: CALL ROND; CALL ROUNDING SUBROUTINE
JC OVERF; IF OVERFLOW
ADD12: MOV B,A; ACCUM SIGN AND 1ST FRCTN
LXI H,PREX; TO ADDRESS PREV EXPONENT
MOV A,E; ACCUMULATOR EXPONENT
SUB M; DIFFERENCE IN EXPONENTS
MOV L,A; DIFFERENCE IN EXPONENTS
MOV A,B; ACCUM SIGN AND 1ST FRCTN
ORI 1; SET SIGN BIT FOR EXIT
MOV A,E; ACCUMULATOR EXPONENT
MOV E,L; SIGNIFICANCE INDEX
RET ; RETURN TO CALLER
; LOAD THE ACCUMULATOR WITH THE OPERAND.
ADD17: LXI H,SF; TO ADDR SUBTRACTION FLAG
MOV A,M; SUBTRACTION FLAG
MVI L,LOW(ACCS); TO ADDR ACCUMULATOR SIGN
XRA M; OPERAND SIGN
DCR L; TO ADDR ACCUM EXPONENT
CALL FSTR0; SET THE ACCUMULATOR
XRA B; ACCUM SIGN AND 1ST FRCTN
JMP ADD12; JOIN EXIT CODE
DB 0; CHECK SUM WORD
; SUBROUTINE TO READ THE OPERAND AND
; CHECK THE ACCUMULATOR EXPONENT.
MDEX: MOV B,A; EXPONENT MODIFIER
INR L; TO ADDR OP SIGN, 1ST FRCTN
MOV C,M; OPERAND SIGN AND 1ST FRACTION
INR L; TO ADDRESS OPERAND 2ND FRACTION
MOV D,M; OPERAND 2ND FRACTION
INR L; TO ADDRESS OPERAND 3RD FRACTION
MOV E,M; OPERAND 3RD FRACTION
LXI H,ACCE; TO ADDRESS ACCUMULATOR EXPONENT
MOV A,M; ACCUMULATOR EXPONENT
ANA A ; SET CONTROL BITS
RZ ; RETURN IF ACCUM IS ZERO
ADD B; RESULT EXPONENT PLUS BIAS
MOV B,A; RESULT EXPONENT PLUS BIAS
RAR ; CARRY TO SIGN
XRA B; CARRY AND SIGN MUST DIFFER
MOV A,B; RESULT EXPONENT PLUS BIAS
MVI B,80H; EXP BIAS, SIGN MASK, MS BIT
JP OVUN; IF OVERFLOW OR UNDERFLOW
SUB B; REMOVE EXCESS EXP BIAS
RZ ; RETURN IF UNDERFLOW
MOV M,A; RESULT EXPONENT
INR L; TO ADDRESS ACCUMULATOR SIGN
MOV A,M; ACCUMULATOR SIGN
XRA C; RESULT SIGN IN SIGN BIT
ANA B ; RESULT SIGN
MOV M,A; RESULT SIGN
MOV A,C; OPERAND SIGN AND 1ST FRCTN
ORA B; OPERAND 1ST FRACTION
RET ; RETURN TO CALLER
OVUN: RLC ; SET CARRY BIT IF OVERFLOW
RC ; RETURN IF OVERFLOW
XRA A; ZERO
RET ; RETURN IF UNDERFLOW
; SUBROUTINE TO LEFT SHIFT THE B, C,
; D, AND E REGISTERS ONE BIT.
LSH: MOV A,E; ORIGINAL CONTENTS OF E
RAL ; LEFT SHIFT E
MOV E,A; RESTORE CONTENTS OF E REGISTER
LSH1: MOV A,D; ORIGINAL CONTENTS OF D REGISTER
RAL ; LEFT SHIFT D
MOV D,A; RESTORE CONTENTS OF D REGISTER
MOV A,C; ORIGINAL CONTENTS OF C REGISTER
RAL ; LEFT SHIFT C
MOV C,A; RESTORE CONTENTS OF C REGISTER
MOV A,B; ORIGINAL CONTENTS OF B REGISTER
ADC A; LEFT SHIFT B
MOV B,A; RESTORE CONTENTS OF B REGISTER
RET ; RETURN TO CALLER
; RIGHT SHIFT THE B, C, D AND E REGISTERS
; BY THE SHIFT COUNT IN THE A REGISTER
; SHIFT OPERAND TO REGISTER INDICATED BY
; SHIFT COUNT
RSH: MVI E,0; OPERAND 4TH FRCTN IS ZERO
RSH0: MVI L,8; EACH REG IS 8 BITS OF SHIFT
RSH1: CMP L; COMPARE SHIFT COUNT TO 8
JM RSH2; IF REQ SHIFT LESS THAN 8
MOV E,D; OPERAND 4TH FRACTION
MOV D,C; OPERAND 3RD FRACTION
MOV C,B; OPERAND 2ND FRACTION
MVI B,0; OPERAND 1ST FRACTION IS ZERO
SUB L; REDUCE SHIFT COUNT BY 1 REG
JNZ RSH1; IF MORE SHIFTS REQUIRED
; SHIFT OPERAND RIGHT BY -SHIFT COUNT-
; BITS.
RSH2: ANA A ; SET CONTROL BITS
RZ ; RETURN IF SHIFT COMPLETE
MOV L,A; SHIFT COUNT
RSH3: ANA A ; CLEAR CARRY BIT
MOV A,B; OPERAND 1ST FRACTION
RAR ; RIGHT SHIFT OP 1ST FRCTN
MOV B,A; OPERAND 1ST FRACTION
MOV A,C; OPERAND 2ND FRACTION
RAR ; RIGHT SHIFT OP 2ND FRCTN
MOV C,A; OPERAND 2ND FRACTION
MOV A,D; OPERAND 3RD FRACTION
RAR ; RIGHT SHIFT OP 3RD FRCTN
MOV D,A; OPERAND 3RD FRACTION
MOV A,E; OPERAND 4TH FRACTION
RAR ; RIGHT SHIFT OP 4TH FRCTN
MOV E,A; OPERAND 4TH FRACTION
DCR L; DECREMENT SHIFT COUNT
JNZ RSH3; IF MORE SHIFTS REQUIRED
RET ; RETURN TO CALLER
; COMPLEMENT THE B, C, D, AND E REGISTERS.
FCOMP: DCR L; TO ADDR ACCUM SIGN
MOV A,M; ACCUMULATOR SIGN
XRI 80H; CHANGE SIGN
MOV M,A; ACCUMULATOR SIGN
COMP1: XRA A; ZERO
MOV L,A; ZERO
SUB E; COMPLEMENT 4TH FRCTN
MOV E,A; 4TH FRACTION
MOV A,L; ZERO
SBB D; COMPLEMENT 3RD FRCTN
MOV D,A; 3RD FRACTION
MOV A,L; ZERO
SBB C; COMPLEMENT 2ND FRCTN
MOV C,A; 2ND FRACTION
MOV A,L; ZERO
SBB B; COMPLEMENT 1ST FRCTN
MOV B,A; 1ST FRACTION
RET ; RETURN TO CALLER
; NORMALIZE THE REGISTERS.
NORM: MVI L,20H; MAX NORMALIZING SHIFT
NORM1: MOV A,B; 1ST FRACTION
ANA A ; SET CONTROL BITS
JNZ NORM3; IF 1ST FRACTION NONZERO
MOV B,C; 1ST FRACTION
MOV C,D; 2ND FRACTION
MOV D,E; 3RD FRACTION
MOV E,A; ZERO 4TH FRACTION
MOV A,L; NORMALIZING SHIFT COUNT
SUI 8; REDUCE SHIFT COUNT
MOV L,A; NORMALIZING SHIFT COUNT
JNZ NORM1; IF FRACTION NONZERO
RET ; IF FRACTION IS ZERO
NORM2: DCR L; DECREMENT SHIFT COUNT
MOV A,E; ORIGINAL CONTENTS OF E
RAL ; LEFT SHIFT E
MOV E,A; RESTORE CONTENTS OF E REGISTER
MOV A,D; ORIGINAL CONTENTS OF D REGISTER
RAL ; LEFT SHIFT D
MOV D,A; RESTORE CONTENTS OF D REGISTER
MOV A,C; ORIGINAL CONTENTS OF C REGISTER
RAL ; LEFT SHIFT C
MOV C,A; RESTORE CONTENTS OF C REGISTER
MOV A,B; ORIGINAL CONTENTS OF B REGISTER
ADC A; LEFT SHIFT B
MOV B,A; RESTORE CONTENTS OF B REGISTER
NORM3: JP NORM2; IF NOT NORMALIZED
MOV A,L; NORMALIZING SHIFT COUNT
SUI 20H; REMOVE BIAS
LXI H,ACCE; TO ADDR ACCUM EXPONENT
ADD M; ADJUST ACCUM EXPONENT
MOV M,A; NEW ACCUM EXPONENT
RZ ; RETURN IF ZERO EXP
RAR ; BORROW BIT TO SIGN
ANA A ; SET SIGN TO IND. UNDERFLOW
RET ; RETURN TO CALLER
; SUBROUTINE TO ROUND THE B, C, D REGISTERS.
ROND: LXI H,ACCE; TO ADDR ACCUM EXPONENT
MOV A,E; 4TH FRACTION
ANA A ; SET CONTROL BITS
MOV E,M; ACCUMULATOR EXPONENT
CM RNDR; CALL 2ND LEVEL ROUNDER
RC ; IF OVERFLOW
MOV A,B; 1ST FRACTION
INR L; TO ADDR ACCUM SIGN
XRA M; ACCUM SIGN AND 1ST FRCTN
JMP STR1; RETURN THRU STORE SUBR.
; SECOND LEVEL ROUNDING SUBROUTINE.
RNDR: INR D; ROUND 3RD FRACTION
RNZ ; RETURN IF NO CARRY
INR C; CARRY TO 2ND FRACTION
RNZ ; RETURN IF NO CARRY
INR B; CARRY TO 1ST FRACTION
RNZ ; RETURN IF NO CARRY
MOV A,E; ACCUMULATOR EXPONENT
ADI 1; INCREMENT ACCUM EXPONENT
MOV E,A; NEW ACCUM EXPONENT
MVI B,80H; NEW 1ST FRACTION
MOV M,A; NEW ACCUM EXPONENT
RET ; RETURN TO ROND SUBROUTINE
; FIXED POINT MULTIPLY SUBROUTINE.
MULX: LXI H,MULP1+1; TO ADDR 1ST MULTIPLICAND
MOV M,A; 1ST MULTIPLICAND
LXI H,MULP2+1; TO ADDR 2ND MULTIPLICAND
MOV M,D; 2ND MULTIPLICAND
LXI H,MULP3+1; TO ADDR 3RD MULTIPLICAND
MOV M,E; 3RD MULTIPLICAND
XRA A; CLEAR 6TH PRODUCT
MOV E,A; CLEAR 5TH PRODUCT
MOV D,A; CLEAR 4TH PRODUCT
; MULTIPLY BY EACH ACCUMULATOR
; FRACTION IN TURN.
LXI H,ACC3; TO ADDRESS 3RD FRCTN
CALL MULX2; MULTIPLY BY ACCUM 3RD FRCTN
MVI L,LOW(ACC2); TO ADDRESS 2ND FRCTN
CALL MULX1; MULTIPLY BY ACCUM 2ND FRCTN
MVI L,LOW(ACC1); TO ADDRESS 1ST FRCTN
; MULTIPLY BY ONE ACCUMULATOR WORD.
MULX1: MOV A,D; 5TH PARTIAL PRODUCT
MOV E,C; 4TH PARTIAL PRODUCT
MOV D,B; 3RD PARTIAL PRODUCT
MULX2: MOV B,M; MULTIPLIER
MOV L,A; 5TH PARTIAL PRODUCT
XRA A; ZERO
MOV C,A; 2ND PARTIAL PRODUCT
SUB B; SET CARRY BIT FOR EXIT FLAG
JC MULX3; IF MULTIPLIER IS NOT ZERO
MOV C,D; 2ND PARTIAL PRODUCT
MOV D,E; 3RD PARTIAL PRODUCT
RET ; MULT BY ZERO COMPLETE
; COMPLETE ADDITION OF MULTIPLICAND.
MULX5: MOV C,A; 2ND PARTIAL PRODUCT
JNC MULX3; IF NO CARRY TO 1ST PRODUCT
INR B; ADD CARRY TO 1ST PRODUCT
ANA A ; CLEAR CARRY BIT
; LOOP FOR EACH BIT OF MULTIPLIER WORD.
MULX3: MOV A,L; 5TH PART PRODUCT, EXIT FLAG
ADC A; SHIFT EXIT FLAG OUT IF DONE
RZ ; EXIT IF MULTIPLICATION DONE
MOV L,A; 5TH PART PRODUCT, EXIT FLAG
MOV A,E; 4TH PARTIAL PRODUCT
RAL ; SHIFT 4TH PARTIAL PRODUCT
MOV E,A; 4TH PARTIAL PRODUCT
MOV A,D; 3RD PARTIAL PRODUCT
RAL ; SHIFT 3RD PARTIAL PRODUCT
MOV D,A; 3RD PARTIAL PRODUCT
MOV A,C; 2ND PARTIAL PRODUCT
RAL ; SHIFT 2ND PARTIAL PRODUCT
MOV C,A; 2ND PARTIAL PRODUCT
MOV A,B; 1ST PART PROD AND MULTPLIER
RAL ; SHIFT 1ST PROD AND MULTIPLIER
MOV B,A; 1ST PART PROD AND MULTIPLIER
JNC MULX3; IF NO ADDITION REQUIRED
; ADD THE MULTIPLICAND TO THE PRODUCT
; IF THE MULTIPLIER BIT IS ONE.
MOV A,E; 4TH PARTIAL PRODUCT
; THE FOLLOWING CODE WAS MOVED FROM THE BEGINNING
; OF THE PROGRAM TO THIS LOCATION TO MAKE THINGS
; A LITTLE EASIER...
MULX4:
MULP3:
ADI 0; ADD OPERAND 3RD FRACTION
MOV E,A; 4TH PARTIAL PRODUCT
MOV A,D; 3RD PARTIAL PRODUCT
MULP2:
ACI 0; ADD OPERAND 2ND FRACTION
MOV D,A; 3RD PARTIAL PRODUCT
MOV A,C; 2ND PARTIAL PRODUCT
MULP1:
ACI 0; ADD OPERAND 1ST FRACTION
JMP MULX5
; FIXED POINT DIVIDE SUBROUTINE.
; SUBTRACT DIVISOR FROM ACCUMULATOR TO
; OBTAIN 1ST REMAINDER.
DIVX: LXI H,ACC3; TO ADDRESS ACCUM 3RD FRCTN
MOV A,M; ACCUMULATOR 3RD FRACTION
SUB E; DIVISOR 3RD FRACTION
MOV M,A; REMAINDER 3RD FRACTION
DCR L; TO ADDRESS ACCUM 2ND FRCTN
MOV A,M; ACCUMULATOR 2ND FRACTION
SBB D; DIVISOR 2ND FRACTION
MOV M,A; REMAINDER 2ND FRACTION
DCR L; TO ADDRESS ACCUM 1ST FRCTN
MOV A,M; ACCUMULATOR 1ST FRACTION
SBB C; DIVISOR 1ST FRACTION
MOV M,A; REMAINDER 1ST FRACTION
; HALVE THE DIVISOR AND STORE FOR
; ADDITION OR SUBTRACTION.
MOV A,C; DIVISOR 1ST FRACTION
RAL ; SET CARRY BIT
MOV A,C; DIVISOR 1ST FRACTION
RAR ; HALF OF DIVISOR 1ST FRCTN
; + 80H TO CORRECT QUOTIENT
LXI H,OP1S+1; TO ADDRESS 1ST SUBTRACT DIVISOR
MOV M,A; 1ST SUBTRACT DIVISOR
LXI H,OP1A+1; TO ADDRESS 1ST ADD DIVISOR
MOV M,A; 1ST ADD DIVISOR
MOV A,D; DIVISOR 2ND FRACTION
RAR ; HALF OF DIVISOR 2ND FRACTION
LXI H,OP2S+1; TO ADDRESS 2ND SUBTRACT DIVISOR
MOV M,A; 2ND SUBTRACT DIVISOR
LXI H,OP2A+1; TO ADDRESS 2ND ADD DIVISOR
MOV M,A; 2ND ADD DIVISOR
MOV A,E; DIVISOR 3RD FRACTION
RAR ; HALF OF DIVISOR 3RD FRACTION
LXI H,OP3S+1; TO ADDRESS 3RD SUBTRACT DIVISOR
MOV M,A; 3RD SUBTRACT DIVISOR
LXI H,OP3A+1; TO ADDRESS 3RD ADD DIVISOR
MOV M,A; 3RD ADD DIVISOR
MVI B,0; INIT QUOTIENT 1ST FRCTN
MOV A,B; DIVISOR FOURTH FRACTION IS ZERO
RAR ; LOW BIT OF DIVISOR 3RD FRACTION
LXI H,OP4S+1; TO ADDRESS 4TH SUBTRACT DIVISOR
MOV M,A; 4TH SUBTRACT DIVISOR
LXI H,OP4A+1; TO ADDRESS 4TH ADD DIVISOR
MOV M,A; 4TH ADD DIVISOR
LXI H,OP4X+1; TO ADDRESS 4TH ADD DIVISOR
MOV M,A; 4TH ADD DIVISOR
; LOAD 1ST REMAINDER, CHECK SIGN.
LXI H,ACC1; TO ADDR REMAINDER 1ST FRCTN
MOV A,M; REMAINDER 1ST FRACTION
INR L; TO ADDR REMAINDER 2ND FRCTN
MOV D,M; REMAINDER 2ND FRACTION
INR L; TO ADDR REMAINDER 3RD FRCTN
MOV E,M; REMAINDER 3RD FRACTION
ANA A ; SET CONTROL BITS
JM DIVX4; IF REMAINDER IS NEGATIVE
; ADJUST EXPONENT,POSITION REMAINDER
; AND INITIALIZE THE QUOTIENT.
MVI L,LOW(ACCE); TO ADDRESS ACCUMULATOR EXPONENT
MOV C,M; QUOTIENT EXPONENT
INR C; INCREMENT QUOTIENT EXPONENT
RZ ; RETURN IF OVERFLOW
MOV M,C; QUOTIENT EXPONENT
MOV L,E; REMAINDER 3RD FRACTION
MOV H,D; REMAINDER 2ND FRACTION
MOV E,A; REMAINDER 1ST FRACTION
MVI D,1; INITIALIZE QUOT 3RD FRCTN
MOV C,B; INITIALIZE QUOT 2ND FRCTN
; SUBTRACT THE DIVISOR FROM THE REMAINDER
; IF IT IS POSITIVE
DIVX1: XRA A; REMAINDER 4TH FRCTN IS ZERO
CALL DIVX5;
DIVX2: RLC ; SHFT REM 4TH FRCTN TO CY
; SHIFT THE REMAINDER LEFT ONE BIT.
MOV A,B; QUOTIENT 1ST FRACTION
RAL ; MS BIT OF QUOTIENT TO CY
RC ; IF DIVISION COMPLETE
RAR ; REMAINDER 4TH FRCTN TO CY
MOV A,L; REMAINDER 3RD FRACTION
RAL ; LEFT SHIFT REM 3RD FRCTN
MOV L,A; REMAINDER 3RD FRACTION
MOV A,H; REMAINDER 2ND FRACTION
RAL ; LEFT SHIFT REM 2ND FRCTN
MOV H,A; REMAINDER 2ND FRACTION
CALL LSH; CALL LEFT SHIFT SUBROUTINE
; BRANCH IF SUBTRACTION IS REQUIRED
MOV A,D; QUOTIENT 3RD FRACTION
RRC ; REM SIGN INDIC TO CARRY BIT
JC DIVX1; TO SUB DIVISOR IF REM POS
; ADD THE DIVISOR IF THE REMAINDER
; IS NEGATIVE.
DIVX3: MOV A,L; REMAINDER 3RD FRACTION
JMP DIVX6;
; POSITION THE REMAINDER AND INITIALIZE
; THE QUOTIENT.
DIVX4: MOV L,E; REMAINDER 3RD FRACTION
MOV H,D; REMAINDER 2ND FRACTION
MOV E,A; REMAINDER 1ST FRACTION
MOV D,B; INITIALIZE QUOT 3RD FRCTN
MOV C,B; INITIALIZE QUOT 2ND FRCTN
JMP DIVX3; ADD DIVISOR IF REM IS NEG
; ORIGINALLY, THIS CODE WAS AT THE BEGINNING
; OF THE PROGRAM...
DIVX5:
OP4S:
SUI 0; SUB DIVISOR 4TH FRACTION
MOV A,L; REM 3RD FRACTION
OP3S:
SBI 0; SUB DIVISOR 3RD FRACTION
MOV L,A; REM 3RD FRACTION
MOV A,H; REM 2ND FRACTION
OP2S:
SBI 0; SUB DIVISOR 2ND FRACTION
MOV H,A; REM 2ND FRACTION
MOV A,E; REM 1ST FRACTION
OP1S:
SBI 0; SUB DIVISOR 1ST FRACTION
MOV E,A; REM 1ST FRACTION
OP4A:
MVI A,0; REM 4TH FRACTION
RET
DIVX6:
OP3A:
ADI 0; ADD DIVISOR 3RD FRACTION
MOV L,A; REM 3RD FRACTION
MOV A,H; REM 2ND FRACTION
OP2A:
ACI 0; ADD DIVISOR 2ND FRACTION
MOV H,A; REM 2ND FRACTION
MOV A,E; REM 1ST FRACTION
OP1A:
ACI 0; ADD DIVISOR 1ST FRACTION
MOV E,A; REM 1ST FRACTION
OP4X:
MVI A,0; REM 4TH FRACTION
JMP DIVX2
END

BIN
ASSEMBLY & COMPILE TOOLS/Basic-E/source/RUN.COM Normal file
View File

Binary file not shown.

2292
ASSEMBLY & COMPILE TOOLS/Basic-E/source/RUN.PLM Normal file
View File

File diff suppressed because it is too large Load Diff

577
ASSEMBLY & COMPILE TOOLS/Basic-E/source/TRAN.SRC Normal file
View File

@@ -0,0 +1,577 @@
NAME FPINT
CSEG
;
;
; LINK TO EXTERNAL REFERENCES
;
EXTRN FSTOR,FLOAD,FADD,FTEST,FZERO,FABS,FMUL,FDIV
EXTRN FFLOAT,FFIX,FCHS,FSUB
EXTRN OVER
EXTRN OVERF,ACC2,ACCE
EXTRN SEED
PUBLIC IDV,FCOSH,FSQRT,FSIN,FCOS,FATAN,FSINH,FEXP,FLOG
PUBLIC RAND
;
; ENTRY IDV - INVERSE FDIVIDE
;
; STORAGE IN SCRATCH PAD
SCRT: DS 25
IDVT EQU SCRT + 00H
;
IDV: PUSH H
CALL FTEST ;FLOATING POINT ACCUMULATOR TO REGISTERS
LXI H,IDVT
CALL FSTOR ;FDIVISOR TO STORAGE
POP H
CALL FLOAD ;FDIVIDEND TO FLOATING POINT ACCUMULATOR
LXI H,IDVT
JMP FDIV ;RETURN THROUGH DIV ROUTINE
;
;
;
; FLOATING POINT SQUARE ROOT ROUTINE BY NEWTONIAN ITERATION
;
; THE SQUARE ROOT OF THE FABSOLUTE VALUE OF THE
; CONTENTS OF THE FLOATING POINT ACCUMULATOR IS
; RETURNED IN THE FLOATING POINT ACCUMULATOR.
;
;
; STORAGE IN SCRATCH BANK
FSQRN EQU SCRT + 00H
FSQRX EQU SCRT + 04H
;
FSQRT: CALL FABS ;FORCE ARGUMENT POSITIVE, SET ZERO FLAG
RZ ;RETURN ON ZERO
LXI H,FSQRN
CALL FSTOR
ANA A ;RESET CARRY BIT
RAR ;HALVE THE EXPONENT
ADI 40H ;RESTORE THE OFFSET
LXI H,FSQRX
CALL FSTOR
MVI D,5 ;ITERATION COUNT
PUSH D ;STACKED
FSQRL: LXI H,FSQRN
CALL FLOAD
LXI H,FSQRX
CALL FDIV
LXI H,FSQRX
CALL FADD
SUI 1 ;HALVE THE RESULT
LXI H,FSQRX
CALL FSTOR
POP D ;RESTORE ITERATION COUNT
DCR D ;TALLY
JZ FSQRE ;EXIT WHEN COUNT EXHAUSTED
PUSH D ;SAVE IT OTHERWISE
JMP FSQRL ;TO NEXT ITERATION
FSQRE: LXI H,FSQRX ;RESULT TO ACCUMULATOR
CALL FLOAD
RET
;
; EVALUATION OF ELEMENTARY FUNCTION MACLAURIN SERIES
;
;
; ENTRY FMACE FOR EXPONENTIAL TYPE SERIES, E.G.
; SINH(Z) = Z/1 + Z^3/6 + Z^5/120 + ...
; S(I-1) = (1. + X*S(I)/A(I)), S(N) = 1.
;
; ENTRY FMACL FOR LOGARITHMIC TYPE SERIES, E.G.
; ARCTAN(Z) = Z/1 - Z^3/3 + Z^5/5 - ...
; S(I-1) = (1./A(I) + X*S(I)), S(N) = 0.
;
; IN BOTH SERIES DEL^2(A(I)) MUST BE CONSTANT.
; ENTER WITH X IN FMACX, A(N) IN D, D(A(N-1)) IN C,
; D^2(A(1)) IN B.
; RESULT IN FMACS, WHEN A(I) <= 0.
;
; STORAGE IN SCRATCH BANK
FMACX EQU SCRT+00H
FMACS EQU SCRT+04H
FMACT EQU SCRT+08H
FMACG EQU SCRT+0CH
;
; TWO SUBROUTINE LEVELS USED
;
FMACL: XRA A ;CLEAR A REGISTER FOR LOG TYPE SERIES
LXI H,FMACS ;POINT TO SIGMA
MOV M,A ;ZERO STORED
LXI H,FMACB ;PRESET BRANCH B
JMP FMACC ;JOINT CODE
FMACE: LHLD FONE ;MOVE 1.0 TO SIGMA FOR EXP TYPE SERIES
SHLD FMACS
LHLD FONE+2
SHLD FMACS+2
LXI H,FMACA ;PRESET BRANCH A
FMACC: SHLD FMACG ;STORE PRESET BRANCH
MVI E,32 ;COUNT FOR THE FLOATING OF A(I)
FMACD: PUSH B ;CHAIN RULE LOOP
PUSH D ;SAVE A(I), D(A(I)), D^2(A(1))
XRA A ;ZERO THE LEAD POSITIONS OF A(I)
MOV B,A
MOV C,A
CALL FFLOAT ;FLOAT A(I)
LXI H,FMACT
CALL FSTOR
LXI H,FMACX
CALL FLOAD
LXI H,FMACS
CALL FMUL
LHLD FMACG ;CHOOSE THE BRANCH
PCHL
FMACA: LXI H,FMACT
CALL FDIV
LXI H,FONE ;POINTS TO 1.0
JMP FMACF ;REJOIN COMMON CODE
FMACB: LXI H,FMACS
CALL FSTOR ;X*SIGMA
LXI H,FONE ;LOAD 1.0
CALL FLOAD
LXI H,FMACT
CALL FDIV ;1/A(I)
LXI H,FMACS
FMACF: CALL FADD
LXI H,FMACS
CALL FSTOR
POP D ;A(I) AND 32
POP B ;D(A) AND D^2(A)
MOV A,D
SUB C
RZ ;DONE IF ZERO
RC ;OR NEGATIVE
MOV D,A ;A(I-1)
MOV A,C ;D(A(I-1))
SUB B
MOV C,A ;D(A(I-2))
JMP FMACD ;NEXT ITERATION
FONE: DB 81H,0,0,0 ;CAN BE IN ROM
FPIV2: DB 81H,49H,0FH,0DCH;PI/2
FLN2: DB 80H,31H,72H,18H;LN 2
;
;
; SINE-COSINE ROUTINE USING MACLAURIN SERIES
;
;
; ENTRY FSIN FOR SIN(X)
; ENTRY FCOS FOR COS(X)
; ENTER WITH X IN RADIANS IN FLOATING POINT ACCUMULATOR
; RETURNS WITH FUNCTION IN FLOATIG POINT ACCUMULATOR
; (IF FABS(X) >= 2^24*PI, OVERFLOW FLAG IS SET)
;
; STORAGE IN SCRATCH BANK
FSINX EQU SCRT+10H
;
; THREE LEVELS OF SUBROUTINES USED
;
FCOS: CALL FCHS ;COMPLEMENT THE ANGLE
LXI H,FPIV2
CALL FADD
FSIN: CALL FTEST ;FETCH ARGUMENT
LXI H,FSINX
CALL FSTOR
LXI H,FPIV2 ;REDUCE X TO REVOLUTIONS*4
CALL FDIV
MVI E,26 ;REVOLUTIONS AT BINARY SCALE 24
CALL FFIX
JC OVERF ;QUIT IF ANGLE TO LARGE
MVI E,26
MVI D,0 ;WIPE OUT FRACTIONAL REVOLUTIONS
CALL FFLOAT ;INTEGER PART OF REVOLUTIONS
LXI H,FPIV2 ;TO RADIANS
CALL FMUL
CALL FCHS
FSINA: LXI H,FSINX
CALL FADD
LXI H,FSINX
CALL FSTOR
CALL FABS ;FORCE ANGLE INTO REDUCED RANGE
LXI H,FPIV2
CALL FSUB
JM FSINB ;IF NEGATIVE OR ZERO
JZ FSINB ;THEN ANDGLE IS REDUCED
LXI H,FPIV2 ;FABS(X)-PI
CALL FSUB
MOV E,A ;SAVE A REGISTER
LXI H,FSINX+1
MOV A,M
ANI 80H ;SIGN OF X
XRI 80H ;INVERTED
XRA B ;-SIGN(X)*(FABS(X)-PI)
MOV B,A
MOV A,E ;RESTORE A REGISTER
DCX H ;POINT TO FSINX
CALL FSTOR ;REDUCED X
CALL FZERO ;CLEAR ACCUMULATOR
JMP FSINA ;REPEAT UNTIL FABS(X) <= PI/2
;
FSINB: LXI H,FSINX
CALL FLOAD
LXI H,FSINX
CALL FMUL
CALL FCHS ;-X^2
LXI H,FMACX
CALL FSTOR ;TO MACLAURIN SERIES
MVI D,72 ;9*8, 11 TERM DISCARDED, 18 BITS PRECISION
MVI C,30 ;9*8 - 7*6
MVI B,8 ;(9*8 - 7*6) - (7*6 - 5*4)
CALL FMACE
LXI H,FMACS
CALL FLOAD
LXI H,FSINX
CALL FMUL
CPI 81H ;SEE IF TAIL NEEDS CLEANING
JC FSINC ;NO, MAGNITUDE IS < 1.0
LXI H,ACC2
XRA A
MOV M,A
INR L
MOV M,A
FSINC: CALL FTEST ;RESTORE FLAGS AND REGISTERS FOR EXIT
RET
;
;
; ARCTAN ROUTINE USING MACLAURIN SERIES
;
;
;
; ENTRY FATAN FOR ARCTAN(X), WITH X IN FLOATING POINT ACCUMULATOR
; RESULT RETURNED IN FLOATING POINT ACCUMULATOR
;
; STORAGE IN SCRATCH BANK
FATNT EQU SCRT+10H
FATNU EQU SCRT+14H
;
; FOUR LEVELS OF STACK USED
;
FATAN: CALL FTEST ;GET F.P. ACC. INTO REGISTERS
RZ
CPI 81H ;TEST EXPONENT
JC FATN1 ;RETURN TO CALLER FROM FATN1
LXI H,FONE ;1.0
CALL IDV ;1.0/X
CALL FATN1 ;ARCTAN(1/X)
LXI H,FATNU
CALL FSTOR
LXI H,FPIV2 ;PI/2
CALL FLOAD
MOV E,A ;SAVE A REGISTER
LXI H,FATNU+1 ;SIGN(T)
MOV A,M ;TO A REGISTER
ANI 80H
ORA B ;ATTACH TO PI/2
MOV B,A
MOV A,E ;RESTORE A REGISTER
LXI H,FATNT
CALL FSTOR
LXI H,FATNT
CALL FLOAD
LXI H,FATNU ;-SIGN(T)*(PI/S-FABS(T))
CALL FSUB ;=SIGN(T)*FABS(T) = T
RET
;
; EVALUATE ARCTAN OF ARGUMENTS < 1.0
FATN1: LXI H,FATNT ;POINT TO TEMP
CALL FSTOR ;TAN(T)
LXI H,FATNT
CALL FMUL ;TAN(T)^2
LXI H,FONE ;1.0
CALL FADD
CALL FSQRT
LXI H,FONE
CALL FADD ;1.0+SQRT(TAN(T)^2+1.0)
LXI H,FATNT
CALL IDV ;TAN(T/2)
LXI H,FATNT
CALL FSTOR
LXI H,FATNU
INR A ;2*TAN(T/2)
CALL FSTOR
LXI H,FATNT
CALL FMUL
CALL FCHS ;-TAN(T/2)^2
LXI H,FMACX
CALL FSTOR
MVI D,11 ;TERM 13 DISCARDED, 16 BITS PRECISION IN RANGE
MVI C,2 ;(11-9)
MVI B,0 ;(11-9)-(9-7)
CALL FMACL
LXI H,FMACS
CALL FLOAD
LXI H,FATNU
CALL FMUL
RET
;
;
;
; HYPERBOLIC COSINE ROUTINE USING MACLAURIN SERIES
;
;
;
; ENTRY FCOSH FOR COSH(X), WITH X IN THE FLOATING POINT ACCUMULATOR
; THE RESULT IS RETURNED IN THE F.P. ACCUMULATOR.
; IF FABS(X) > 88.0 THE OVERFLOW FLAG IS SET.
;
; STORAGE IN SCRATCH BANK
FCSHD EQU SCRT+0EH ;DOUBLING COUNTER
;
; THREE LEVELS OF STACK USED
;
FCOSH: CALL FTEST ;GET ARGUMENT INTO REGISTERS
LXI H,FMACX
CALL FSTOR
LXI H,FCSHD
MVI M,0
SUI 80H ;REMOVE EXPONENT OFFSET
JM FCSHA ;DOUBLING COUNT AND X ARE OK
CPI 8 ;ELIMINATE OVERSIZE DOUBLING COUNT
JP OVERF ;RETURN THROUGH OVERFLOW ROUTINE
MOV M,A ;SAVE THE DOUBLING COUNT
LXI H,FMACX
MVI M,80H
CALL FLOAD ;PUT X INTO ACC
FCSHA: LXI H,FMACX
CALL FMUL ;X^2
LXI H,FMACX
CALL FSTOR
MVI D,56 ;8*7, 10 TERM DISCARDED, 21 BITS PRECISION
MVI C,26 ;(8*7-6*5)
MVI B,8 ;(8*7-6*5) - (6*5-4*3)
CALL FMACE
FCSHB: LXI H,FCSHD ;ADDRESS THE DOUBLING COUNT
DCR M ;TALLY AT LOOP TOP
JM FCSHC ;DONE WHEN COUNT IS NEGATIVE
LXI H,FMACS ;FETCH COSH(X/2)
CALL FLOAD
LXI H,FMACS
CALL FMUL ;COSH(X/2)^2
LXI H,ACCE
INR M ;2*COSH(X/2)^2
LXI H,FONE ;-1.0
CALL FSUB ;=COSH(X)
LXI H,FMACS
CALL FSTOR
JMP FCSHB ;TEST DOUBLING COUNT
FCSHC: CALL FTEST ;RESTORE REGISTERS AND FLAGS
RET
;
;
;
; EXPONENTIAL AND HYPERBOLIC SIN ROUTINE
;
;
; SCRATCH BANK STORAGE
FSNHD EQU SCRT+0EH
FEXOV EQU SCRT+0FH
FSNHX EQU SCRT+10H
;
;
; ENTRY FEXP FOR EXP(X)
; ENTRY SSINH FOR SINH(X)
; ENTRY WITH X IN FP ACCUMULATOR
; RETURNS WITH FUNCTION IN FP ACCUMULATOR.
; IF FUNCTION EXCEEDS 2^127M OVERFLOW FLAG WILL BE SET
;
FSINH: CALL FTEST ;FETCH FP ACCUMULATOR
LXI H,FSNHX ;SAVE ARGUMENT
CALL FSTOR
LXI H,FSNHD ;ADDRESS DOUBLING COUNTER
MVI M,0
SUI 80H ;REMOVE OFFSET FROM A
JM FSNHA ;DOUBLING COUNT AND X ARE OK
CPI 8 ;ELIMINATE OVERSIZE DOUBLING COUNT
JP OVERF ;RETURN THROUGH OVERFLOW ROUTINE
MOV M,A ;SAVE DOUBLING COUNT
LXI H,FSNHX ;BRING ARGUMENT INTO RANGE
MVI M,80H
CALL FLOAD ;PUT X INTO FLOATING ACCUMULATOR
FSNHA: LXI H,FSNHX
CALL FMUL ;X^2
LXI H,FMACX
CALL FSTOR
MVI D,42 ;7*6, 9 TERM DISCARDED, 18 BITS PRECISION
MVI C,22 ;7*6-5*4
MVI B,8 ;(7*6-5*4)-(F*4-3*2)
CALL FMACE
LXI H,FMACS
CALL FLOAD
LXI H,FSNHX
CALL FMUL
LXI H,FSNHX ;SINH(X)
CALL FSTOR
LXI H,FSNHX ;SINH(X)^2
CALL FMUL
LXI H,FONE ;+1.0
CALL FADD
CALL FSQRT ;COSH(X) FOR DOUBLINE AND FOR EXP(X9
LXI H,FMACX ;TEMP
CALL FSTOR
FSNHB: LXI H,FSNHD ;ADDRESS DOUBLING COUNT
DCR M ;TALLY AT LOOP TOP
JM FSNHC ;DONE WHEN NEGATIVE
LXI H,FMACX ;COSH(X/2)
CALL FLOAD
LXI H,FSNHX ;SINH(X/2)
CALL FMUL
INR A ;2.*SINH(X/2)*COSH(X/2)
LXI H,FSNHX ;SINH(X)
CALL FSTOR
LXI H,FMACX ;COSH(X/2)
CALL FLOAD
LXI H,FMACX
CALL FMUL
LXI H,ACCE ;2.*COSH(X/2)^2
INR M
LXI H,FONE ;-1
CALL FSUB
LXI H,FMACX ;=COSH(X)
CALL FSTOR
JMP FSNHB ;TEST THE DOUBLING COUNT
FSNHC: LXI H,FSNHX
CALL FLOAD
RET
FEXP: CALL FTEST
JP FEXPP
LXI H,OVER ;SAVE OVERFLOW FLAG
MOV E,M
MVI M,0
LXI H,FEXOV
MOV M,E ;OLD FLAG TO SAVE CELL
CALL FABS
CALL FEXPP ;EXP(-X) IN ACC
LXI H,FEXOV ;GET OLD OVERFLOW FLAG BACK
MOV E,M
LXI H,OVER ;PICK UP NEW ONE TO TEST
MOV A,M
MOV M,E ;RESTORE OLD OVERFLOW FLAG
ANA A ;SET FLAGS
JNZ FZERO ;RECIPROCAL OF OVERFLOW IS ZERO
LXI H,FONE
CALL IDV ;1./EXP(-X) = EXP(X)
RET
FEXPP: CALL FSINH ;SINH(X)
LXI H,FMACX ;+COSH(X)
CALL FADD ;=EXP(X)
RET
;
;
;
; NATURAL LOGARITHM ROUTINE USING MACLAURIN SERIES
;
;
;
;
; ENTRY POINTS IN MACLAURIN SERIES
; STORAGE IN SCRATCH BANK
FLOGE EQU SCRT+0EH
FLOGX EQU SCRT+10H
;
;
; ENTRY FLOG FOR LN(FABS(X)), WITH X IN F.P. ACCUMULATOR
; RESULT IS RETURNED IN FLOATING POINT ACCUMULATOR
; IF X = 0 THE OVERFLOW FLAG IS SET
;
; 3 LEVELS OF SUBROUTINES USED
;
FLOG: CALL FABS ;FORCE ARGUMENT POSITIVE, SET ZERO FLAG
JZ OVERF ;RETURN THROUGH OVERFLOW ROUTINE
SUI 81H ;REMOVE EXPONENT OFFSET
LXI H,FLOGE
MOV M,A
MVI A,81H ;NORMALIZE ARGUMENT
LXI H,FLOGX
CALL FSTOR ;CALL IT X
LXI H,FLOGX
CALL FLOAD
LXI H,FONE
CALL FADD
LXI H,FMACS
CALL FSTOR ;X+1.0
LXI H,FLOGX
CALL FLOAD
LXI H,FONE
CALL FSUB ;X-1.0
LXI H,FMACS
CALL FDIV
LXI H,FLOGX
CALL FSTOR ;(X-1.0)/(X+1.0)
LXI H,FLOGX
CALL FMUL
LXI H,FMACX
CALL FSTOR ;((X-1.0)/(X+1.0))^2
MVI D,9 ;DISCARD 11 TERM FOR 18 BITS PRECISION
MVI C,2 ;9-7
MVI B,0 ;(9-7)-(7-5)
CALL FMACL
LXI H,FMACS
INR M ;DOUBLE THE SUM
CALL FLOAD
LXI H,FLOGX
CALL FMUL ;LOGARITHM OF FRACTIONAL PART
LXI H,FLOGX
CALL FSTOR
LXI H,FLOGE
MOV A,M
MVI B,0
MOV C,B
MOV D,B
MVI E,8 ;BINARY SCALE FACTOR FOR EXPONENT
CALL FFLOAT
LXI H,FLN2
CALL FMUL ;LOGARITHM OF 2^EXPONENT
LXI H,FLOGX ;LOG OF FRACTIONAL PART
CALL FADD
RET
;
; RANDOM NUMBER GENERATOR
;
;
RAND: ;COMPUTE NEXT RANDOM NUMBER, AND LEAVE AT SEED
LXI H,SEED
MOV C,M ;GET LEAST SIGNIFICANT BYTE
INR L
MOV B,M ;X(N) IN B,C
DCR L ;ADDRESS SEED FOR SBR2
CALL AROUT ;CALCUALTE X(N)*2053D
LXI H,CNST ;ADDRESS CONSTANT 13849
CALL SBR2
LXI H,SEED ;ADDRESS SEED AGAIN
MOV M,C ;STORE NEW SEED
INR L
MOV M,B
RET ;WITH SEED SET TO RANDOM NUMBER
;
CNST: DW 13849
;
AROUT: ;COMPUTE X(N)*2053D TO B,C
MVI D,9 ;X(N)*2**9
CALL SBR1
CALL SBR2 ;X(N)+X(N)*2**9
MVI D,2 ;2**2*(X(N)+X(N)*2**9)
CALL SBR1
CALL SBR2 ;ADD TO X(N)
RET
;
SBR1: ;FORMS (B AND C)*2**D
SUB A ;CLEAR A AND CARRY
MOV A,C ;SHIFT C LEFT
RAL
MOV C,A
MOV A,B ;SHIFT B LEFT
RAL
MOV B,A
DCR D ;TEST D=0
RZ ;IF YES, RETURN
JMP SBR1 ;NO, SHIFT AGAIN
;
SBR2: ;16-BIT ADD OF B,C TO M(H,L), RESULT TO B,C
SUB A ;CLEAR A AND CARRY
MOV A,M ;LOAD LOW BYTE
ADD C ;M(H,L)+C
MOV C,A
INR L ;M(H,L+1)
MOV A,M
ADC B
MOV B,A
DCR L ;RESTORE H,L FOR NEXT OPERATION
RET
END

2519
ASSEMBLY & COMPILE TOOLS/Basic-E/source/manual.txt Normal file
View File

File diff suppressed because it is too large Load Diff

2521
ASSEMBLY & COMPILE TOOLS/Basic-E/source/readme.md Normal file
View File

File diff suppressed because it is too large Load Diff

3656
ASSEMBLY & COMPILE TOOLS/PLM COMPILER/PLM81.FOR Normal file
View File

File diff suppressed because it is too large Load Diff

6050
ASSEMBLY & COMPILE TOOLS/PLM COMPILER/PLM82.FOR Normal file
View File

File diff suppressed because it is too large Load Diff

93
ASSEMBLY & COMPILE TOOLS/PLM COMPILER/PLMCOMP.DOC Normal file
View File

@@ -0,0 +1,93 @@
PL/M is a high-level programming language especially designed to
simplify the task of system programming for the Intel 8-bit family
of microcomputers--the 8008 and the 8080. The files provided in
this archive contain version 2.0 of Intel's PL/M cross compiler
for the 8080. The PL/M programming langauge is described in the
Intel publication, 8008 and 8080 PL/M Programming Manual. A second
Intel publication, 8080 PL/M Compiler Operators Manual, describes
the operation of the PL/M cross compiler.
The Intel 8080 PL/M Cross Compiler is a two pass compiler written
in ANSI FORTRAN. PASS 1 reads a PL/M source program and converts
it to an intermediate form on work files. Optionally, a listing of
the input source program may be obtained during this pass. Errors
in program syntax are detected at this stage, and appropriate error
messages are sent to the list file. PASS 2 processes the work files
produced by PASS 1, and generates machine code for the MCS-80 CPU.
This machine code, which may be in either BNPF or Hex format, may be
loaded and executed directly on an INTELLEC 8/Mod 80 Microcomputer
Development System, simulated using INTERP/80, a cross-simulator of
the 8080 CPU, or used to program ROMs. PASS 2 will optionally
produce a symbol table and a mnemonic listing of the generated
machine code. Certain errors may be detected during PASS 2 and are
reported in the list file.
The operation of each pass of the PL/M compiler is governed by a set
of parameters know as compiler controls, each control is identified
by a unique letter of the alphabet. Each compiler control is provided
with a default value which is used throughout the compilation unless
explicitly altered by the user. The commonly used compiler controls
are described below and a complete list of compiler controls is given
in Intel's 8080 PL/M Compiler Operators Manual.
The value of the compiler controls may be changed at any time during
PASS 1 or at the beginning of PASS 2 by entering a control record.
Control records must begin with a dollar sign ($) and have the
following form:
$<id>=<value> [ $<id>=<value> ] ...
where <id> is the unique letter assigned to the compiler control
that is to be changed and <value> is the new value. Blanks may be
included on either side of the equal sign (=) but not within the
$<id> or <value>. Two special control record formats are available
to interrogate the current values of the compiler controls. A
specification like the following:
$$<id>
will cause the current value of the compiler control represented
by <id> to be listed, while a specification that consists of just
two dollar signs will cause the values of all compiler controls to
be listed.
Control records may be included anywhere within the source input read
by PASS 1 or in one or more input lines terminated with an all blank
or null line to be read at the start of PASS 2.
PASS 1 Compiler Controls
CONTROL VALUES DEFAULT USE
L 1-79 1 Leftmargin. Specifies the first
character position processed on each
input line. All leading characters are
ignored.
P 0,1 1 Echo input if 1, suppress echo if 0.
R 1-80 80 Rightmargin, ignore trailing characters
on each input record.
W 1-120 120 Maximun number of characters per output
line.
PASS 2 Compiler Controls
CONTROL VALUES DEFAULT USE
F 0,1 1 Display decoded memory initialization.
T 0,1 1 Display cross-reference table of
approximate memory address versus
source line number.
H 0 Header. Decimal address at which
generated code should start. I.e.,
the start of the program's ISA.
M 0,1 1 Display symbol table.
Q 0,1 1 If 1 then object file is written in
BNPF, otherwise the object file is
written in Hex format.
V 0 Page number of first page of the VSA.
I.e., variable storage, stack, etc.
If set to zero the first availabe page
above the ISA is used.


352
ASSEMBLY & COMPILE TOOLS/PLM COMPILER/PLMLANG.DOC Normal file
View File

@@ -0,0 +1,352 @@
PL/M-80 Language Summary
PL/M-80 is a programming language for i8080 systems. It is based most
notable on PL/I. It has the type of block structure and scope rules
most programmers now expect despite the fact it is a fairly small
language.
The one thing that may "trip-up" may Pascal programmers is that PL/M
(and its PL/I big brother) use semicolon as a terminator, not as a
statement separator. Semicolons mark the end of every statement.
The remainder of this file summarizes the PL/M-80 language and its
features. It is only a summary; no attempt is made to provide a
complete and unambiguous description.
PL/M Character Set
==================
Alphabetics: A B C D E F G H I J K L M N O P Q R S T U V W X Y Z
Numerics: 0 1 2 3 4 5 6 7 8 9
Specials: $ = . / ( ) + - ' * , < > : ; and space
All other characters are unrecognized by PL/M in the sense that they
are regarded as equivalent to the space character.
PL/M Identifiers
================
Identifiers may be from 1 to 31 characters in length. An alphabetic
must be the first character in an identifer name; the remainder may
be alphabetic or numeric. In addition, dollar signs may be imbedded
within a variable name to improve readability. They are ignored by
PL/M. (The identifiers LINE$COUNT and LINECOUNT are interpreted
as identical names.)
The following are all reserved words, and may not be used as
identifier names:
ADDRESS DATA EOF LABEL PROCEDURE
AND DECLARE GO LITERALLY RETURN
BASED DISABLE GOTO MINUS THEN
BY DO HALT MOD TO
BYTE ELSE IF NOT WHILE
CALL ENABLE INITIAL OR XOR
CASE END INTERRUPT PLUS
PL/M Data Types
===============
There are two data types in PL/M. The data type BYTE refers to
8-bit data; ADDRESS, to 16. It is also possible to construct
arrays of either type and pointers to either type.
PL/M Constants
================
Numeric constants may be expressed as binary, octal, decimal, and
hexadecimal numbers. The radix for the number is specified by a
letter appended to the number: B for binary, O and Q for octal,
D for decimal, and H for hexadecimal. If the letter suffix is
omitted, the number is treated as decimal. Hexadecimal constants
must begin with a numeric to avoid confusion with identifier names.
As with identifiers, dollar signs may be imbedded in numeric constants
to improve readability. However a number is expressed, it must be
representable in 16 bits.
Character string constants are enclosed in apostrophes. An apostrophe
within the string must be doubled. Character strings are represented
using 7-bit ASCII codes. Character strings constants of length 1 are
treated as BYTE values; length 2 as ADDRESS values. Longer strings
are only useful with the "dot" operator.
PL/M Expressions
================
There are seven arithmetic operators in PL/M. All perform unsigned
arithmetic operations on either BYTE or ADDRESS values.
+ Binary addition operator.
- Binary subtraction operator, or unary negation.
PLUS Binary addition-with-carry operator.
MINUS Binary subtraction-with-carry operator.
* Binary multiplication operator.
/ Binary division operator.
MOD Binary remainder operator.
Multiply and divide always produce ADDRESS results. The others
produce BYTE results if both operands are BYTE values; ADDRESS,
otherwise.
There are four boolean operators in PL/M. All perform either 8-bit
or 16-bit boolean operations of their operands.
NOT Unary complement operator.
AND Binary conjunction operator.
OR Binary disjunction operator.
XOR Binary exclusive-disjunction operator.
The operators produce BYTE results if both operands are BYTE values.
If at least one is of type ADDRESS, the other is extended with
high-order zeroes if necessary, and the result is type ADDRESS.
There are six relational operators. All return a true/false result
with 0FFH representing "true" and 00H, "false".
< Binary less-than operator.
<= Binary less-than-or-equal operator.
= Binary equal operator.
>= Binary greater-than-or-equal operator.
> Binary greater-than operator.
<> Binary not-equal operator.
There is one other PL/M operator, the so-called "dot" operator. It
is a unary operator that returns the memory address of its operand.
The operator may be used in the following forms:
.variable
.constant
.(constant)
.(constant, ...)
The construction " .(08H, 'Message', 0DH) " might best be considered
as the address of a nine-element BYTE array.
Expression evaluation obeys operator precedence unless modified by
parenthesis. The following lists the operators in order of precedence:
Highest: .
* / MOD
+ - PLUS MINUS
< <= = => > <>
NOT
AND
Lowest: OR XOR
PL/M Executable Statements
==========================
Commentary.
/* Not really an executable statement, but... */
Assignment.
variable = expression ;
-or- variable, variable, ... = expression ;
Imbedded assignment. (May be used within an expression.)
(variable := expression)
Do-End. (Simple statement grouping.)
DO;
statement; ...;
END;
Do-While. (Loop while rightmost bit of expression = 1.)
DO WHILE expression;
statement; ...;
END;
Iterative Do.
DO variable = expression1 to expression2;
statement; ...;
END;
Do-Case. (Execute i-th statement, numbered from 0.)
DO CASE expression;
statement0;
statement1;
...;
END;
If-Then.
IF expression THEN statement;
If-Then-Else.
IF expression THEN statement; ELSE statement;
Go To. (GO TO and GOTO are synonomous.)
GO TO label;
-or- GO TO number;
-or- GO TO variable;
The first form causes a GOTO the statement prefixed with 'label:'.
The latter two forms cause a GOTO an absolute storage location.
Disable interrupts.
DISABLE;
Enable interrupts.
ENABLE;
PL/M Variable Declarations
==========================
Identifiers are defined with the DECLARE statement. The following
are typical forms for the DECLARE statement.
Single identifier: DECLARE identifier type;
Group of identifiers: DECLARE (identifier, ...) type;
Array: DECLARE identifier (constant) type;
Multiple: DECLARE id type, id type, ...;
Array subscripts start at 0. Thus, DECLARE A(10) BYTE; defines the
array of elements A(0)...A(9).
Declared variables may have initial values specified by including
the INITIAL attribute after the type on the DECLARE statement:
DECLARE A(10) BYTE INITIAL(10,11,12,13,14,15,16,17,18,19);
Variables declared with the INITIAL attribute are preset at program
load time. They are not reset at procedure invocation or anywhere
else. The INITIAL attribute may specify fewer values then would
be needed for the declared variables.
A DATA attribute is available for declaring storage constants. No
type or array sizes are specified; BYTE is assumed and the array
size is implicitly determined from the DATA value. The values of
identifiers declared as DATA must not be changed during program
execution.
DECLARE GREETINGS DATA ('Hello, world.');
PL/M also supports a limited macro facility. Identifiers may be
declared with the LITERALLY attribute. The literal value is
substituted in the program source text where ever the identifier is
used.
DECLARE FOREVER LITERALLY 'WHILE TRUE';
. . .
DO FOREVER;
Variables may be declared as BASED, as in
DECLARE A$PTR ADDRESS,
A BASED A$PTR BYTE;
In this example, the memory location associated with variable A is
determined by the address stored in variable A$PTR.
Labels are declared using LABEL for the type. An identifier so
declared should also appear before an executable statement, separated
from the statement by a colon. (It is often not strictly necessary
to declare all labels. An implicit DECLARE results when an otherwise
undeclared label is encountered in the program. That is,
COME$HERE: CALL PRT$MESSAGE(3);
is equivalent to
DECLARE COME$HERE LABEL;
COME$HERE: CALL PRT$MESSAGE(3);
However, due to scope rules, a earlier reference to the label (in a
GOTO statement) may be flagged in error, because the implicit DECLARE
is physically latter in the program.
PL/M Procedure Declarations
===========================
Procedures must be defined before they are used. This declaration
form is:
identifier: PROCEDURE (arg, ...) type;
statement; ...;
END identifier;
The 'identifier' (which appears in two places) specifies the name for
the procedure. If no result is returned, the 'type' is omitted from
the PROCEDURE statement.
Return from a procedure is implicit after the last statement of the
procedure, although no value is returned in this case. Return may be
explicitly specified with the RETURN statement:
No value: RETURN ;
Value: RETURN expression ;
Procedures may be declared with the special type INTERRUPT followed
by a number in the range 0 through 7. Such a procedure will be used
as an interrupt handler for the corresponding RST instruction.
Interrupts are re-enabled on return from an interrupt procedure.
Procedures may not be recursive. Procedures are invoked either with
the CALL statement, or within an expression.
Stand-alone: CALL identifier (arg, ...);
Within expressions: identifier (arg, ...)
Built-in Procedures
===================
INPUT(number)
Returns a BYTE value from the I/O port specified by 'number'.
OUTPUT(number) = expression;
Sends the BYTE value of 'expression' to the I/O port specified
by 'number'.
LENGTH(identifier)
Returns the number of elements in the array 'identifier'.
LAST(identifier)
Returns the highest subscript for array 'identifier'. Note that
LAST = LENGTH - 1.
LOW(expression)
Returns the low-order byte of 'expression'.
HIGH(expression)
Returns the high-order byte of 'expression'.
DOUBLE(expression)
Returns an ADDRESS value equivalent to 'expression'. High-order
zeroes are used to pad BYTE expressions.
ROL(expr1, expr2) and ROR(expr1, expr2)
Returns the value of 'expr1' rotated left/right the number of bits
specified by 'expr2'. Both expressions must be BYTE values. The
value of 'expr2' must not be zero.
SCL(expr1, expr2) and SCR(expr1, expr2)
Returns the value of 'expr1' rotated left/right the number of bits
specified by 'expr2'. The carry flag participates in the rotate.
'expr2' must be a BYTE value; 'expr1' may be BYTE or ADDRESS. The
value returned is of the same type as 'expr1'. The value of
'expr2' must not be zero.
SHL(expr1, expr2) and SHR(expr1, expr2)
Returns the value of 'expr1' shifted left/right the number of bits
specified by 'expr2'. The last bit shifted out ends up in the
carry flag. 'expr2' must be a BYTE value; 'expr1' may be BYTE or
ADDRESS. The value returned is of the same type as 'expr1'. The
value of 'expr2' must not be zero.
CALL TIME(expression)
The expression is evaluated as a BYTE value. The TIME procedure
delays 100 microseconds times the value. (Timing is based on
instruction execution times for the standard i8080 cpu.)
DEC(expr1 + expr2) and DEC(expr1 PLUS expr2)
The two expressions must be unsubscripted variables, constants,
or expressions that represent BCD values. The DEC function does
the necessary decimal adjustment to produce the BCD result from
the addition.
Pre-defined Variables
=====================
CARRY, ZERO, SIGN, PARITY
The values of these variables reflect the current values of the
cpu flags.
MEMORY
The MEMORY variable is assigned the to the first memory location
following the PL/M program. It is useful for determining where
free memory begins.
STACKPTR
The STACKPTR variable's value reflects the current value of the
SP register. The variable may be assigned a new value to alter
the stack register.


67
ASSEMBLY & COMPILE TOOLS/PLM COMPILER/PLMSAMP.HEX Normal file
View File

@@ -0,0 +1,67 @@
5 MEMORY 00300H
25 SQUAREROOT 00016H
26 X 002DAH
28 Y 002DCH
29 Z 002DEH
33 PRINTCHAR 000A7H
34 CHAR 002E1H
37 PRINTSTRING 000AFH
38 NAME 002E2H
39 LENGTH 002E4H
41 I 002E5H
46 PRINTNUMBER 000D9H
47 NUMBER 002E6H
48 BASE 002E9H
49 CHARS 002EAH
50 ZEROSUPPRESS 002EBH
52 I 002ECH
53 J 002EDH
54 TEMP 002EEH
64 I 002FEH
66 HEADING 00182H
$
****************************************
:1000100031DA02C3F50121DA027123702D4E2C462C
:100020002C7123702ADA0223EB7AB71F577B1F212A
:10003000DE0277237221DC027E2C462C962C4F7830
:100040009EB1CAA1002D4E2C462EDC71237021DCFE
:10005000025E2C562EDA4E2C46C389007A2F577B2F
:100060002F5F132100003E11E519D26E00E3E1F588
:1000700079174F7817477D176F7C1767F13DC26876
:1000800000B77C1F577D1F5FC9CD5C002ADC0209C9
:1000900023EB7AB71F577B1F21DE02772372C3350C
:1000A000002EDC7E2C46C921E10271C30938C9212A
:1000B000E2027123702C732C360021E4024E0D797C
:1000C0002C96DAD8004E06002AE202097E4FCDA710
:1000D0000021E50234C2BA00C921EA02712C733E44
:1000E0000F2D96D2E800360F2EEC360121EA027E63
:1000F0002EEC96DA680121E9025E16002EE64E2CFF
:1001000046CD5C00013000EB09EB21ED02733E3976
:1001100096D218017EC607772D4E0D3EFFC22101F3
:10012000AF2DA62EE64F7E2C56D6005F7ADE00B3AA
:10013000D6019FA10FD23C012EED36203E102EECB1
:10014000964F06002EEE09EB21ED024E791221E9C1
:10015000025E16002EE64E2C46CD5C0021E60271B2
:1001600023702EEC34C2EC0001EE02111000696025
:1001700019EB7B21EA02965F7ADE004B475ECDAF3A
:1001800000C90D0A0A0A202020202020202020203B
:10019000202020202020202020202020202054410A
:1001A000424C45204F462053515541524520524F15
:1001B0004F54530D0A0A2056414C55452020524FAA
:1001C0004F542056414C55452020524F4F542056F5
:1001D000414C55452020524F4F542056414C5545D7
:1001E0002020524F4F542056414C55452020524F0D
:1001F0004F540D0A0A21FE0236012336003EE8065E
:100200000321FE02962C4F789EDA90021E051600FE
:1002100021FE024E2C46CD5C007BD6015F7ADE00CB
:10022000B3C251021EFA160021FE024E2C46CD5CCE
:10023000007BD6015F7ADE00B3C249020182011E53
:1002400073CDAF00C351020D0A0147021E02CDAFAC
:100250000021FE024E2C462EE67123702EE9360A4E
:100260000E061E01CDD9002EFE4E2C46CD160021C5
:10027000E602772336002EE9360A0E061E01CDD996
:10028000002EFE4E2C462101000922FE02C3FD0174
:02029000FB76FB
:0000000000
****************************************
$

70
ASSEMBLY & COMPILE TOOLS/PLM COMPILER/PLMSAMP.PLM Normal file
View File

@@ -0,0 +1,70 @@
/*
SAMPLE PL/M PROGRAM
THIS PROGRAM CALCULATES AND PRINTS OUT THE SQUARE ROOTS OF
ALL INTEGERS BETWEEN 1 AND 1000.
*/
DECLARE CR LITERALLY '0DH', LF LITERALLY '0AH', TRUE LITERALLY '1',
FALSE LITERALLY '0';
10H: /* IS THE ORIGIN OF THIS PROGRAM */
SQUARE$ROOT: PROCEDURE(X) BYTE;
DECLARE (X,Y,Z) ADDRESS;
Y=X; Z=SHR(X+1,1);
DO WHILE Y<>Z;
Y=Z; Z=SHR(X/Y + Y + 1, 1);
END;
RETURN Y;
END SQUAREROOT;
/* PRINT USING INTELLEC MONITOR */
PRINT$CHAR: PROCEDURE (CHAR);
DECLARE CHAR BYTE;
DECLARE IOCO LITERALLY '3809H';
GO TO IOCO;
END PRINT$CHAR;
PRINT$STRING: PROCEDURE(NAME,LENGTH);
DECLARE NAME ADDRESS,
(LENGTH,I,CHAR BASED NAME) BYTE;
DO I = 0 TO LENGTH-1;
CALL PRINT$CHAR(CHAR(I));
END;
END PRINT$STRING;
PRINT$NUMBER: PROCEDURE(NUMBER,BASE,CHARS,ZERO$SUPPRESS);
DECLARE NUMBER ADDRESS, (BASE,CHARS,ZERO$SUPPRESS,I,J) BYTE;
DECLARE TEMP(16) BYTE;
IF CHARS > LAST(TEMP) THEN CHARS = LAST(TEMP);
DO I = 1 TO CHARS;
J=NUMBER MOD BASE + '0';
IF J > '9' THEN J = J + 7;
IF ZERO$SUPPRESS AND I <> 1 AND NUMBER = 0 THEN
J = ' ';
TEMP(LENGTH(TEMP)-I) = J;
NUMBER = NUMBER / BASE;
END;
CALL PRINT$STRING(.TEMP + LENGTH(TEMP) - CHARS,CHARS);
END PRINT$NUMBER;
DECLARE I ADDRESS,
CRLF LITERALLY 'CR,LF',
HEADING DATA (CRLF,LF,LF,
' TABLE OF SQUARE ROOTS', CRLF,LF,
' VALUE ROOT VALUE ROOT VALUE ROOT VALUE ROOT VALUE ROOT',
CRLF,LF);
/* SILENCE TTY AND PRINT COMPUTED VALUES */
DO I = 1 TO 1000;
IF I MOD 5 = 1 THEN
DO; IF I MOD 250 = 1 THEN
CALL PRINT$STRING(.HEADING,LENGTH(HEADING));
ELSE
CALL PRINT$STRING(.(CR,LF),2);
END;
CALL PRINT$NUMBER(I,10,6,TRUE /* TRUE SUPPRESSES LEADING ZEROES */);
CALL PRINT$NUMBER(SQUARE$ROOT(I), 10,6, TRUE);
END;
EOF

147
ASSEMBLY & COMPILE TOOLS/PLM COMPILER/PLMSAMP.PRN Normal file
View File

@@ -0,0 +1,147 @@
8080 PLM1 VERS 2.0
00001 1 /*
00002 1 SAMPLE PL/M PROGRAM
00003 1
00004 1 THIS PROGRAM CALCULATES AND PRINTS OUT THE SQUARE ROOTS OF
00005 1 ALL INTEGERS BETWEEN 1 AND 1000.
00006 1 */
00007 1 DECLARE CR LITERALLY '0DH', LF LITERALLY '0AH', TRUE LITERALLY '1',
00008 1 FALSE LITERALLY '0';
00009 1
00010 1 10H: /* IS THE ORIGIN OF THIS PROGRAM */
00011 1
00012 1 SQUARE$ROOT: PROCEDURE(X) BYTE;
00013 2 DECLARE (X,Y,Z) ADDRESS;
00014 2 Y=X; Z=SHR(X+1,1);
00015 2 DO WHILE Y<>Z;
00016 2 Y=Z; Z=SHR(X/Y + Y + 1, 1);
00017 3 END;
00018 2 RETURN Y;
00019 2 END SQUAREROOT;
00020 1
00021 1 /* PRINT USING INTELLEC MONITOR */
00022 1 PRINT$CHAR: PROCEDURE (CHAR);
00023 2 DECLARE CHAR BYTE;
00024 2 DECLARE IOCO LITERALLY '3809H';
00025 2 GO TO IOCO;
00026 2 END PRINT$CHAR;
00027 1
00028 1 PRINT$STRING: PROCEDURE(NAME,LENGTH);
00029 2 DECLARE NAME ADDRESS,
00030 2 (LENGTH,I,CHAR BASED NAME) BYTE;
00031 2 DO I = 0 TO LENGTH-1;
00032 2 CALL PRINT$CHAR(CHAR(I));
00033 3 END;
00034 2 END PRINT$STRING;
00035 1
00036 1 PRINT$NUMBER: PROCEDURE(NUMBER,BASE,CHARS,ZERO$SUPPRESS);
00037 2 DECLARE NUMBER ADDRESS, (BASE,CHARS,ZERO$SUPPRESS,I,J) BYTE;
00038 2 DECLARE TEMP(16) BYTE;
00039 2 IF CHARS > LAST(TEMP) THEN CHARS = LAST(TEMP);
00040 2 DO I = 1 TO CHARS;
00041 2 J=NUMBER MOD BASE + '0';
00042 3 IF J > '9' THEN J = J + 7;
00043 3 IF ZERO$SUPPRESS AND I <> 1 AND NUMBER = 0 THEN
00044 3 J = ' ';
00045 3 TEMP(LENGTH(TEMP)-I) = J;
00046 3 NUMBER = NUMBER / BASE;
00047 3 END;
00048 2 CALL PRINT$STRING(.TEMP + LENGTH(TEMP) - CHARS,CHARS);
00049 2 END PRINT$NUMBER;
00050 1
00051 1 DECLARE I ADDRESS,
00052 1 CRLF LITERALLY 'CR,LF',
00053 1 HEADING DATA (CRLF,LF,LF,
00054 1 ' TABLE OF SQUARE ROOTS', CRLF,LF,
00055 1 ' VALUE ROOT VALUE ROOT VALUE ROOT VALUE ROOT VALUE ROOT',
00056 1 CRLF,LF);
00057 1
00058 1 /* SILENCE TTY AND PRINT COMPUTED VALUES */
00059 1 DO I = 1 TO 1000;
00060 1 IF I MOD 5 = 1 THEN
00061 2 DO; IF I MOD 250 = 1 THEN
00062 3 CALL PRINT$STRING(.HEADING,LENGTH(HEADING));
00063 3 ELSE
00064 3 CALL PRINT$STRING(.(CR,LF),2);
00065 3 END;
00066 2 CALL PRINT$NUMBER(I,10,6,TRUE /* TRUE SUPPRESSES LEADING ZEROES */);
00067 2 CALL PRINT$NUMBER(SQUARE$ROOT(I), 10,6, TRUE);
00068 2 END;
00069 1
00070 1 EOF
NO PROGRAM ERRORS
8080 PLM2 VERS 2.0
1=0003H 12=0013H 13=0016H 14=001CH 15=002FH 16=0045H 17=0098H 18=00A1H 19=00A7H 23=00ABH
25=00AEH 26=00AFH 29=00B7H 31=00BAH 32=00C5H 33=00D1H 34=00D8H 35=00D9H 37=00DFH 39=00E3H
40=00E6H 41=00F6H 42=010AH 43=0117H 44=0134H 45=0138H 46=0148H 47=015CH 48=0168H 49=0181H
50=0182H 56=01F5H 59=01FDH 60=020CH 61=0221H 62=0239H 63=0244H 64=0247H 65=0251H 66=025CH
67=0267H 68=0281H 69=0290H
STACK SIZE = 6 BYTES
MEMORY..........................0300H
SQUAREROOT......................0016H
X...............................02DAH
Y...............................02DCH
Z...............................02DEH
PRINTCHAR.......................00A7H
CHAR............................02E1H
PRINTSTRING.....................00AFH
NAME............................02E2H
LENGTH..........................02E4H
I...............................02E5H
PRINTNUMBER.....................00D9H
NUMBER..........................02E6H
BASE............................02E9H
CHARS...........................02EAH
ZEROSUPPRESS....................02EBH
I...............................02ECH
J...............................02EDH
TEMP............................02EEH
I...............................02FEH
HEADING.........................0182H
0010H LXI SP DAH 02H JMP F5H 01H LXI H DAH 02H MOV MC INX H MOV MB DCR L MOV CM INR L MOV BM
0020H INR L MOV MC INX H MOV MB LHLD DAH 02H INX H XCHG MOV AD ORA A RAR MOV DA MOV AE RAR LXI H
0030H DEH 02H MOV MA INX H MOV MD LXI H DCH 02H MOV AM INR L MOV BM INR L SUB M INR L MOV CA MOV AB
0040H SBC M ORA C JZ A1H 00H DCR L MOV CM INR L MOV BM MOV LI DCH MOV MC INX H MOV MB LXI H DCH
0050H 02H MOV EM INR L MOV DM MOV LI DAH MOV CM INR L MOV BM JMP 89H 00H MOV AD CMA MOV DA MOV AE
0060H CMA MOV EA INX D LXI H 00H 00H MOV AI 11H PUSH H DAD D JNC 6EH 00H XTHL POP H PUSH A
0070H MOV AC RAL MOV CA MOV AB RAL MOV BA MOV AL RAL MOV LA MOV AH RAL MOV HA POP A DCR A JNZ 68H
0080H 00H ORA A MOV AH RAR MOV DA MOV AL RAR MOV EA RET CALL 5CH 00H LHLD DCH 02H DAD B
0090H INX H XCHG MOV AD ORA A RAR MOV DA MOV AE RAR LXI H DEH 02H MOV MA INX H MOV MD JMP 35H
00A0H 00H MOV LI DCH MOV AM INR L MOV BM RET LXI H E1H 02H MOV MC JMP 09H 38H RET LXI H
00B0H E2H 02H MOV MC INX H MOV MB INR L MOV ME INR L MOV MI 00H LXI H E4H 02H MOV CM DCR C MOV AC
00C0H INR L SUB M JC D8H 00H MOV CM MOV BI 00H LHLD E2H 02H DAD B MOV AM MOV CA CALL A7H
00D0H 00H LXI H E5H 02H INR M JNZ BAH 00H RET LXI H EAH 02H MOV MC INR L MOV ME MOV AI
00E0H 0FH DCR L SUB M JNC E8H 00H MOV MI 0FH MOV LI ECH MOV MI 01H LXI H EAH 02H MOV AM
00F0H MOV LI ECH SUB M JC 68H 01H LXI H E9H 02H MOV EM MOV DI 00H MOV LI E6H MOV CM INR L
0100H MOV BM CALL 5CH 00H LXI B 30H 00H XCHG DAD B XCHG LXI H EDH 02H MOV ME MOV AI 39H
0110H SUB M JNC 18H 01H MOV AM ADD I 07H MOV MA DCR L MOV CM DCR C MOV AI FFH JNZ 21H 01H
0120H XRA A DCR L ANA M MOV LI E6H MOV CA MOV AM INR L MOV DM SUB I 00H MOV EA MOV AD SBC I 00H ORA E
0130H SUB I 01H SBC A ANA C RRC JNC 3CH 01H MOV LI EDH MOV MI 20H MOV AI 10H MOV LI ECH
0140H SUB M MOV CA MOV BI 00H MOV LI EEH DAD B XCHG LXI H EDH 02H MOV CM MOV AC STAX D LXI H E9H
0150H 02H MOV EM MOV DI 00H MOV LI E6H MOV CM INR L MOV BM CALL 5CH 00H LXI H E6H 02H MOV MC
0160H INX H MOV MB MOV LI ECH INR M JNZ ECH 00H LXI B EEH 02H LXI D 10H 00H MOV LC MOV HB
0170H DAD D XCHG MOV AE LXI H EAH 02H SUB M MOV EA MOV AD SBC I 00H MOV CE MOV BA MOV EM CALL AFH
0180H 00H RET
0182H 0DH 0AH 0AH 0AH 20H 20H 20H 20H 20H 20H 20H 20H 20H 20H 20H 20H 20H 20H 20H 20H 20H 20H 20H 20H 20H 20H 20H 20H
019EH 54H 41H 42H 4CH 45H 20H 4FH 46H 20H 53H 51H 55H 41H 52H 45H 20H 52H 4FH 4FH 54H 53H 0DH 0AH 0AH 20H 56H 41H 4CH
01BAH 55H 45H 20H 20H 52H 4FH 4FH 54H 20H 56H 41H 4CH 55H 45H 20H 20H 52H 4FH 4FH 54H 20H 56H 41H 4CH 55H 45H 20H 20H
01D6H 52H 4FH 4FH 54H 20H 56H 41H 4CH 55H 45H 20H 20H 52H 4FH 4FH 54H 20H 56H 41H 4CH 55H 45H 20H 20H 52H 4FH 4FH 54H
01F2H 0DH 0AH 0AH
01F5H LXI H FEH 02H MOV MI 01H INX H MOV MI 00H MOV AI E8H MOV BI 03H LXI H FEH 02H SUB M
0205H INR L MOV CA MOV AB SBC M JC 90H 02H MOV EI 05H MOV DI 00H LXI H FEH 02H MOV CM INR L
0215H MOV BM CALL 5CH 00H MOV AE SUB I 01H MOV EA MOV AD SBC I 00H ORA E JNZ 51H 02H MOV EI
0225H FAH MOV DI 00H LXI H FEH 02H MOV CM INR L MOV BM CALL 5CH 00H MOV AE SUB I 01H MOV EA
0235H MOV AD SBC I 00H ORA E JNZ 49H 02H LXI B 82H 01H MOV EI 73H CALL AFH 00H JMP
0245H 51H 02H
0247H 0DH 0AH
0249H LXI B 47H 02H MOV EI 02H CALL AFH 00H LXI H FEH 02H MOV CM INR L MOV BM MOV LI E6H
0259H MOV MC INX H MOV MB MOV LI E9H MOV MI 0AH MOV CI 06H MOV EI 01H CALL D9H 00H MOV LI FEH
0269H MOV CM INR L MOV BM CALL 16H 00H LXI H E6H 02H MOV MA INX H MOV MI 00H MOV LI E9H MOV MI
0279H 0AH MOV CI 06H MOV EI 01H CALL D9H 00H MOV LI FEH MOV CM INR L MOV BM LXI H 01H 00H
0289H DAD B SHLD FEH 02H JMP FDH 01H EI HLT
NO PROGRAM ERRORS

63
ASSEMBLY & COMPILE TOOLS/PLM COMPILER/README.MARKDOWN Normal file
View File

@@ -0,0 +1,63 @@
\README.PLM = Original
Here is the source to the Intel PLM compiler. It is written in Fortran (66), and is supposed to be pretty clean.
It compiles correctly with gcc's g77 on Linux. However, it is not the version required to compile CP/M 2.2 or 3.0. It works well, but lacks support for external definitions and some PLM constructs, as required by the DR source.
--
This archive contains the FORTRAN IV source code for the PL/M-80
cross compiler. It bears the Intel's copyright, but at some time
in the late 1970's the code was made available by Intel. The
history of all of this, and the conditions behind it, have become
a bit merky over the years; however, to the best of my knowledge,
you are free to use it for personal and educational applications.
The copy provided in this package was extracted from the standard
distribution tapes for the Michigan Terminal System, an operating
system for IBM mainframe hardware used by about six universities
around the world.
The compiler has been successfully installed on an IBM mainframe
running both the MTS operating system and the more common VM/CMS.
The source code has been compiled by the FORTRAN-G1, FORTRAN-HX,
and VS/FORTRAN compilers. It should be compilable by any other
FORTRAN compilers that accept the 1966 (FORTRAN IV) standard
since the code seems to confirm rather well to that standard.
Getting a working version on an 8080 or Z80 micro computer may
be a problem, though, but only because of the size of the two
modules. I have not tried this, but I suspect MicroSoft's
FORTRAN product for MSDOS systems should be able to handle it.
Alas, machine-readable documentation for the langauge and for
installing the compiler is not available. I have tried to give
a capsule summary of the langauge in PLMLANG.DOC, but it in no
way constitutes a complete description. PLMCOMP.DOC describes
the compiler options.
The following files are provided.
-README PLM You are reading it now.
PLM81 FOR Source for Pass 1 of the compiler.
PLM82 FOR Source for Pass 2 of the compiler.
PLMLANG DOC Summary of the PL/M language.
PLMCOMP DOC Description of compiler switches.
PLMSAMP PLM Sample PL/M program.
PLMSAMP HEX Compiler output for the sample.
PLMSAMP PRN Compiler listing for the sample.
The package is made available under the "Care-Ware" philosophy.
This is really quite simple: If you are just so pleased to
finally have something like this in you possession that you
feel duty-bound to send a check for some amount to somewhere,
may I suggest you send it to:
CARE
Post Office Box 13140
Philadelphia, Pennsylvania 19101-9903
(Who knows, maybe this will catch on :-) Contributions to CARE
should be made in your name, not mine.
John Fisher
INTERNET: FISHER@VM.ECS.RPI.EDU
BITNET: FISHER@RPIECS


56
ASSEMBLY & COMPILE TOOLS/PLM COMPILER/README.PLM Normal file
View File

@@ -0,0 +1,56 @@
This archive contains the FORTRAN IV source code for the PL/M-80
cross compiler. It bears the Intel's copyright, but at some time
in the late 1970's the code was made available by Intel. The
history of all of this, and the conditions behind it, have become
a bit merky over the years; however, to the best of my knowledge,
you are free to use it for personal and educational applications.
The copy provided in this package was extracted from the standard
distribution tapes for the Michigan Terminal System, an operating
system for IBM mainframe hardware used by about six universities
around the world.
The compiler has been successfully installed on an IBM mainframe
running both the MTS operating system and the more common VM/CMS.
The source code has been compiled by the FORTRAN-G1, FORTRAN-HX,
and VS/FORTRAN compilers. It should be compilable by any other
FORTRAN compilers that accept the 1966 (FORTRAN IV) standard
since the code seems to confirm rather well to that standard.
Getting a working version on an 8080 or Z80 micro computer may
be a problem, though, but only because of the size of the two
modules. I have not tried this, but I suspect MicroSoft's
FORTRAN product for MSDOS systems should be able to handle it.
Alas, machine-readable documentation for the langauge and for
installing the compiler is not available. I have tried to give
a capsule summary of the langauge in PLMLANG.DOC, but it in no
way constitutes a complete description. PLMCOMP.DOC describes
the compiler options.
The following files are provided.
-README PLM You are reading it now.
PLM81 FOR Source for Pass 1 of the compiler.
PLM82 FOR Source for Pass 2 of the compiler.
PLMLANG DOC Summary of the PL/M language.
PLMCOMP DOC Description of compiler switches.
PLMSAMP PLM Sample PL/M program.
PLMSAMP HEX Compiler output for the sample.
PLMSAMP PRN Compiler listing for the sample.
The package is made available under the "Care-Ware" philosophy.
This is really quite simple: If you are just so pleased to
finally have something like this in you possession that you
feel duty-bound to send a check for some amount to somewhere,
may I suggest you send it to:
CARE
Post Office Box 13140
Philadelphia, Pennsylvania 19101-9903
(Who knows, maybe this will catch on :-) Contributions to CARE
should be made in your name, not mine.
John Fisher
INTERNET: FISHER@VM.ECS.RPI.EDU
BITNET: FISHER@RPIECS


36
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/abs.mar Normal file
View File

@@ -0,0 +1,36 @@
.TITLE ABS. PLM RUNTIME LIBRARY: ABS
;-----------------------------------------------------------------------
;
; D I S C L A I M E R N O T I C E
; ------------------- -----------
;
; This document and/or portions of the material and data furnished
; herewith, was developed under sponsorship of the U. S. Government.
; Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior
; University, nor their employees, nor their respective contractors,
; subcontractors, or their employees, makes any warranty, express or
; implied, or assumes any liability or responsibility for accuracy,
; completeness or usefulness of any information, apparatus, product
; or process disclosed, or represents that its use will not infringe
; privately-owned rights. Mention of any product, its manufacturer,
; or suppliers shall not, nor is it intended to, imply approval, dis-
; approval, or fitness for any particular use. The U. S. and the
; University at all times retain the right to use and disseminate same
; for any purpose whatsoever. Such distribution shall be made by the
; National Energy Software Center at the Argonne National Laboratory
; and only subject to the distributee furnishing satisfactory proof
; that he has a valid license from the Intel Corporation in effect.
;
;-----------------------------------------------------------------------
.PSECT PLMRUN_CODE,RD,NOWRT,EXE,GBL,CON,LONG
;
; X = ABS(Y)
;
Y=4 ; REAL.
.ENTRY ABS.,^M<>
BICL3 #^X8000,Y(AP),R0
RET
.END

285
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/argument.plm Normal file
View File

@@ -0,0 +1,285 @@
$TITLE ("UDI Procedures to Get Command Arguments")
$LARGE OPTIMIZE(3)
DQ_argument: do; /* UDI procedures to get command arguments. */
/*************************************************************************/
/* */
/* D I S C L A I M E R N O T I C E */
/* ------------------- ----------- */
/* */
/* This document and/or portions of the material and data furnished */
/* herewith, was developed under sponsorship of the U. S. Government. */
/* Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior */
/* University, nor their employees, nor their respective contractors, */
/* subcontractors, or their employees, makes any warranty, express or */
/* implied, or assumes any liability or responsibility for accuracy, */
/* completeness or usefulness of any information, apparatus, product */
/* or process disclosed, or represents that its use will not infringe */
/* privately-owned rights. Mention of any product, its manufacturer, */
/* or suppliers shall not, nor is it intended to, imply approval, dis- */
/* approval, or fitness for any particular use. The U. S. and the */
/* University at all times retain the right to use and disseminate same */
/* for any purpose whatsoever. Such distribution shall be made by the */
/* National Energy Software Center at the Argonne National Laboratory */
/* and only subject to the distributee furnishing satisfactory proof */
/* that he has a valid license from the Intel Corporation in effect. */
/* */
/*-----------------------------------------------------------------------*/
/* */
/* R E V I S I O N H I S T O R Y */
/* */
/* 07JAN82 Alex Hunter 1. Changed default delimiter set to */
/* agree with Series III default. */
/* 2. Added DQ$SET$DELIMITERS procedure. */
/* 31JAN82 Alex Hunter 1. Added indirect command lines. */
/* 03FEB82 Alex Hunter 1. Changed module name. */
/* 05FEB82 Alex Hunter 1. Only allow @file from invocation line.*/
/* 07FEB82 Alex Hunter 1. Fix bug for zero-length indirect */
/* files. */
/* */
/*************************************************************************/
declare %PTR literally 'POINTER';
$INCLUDE (PLM$UDI:CUSTOMARY.LIT)
$INCLUDE (PLM$UDI:ASCII.LIT)
$INCLUDE (PLM$UDI:EXCEPT.LIT)
$INCLUDE (PLM$UDI:EXITCODES.LIT)
$INCLUDE (PLM$UDI:DESCRIPT.LIT)
/**************** EXTERNAL UDI ROUTINES ********************/
DECLARE CONNECTION literally 'WORD';
DQ$ATTACH: PROCEDURE (path$p,excep$p) CONNECTION EXTERNAL;
DECLARE (path$p,excep$p) POINTER;
END;
DQ$DETACH: PROCEDURE (conn,excep$p) EXTERNAL;
DECLARE conn CONNECTION, excep$p POINTER;
END;
DQ$EXIT: PROCEDURE (completion$code) EXTERNAL;
DECLARE completion$code WORD;
END;
DQ$OPEN: PROCEDURE (conn,access,num$buf,excep$p) EXTERNAL;
DECLARE conn CONNECTION, access BYTE, num$buf BYTE,
excep$p POINTER;
END;
DQ$READ: PROCEDURE (conn,buf$p,count,excep$p) WORD EXTERNAL;
DECLARE conn CONNECTION, buf$p POINTER, count WORD,
excep$p POINTER;
END;
/*********************************************/
declare CR literally 'ASC$CR', LF literally 'ASC$LF',
TAB literally 'ASC$HT';
LIB%GET_FOREIGN: procedure (tail$d,prompt$d,outlen$p) external;
declare (tail$d,prompt$d,outlen$p) pointer;
end;
common /command_tail/ tail (256) byte;
declare tail$desc descriptor
data (size(tail)-1,DSC$K_DTYPE_T,DSC$K_CLASS_S,@tail);
declare prompt (*) byte data ('$_Command_tail: ');
declare prompt$desc descriptor
data (size(prompt),DSC$K_DTYPE_T,DSC$K_CLASS_S,@prompt);
declare i word;
declare initialized byte initial(FALSE);
declare command$buf$p pointer;
declare (command based command$buf$p) (1) byte;
declare default$delimiter$set (*) byte data
(20, ',()=#!$%\~+-&|[]<>;', ASC$DEL);
declare current$delimiter$set$p pointer initial (@default$delimiter$set);
declare (current$delimiter$set based current$delimiter$set$p) (1) byte;
declare indirect$buffer (4097) byte;
declare indirect$file$name (81) byte;
declare parsing$indirect$file byte initial (FALSE);
declare parsing$invocation$line byte initial (FALSE);
$subtitle ("DQ$GET$ARGUMENT -- Get Command Argument")
DQ$GET$ARGUMENT: procedure (argument$p, excep$p) byte reentrant public;
declare (argument$p, excep$p) %PTR;
declare (argument based argument$p) structure (length byte,
arg(80) byte);
declare (status based excep$p) word;
declare quote byte;
declare terminator byte;
declare conn word;
declare local$status word;
declare buffer$length word;
declare count word;
declare index word;
delimiter: procedure byte;
if command(i) <= 20H or
FINDB(@current$delimiter$set(1),command(i),
current$delimiter$set(0)) <> 0FFFFH
then
return TRUE;
else
return FALSE;
end delimiter;
putc: procedure (char);
declare char byte;
if argument.length < 80 then do;
argument.arg(argument.length)=char;
argument.length=argument.length+1;
end;
else
status = E$STRING$BUF;
return;
end putc;
status = E$OK;
argument.length = 0;
if not initialized then do;
declare outlen word;
call LIB%GET_FOREIGN (@tail$desc,
@prompt$desc,@outlen);
tail(outlen)=CR;
command$buf$p = tail$desc.ptr;
i = 0;
initialized = TRUE;
parsing$invocation$line=TRUE;
end;
rescan:
do while command(i)=' ' or command(i)=tab; i=i+1; end;
if parsing$invocation$line and command(i)='@' then
do;
if parsing$indirect$file then
call DQ$EXIT(X$bad$indirect$syntax);
endif
i=i+1;
parsing$indirect$file=TRUE;
terminator=DQ$GET$ARGUMENT(@indirect$file$name,@local$status);
parsing$indirect$file=FALSE;
if terminator<>CR then
call DQ$EXIT(X$indirect$not$last);
endif
conn=DQ$ATTACH(@indirect$file$name,@local$status);
if local$status<>E$OK then
call DQ$EXIT(X$bad$indirect$file);
endif
call DQ$OPEN(conn,1,1,@local$status);
if local$status<>E$OK then
call DQ$EXIT(X$bad$indirect$file);
endif
buffer$length=0;
count=1;
do while count>0 and buffer$length<size(indirect$buffer);
count=DQ$READ(conn,@indirect$buffer(buffer$length),
size(indirect$buffer)-buffer$length,
@local$status);
if local$status<>E$OK then
call DQ$EXIT(X$bad$indirect$file);
endif
buffer$length=buffer$length+count;
enddo
if buffer$length>=size(indirect$buffer) then
call DQ$EXIT(X$indirect$too$long);
endif
call DQ$DETACH(conn,@local$status);
if local$status<>E$OK then
call DQ$EXIT(X$bad$indirect$file);
endif
do index=1 to buffer$length;
if indirect$buffer(index-1)=CR or
indirect$buffer(index-1)=LF then
indirect$buffer(index-1)=' ';
endif
enddo
indirect$buffer(buffer$length)=CR;
command$buf$p = @indirect$buffer;
i = 0;
go to rescan;
enddo
endif
if delimiter then do;
i=i+1;
return command(i-1);
end;
if command(i)='''' or command(i)='"' then do;
quote = command(i);
do while command(i)=quote;
i=i+1;
do while command(i)<>quote and command(i)<>CR;
call putc(command(i));
i=i+1;
end;
if command(i)<>CR then i=i+1;
if command(i)=quote then call putc(quote);
end;
end;
else do while not delimiter;
if command(i)>='a' and command(i)<='z' then
call putc(command(i)+('A'-'a'));
else
call putc(command(i));
i=i+1;
end;
do while command(i)=' ' or command(i)=tab; i=i+1; end;
if delimiter then do;
i=i+1;
return command(i-1);
end;
else
return ' ';
end DQ$GET$ARGUMENT;
$subtitle ("DQ$SWITCH$BUFFER -- Change Command Buffer")
DQ$SWITCH$BUFFER: procedure (buffer$p, excep$p) word public;
declare (buffer$p, excep$p) %PTR;
declare (status based excep$p) word;
declare OLD$I word;
command$buf$p = buffer$p;
OLD$I = i; i = 0;
initialized = TRUE;
parsing$invocation$line = FALSE;
status = E$OK;
return OLD$I;
end DQ$SWITCH$BUFFER;
$subtitle ("DQ$SET$DELIMITERS -- Change Delimiter Set")
DQ$SET$DELIMITERS: procedure (delimiter$set$p, excep$p) public;
declare (delimiter$set$p, excep$p) %PTR;
declare (status based excep$p) word;
if delimiter$set$p = 0 then
current$delimiter$set$p = @default$delimiter$set;
else
current$delimiter$set$p = delimiter$set$p;
status = E$OK;
end DQ$SET$DELIMITERS;
end DQ_argument;

38
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/ascii.lit Normal file
View File

@@ -0,0 +1,38 @@
/* Non-printing ASCII character literal declarations. */
$SAVE NOLIST
/* */
/* D I S C L A I M E R N O T I C E */
/* ------------------- ----------- */
/* */
/* This document and/or portions of the material and data furnished */
/* herewith, was developed under sponsorship of the U. S. Government. */
/* Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior */
/* University, nor their employees, nor their respective contractors, */
/* subcontractors, or their employees, makes any warranty, express or */
/* implied, or assumes any liability or responsibility for accuracy, */
/* completeness or usefulness of any information, apparatus, product */
/* or process disclosed, or represents that its use will not infringe */
/* privately-owned rights. Mention of any product, its manufacturer, */
/* or suppliers shall not, nor is it intended to, imply approval, dis- */
/* approval, or fitness for any particular use. The U. S. and the */
/* University at all times retain the right to use and disseminate same */
/* for any purpose whatsoever. Such distribution shall be made by the */
/* National Energy Software Center at the Argonne National Laboratory */
/* and only subject to the distributee furnishing satisfactory proof */
/* that he has a valid license from the Intel Corporation in effect. */
/* */
declare
ASC$NUL literally '00H',
ASC$BEL literally '07H',
ASC$BS literally '08H',
ASC$HT literally '09H',
ASC$LF literally '0AH',
ASC$VT literally '0BH',
ASC$FF literally '0CH',
ASC$CR literally '0DH',
ASC$ESC literally '1BH',
ASC$DEL literally '7FH';
$RESTORE

74
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/change.plm Normal file
View File

@@ -0,0 +1,74 @@
$TITLE ('UDI Change Extension Routine')
$LARGE
DQ_CHANGE$EXTENSION: do; /* UDI DQ$CHANGE$EXTENSION routine. */
/*************************************************************************/
/* */
/* D I S C L A I M E R N O T I C E */
/* ------------------- ----------- */
/* */
/* This document and/or portions of the material and data furnished */
/* herewith, was developed under sponsorship of the U. S. Government. */
/* Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior */
/* University, nor their employees, nor their respective contractors, */
/* subcontractors, or their employees, makes any warranty, express or */
/* implied, or assumes any liability or responsibility for accuracy, */
/* completeness or usefulness of any information, apparatus, product */
/* or process disclosed, or represents that its use will not infringe */
/* privately-owned rights. Mention of any product, its manufacturer, */
/* or suppliers shall not, nor is it intended to, imply approval, dis- */
/* approval, or fitness for any particular use. The U. S. and the */
/* University at all times retain the right to use and disseminate same */
/* for any purpose whatsoever. Such distribution shall be made by the */
/* National Energy Software Center at the Argonne National Laboratory */
/* and only subject to the distributee furnishing satisfactory proof */
/* that he has a valid license from the Intel Corporation in effect. */
/* */
/*************************************************************************/
$INCLUDE (PLM$UDI:CUSTOMARY.LIT)
$INCLUDE (PLM$UDI:EXCEPT.LIT)
declare %PTR literally 'POINTER';
DQ$CHANGE$EXTENSION: procedure (path$p,extension$p,excep$p) public;
declare (path$p,extension$p,excep$p) %PTR;
declare (path based path$p) (46) byte,
(extension based extension$p) (3) byte,
(status based excep$p) byte;
declare inside_directory byte;
declare i integer;
status = E$OK;
inside_directory=FALSE;
i=1;
do while i<=path(0) and (inside_directory or path(i)<>'.');
if path(i)='[' then
inside_directory=TRUE;
else if path(i)=']' then
inside_directory=FALSE;
i=i+1;
end;
i=i-1;
if extension(0)<>' ' then do;
if i>41 then
status = E$STRING$BUF;
else do;
path(i+1)='.';
path(i+2)=extension(0);
path(i+3)=extension(1);
path(i+4)=extension(2);
i=i+4;
end;
end;
path(0)=i;
end DQ$CHANGE$EXTENSION;
end DQ_CHANGE$EXTENSION;

38
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/close.plm Normal file
View File

@@ -0,0 +1,38 @@
$TITLE ('DQ$CLOSE to XQ_CLOSE Interface Routine.')
$LARGE
/*************************************************************************/
/* */
/* D I S C L A I M E R N O T I C E */
/* ------------------- ----------- */
/* */
/* This document and/or portions of the material and data furnished */
/* herewith, was developed under sponsorship of the U. S. Government. */
/* Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior */
/* University, nor their employees, nor their respective contractors, */
/* subcontractors, or their employees, makes any warranty, express or */
/* implied, or assumes any liability or responsibility for accuracy, */
/* completeness or usefulness of any information, apparatus, product */
/* or process disclosed, or represents that its use will not infringe */
/* privately-owned rights. Mention of any product, its manufacturer, */
/* or suppliers shall not, nor is it intended to, imply approval, dis- */
/* approval, or fitness for any particular use. The U. S. and the */
/* University at all times retain the right to use and disseminate same */
/* for any purpose whatsoever. Such distribution shall be made by the */
/* National Energy Software Center at the Argonne National Laboratory */
/* and only subject to the distributee furnishing satisfactory proof */
/* that he has a valid license from the Intel Corporation in effect. */
/* */
/*************************************************************************/
DQ_CLOSE: do;
XQ_CLOSE: procedure (conn$p,excep$p) external;
declare (conn$p,excep$p) pointer;
end;
DQ$CLOSE: procedure (conn,excep$p) public;
declare conn word, excep$p pointer;
call XQ_CLOSE(@conn,excep$p);
end;
end DQ_CLOSE;

73
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/cntrlfld.mar Normal file
View File

@@ -0,0 +1,73 @@
.TITLE XQ_GET_CNTRL_FLD
;-----------------------------------------------------------------------
;
; D I S C L A I M E R N O T I C E
; ------------------- -----------
;
; This document and/or portions of the material and data furnished
; herewith, was developed under sponsorship of the U. S. Government.
; Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior
; University, nor their employees, nor their respective contractors,
; subcontractors, or their employees, makes any warranty, express or
; implied, or assumes any liability or responsibility for accuracy,
; completeness or usefulness of any information, apparatus, product
; or process disclosed, or represents that its use will not infringe
; privately-owned rights. Mention of any product, its manufacturer,
; or suppliers shall not, nor is it intended to, imply approval, dis-
; approval, or fitness for any particular use. The U. S. and the
; University at all times retain the right to use and disseminate same
; for any purpose whatsoever. Such distribution shall be made by the
; National Energy Software Center at the Argonne National Laboratory
; and only subject to the distributee furnishing satisfactory proof
; that he has a valid license from the Intel Corporation in effect.
;
;-----------------------------------------------------------------------
;
; This USEROPEN procedure is used by the XQIO package to
; obtain access to SOS and Wylbur-style lines numbers in
; source files. This code has been stolen almost verbatim
; from the VAX-11 FORTRAN User's Guide, section 3.5.9.
;
;-----------------------------------------------------------------------
;
; R E V I S I O N H I S T O R Y
;
;
; 04FEB82 Alex Hunter 1. Original version.
;
;-----------------------------------------------------------------------
$FABDEF ; Define RAB and FAB offsets.
$RABDEF
; Define argument list offsets.
FABOFF=4 ; 1st argument is FAB.
RABOFF=8 ; 2nd argument is RAB.
LUNOFF=12 ; 3rd argument is logical unit.
.ENTRY XQ_GET_CNTRL_FLD, ^M<R2>
MOVL FABOFF(AP),R0 ; Load FAB address to R0.
MOVL RABOFF(AP),R1 ; Load RAB address to R1.
MOVL @LUNOFF(AP),R2 ; Logical unit number to R2.
; Set size of header field into FAB.
MOVB #2,FAB$B_FSZ(R0)
; Set address into RAB.
MOVAW W_LINE_NUMBER[R2],RAB$L_RHB(R1)
$OPEN FAB=@FABOFF(AP) ; Perform the OPEN.
BLBC R0,10$ ; Return immediately if error.
$CONNECT RAB=@RABOFF(AP); Connect stream to file.
10$: RET ; Status value is from the OPEN or
; the CONNECT.
.PSECT XQ_LINE_SEQS,PIC,OVR,REL,GBL,SHR,NOEXE,RD,WRT,LONG
W_LINE_NUMBER:
.BLKW 100
.END

59
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/compares.mar Normal file
View File

@@ -0,0 +1,59 @@
.TITLE COMPARES. PLM RUNTIME LIBRARY: CMPB/CMPW.
;-----------------------------------------------------------------------
;
; D I S C L A I M E R N O T I C E
; ------------------- -----------
;
; This document and/or portions of the material and data furnished
; herewith, was developed under sponsorship of the U. S. Government.
; Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior
; University, nor their employees, nor their respective contractors,
; subcontractors, or their employees, makes any warranty, express or
; implied, or assumes any liability or responsibility for accuracy,
; completeness or usefulness of any information, apparatus, product
; or process disclosed, or represents that its use will not infringe
; privately-owned rights. Mention of any product, its manufacturer,
; or suppliers shall not, nor is it intended to, imply approval, dis-
; approval, or fitness for any particular use. The U. S. and the
; University at all times retain the right to use and disseminate same
; for any purpose whatsoever. Such distribution shall be made by the
; National Energy Software Center at the Argonne National Laboratory
; and only subject to the distributee furnishing satisfactory proof
; that he has a valid license from the Intel Corporation in effect.
;
;-----------------------------------------------------------------------
.PSECT PLMRUN_CODE,RD,NOWRT,EXE,GBL,CON,LONG
;
; W = CMPB(SOURCE1,SOURCE2,COUNT)
;
SOURCE1=4 ; POINTER.
SOURCE2=8 ; POINTER.
COUNT=12 ; WORD.
.ENTRY CMPB.,^M<R2,R3>
CMPC3 COUNT(AP),@SOURCE1(AP),@SOURCE2(AP)
BNEQ 1$
DECW R0 ; STRINGS EQUAL: RETURN 0FFFFH.
RET
1$: SUBW3 R0,COUNT(AP),R0 ; RETURN INDEX OF FIRST NON-COMPARE.
RET
;
; W = CMPW(SOURCE1,SOURCE2,COUNT)
;
.ENTRY CMPW.,^M<R3>
MOVZWL COUNT(AP),R0
BEQL 3$
MOVL SOURCE1(AP),R1
MOVL SOURCE2(AP),R3
2$: CMPW (R1)+,(R3)+
BNEQ 4$
SOBGTR R0,2$
3$: DECW R0 ; STRINGS EQUAL: RETURN 0FFFFH.
RET
4$: SUBW3 R0,COUNT(AP),R0 ; RETURN INDEX OF FIRST NON-COMPARE.
RET
.END

76
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/config.mar Normal file
View File

@@ -0,0 +1,76 @@
.TITLE CONFIGURATION
;-----------------------------------------------------------------------
;
; D I S C L A I M E R N O T I C E
; ------------------- -----------
;
; This document and/or portions of the material and data furnished
; herewith, was developed under sponsorship of the U. S. Government.
; Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior
; University, nor their employees, nor their respective contractors,
; subcontractors, or their employees, makes any warranty, express or
; implied, or assumes any liability or responsibility for accuracy,
; completeness or usefulness of any information, apparatus, product
; or process disclosed, or represents that its use will not infringe
; privately-owned rights. Mention of any product, its manufacturer,
; or suppliers shall not, nor is it intended to, imply approval, dis-
; approval, or fitness for any particular use. The U. S. and the
; University at all times retain the right to use and disseminate same
; for any purpose whatsoever. Such distribution shall be made by the
; National Energy Software Center at the Argonne National Laboratory
; and only subject to the distributee furnishing satisfactory proof
; that he has a valid license from the Intel Corporation in effect.
;
;-----------------------------------------------------------------------
.MACRO ALLOCATE STACK=0,-
MEMORY_SIZE=0,-
OVERLAY_DATA=0,-
SELECTOR_SPACE=0
.PSECT $AAA_OVERLAY_DATA,RD,WRT,NOEXE,GBL,CON,LONG
K.==.+^X8000
D$::
D.:: .LONG $OVERLAY
.BLKB OVERLAY_DATA
E$::
E.::
.PSECT $YYY_STACK,RD,WRT,EXE,GBL,CON,LONG
S.BOT:: .BLKB STACK
S.::
STACK.SIZ==STACK
STACK.LEN==STACK
STACK.LAST==STACK-1
.PSECT MEMORY,PIC,OVR,GBL,SHR,NOEXE,RD,WRT,LONG
MEMORY.:: .BLKB MEMORY_SIZE
MEMORY.TOP::
MEMORY.SIZ==MEMORY_SIZE
MEMORY.LEN==MEMORY_SIZE
MEMORY.LAST==MEMORY_SIZE-1
.PSECT $AAA_CGROUP_VECTOR,RD,NOWRT,EXE,GBL,CON
V$::
V.::
.PSECT $OVERLAY_INFO,LONG,RD,NOWRT,NOEXE
$OVERLAY::
.ENDM ALLOCATE
.MACRO OVERLAY NAME,ABBREV
.PSECT $AAA_'ABBREV,RD,WRT,NOEXE,GBL,CON,LONG
D.'ABBREV::
.LONG $OVERLAY
.PSECT $ZZZ_'ABBREV,RD,WRT,NOEXE,GBL,CON,LONG
E.'ABBREV::
.PSECT $OVERLAY_INFO
.ASCIC `%EXTRACT(0,15,NAME)`
NAME.SIZ=%LENGTH(NAME)
.ASCII `%EXTRACT(NAME.SIZ,15,< >)`
.LONG D.'ABBREV,E.'ABBREV
.ENDM OVERLAY
.MACRO END_OVERLAYS
.PSECT $OVERLAY_INFO
.BYTE 0
.ENDM END_OVERLAYS
.END

38
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/connstat.plm Normal file
View File

@@ -0,0 +1,38 @@
$TITLE ('DQ$GET$CONNECTION$STATUS Interface Routine.')
$LARGE
/*************************************************************************/
/* */
/* D I S C L A I M E R N O T I C E */
/* ------------------- ----------- */
/* */
/* This document and/or portions of the material and data furnished */
/* herewith, was developed under sponsorship of the U. S. Government. */
/* Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior */
/* University, nor their employees, nor their respective contractors, */
/* subcontractors, or their employees, makes any warranty, express or */
/* implied, or assumes any liability or responsibility for accuracy, */
/* completeness or usefulness of any information, apparatus, product */
/* or process disclosed, or represents that its use will not infringe */
/* privately-owned rights. Mention of any product, its manufacturer, */
/* or suppliers shall not, nor is it intended to, imply approval, dis- */
/* approval, or fitness for any particular use. The U. S. and the */
/* University at all times retain the right to use and disseminate same */
/* for any purpose whatsoever. Such distribution shall be made by the */
/* National Energy Software Center at the Argonne National Laboratory */
/* and only subject to the distributee furnishing satisfactory proof */
/* that he has a valid license from the Intel Corporation in effect. */
/* */
/*************************************************************************/
DQ_GETCONNECTIONSTATUS: do;
XQ_GET$CONNECTION$STATUS: procedure (conn$p,info$p,excep$p) external;
declare (conn$p,info$p,excep$p) pointer;
end;
DQ$GET$CONNECTION$STATUS: procedure (conn,info$p,excep$p) public;
declare conn word, (info$p,excep$p) pointer;
call XQ_GET$CONNECTION$STATUS(@conn,info$p,excep$p);
end;
end DQ_GETCONNECTIONSTATUS;

39
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/customary.lit Normal file
View File

@@ -0,0 +1,39 @@
/* Customary literal declarations. */
$SAVE NOLIST
/* */
/* D I S C L A I M E R N O T I C E */
/* ------------------- ----------- */
/* */
/* This document and/or portions of the material and data furnished */
/* herewith, was developed under sponsorship of the U. S. Government. */
/* Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior */
/* University, nor their employees, nor their respective contractors, */
/* subcontractors, or their employees, makes any warranty, express or */
/* implied, or assumes any liability or responsibility for accuracy, */
/* completeness or usefulness of any information, apparatus, product */
/* or process disclosed, or represents that its use will not infringe */
/* privately-owned rights. Mention of any product, its manufacturer, */
/* or suppliers shall not, nor is it intended to, imply approval, dis- */
/* approval, or fitness for any particular use. The U. S. and the */
/* University at all times retain the right to use and disseminate same */
/* for any purpose whatsoever. Such distribution shall be made by the */
/* National Energy Software Center at the Argonne National Laboratory */
/* and only subject to the distributee furnishing satisfactory proof */
/* that he has a valid license from the Intel Corporation in effect. */
/* */
/********************************************************************/
/*
/* R E V I S I O N H I S T O R Y
/*
/* 09NOV81 Alex Hunter 1. Removed definitions of %-keywords, since
/* PL/M-VAX V5.7 no longer wants the '%'.
/*
/********************************************************************/
declare TRUE literally '0FFH', FALSE literally '0',
FOREVER literally 'while 1',
ENDDO literally 'END;',
ENDIF literally ' ';
$RESTORE

138
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/decode.plm Normal file
View File

@@ -0,0 +1,138 @@
$TITLE ('UDI DECODE EXCEPTION')
$LARGE
/*************************************************************************/
/* */
/* D I S C L A I M E R N O T I C E */
/* ------------------- ----------- */
/* */
/* This document and/or portions of the material and data furnished */
/* herewith, was developed under sponsorship of the U. S. Government. */
/* Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior */
/* University, nor their employees, nor their respective contractors, */
/* subcontractors, or their employees, makes any warranty, express or */
/* implied, or assumes any liability or responsibility for accuracy, */
/* completeness or usefulness of any information, apparatus, product */
/* or process disclosed, or represents that its use will not infringe */
/* privately-owned rights. Mention of any product, its manufacturer, */
/* or suppliers shall not, nor is it intended to, imply approval, dis- */
/* approval, or fitness for any particular use. The U. S. and the */
/* University at all times retain the right to use and disseminate same */
/* for any purpose whatsoever. Such distribution shall be made by the */
/* National Energy Software Center at the Argonne National Laboratory */
/* and only subject to the distributee furnishing satisfactory proof */
/* */
/*-----------------------------------------------------------------------*/
/* */
/* R E V I S I O N H I S T O R Y */
/* */
/* 14JAN82 Alex Hunter 1. Change value of E$SUPPORT per Series III */
/* Programmer's Reference Manual Rev. B. */
/* 2. No longer necessary to use COMMON to */
/* place messages in high core. */
/* 03FEB82 Alex Hunter 1. Change module name. */
/* 2. Implicit dimension for exception, place */
/* in ROM psect. */
/* 3. Change test in search loop. */
/* */
/*************************************************************************/
DQ_DECODE: do;
$INCLUDE (PLM$UDI:EXCEPT.LIT)
declare PTR literally 'POINTER';
declare text literally '(*) byte data';
declare
M$OK text ('OK--Normal completion.'),
M$CONTEXT text ('CONTEXT--Illegal context.'),
M$CROSSFS text ('CROSSFS--Illegal cross volume rename.'),
M$EXIST text ('EXIST--Object does not exist.'),
M$FACCESS text ('FACCESS--File access violation.'),
M$FEXIST text ('FEXIST--File already exists.'),
M$FNEXIST text ('FNEXIST--File does not exist.'),
M$MEM text ('MEM--Insufficient memory.'),
M$NOPEN text ('NOPEN--File is not open.'),
M$OPEN text ('OPEN--File is already open.'),
M$OREAD text ('OREAD--File open for read only.'),
M$OWRITE text ('OWRITE--File open for write only.'),
M$PARAM text ('PARAM--Illegal parameter.'),
M$PTR text ('PTR--Illegal pointer.'),
M$SHARE text ('SHARE--Can''t share file.'),
M$SIX text ('SIX--Too many open connections.'),
M$SPACE text ('SPACE--Directory is full.'),
M$STRING$BUF text ('STRING$BUF--String too long for buffer.'),
M$SUPPORT text ('SUPPORT--Operation not supported.'),
M$SYNTAX text ('SYNTAX--Illegal pathname.'),
M$UNSAT text ('UNSAT--Unresolved external symbols.'),
M$ADDRESS text ('ADDRESS--Bad address in overlay.'),
M$BAD$FILE text ('BAD$FILE--Invalid object file.'),
M$ZERO$DIVIDE text ('ZERO$DIVIDE--Attempt to divide by zero.'),
M$OVERFLOW text ('OVERFLOW--Arithmetic overflow.'),
M$8087 text ('8087--NDP error.'),
M$HUH text ('???--Unrecognized exception code.'),
exception (*) structure (code word, msg$p pointer, msg$size byte)
data ( E$OK, @M$OK, size(M$OK),
E$CONTEXT, @M$CONTEXT, size(M$CONTEXT),
E$CROSSFS, @M$CROSSFS, size(M$CROSSFS),
E$EXIST, @M$EXIST, size(M$EXIST),
E$FACCESS, @M$FACCESS, size(M$FACCESS),
E$FEXIST, @M$FEXIST, size(M$FEXIST),
E$FNEXIST, @M$FNEXIST, size(M$FNEXIST),
E$MEM, @M$MEM, size(M$MEM),
E$NOPEN, @M$NOPEN, size(M$NOPEN),
E$OPEN, @M$OPEN, size(M$OPEN),
E$OREAD, @M$OREAD, size(M$OREAD),
E$OWRITE, @M$OWRITE, size(M$OWRITE),
E$PARAM, @M$PARAM, size(M$PARAM),
E$PTR, @M$PTR, size(M$PTR),
E$SHARE, @M$SHARE, size(M$SHARE),
E$SIX, @M$SIX, size(M$SIX),
E$SPACE, @M$SPACE, size(M$SPACE),
E$STRING$BUF, @M$STRING$BUF, size(M$STRING$BUF),
E$SUPPORT, @M$SUPPORT, size(M$SUPPORT),
/* old E$SUPPORT */ 010BH, @M$SUPPORT, size(M$SUPPORT),
E$SYNTAX, @M$SYNTAX, size(M$SYNTAX),
E$UNSAT, @M$UNSAT, size(M$UNSAT),
E$ADDRESS, @M$ADDRESS, size(M$ADDRESS),
E$BAD$FILE, @M$BAD$FILE, size(M$BAD$FILE),
E$ZERO$DIVIDE, @M$ZERO$DIVIDE, size(M$ZERO$DIVIDE),
E$OVERFLOW, @M$OVERFLOW, size(M$OVERFLOW),
E$8087, @M$8087, size(M$8087),
0FFFFH, @M$HUH, size(M$HUH),
),
preface (*) byte data ('EXCEPTION nnnnH E$'),
hex (*) byte data ('0123456789ABCDEF');
DQ$DECODE$EXCEPTION: procedure (exception$code,message$p,excep$p) public;
declare exception$code word,
(message$p,excep$p) PTR;
declare (message based message$p) (1) byte,
(status based excep$p) word;
declare (i,j) integer;
j=0;
do while exception(j).code<>exception$code and j<last(exception);
j=j+1;
end;
message(0) = size(preface) + exception(j).msg$size;
call MOVB (@preface, @message(1), size(preface));
do i=0 to 3;
message(i+11)=hex(SHR(exception$code,(3-i)*4) AND 0FH);
end;
call MOVB (exception(j).msg$p, @message(size(preface)+1),
exception(j).msg$size);
status=E$OK;
end DQ$DECODE$EXCEPTION;
end DQ_DECODE;

64
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/descript.lit Normal file
View File

@@ -0,0 +1,64 @@
/* VAX data descriptor literal definitions. */
$SAVE NOLIST
/* */
/* D I S C L A I M E R N O T I C E */
/* ------------------- ----------- */
/* */
/* This document and/or portions of the material and data furnished */
/* herewith, was developed under sponsorship of the U. S. Government. */
/* Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior */
/* University, nor their employees, nor their respective contractors, */
/* subcontractors, or their employees, makes any warranty, express or */
/* implied, or assumes any liability or responsibility for accuracy, */
/* completeness or usefulness of any information, apparatus, product */
/* or process disclosed, or represents that its use will not infringe */
/* privately-owned rights. Mention of any product, its manufacturer, */
/* or suppliers shall not, nor is it intended to, imply approval, dis- */
/* approval, or fitness for any particular use. The U. S. and the */
/* University at all times retain the right to use and disseminate same */
/* for any purpose whatsoever. Such distribution shall be made by the */
/* National Energy Software Center at the Argonne National Laboratory */
/* and only subject to the distributee furnishing satisfactory proof */
/* that he has a valid license from the Intel Corporation in effect. */
/* */
declare DESCRIPTOR literally
'structure (length word,dtype byte,class byte,ptr pointer)';
declare
DSC$K_DTYPE_Z literally '0',
DSC$K_DTYPE_V literally '1',
DSC$K_DTYPE_BU literally '2',
DSC$K_DTYPE_WU literally '3',
DSC$K_DTYPE_LU literally '4',
DSC$K_DTYPE_QU literally '5',
DSC$K_DTYPE_B literally '6',
DSC$K_DTYPE_W literally '7',
DSC$K_DTYPE_L literally '8',
DSC$K_DTYPE_Q literally '9',
DSC$K_DTYPE_F literally '10',
DSC$K_DTYPE_D literally '11',
DSC$K_DTYPE_FC literally '12',
DSC$K_DTYPE_DC literally '13',
DSC$K_DTYPE_T literally '14',
DSC$K_DTYPE_NU literally '15',
DSC$K_DTYPE_NL literally '16',
DSC$K_DTYPE_NLO literally '17',
DSC$K_DTYPE_NR literally '18',
DSC$K_DTYPE_NRO literally '19',
DSC$K_DTYPE_NZ literally '20',
DSC$K_DTYPE_P literally '21',
DSC$K_DTYPE_ZI literally '22',
DSC$K_DTYPE_ZEM literally '23';
declare
DSC$K_CLASS_S literally '1',
DSC$K_CLASS_D literally '2',
DSC$K_CLASS_A literally '4',
DSC$K_CLASS_P literally '5',
DSC$K_CLASS_PI literally '6',
DSC$K_CLASS_J literally '7',
DSC$K_CLASS_JI literally '8';
$RESTORE

38
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/detach.plm Normal file
View File

@@ -0,0 +1,38 @@
$TITLE ('DQ$DETACH to XQ_DETACH Interface Routine.')
$LARGE
/*************************************************************************/
/* */
/* D I S C L A I M E R N O T I C E */
/* ------------------- ----------- */
/* */
/* This document and/or portions of the material and data furnished */
/* herewith, was developed under sponsorship of the U. S. Government. */
/* Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior */
/* University, nor their employees, nor their respective contractors, */
/* subcontractors, or their employees, makes any warranty, express or */
/* implied, or assumes any liability or responsibility for accuracy, */
/* completeness or usefulness of any information, apparatus, product */
/* or process disclosed, or represents that its use will not infringe */
/* privately-owned rights. Mention of any product, its manufacturer, */
/* or suppliers shall not, nor is it intended to, imply approval, dis- */
/* approval, or fitness for any particular use. The U. S. and the */
/* University at all times retain the right to use and disseminate same */
/* for any purpose whatsoever. Such distribution shall be made by the */
/* National Energy Software Center at the Argonne National Laboratory */
/* and only subject to the distributee furnishing satisfactory proof */
/* that he has a valid license from the Intel Corporation in effect. */
/* */
/*************************************************************************/
DQ_DETACH: do;
XQ_DETACH: procedure (conn$p,excep$p) external;
declare (conn$p,excep$p) pointer;
end;
DQ$DETACH: procedure (conn,excep$p) public;
declare conn word, excep$p pointer;
call XQ_DETACH(@conn,excep$p);
end;
end DQ_DETACH;

23
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/disclaim.mar Normal file
View File

@@ -0,0 +1,23 @@
;-----------------------------------------------------------------------
;
; D I S C L A I M E R N O T I C E
; ------------------- -----------
;
; This document and/or portions of the material and data furnished
; herewith, was developed under sponsorship of the U. S. Government.
; Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior
; University, nor their employees, nor their respective contractors,
; subcontractors, or their employees, makes any warranty, express or
; implied, or assumes any liability or responsibility for accuracy,
; completeness or usefulness of any information, apparatus, product
; or process disclosed, or represents that its use will not infringe
; privately-owned rights. Mention of any product, its manufacturer,
; or suppliers shall not, nor is it intended to, imply approval, dis-
; approval, or fitness for any particular use. The U. S. and the
; University at all times retain the right to use and disseminate same
; for any purpose whatsoever. Such distribution shall be made by the
; National Energy Software Center at the Argonne National Laboratory
; and only subject to the distributee furnishing satisfactory proof
; that he has a valid license from the Intel Corporation in effect.
;
;-----------------------------------------------------------------------

23
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/disclaim.plm Normal file
View File

@@ -0,0 +1,23 @@
/*************************************************************************/
/* */
/* D I S C L A I M E R N O T I C E */
/* ------------------- ----------- */
/* */
/* This document and/or portions of the material and data furnished */
/* herewith, was developed under sponsorship of the U. S. Government. */
/* Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior */
/* University, nor their employees, nor their respective contractors, */
/* subcontractors, or their employees, makes any warranty, express or */
/* implied, or assumes any liability or responsibility for accuracy, */
/* completeness or usefulness of any information, apparatus, product */
/* or process disclosed, or represents that its use will not infringe */
/* privately-owned rights. Mention of any product, its manufacturer, */
/* or suppliers shall not, nor is it intended to, imply approval, dis- */
/* approval, or fitness for any particular use. The U. S. and the */
/* University at all times retain the right to use and disseminate same */
/* for any purpose whatsoever. Such distribution shall be made by the */
/* National Energy Software Center at the Argonne National Laboratory */
/* and only subject to the distributee furnishing satisfactory proof */
/* that he has a valid license from the Intel Corporation in effect. */
/* */
/*************************************************************************/

7
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/dm.com Normal file
View File

@@ -0,0 +1,7 @@
$SET VERIFY
$!
$! 16FEB82 Alex Hunter 1. Original version.
$!
$MAC/NOLIS/E=D DM
$!
$SET NOVERIFY

25
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/dm.mar Normal file
View File

@@ -0,0 +1,25 @@
.TITLE DM DUMMY MODULE NEEDED TO DEFINE CLUSTER.
;-----------------------------------------------------------------------
;
; D I S C L A I M E R N O T I C E
; ------------------- -----------
;
; This document and/or portions of the material and data furnished
; herewith, was developed under sponsorship of the U. S. Government.
; Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior
; University, nor their employees, nor their respective contractors,
; subcontractors, or their employees, makes any warranty, express or
; implied, or assumes any liability or responsibility for accuracy,
; completeness or usefulness of any information, apparatus, product
; or process disclosed, or represents that its use will not infringe
; privately-owned rights. Mention of any product, its manufacturer,
; or suppliers shall not, nor is it intended to, imply approval, dis-
; approval, or fitness for any particular use. The U. S. and the
; University at all times retain the right to use and disseminate same
; for any purpose whatsoever. Such distribution shall be made by the
; National Energy Software Center at the Argonne National Laboratory
; and only subject to the distributee furnishing satisfactory proof
; that he has a valid license from the Intel Corporation in effect.
;
;-----------------------------------------------------------------------
.END

58
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/except.for Normal file
View File

@@ -0,0 +1,58 @@
C***********************************************************************
C
C D I S C L A I M E R N O T I C E
C ------------------- -----------
C
C This document and/or portions of the material and data furnished
C herewith, was developed under sponsorship of the U. S. Government.
C Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior
C University, nor their employees, nor their respective contractors,
C subcontractors, or their employees, makes any warranty, express or
C implied, or assumes any liability or responsibility for accuracy,
C completeness or usefulness of any information, apparatus, product
C or process disclosed, or represents that its use will not infringe
C privately-owned rights. Mention of any product, its manufacturer,
C or suppliers shall not, nor is it intended to, imply approval, dis-
C approval, or fitness for any particular use. The U. S. and the
C University at all times retain the right to use and disseminate same
C for any purpose whatsoever. Such distribution shall be made by the
C National Energy Software Center at the Argonne National Laboratory
C and only subject to the distributee furnishing satisfactory proof
C that he has a valid license from the Intel Corporation in effect.
C
C-----------------------------------------------------------------------
C
C R E V I S I O N H I S T O R Y
C
C 14JAN82 Alex Hunter 1. Change value of E$SUPPORT per Series III
C Programmer's Reference Manual Rev. B.
C
C***********************************************************************
PARAMETER
# E$OK = '0000'X,
# E$CONTEXT = '0101'X,
# E$CROSSFS = '0102'X,
# E$EXIST = '0103'X,
# E$FACCESS = '0026'X,
# E$FEXIST = '0020'X,
# E$FNEXIST = '0021'X,
# E$MEM = '0002'X,
# E$NOPEN = '0104'X,
# E$OPEN = '0105'X,
# E$OREAD = '0106'X,
# E$OWRITE = '0107'X,
# E$PARAM = '0108'X,
# E$PTR = '0109'X,
# E$SHARE = '0028'X,
# E$SIX = '010A'X,
# E$SPACE = '0029'X,
# E$STRING$BUF = '0081'X,
# E$SUPPORT = '0023'X,
# E$SYNTAX = '010C'X,
# E$UNSAT = '010E'X,
# E$ADDRESS = '010F'X,
# E$BAD$FILE = '0110'X,
# E$ZERO$DIVIDE = '8000'X,
# E$OVERFLOW = '8001'X,
# E$8087 = '8007'X

63
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/except.lit Normal file
View File

@@ -0,0 +1,63 @@
/* UDI exception codes. */
$SAVE NOLIST
/*************************************************************************/
/* */
/* D I S C L A I M E R N O T I C E */
/* ------------------- ----------- */
/* */
/* This document and/or portions of the material and data furnished */
/* herewith, was developed under sponsorship of the U. S. Government. */
/* Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior */
/* University, nor their employees, nor their respective contractors, */
/* subcontractors, or their employees, makes any warranty, express or */
/* implied, or assumes any liability or responsibility for accuracy, */
/* completeness or usefulness of any information, apparatus, product */
/* or process disclosed, or represents that its use will not infringe */
/* privately-owned rights. Mention of any product, its manufacturer, */
/* or suppliers shall not, nor is it intended to, imply approval, dis- */
/* approval, or fitness for any particular use. The U. S. and the */
/* University at all times retain the right to use and disseminate same */
/* for any purpose whatsoever. Such distribution shall be made by the */
/* National Energy Software Center at the Argonne National Laboratory */
/* and only subject to the distributee furnishing satisfactory proof */
/* that he has a valid license from the Intel Corporation in effect. */
/* */
/*-----------------------------------------------------------------------*/
/* */
/* R E V I S I O N H I S T O R Y */
/* */
/* 14JAN82 Alex Hunter 1. Change value of E$SUPPORT per Series III */
/* Programmer's Reference Manual Rev. B. */
/* */
/*************************************************************************/
declare
E$OK literally '0000H',
E$CONTEXT literally '0101H',
E$CROSSFS literally '0102H',
E$EXIST literally '0103H',
E$FACCESS literally '0026H',
E$FEXIST literally '0020H',
E$FNEXIST literally '0021H',
E$MEM literally '0002H',
E$NOPEN literally '0104H',
E$OPEN literally '0105H',
E$OREAD literally '0106H',
E$OWRITE literally '0107H',
E$PARAM literally '0108H',
E$PTR literally '0109H',
E$SHARE literally '0028H',
E$SIX literally '010AH',
E$SPACE literally '0029H',
E$STRING$BUF literally '0081H',
E$SUPPORT literally '0023H',
E$SYNTAX literally '010CH',
E$UNSAT literally '010EH',
E$ADDRESS literally '010FH',
E$BAD$FILE literally '0110H',
E$ZERO$DIVIDE literally '8000H',
E$OVERFLOW literally '8001H',
E$8087 literally '8007H';
$RESTORE

38
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/exit.plm Normal file
View File

@@ -0,0 +1,38 @@
$TITLE ('DQ$EXIT to XQ_EXIT Interface Routine.')
$LARGE
/*************************************************************************/
/* */
/* D I S C L A I M E R N O T I C E */
/* ------------------- ----------- */
/* */
/* This document and/or portions of the material and data furnished */
/* herewith, was developed under sponsorship of the U. S. Government. */
/* Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior */
/* University, nor their employees, nor their respective contractors, */
/* subcontractors, or their employees, makes any warranty, express or */
/* implied, or assumes any liability or responsibility for accuracy, */
/* completeness or usefulness of any information, apparatus, product */
/* or process disclosed, or represents that its use will not infringe */
/* privately-owned rights. Mention of any product, its manufacturer, */
/* or suppliers shall not, nor is it intended to, imply approval, dis- */
/* approval, or fitness for any particular use. The U. S. and the */
/* University at all times retain the right to use and disseminate same */
/* for any purpose whatsoever. Such distribution shall be made by the */
/* National Energy Software Center at the Argonne National Laboratory */
/* and only subject to the distributee furnishing satisfactory proof */
/* that he has a valid license from the Intel Corporation in effect. */
/* */
/*************************************************************************/
DQ_EXIT: do;
XQ_EXIT: procedure (completion$code$p) external;
declare completion$code$p pointer;
end;
DQ$EXIT: procedure (completion$code) public;
declare completion$code word;
call XQ_EXIT(@completion$code);
end;
end DQ_EXIT;

45
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/exitcodes.lit Normal file
View File

@@ -0,0 +1,45 @@
/* UDI exit completion codes. */
$SAVE NOLIST
/*************************************************************************/
/* */
/* D I S C L A I M E R N O T I C E */
/* ------------------- ----------- */
/* */
/* This document and/or portions of the material and data furnished */
/* herewith, was developed under sponsorship of the U. S. Government. */
/* Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior */
/* University, nor their employees, nor their respective contractors, */
/* subcontractors, or their employees, makes any warranty, express or */
/* implied, or assumes any liability or responsibility for accuracy, */
/* completeness or usefulness of any information, apparatus, product */
/* or process disclosed, or represents that its use will not infringe */
/* privately-owned rights. Mention of any product, its manufacturer, */
/* or suppliers shall not, nor is it intended to, imply approval, dis- */
/* approval, or fitness for any particular use. The U. S. and the */
/* University at all times retain the right to use and disseminate same */
/* for any purpose whatsoever. Such distribution shall be made by the */
/* National Energy Software Center at the Argonne National Laboratory */
/* and only subject to the distributee furnishing satisfactory proof */
/* that he has a valid license from the Intel Corporation in effect. */
/* */
/*-----------------------------------------------------------------------*/
/* */
/* R E V I S I O N H I S T O R Y */
/* */
/* 31JAN82 Alex Hunter 1. Written. */
/* */
/*************************************************************************/
declare
X$OK literally '0',
X$warnings literally '1',
X$errors literally '2',
X$fatal literally '3',
X$abort literally '4',
X$bad$indirect$syntax literally '101',
X$indirect$not$last literally '102',
X$bad$indirect$file literally '103',
X$indirect$too$long literally '104';
$RESTORE

90
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/finds.mar Normal file
View File

@@ -0,0 +1,90 @@
.TITLE FINDS. PLM RUNTIME LIBRARY: FINDB., ET AL.
;-----------------------------------------------------------------------
;
; D I S C L A I M E R N O T I C E
; ------------------- -----------
;
; This document and/or portions of the material and data furnished
; herewith, was developed under sponsorship of the U. S. Government.
; Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior
; University, nor their employees, nor their respective contractors,
; subcontractors, or their employees, makes any warranty, express or
; implied, or assumes any liability or responsibility for accuracy,
; completeness or usefulness of any information, apparatus, product
; or process disclosed, or represents that its use will not infringe
; privately-owned rights. Mention of any product, its manufacturer,
; or suppliers shall not, nor is it intended to, imply approval, dis-
; approval, or fitness for any particular use. The U. S. and the
; University at all times retain the right to use and disseminate same
; for any purpose whatsoever. Such distribution shall be made by the
; National Energy Software Center at the Argonne National Laboratory
; and only subject to the distributee furnishing satisfactory proof
; that he has a valid license from the Intel Corporation in effect.
;
;-----------------------------------------------------------------------
.PSECT PLMRUN_CODE,RD,NOWRT,EXE,GBL,CON,LONG
;
; W = FINDB(SOURCE,TARGET,COUNT)
;
SOURCE=4 ; POINTER.
TARGET=8 ; BYTE OR WORD.
COUNT=12 ; WORD.
.ENTRY FINDB.,^M<>
LOCC TARGET(AP),COUNT(AP),@SOURCE(AP)
BNEQ 1$
DECW R0 ; NOT FOUND: RETURN 0FFFFH.
RET
1$: SUBW3 R0,COUNT(AP),R0 ; FOUND: RETURN STRING INDEX.
RET
;
; W = FINDRB(SOURCE,TARGET,COUNT)
;
.ENTRY FINDRB.,^M<R3>
MOVZWL COUNT(AP),R0
BEQL 3$ ; NOT FOUND IF LENGTH=0.
ADDL3 R0,SOURCE(AP),R1
MOVB TARGET(AP),R3
2$: CMPB R3,-(R1)
BEQL 3$
SOBGTR R0,2$
3$: DECW R0 ; RETURN STR INDEX (FFFF IF NOT FOUND).
RET
;
; W = FINDW(SOURCE,TARGET,COUNT)
;
.ENTRY FINDW.,^M<R3>
MOVZWL COUNT(AP),R0
BEQL 3$ ; NOT FOUND IF LENGTH=0.
MOVL SOURCE(AP),R1
MOVW TARGET(AP),R3
2$: CMPW R3,(R1)+
BEQL 4$
SOBGTR R0,2$
3$: DECW R0 ; NOT FOUND: RETURN 0FFFFH.
RET
4$: SUBW3 R0,COUNT(AP),R0 ; FOUND: RETURN STRING INDEX.
RET
;
; W = FINDRW(SOURCE,TARGET,COUNT)
;
.ENTRY FINDRW.,^M<R3>
MOVZWL COUNT(AP),R0
BEQL 3$ ; NOT FOUND IF LENGTH=0.
ADDL3 R0,SOURCE(AP),R1
ADDL2 R0,R1
MOVW TARGET(AP),R3
2$: CMPW R3,-(R1)
BEQL 3$
SOBGTR R0,2$
3$: DECW R0 ; RETURN STR INDEX (FFFF IF NOT FOUND).
RET
.END

76
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/gettime.plm Normal file
View File

@@ -0,0 +1,76 @@
$TITLE ('UDI GET TIME SYSTEM CALL')
$LARGE
/*************************************************************************/
/* */
/* D I S C L A I M E R N O T I C E */
/* ------------------- ----------- */
/* */
/* This document and/or portions of the material and data furnished */
/* herewith, was developed under sponsorship of the U. S. Government. */
/* Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior */
/* University, nor their employees, nor their respective contractors, */
/* subcontractors, or their employees, makes any warranty, express or */
/* implied, or assumes any liability or responsibility for accuracy, */
/* completeness or usefulness of any information, apparatus, product */
/* or process disclosed, or represents that its use will not infringe */
/* privately-owned rights. Mention of any product, its manufacturer, */
/* or suppliers shall not, nor is it intended to, imply approval, dis- */
/* approval, or fitness for any particular use. The U. S. and the */
/* University at all times retain the right to use and disseminate same */
/* for any purpose whatsoever. Such distribution shall be made by the */
/* National Energy Software Center at the Argonne National Laboratory */
/* and only subject to the distributee furnishing satisfactory proof */
/* that he has a valid license from the Intel Corporation in effect. */
/* */
/*************************************************************************/
DQ_GET$TIME: do;
$INCLUDE (PLM$UDI:EXCEPT.LIT)
declare PTR literally 'POINTER';
FOR%DATE: procedure (date$p) external;
declare date$p pointer;
end;
FOR%TIME: procedure (time$p) external;
declare time$p pointer;
end;
declare month (12) structure (name(3) byte, number(2) byte)
data( 'JAN01', 'FEB02', 'MAR03',
'APR04', 'MAY05', 'JUN06',
'JUL07', 'AUG08', 'SEP09',
'OCT10', 'NOV11', 'DEC12');
DQ$GET$TIME: procedure (dt$p, excep$p) public;
declare (dt$p,excep$p) PTR;
declare (dt based dt$p) structure (date(8) byte, time(8) byte);
declare (status based excep$p) word;
declare i integer;
call FOR%DATE(@dt.date(7));
i=0;
do while dt.date(10)<>month(i).name(0) or
dt.date(11)<>month(i).name(1) or
dt.date(12)<>month(i).name(2);
i=i+1;
end;
dt.date(0)=month(i).number(0); /* MM */
dt.date(1)=month(i).number(1);
dt.date(2),dt.date(5)='/';
dt.date(3)=dt.date(7) OR '0'; /* DD */
dt.date(4)=dt.date(8);
dt.date(6)=dt.date(14); /* YY */
dt.date(7)=dt.date(15);
call FOR%TIME(@dt.time); /* HH:MM:SS */
status=E$OK;
end DQ$GET$TIME;
end DQ_GET$TIME;

53
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/hilo.mar Normal file
View File

@@ -0,0 +1,53 @@
.TITLE HILO. PLM RUNTIME LIBRARY: HIGH, LOW, DOUBLE.
;-----------------------------------------------------------------------
;
; D I S C L A I M E R N O T I C E
; ------------------- -----------
;
; This document and/or portions of the material and data furnished
; herewith, was developed under sponsorship of the U. S. Government.
; Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior
; University, nor their employees, nor their respective contractors,
; subcontractors, or their employees, makes any warranty, express or
; implied, or assumes any liability or responsibility for accuracy,
; completeness or usefulness of any information, apparatus, product
; or process disclosed, or represents that its use will not infringe
; privately-owned rights. Mention of any product, its manufacturer,
; or suppliers shall not, nor is it intended to, imply approval, dis-
; approval, or fitness for any particular use. The U. S. and the
; University at all times retain the right to use and disseminate same
; for any purpose whatsoever. Such distribution shall be made by the
; National Energy Software Center at the Argonne National Laboratory
; and only subject to the distributee furnishing satisfactory proof
; that he has a valid license from the Intel Corporation in effect.
;
;-----------------------------------------------------------------------
.PSECT PLMRUN_CODE,RD,NOWRT,EXE,GBL,CON,LONG
;
; B = HIGH(WORD)
;
WORD=4 ; WORD VALUE.
BYTE=4 ; BYTE VALUE.
.ENTRY HIGH.,^M<>
MOVZBL WORD+1(AP),R0
RET
;
; B = LOW(WORD)
;
.ENTRY LOW.,^M<>
MOVZBL WORD(AP),R0
RET
;
; W = DOUBLE(BYTE)
;
.ENTRY DOUBLE.,^M<>
MOVZBL BYTE(AP),R0
RET
.END

38
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/iabs.mar Normal file
View File

@@ -0,0 +1,38 @@
.TITLE IABS. PLM RUNTIME LIBRARY: IABS
;-----------------------------------------------------------------------
;
; D I S C L A I M E R N O T I C E
; ------------------- -----------
;
; This document and/or portions of the material and data furnished
; herewith, was developed under sponsorship of the U. S. Government.
; Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior
; University, nor their employees, nor their respective contractors,
; subcontractors, or their employees, makes any warranty, express or
; implied, or assumes any liability or responsibility for accuracy,
; completeness or usefulness of any information, apparatus, product
; or process disclosed, or represents that its use will not infringe
; privately-owned rights. Mention of any product, its manufacturer,
; or suppliers shall not, nor is it intended to, imply approval, dis-
; approval, or fitness for any particular use. The U. S. and the
; University at all times retain the right to use and disseminate same
; for any purpose whatsoever. Such distribution shall be made by the
; National Energy Software Center at the Argonne National Laboratory
; and only subject to the distributee furnishing satisfactory proof
; that he has a valid license from the Intel Corporation in effect.
;
;-----------------------------------------------------------------------
.PSECT PLMRUN_CODE,RD,NOWRT,EXE,GBL,CON,LONG
;
; I = IABS(J)
;
J=4 ; (LONG)WORD.
.ENTRY IABS.,^M<>
MOVL J(AP),R0
BGEQ 1$
MNEGL R0,R0
1$: RET
.END

177
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/iodef.for Normal file
View File

@@ -0,0 +1,177 @@
PARAMETER IO$V_FCODE = '00000000'X
PARAMETER IO$_NOP = '00000000'X
PARAMETER IO$_UNLOAD = '00000001'X
PARAMETER IO$_LOADMCODE = '00000001'X
PARAMETER IO$_STARTMPROC = '00000002'X
PARAMETER IO$_SEEK = '00000002'X
PARAMETER IO$_SPACEFILE = '00000002'X
PARAMETER IO$_RECAL = '00000003'X
PARAMETER IO$_STOP = '00000003'X
PARAMETER IO$_INITIALIZE = '00000004'X
PARAMETER IO$_DRVCLR = '00000004'X
PARAMETER IO$_SETCLOCKP = '00000005'X
PARAMETER IO$_RELEASE = '00000005'X
PARAMETER IO$V_DELDATA = '00000006'X
PARAMETER IO$V_CANCTRLO = '00000006'X
PARAMETER IO$V_SETEVF = '00000006'X
PARAMETER IO$_ERASETAPE = '00000006'X
PARAMETER IO$S_FCODE = '00000006'X
PARAMETER IO$V_TYPEAHDCNT = '00000006'X
PARAMETER IO$_STARTDATAP = '00000006'X
PARAMETER IO$_OFFSET = '00000006'X
PARAMETER IO$V_NOECHO = '00000006'X
PARAMETER IO$V_INTERRUPT = '00000006'X
PARAMETER IO$V_WORD = '00000006'X
PARAMETER IO$V_STARTUP = '00000006'X
PARAMETER IO$V_NOW = '00000006'X
PARAMETER IO$V_BINARY = '00000006'X
PARAMETER IO$V_ACCESS = '00000006'X
PARAMETER IO$V_REVERSE = '00000006'X
PARAMETER IO$V_COMMOD = '00000006'X
PARAMETER IO$V_READATTN = '00000007'X
PARAMETER IO$V_ENABLMBX = '00000007'X
PARAMETER IO$V_PACKED = '00000007'X
PARAMETER IO$V_TIMED = '00000007'X
PARAMETER IO$V_MOVETRACKD = '00000007'X
PARAMETER IO$V_RESET = '00000007'X
PARAMETER IO$V_CREATE = '00000007'X
PARAMETER IO$V_NOWAIT = '00000007'X
PARAMETER IO$V_SHUTDOWN = '00000007'X
PARAMETER IO$V_CTRLYAST = '00000007'X
PARAMETER IO$_RETCENTER = '00000007'X
PARAMETER IO$_QSTOP = '00000007'X
PARAMETER IO$V_WRTATTN = '00000008'X
PARAMETER IO$V_ATTNAST = '00000008'X
PARAMETER IO$V_CTRLCAST = '00000008'X
PARAMETER IO$V_DELETE = '00000008'X
PARAMETER IO$V_DIAGNOSTIC = '00000008'X
PARAMETER IO$V_INTSKIP = '00000008'X
PARAMETER IO$V_NOFORMAT = '00000008'X
PARAMETER IO$_PACKACK = '00000008'X
PARAMETER IO$V_CVTLOW = '00000008'X
PARAMETER IO$V_ABORT = '00000008'X
PARAMETER IO$_SPACERECORD = '00000009'X
PARAMETER IO$V_HANGUP = '00000009'X
PARAMETER IO$V_SETFNCT = '00000009'X
PARAMETER IO$V_SKPSECINH = '00000009'X
PARAMETER IO$V_SYNCH = '00000009'X
PARAMETER IO$V_OPPOSITE = '00000009'X
PARAMETER IO$_SEARCH = '00000009'X
PARAMETER IO$V_NOFILTR = '00000009'X
PARAMETER IO$V_MOUNT = '00000009'X
PARAMETER IO$V_DSABLMBX = '0000000A'X
PARAMETER IO$_WRITECHECK = '0000000A'X
PARAMETER IO$V_DMOUNT = '0000000A'X
PARAMETER IO$V_DATAPATH = '0000000A'X
PARAMETER IO$V_SWAP = '0000000A'X
PARAMETER IO$V_CECYL = '0000000A'X
PARAMETER IO$_WRITEPBLK = '0000000B'X
PARAMETER IO$V_PURGE = '0000000B'X
PARAMETER IO$V_INHERLOG = '0000000B'X
PARAMETER IO$V_CYCLE = '0000000C'X
PARAMETER IO$V_INHSEEK = '0000000C'X
PARAMETER IO$V_TRMNOECHO = '0000000C'X
PARAMETER IO$V_INHEXTGAP = '0000000C'X
PARAMETER IO$_READPBLK = '0000000C'X
PARAMETER IO$V_REFRESH = '0000000D'X
PARAMETER IO$_WRITEHEAD = '0000000D'X
PARAMETER IO$V_DATACHECK = '0000000E'X
PARAMETER IO$_READHEAD = '0000000E'X
PARAMETER IO$_WRITETRACKD = '0000000F'X
PARAMETER IO$V_INHRETRY = '0000000F'X
PARAMETER IO$_READTRACKD = '00000010'X
PARAMETER IO$_REREADN = '00000016'X
PARAMETER IO$_REREADP = '00000017'X
PARAMETER IO$_WRITERET = '00000018'X
PARAMETER IO$_WRITECHECKH = '00000018'X
PARAMETER IO$_READPRESET = '00000019'X
PARAMETER IO$_STARTSPNDL = '00000019'X
PARAMETER IO$_SETCHAR = '0000001A'X
PARAMETER IO$_SENSECHAR = '0000001B'X
PARAMETER IO$_WRITEMARK = '0000001C'X
PARAMETER IO$_DIAGNOSE = '0000001D'X
PARAMETER IO$_WRTTMKR = '0000001D'X
PARAMETER IO$_FORMAT = '0000001E'X
PARAMETER IO$_CLEAN = '0000001E'X
PARAMETER IO$_PHYSICAL = '0000001F'X
PARAMETER IO$_WRITELBLK = '00000020'X
PARAMETER IO$_READLBLK = '00000021'X
PARAMETER IO$_REWINDOFF = '00000022'X
PARAMETER IO$_SETMODE = '00000023'X
PARAMETER IO$_REWIND = '00000024'X
PARAMETER IO$_SKIPFILE = '00000025'X
PARAMETER IO$_SKIPRECORD = '00000026'X
PARAMETER IO$_SENSEMODE = '00000027'X
PARAMETER IO$_WRITEOF = '00000028'X
PARAMETER IO$_LOGICAL = '0000002F'X
PARAMETER IO$_WRITEVBLK = '00000030'X
PARAMETER IO$_READVBLK = '00000031'X
PARAMETER IO$_ACCESS = '00000032'X
PARAMETER IO$_CREATE = '00000033'X
PARAMETER IO$_DEACCESS = '00000034'X
PARAMETER IO$_DELETE = '00000035'X
PARAMETER IO$_MODIFY = '00000036'X
PARAMETER IO$_SETCLOCK = '00000037'X
PARAMETER IO$_READPROMPT = '00000037'X
PARAMETER IO$_STARTDATA = '00000038'X
PARAMETER IO$_ACPCONTROL = '00000038'X
PARAMETER IO$_MOUNT = '00000039'X
PARAMETER IO$_TTYREADALL = '0000003A'X
PARAMETER IO$_TTYREADPALL = '0000003B'X
PARAMETER IO$_CONINTREAD = '0000003C'X
PARAMETER IO$_CONINTWRITE = '0000003D'X
PARAMETER IO$M_FCODE = '0000003F'X
PARAMETER IO$_VIRTUAL = '0000003F'X
PARAMETER IO$M_ACCESS = '00000040'X
PARAMETER IO$M_TYPEAHDCNT = '00000040'X
PARAMETER IO$M_INTERRUPT = '00000040'X
PARAMETER IO$M_SETEVF = '00000040'X
PARAMETER IO$M_BINARY = '00000040'X
PARAMETER IO$M_NOECHO = '00000040'X
PARAMETER IO$M_STARTUP = '00000040'X
PARAMETER IO$M_NOW = '00000040'X
PARAMETER IO$M_DELDATA = '00000040'X
PARAMETER IO$M_COMMOD = '00000040'X
PARAMETER IO$M_REVERSE = '00000040'X
PARAMETER IO$M_CANCTRLO = '00000040'X
PARAMETER IO$M_WORD = '00000040'X
PARAMETER IO$M_MOVETRACKD = '00000080'X
PARAMETER IO$M_ENABLMBX = '00000080'X
PARAMETER IO$M_CTRLYAST = '00000080'X
PARAMETER IO$M_TIMED = '00000080'X
PARAMETER IO$M_PACKED = '00000080'X
PARAMETER IO$M_SHUTDOWN = '00000080'X
PARAMETER IO$M_NOWAIT = '00000080'X
PARAMETER IO$M_CREATE = '00000080'X
PARAMETER IO$M_READATTN = '00000080'X
PARAMETER IO$M_RESET = '00000080'X
PARAMETER IO$M_ATTNAST = '00000100'X
PARAMETER IO$M_DELETE = '00000100'X
PARAMETER IO$M_CTRLCAST = '00000100'X
PARAMETER IO$M_WRTATTN = '00000100'X
PARAMETER IO$M_CVTLOW = '00000100'X
PARAMETER IO$M_ABORT = '00000100'X
PARAMETER IO$M_DIAGNOSTIC = '00000100'X
PARAMETER IO$M_INTSKIP = '00000100'X
PARAMETER IO$M_NOFORMAT = '00000100'X
PARAMETER IO$M_OPPOSITE = '00000200'X
PARAMETER IO$M_SETFNCT = '00000200'X
PARAMETER IO$M_HANGUP = '00000200'X
PARAMETER IO$M_SYNCH = '00000200'X
PARAMETER IO$M_MOUNT = '00000200'X
PARAMETER IO$M_SKPSECINH = '00000200'X
PARAMETER IO$M_NOFILTR = '00000200'X
PARAMETER IO$M_DMOUNT = '00000400'X
PARAMETER IO$M_DSABLMBX = '00000400'X
PARAMETER IO$M_DATAPATH = '00000400'X
PARAMETER IO$M_CECYL = '00000400'X
PARAMETER IO$M_SWAP = '00000400'X
PARAMETER IO$M_INHERLOG = '00000800'X
PARAMETER IO$M_PURGE = '00000800'X
PARAMETER IO$M_INHSEEK = '00001000'X
PARAMETER IO$M_INHEXTGAP = '00001000'X
PARAMETER IO$M_CYCLE = '00001000'X
PARAMETER IO$M_TRMNOECHO = '00001000'X
PARAMETER IO$M_REFRESH = '00002000'X
PARAMETER IO$M_DATACHECK = '00004000'X
PARAMETER IO$M_INHRETRY = '00008000'X

9
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/lognames.com Normal file
View File

@@ -0,0 +1,9 @@
$!
$! LOGNAMES.COM
$!
$! Command file to assign system-dependent logical names.
$!
$! 04FEB82 Alex Hunter 1. Original version.
$!
$ASSIGN DISK1:[AFH.VAXLIB.PLMRUN] PLM$UDI ! UDI library directory.
$!

19
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/maketape.com Normal file
View File

@@ -0,0 +1,19 @@
$SET VERIFY
$! MAKETAPE.COM
$!
$!
$! Command file to generate the build-it-from-source kit
$! for the PL/M-VAX runtime library (including the UDI
$! routines).
$!
$! 05FEB82 Alex Hunter 1. Original version.
$! 06APR82 Alex Hunter 1. Allocate MTA0 instead of MT.
$!
$ALLOCATE MTA0 TAPE
$INIT/DENSITY=1600 TAPE PLMUDI
$MOUNT TAPE PLMUDI
$COPY/LOG *.* TAPE
$DIR/SIZ/DAT TAPE
$DISMOUNT TAPE
$DEALLOCATE TAPE
$SET NOVERIFY

39
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/move.mar Normal file
View File

@@ -0,0 +1,39 @@
.TITLE MOVE. PLM RUNTIME LIBRARY: MOVE.
;-----------------------------------------------------------------------
;
; D I S C L A I M E R N O T I C E
; ------------------- -----------
;
; This document and/or portions of the material and data furnished
; herewith, was developed under sponsorship of the U. S. Government.
; Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior
; University, nor their employees, nor their respective contractors,
; subcontractors, or their employees, makes any warranty, express or
; implied, or assumes any liability or responsibility for accuracy,
; completeness or usefulness of any information, apparatus, product
; or process disclosed, or represents that its use will not infringe
; privately-owned rights. Mention of any product, its manufacturer,
; or suppliers shall not, nor is it intended to, imply approval, dis-
; approval, or fitness for any particular use. The U. S. and the
; University at all times retain the right to use and disseminate same
; for any purpose whatsoever. Such distribution shall be made by the
; National Energy Software Center at the Argonne National Laboratory
; and only subject to the distributee furnishing satisfactory proof
; that he has a valid license from the Intel Corporation in effect.
;
;-----------------------------------------------------------------------
.PSECT PLMRUN_CODE,RD,NOWRT,EXE,GBL,CON,LONG
;
; CALL MOVE(COUNT,SOURCE,DESTINATION)
;
COUNT=4 ; WORD.
SOURCE=8 ; POINTER.
DESTINATION=12 ; POINTER.
PLM$MOVE::
.ENTRY MOVE.,^M<R2,R3,R4,R5>
MOVC3 COUNT(AP),@SOURCE(AP),@DESTINATION(AP)
RET
.END

106
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/moves.mar Normal file
View File

@@ -0,0 +1,106 @@
.TITLE MOVES. PLM RUNTIME LIBRARY: MOVB. ET AL.
;-----------------------------------------------------------------------
;
; D I S C L A I M E R N O T I C E
; ------------------- -----------
;
; This document and/or portions of the material and data furnished
; herewith, was developed under sponsorship of the U. S. Government.
; Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior
; University, nor their employees, nor their respective contractors,
; subcontractors, or their employees, makes any warranty, express or
; implied, or assumes any liability or responsibility for accuracy,
; completeness or usefulness of any information, apparatus, product
; or process disclosed, or represents that its use will not infringe
; privately-owned rights. Mention of any product, its manufacturer,
; or suppliers shall not, nor is it intended to, imply approval, dis-
; approval, or fitness for any particular use. The U. S. and the
; University at all times retain the right to use and disseminate same
; for any purpose whatsoever. Such distribution shall be made by the
; National Energy Software Center at the Argonne National Laboratory
; and only subject to the distributee furnishing satisfactory proof
; that he has a valid license from the Intel Corporation in effect.
;
;-----------------------------------------------------------------------
.PSECT PLMRUN_CODE,RD,NOWRT,EXE,GBL,CON,LONG
;
; CALL MOVB(SOURCE,DESTINATION,COUNT)
;
SOURCE=4 ; POINTER.
DESTINATION=8 ; POINTER.
COUNT=12 ; WORD.
.ENTRY MOVB.,^M<R2,R3,R4,R5>
CMPL SOURCE(AP),DESTINATION(AP)
BLEQU 1$
;
; NO OVERLAP POSSIBLE.
;
MOVC3 COUNT(AP),@SOURCE(AP),@DESTINATION(AP)
RET
;
; OVERLAP POSSIBLE.
;
1$: MOVZWL COUNT(AP),R0
BEQL 3$
MOVL SOURCE(AP),R1
MOVL DESTINATION(AP),R3
2$: MOVB (R1)+,(R3)+
SOBGTR R0,2$
3$: RET
;
; CALL MOVRB(SOURCE,DESTINATION,COUNT)
;
.ENTRY MOVRB.,^M<R2,R3,R4,R5>
CMPL SOURCE(AP),DESTINATION(AP)
BGEQU 1$
;
; NO OVERLAP POSSIBLE.
;
MOVC3 COUNT(AP),@SOURCE(AP),@DESTINATION(AP)
RET
;
; OVERLAP POSSIBLE.
;
1$: MOVZWL COUNT(AP),R0
BEQL 3$
ADDL3 R0,SOURCE(AP),R1
ADDL3 R0,DESTINATION(AP),R3
2$: MOVB -(R1),-(R3)
SOBGTR R0,2$
3$: RET
;
; CALL MOVW(SOURCE,DESTINATION,COUNT)
;
.ENTRY MOVW.,^M<R3>
MOVZWL COUNT(AP),R0
BEQL 3$
MOVL SOURCE(AP),R1
MOVL DESTINATION(AP),R3
2$: MOVW (R1)+,(R3)+
SOBGTR R0,2$
3$: RET
;
; CALL MOVRW(SOURCE,DESTINATION,COUNT)
;
.ENTRY MOVRW.,^M<R3>
MOVZWL COUNT(AP),R0
BEQL 3$
ADDL3 R0,SOURCE(AP),R1
ADDL2 R0,R1
ADDL3 R0,DESTINATION(AP),R3
ADDL2 R0,R3
2$: MOVW -(R1),-(R3)
SOBGTR R0,2$
3$: RET
.END

38
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/open.plm Normal file
View File

@@ -0,0 +1,38 @@
$TITLE ('DQ$OPEN to XQ_OPEN Interface Routine.')
$LARGE
/*************************************************************************/
/* */
/* D I S C L A I M E R N O T I C E */
/* ------------------- ----------- */
/* */
/* This document and/or portions of the material and data furnished */
/* herewith, was developed under sponsorship of the U. S. Government. */
/* Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior */
/* University, nor their employees, nor their respective contractors, */
/* subcontractors, or their employees, makes any warranty, express or */
/* implied, or assumes any liability or responsibility for accuracy, */
/* completeness or usefulness of any information, apparatus, product */
/* or process disclosed, or represents that its use will not infringe */
/* privately-owned rights. Mention of any product, its manufacturer, */
/* or suppliers shall not, nor is it intended to, imply approval, dis- */
/* approval, or fitness for any particular use. The U. S. and the */
/* University at all times retain the right to use and disseminate same */
/* for any purpose whatsoever. Such distribution shall be made by the */
/* National Energy Software Center at the Argonne National Laboratory */
/* and only subject to the distributee furnishing satisfactory proof */
/* that he has a valid license from the Intel Corporation in effect. */
/* */
/*************************************************************************/
DQ_OPEN: do;
XQ_OPEN: procedure (conn$p,access$p,numbuf$p,excep$p) external;
declare (conn$p,access$p,numbuf$p,excep$p) pointer;
end;
DQ$OPEN: procedure (conn,access,num$buf,excep$p) public;
declare conn word, access byte, num$buf byte, excep$p pointer;
call XQ_OPEN(@conn,@access,@num$buf,excep$p);
end;
end DQ_OPEN;

86
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/overlay.plm Normal file
View File

@@ -0,0 +1,86 @@
$TITLE ('UDI OVERLAY SYSTEM CALL')
$LARGE NOWARN
/*************************************************************************/
/* */
/* D I S C L A I M E R N O T I C E */
/* ------------------- ----------- */
/* */
/* This document and/or portions of the material and data furnished */
/* herewith, was developed under sponsorship of the U. S. Government. */
/* Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior */
/* University, nor their employees, nor their respective contractors, */
/* subcontractors, or their employees, makes any warranty, express or */
/* implied, or assumes any liability or responsibility for accuracy, */
/* completeness or usefulness of any information, apparatus, product */
/* or process disclosed, or represents that its use will not infringe */
/* privately-owned rights. Mention of any product, its manufacturer, */
/* or suppliers shall not, nor is it intended to, imply approval, dis- */
/* approval, or fitness for any particular use. The U. S. and the */
/* University at all times retain the right to use and disseminate same */
/* for any purpose whatsoever. Such distribution shall be made by the */
/* National Energy Software Center at the Argonne National Laboratory */
/* and only subject to the distributee furnishing satisfactory proof */
/* that he has a valid license from the Intel Corporation in effect. */
/* */
/*************************************************************************/
DQ_OVERLAY: do;
/*------------------------------------------------------*/
/* */
/* The function of DQ$OVERLAY in the VMS environment */
/* is to copy the local data for the specified */
/* 'overlay' down into the common data overlay area */
/* which has been reserved in the 64K DGROUP address */
/* space. */
/* */
/*------------------------------------------------------*/
$INCLUDE (PLM$UDI:EXCEPT.LIT)
declare D% byte external, /* First byte of overlay data area */
E% byte external; /* Last byte +1 */
declare %overlay(1) structure( /* Supplied by application system */
name(16) byte, /* Overlay name (string) */
start pointer, /* Address of first local data byte */
stop pointer) /* Address of last byte +1 */
external;
DQ$OVERLAY: procedure (name$p,excep$p) public;
declare (name$p,excep$p) pointer;
declare (name based name$p) (1) byte;
declare (status based excep$p) word;
declare i integer;
if name(0) > last(%overlay.name) then
do;
status=E$SYNTAX; /* Overlay name too long. */
return;
end;
i=0;
do while %overlay(i).name(0) <> 0;
if CMPB(%_pointer(name$p),@%overlay(i).name,
%overlay(i).name(0)+1) = 0FFFFH then
do;
if %overlay(i).stop-%overlay(i).start > @E%-@D% then
do;
status=E$ADDRESS; /* Overlay data area too small. */
return;
end;
call MOVE(%overlay(i).stop-%overlay(i).start,
%overlay(i).start,@D%);
status=E$OK;
return;
end;
i=i+1;
end;
status=E$EXIST; /* Overlay name not in table. */
return;
end DQ$OVERLAY;
end DQ_OVERLAY;

11
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/plmmac.bld Normal file
View File

@@ -0,0 +1,11 @@
$SET VERIFY
$!
$! PLMMAC.BLD
$!
$! Command file to build the PLMMAC.MLB macro library.
$!
$! 06FEB82 Alex Hunter 1. Original version.
$!
$LIB/CREATE/MACRO PLMMAC CONFIG
$!
$SET NOVERIFY

55
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/plmrun.bld Normal file
View File

@@ -0,0 +1,55 @@
$SET VERIFY
$!
$! PLMRUN.BLD
$!
$! Command file to build the PL/M-VAX runtime library
$! (including the UDI routines).
$!
$! 05FEB82 Alex Hunter 1. Original version.
$!
$@LOGNAMES
$!
$MAC/LIS/E=D ABS
$MAC/LIS/E=D CNTRLFLD
$MAC/LIS/E=D COMPARES
$MAC/LIS/E=D FINDS
$MAC/LIS/E=D HILO
$MAC/LIS/E=D IABS
$MAC/LIS/E=D MOVE
$MAC/LIS/E=D MOVES
$MAC/LIS/E=D RENAME
$MAC/LIS/E=D SETS
$MAC/LIS/E=D SHIFTS
$MAC/LIS/E=D SKIPS
$MAC/LIS/E=D XLAT
$!
$PLM ARGUMENT DEBUG
$PLM CHANGE DEBUG
$PLM CLOSE DEBUG
$PLM CONNSTAT DEBUG
$PLM DECODE DEBUG
$PLM DETACH DEBUG
$PLM EXIT DEBUG
$PLM GETTIME DEBUG
$PLM OPEN DEBUG
$PLM OVERLAY DEBUG
$PLM READ DEBUG
$PLM SEEK DEBUG
$PLM SPECIAL DEBUG
$PLM SYSTEMID DEBUG
$PLM TRUNCATE DEBUG
$PLM WRITE DEBUG
$!
$FOR/NOLIS/NOCHECK/DEBUG XQIO
$!
$MESS/LIS UDIMSGS
$!
$LIB/CRE PLMRUN -
ABS,CNTRLFLD,COMPARES,FINDS,HILO,IABS,MOVE,-
MOVES,RENAME,SETS,SHIFTS,SKIPS,XLAT,-
ARGUMENT,CHANGE,CLOSE,CONNSTAT,DECODE,DETACH,EXIT,-
GETTIME,OPEN,OVERLAY,READ,SEEK,SPECIAL,SYSTEMID,-
TRUNCATE,WRITE,-
XQIO,-
UDIMSGS
$SET NOVERIFY

44
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/read.me Normal file
View File

@@ -0,0 +1,44 @@
February 16, 1982
Alex Hunter
READ.ME
This directory contains the source files, include files, and
command files needed to build the PL/M-VAX runtime library
(including the UDI routines), and the configuration macro library.
The *.PLM, *.MAR, and *.FOR files are source files. The *.LIT,
*.DEF, EXCEPT.FOR, RMSDEF.FOR, IODEF.FOR, and XQCOMMON.FOR files are
include files. (RMSDEF.FOR and IODEF.FOR are copies of parameter
definition files from SYS$LIBRARY. Apparently these files are not
present in all VMS systems.)
UDIMSGS.MSG is the source file for the UDI message facility.
LOGNAMES.COM is a command file containing logical name assignments
used by other command files in this directory. LOGNAMES.COM should
be edited to reflect the directory names in use on your system.
Any command file which makes use of system-dependent logical name
assignments will contain a call to LOGNAMES.COM, so LOGNAMES.COM
should be the only command file requiring editing.
PLMRUN.BLD is a command file to build the PLMRUN.OLB library
from scratch. XQIO.BLD is a command file to rebuild just the
XQIO package.
PLMMAC.BLD is a command file to build the PLMMAC.MLB configuration
macro library from scratch.
DM.MAR is a source file used to produce the dummy (null) object file
DM.OBJ which is referenced by various *.LNK command files to satisfy
the VMS linker's need for an object file specification in the CLUSTER
command. DM.COM is a command file used to assemble DM.MAR.
VMSRTL.V23 is version 2.3 of the VMS shared runtime library. Various
*.LNK command files reference this copy (rather than the currently
installed shared library) in order to produce executable images
which will run under VMS 2.3 (and later).
MAKETAPE.COM is the command file used to write the contents of
this directory to mag tape.

42
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/read.plm Normal file
View File

@@ -0,0 +1,42 @@
$TITLE ('DQ$READ to XQ_READ Interface Routine.')
$LARGE
/*************************************************************************/
/* */
/* D I S C L A I M E R N O T I C E */
/* ------------------- ----------- */
/* */
/* This document and/or portions of the material and data furnished */
/* herewith, was developed under sponsorship of the U. S. Government. */
/* Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior */
/* University, nor their employees, nor their respective contractors, */
/* subcontractors, or their employees, makes any warranty, express or */
/* implied, or assumes any liability or responsibility for accuracy, */
/* completeness or usefulness of any information, apparatus, product */
/* or process disclosed, or represents that its use will not infringe */
/* privately-owned rights. Mention of any product, its manufacturer, */
/* or suppliers shall not, nor is it intended to, imply approval, dis- */
/* approval, or fitness for any particular use. The U. S. and the */
/* University at all times retain the right to use and disseminate same */
/* for any purpose whatsoever. Such distribution shall be made by the */
/* National Energy Software Center at the Argonne National Laboratory */
/* and only subject to the distributee furnishing satisfactory proof */
/* that he has a valid license from the Intel Corporation in effect. */
/* */
/*************************************************************************/
DQ_READ: do;
$INCLUDE (PLM$UDI:DESCRIPT.LIT)
XQ_READ: procedure (conn$p,buf$d$p,excep$p) word external;
declare (conn$p,buf$d$p,excep$p) pointer;
end;
DQ$READ: procedure (conn,buf$p,count,excep$p) word public;
declare conn word, buf$p pointer, count word, excep$p pointer;
declare buf$d descriptor initial(0,DSC$K_DTYPE_T,DSC$K_CLASS_S);
buf$d.length=count; buf$d.ptr=buf$p;
return XQ_READ(@conn,@buf$d,excep$p);
end;
end DQ_READ;

44
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/readme.md Normal file
View File

@@ -0,0 +1,44 @@
February 16, 1982
Alex Hunter
READ.ME
This directory contains the source files, include files, and
command files needed to build the PL/M-VAX runtime library
(including the UDI routines), and the configuration macro library.
The *.PLM, *.MAR, and *.FOR files are source files. The *.LIT,
*.DEF, EXCEPT.FOR, RMSDEF.FOR, IODEF.FOR, and XQCOMMON.FOR files are
include files. (RMSDEF.FOR and IODEF.FOR are copies of parameter
definition files from SYS$LIBRARY. Apparently these files are not
present in all VMS systems.)
UDIMSGS.MSG is the source file for the UDI message facility.
LOGNAMES.COM is a command file containing logical name assignments
used by other command files in this directory. LOGNAMES.COM should
be edited to reflect the directory names in use on your system.
Any command file which makes use of system-dependent logical name
assignments will contain a call to LOGNAMES.COM, so LOGNAMES.COM
should be the only command file requiring editing.
PLMRUN.BLD is a command file to build the PLMRUN.OLB library
from scratch. XQIO.BLD is a command file to rebuild just the
XQIO package.
PLMMAC.BLD is a command file to build the PLMMAC.MLB configuration
macro library from scratch.
DM.MAR is a source file used to produce the dummy (null) object file
DM.OBJ which is referenced by various *.LNK command files to satisfy
the VMS linker's need for an object file specification in the CLUSTER
command. DM.COM is a command file used to assemble DM.MAR.
VMSRTL.V23 is version 2.3 of the VMS shared runtime library. Various
*.LNK command files reference this copy (rather than the currently
installed shared library) in order to produce executable images
which will run under VMS 2.3 (and later).
MAKETAPE.COM is the command file used to write the contents of
this directory to mag tape.

57
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/rename.mar Normal file
View File

@@ -0,0 +1,57 @@
.TITLE XQ___RENAME RENAME OLD_FILE TO NEW_FILE
;-----------------------------------------------------------------------
;
; D I S C L A I M E R N O T I C E
; ------------------- -----------
;
; This document and/or portions of the material and data furnished
; herewith, was developed under sponsorship of the U. S. Government.
; Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior
; University, nor their employees, nor their respective contractors,
; subcontractors, or their employees, makes any warranty, express or
; implied, or assumes any liability or responsibility for accuracy,
; completeness or usefulness of any information, apparatus, product
; or process disclosed, or represents that its use will not infringe
; privately-owned rights. Mention of any product, its manufacturer,
; or suppliers shall not, nor is it intended to, imply approval, dis-
; approval, or fitness for any particular use. The U. S. and the
; University at all times retain the right to use and disseminate same
; for any purpose whatsoever. Such distribution shall be made by the
; National Energy Software Center at the Argonne National Laboratory
; and only subject to the distributee furnishing satisfactory proof
; that he has a valid license from the Intel Corporation in effect.
;
;-----------------------------------------------------------------------
;
;
; INTEGER*4 XQ___RENAME,STATUS
; STATUS = XQ___RENAME(OLD_FILE,NEW_FILE)
;
; WHERE OLD_FILE AND NEW_FILE ARE CHARACTER STRINGS OR EXPRESSIONS,
; AND STATUS WILL RECEIVE THE RMS RESULT CODE.
;
;-----------------------------------------------------------------------
;
; R E V I S I O N H I S T O R Y
;
;
; 03FEB82 Alex Hunter 1. Changed routine and psect names.
;
;-----------------------------------------------------------------------
.PSECT XQ_DATA,RD,WRT,NOEXE,GBL,CON,LONG
FAB.1: $FAB NAM=NAM.1
FAB.2: $FAB NAM=NAM.2
NAM.1: $NAM ESA=ESA.1,ESS=48
NAM.2: $NAM ESA=ESA.2,ESS=48
ESA.1: .BLKB 48
ESA.2: .BLKB 48
.PSECT XQ_CODE,RD,NOWRT,EXE,GBL,CON,LONG
.ENTRY XQ___RENAME,^M<R2>
MOVQ @4(AP),R1 ; GET OLD_FILE DESCRIPTOR.
$FAB_STORE FAB=FAB.1,FNS=R1,FNA=(R2)
MOVQ @8(AP),R1 ; GET NEW_FILE DESCRIPTOR.
$FAB_STORE FAB=FAB.2,FNS=R1,FNA=(R2)
$RENAME OLDFAB=FAB.1,NEWFAB=FAB.2
RET
.END

194
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/rmsdef.for Normal file
View File

@@ -0,0 +1,194 @@
PARAMETER RMS$V_STVSTATUS = '0000000E'X
PARAMETER RMS$_SUC = '00010001'X
PARAMETER RMS$_NORMAL = '00010001'X
PARAMETER RMS$_CONTROLO = '00010609'X
PARAMETER RMS$_CONTROLY = '00010611'X
PARAMETER RMS$_CREATED = '00010619'X
PARAMETER RMS$_SUPERSEDE = '00010631'X
PARAMETER RMS$_CONTROLC = '00010651'X
PARAMETER RMS$_STALL = '00018001'X
PARAMETER RMS$_PENDING = '00018009'X
PARAMETER RMS$_OK_DUP = '00018011'X
PARAMETER RMS$_OK_IDX = '00018019'X
PARAMETER RMS$_OK_RLK = '00018021'X
PARAMETER RMS$_TEMP10 = '00018029'X
PARAMETER RMS$_KFF = '00018031'X
PARAMETER RMS$_OK_ALK = '00018039'X
PARAMETER RMS$_OK_DEL = '00018041'X
PARAMETER RMS$_OK_RNF = '00018049'X
PARAMETER RMS$_OK_LIM = '00018051'X
PARAMETER RMS$_OK_NOP = '00018059'X
PARAMETER RMS$_BOF = '00018198'X
PARAMETER RMS$_RNL = '000181A0'X
PARAMETER RMS$_RTB = '000181A8'X
PARAMETER RMS$_TMO = '000181B0'X
PARAMETER RMS$_TNS = '000181B8'X
PARAMETER RMS$_BES = '000181C0'X
PARAMETER RMS$_PES = '000181C8'X
PARAMETER RMS$_ACT = '0001825A'X
PARAMETER RMS$_DEL = '00018262'X
PARAMETER RMS$_TEMP1 = '0001826A'X
PARAMETER RMS$_DNR = '00018272'X
PARAMETER RMS$_EOF = '0001827A'X
PARAMETER RMS$_FEX = '00018282'X
PARAMETER RMS$_FLK = '0001828A'X
PARAMETER RMS$_FNF = '00018292'X
PARAMETER RMS$_PRV = '0001829A'X
PARAMETER RMS$_REX = '000182A2'X
PARAMETER RMS$_RLK = '000182AA'X
PARAMETER RMS$_RNF = '000182B2'X
PARAMETER RMS$_WLK = '000182BA'X
PARAMETER RMS$_EXP = '000182C2'X
PARAMETER RMS$_NMF = '000182CA'X
PARAMETER RMS$_SUP = '000182D2'X
PARAMETER RMS$_RSA = '000182DA'X
PARAMETER RMS$_CRC = '000182E2'X
PARAMETER RMS$_WCC = '000182EA'X
PARAMETER RMS$_IDR = '000182F2'X
PARAMETER RMS$_ABO = '000183EC'X
PARAMETER RMS$_AID = '000183F4'X
PARAMETER RMS$_ALN = '000183FC'X
PARAMETER RMS$_ALQ = '00018404'X
PARAMETER RMS$_ANI = '0001840C'X
PARAMETER RMS$_AOP = '00018414'X
PARAMETER RMS$_BKS = '0001841C'X
PARAMETER RMS$_BKZ = '00018424'X
PARAMETER RMS$_BLN = '0001842C'X
PARAMETER RMS$_BUG = '00018434'X
PARAMETER RMS$_BUG_DDI = '0001843C'X
PARAMETER RMS$_BUG_DAP = '00018444'X
PARAMETER RMS$_BUG_XX2 = '0001844C'X
PARAMETER RMS$_BUG_XX3 = '00018454'X
PARAMETER RMS$_BUG_XX4 = '0001845C'X
PARAMETER RMS$_BUG_XX5 = '00018464'X
PARAMETER RMS$_BUG_XX6 = '0001846C'X
PARAMETER RMS$_BUG_XX7 = '00018474'X
PARAMETER RMS$_BUG_XX8 = '0001847C'X
PARAMETER RMS$_BUG_XX9 = '00018484'X
PARAMETER RMS$_CAA = '0001848C'X
PARAMETER RMS$_CCR = '00018494'X
PARAMETER RMS$_CHG = '0001849C'X
PARAMETER RMS$_CHK = '000184A4'X
PARAMETER RMS$_COD = '000184AC'X
PARAMETER RMS$_CUR = '000184B4'X
PARAMETER RMS$_DAN = '000184BC'X
PARAMETER RMS$_DEV = '000184C4'X
PARAMETER RMS$_DIR = '000184CC'X
PARAMETER RMS$_DME = '000184D4'X
PARAMETER RMS$_DNA = '000184DC'X
PARAMETER RMS$_DTP = '000184E4'X
PARAMETER RMS$_DUP = '000184EC'X
PARAMETER RMS$_DVI = '000184F4'X
PARAMETER RMS$_ESA = '000184FC'X
PARAMETER RMS$_ESS = '00018504'X
PARAMETER RMS$_FAB = '0001850C'X
PARAMETER RMS$_FAC = '00018514'X
PARAMETER RMS$_FLG = '0001851C'X
PARAMETER RMS$_FNA = '00018524'X
PARAMETER RMS$_FNM = '0001852C'X
PARAMETER RMS$_FSZ = '00018534'X
PARAMETER RMS$_FOP = '0001853C'X
PARAMETER RMS$_FUL = '00018544'X
PARAMETER RMS$_IAL = '0001854C'X
PARAMETER RMS$_IAN = '00018554'X
PARAMETER RMS$_IDX = '0001855C'X
PARAMETER RMS$_IFI = '00018564'X
PARAMETER RMS$_IMX = '0001856C'X
PARAMETER RMS$_IOP = '00018574'X
PARAMETER RMS$_IRC = '0001857C'X
PARAMETER RMS$_ISI = '00018584'X
PARAMETER RMS$_KBF = '0001858C'X
PARAMETER RMS$_KEY = '00018594'X
PARAMETER RMS$_KRF = '0001859C'X
PARAMETER RMS$_KSZ = '000185A4'X
PARAMETER RMS$_LAN = '000185AC'X
PARAMETER RMS$_LBL = '000185B4'X
PARAMETER RMS$_LNE = '000185BC'X
PARAMETER RMS$_LOC = '000185C4'X
PARAMETER RMS$_MRN = '000185CC'X
PARAMETER RMS$_MRS = '000185D4'X
PARAMETER RMS$_NAM = '000185DC'X
PARAMETER RMS$_NEF = '000185E4'X
PARAMETER RMS$_NID = '000185EC'X
PARAMETER RMS$_NOD = '000185F4'X
PARAMETER RMS$_NPK = '000185FC'X
PARAMETER RMS$_ORD = '00018604'X
PARAMETER RMS$_ORG = '0001860C'X
PARAMETER RMS$_PBF = '00018614'X
PARAMETER RMS$_PLG = '0001861C'X
PARAMETER RMS$_POS = '00018624'X
PARAMETER RMS$_PRM = '0001862C'X
PARAMETER RMS$_QUO = '00018634'X
PARAMETER RMS$_RAB = '0001863C'X
PARAMETER RMS$_RAC = '00018644'X
PARAMETER RMS$_RAT = '0001864C'X
PARAMETER RMS$_RBF = '00018654'X
PARAMETER RMS$_RFA = '0001865C'X
PARAMETER RMS$_RFM = '00018664'X
PARAMETER RMS$_RHB = '0001866C'X
PARAMETER RMS$_RLF = '00018674'X
PARAMETER RMS$_ROP = '0001867C'X
PARAMETER RMS$_RRV = '00018684'X
PARAMETER RMS$_RVU = '0001868C'X
PARAMETER RMS$_RSS = '00018694'X
PARAMETER RMS$_RST = '0001869C'X
PARAMETER RMS$_RSZ = '000186A4'X
PARAMETER RMS$_SEQ = '000186AC'X
PARAMETER RMS$_SHR = '000186B4'X
PARAMETER RMS$_SIZ = '000186BC'X
PARAMETER RMS$_SQO = '000186C4'X
PARAMETER RMS$_STK = '000186CC'X
PARAMETER RMS$_SYN = '000186D4'X
PARAMETER RMS$_TRE = '000186DC'X
PARAMETER RMS$_TYP = '000186E4'X
PARAMETER RMS$_UBF = '000186EC'X
PARAMETER RMS$_USZ = '000186F4'X
PARAMETER RMS$_VER = '000186FC'X
PARAMETER RMS$_VOL = '00018704'X
PARAMETER RMS$_XAB = '0001870C'X
PARAMETER RMS$_ESL = '00018714'X
PARAMETER RMS$_WSF = '0001871C'X
PARAMETER RMS$_ENV = '00018724'X
PARAMETER RMS$_PLV = '0001872C'X
PARAMETER RMS$_MBC = '00018734'X
PARAMETER RMS$_RSL = '0001873C'X
PARAMETER RMS$_WLD = '00018744'X
PARAMETER RMS$_NET = '0001874C'X
PARAMETER RMS$_IBF = '00018754'X
PARAMETER RMS$_REF = '0001875C'X
PARAMETER RMS$_IFL = '00018764'X
PARAMETER RMS$_DFL = '0001876C'X
PARAMETER RMS$_KNM = '00018774'X
PARAMETER RMS$_IBK = '0001877C'X
PARAMETER RMS$_KSI = '00018784'X
PARAMETER RMS$_LEX = '0001878C'X
PARAMETER RMS$_SEG = '00018794'X
PARAMETER RMS$_SNE = '0001879C'X
PARAMETER RMS$_SPE = '000187A4'X
PARAMETER RMS$_UPI = '000187AC'X
PARAMETER RMS$_ACS = '000187B4'X
PARAMETER RMS$_STR = '000187BC'X
PARAMETER RMS$_FTM = '000187C4'X
PARAMETER RMS$_ACC = '0001C002'X
PARAMETER RMS$_CRE = '0001C00A'X
PARAMETER RMS$_DAC = '0001C012'X
PARAMETER RMS$_ENT = '0001C01A'X
PARAMETER RMS$_EXT = '0001C022'X
PARAMETER RMS$_FND = '0001C02A'X
PARAMETER RMS$_MKD = '0001C032'X
PARAMETER RMS$_DPE = '0001C03A'X
PARAMETER RMS$_SPL = '0001C042'X
PARAMETER RMS$_DNF = '0001C04A'X
PARAMETER RMS$_ATR = '0001C0CC'X
PARAMETER RMS$_ATW = '0001C0D4'X
PARAMETER RMS$_CCF = '0001C0DC'X
PARAMETER RMS$_CDA = '0001C0E4'X
PARAMETER RMS$_CHN = '0001C0EC'X
PARAMETER RMS$_RER = '0001C0F4'X
PARAMETER RMS$_RMV = '0001C0FC'X
PARAMETER RMS$_RPL = '0001C104'X
PARAMETER RMS$_SYS = '0001C10C'X
PARAMETER RMS$_WER = '0001C114'X
PARAMETER RMS$_WPL = '0001C11C'X
PARAMETER RMS$_IFA = '0001C124'X
PARAMETER RMS$_WBE = '0001C12C'X

40
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/seek.plm Normal file
View File

@@ -0,0 +1,40 @@
$TITLE ('DQ$SEEK to XQ_SEEK Interface Routine.')
$LARGE
/*************************************************************************/
/* */
/* D I S C L A I M E R N O T I C E */
/* ------------------- ----------- */
/* */
/* This document and/or portions of the material and data furnished */
/* herewith, was developed under sponsorship of the U. S. Government. */
/* Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior */
/* University, nor their employees, nor their respective contractors, */
/* subcontractors, or their employees, makes any warranty, express or */
/* implied, or assumes any liability or responsibility for accuracy, */
/* completeness or usefulness of any information, apparatus, product */
/* or process disclosed, or represents that its use will not infringe */
/* privately-owned rights. Mention of any product, its manufacturer, */
/* or suppliers shall not, nor is it intended to, imply approval, dis- */
/* approval, or fitness for any particular use. The U. S. and the */
/* University at all times retain the right to use and disseminate same */
/* for any purpose whatsoever. Such distribution shall be made by the */
/* National Energy Software Center at the Argonne National Laboratory */
/* and only subject to the distributee furnishing satisfactory proof */
/* that he has a valid license from the Intel Corporation in effect. */
/* */
/*************************************************************************/
DQ_SEEK: do;
XQ_SEEK: procedure (conn$p,mode$p,high$offset$p,low$offset$p,excep$p)
external;
declare (conn$p,mode$p,high$offset$p,low$offset$p,excep$p) pointer;
end;
DQ$SEEK: procedure (conn,mode,high$offset,low$offset,excep$p) public;
declare conn word, mode byte, (low$offset,high$offset) word,
excep$p pointer;
call XQ_SEEK(@conn,@mode,@high$offset,@low$offset,excep$p);
end;
end DQ_SEEK;

51
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/sets.mar Normal file
View File

@@ -0,0 +1,51 @@
.TITLE SETS. PLM RUNTIME LIBRARY: SETB/SETW
;-----------------------------------------------------------------------
;
; D I S C L A I M E R N O T I C E
; ------------------- -----------
;
; This document and/or portions of the material and data furnished
; herewith, was developed under sponsorship of the U. S. Government.
; Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior
; University, nor their employees, nor their respective contractors,
; subcontractors, or their employees, makes any warranty, express or
; implied, or assumes any liability or responsibility for accuracy,
; completeness or usefulness of any information, apparatus, product
; or process disclosed, or represents that its use will not infringe
; privately-owned rights. Mention of any product, its manufacturer,
; or suppliers shall not, nor is it intended to, imply approval, dis-
; approval, or fitness for any particular use. The U. S. and the
; University at all times retain the right to use and disseminate same
; for any purpose whatsoever. Such distribution shall be made by the
; National Energy Software Center at the Argonne National Laboratory
; and only subject to the distributee furnishing satisfactory proof
; that he has a valid license from the Intel Corporation in effect.
;
;-----------------------------------------------------------------------
.PSECT PLMRUN_CODE,RD,NOWRT,EXE,GBL,CON,LONG
;
; CALL SETB(NEWVALUE,DESTINATION,COUNT)
;
NEWVALUE=4 ; BYTE (SETB) OR WORD (SETW).
DESTINATION=8 ; POINTER.
COUNT=12 ; WORD.
.ENTRY SETB.,^M<R2,R3,R4,R5>
MOVC5 #0,(R0),NEWVALUE(AP),COUNT(AP),@DESTINATION(AP)
RET
;
; CALL SETW(NEWVALUE,DESTINATION,COUNT)
;
.ENTRY SETW.,^M<R3>
MOVZWL COUNT(AP),R0
BEQL 2$
MOVL DESTINATION(AP),R1
MOVW NEWVALUE(AP),R3
1$: MOVW R3,(R1)+
SOBGTR R0,1$
2$: RET
.END

88
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/shifts.mar Normal file
View File

@@ -0,0 +1,88 @@
.TITLE SHIFTS. PLM RUNTIME LIBRARY: ROL, ET AL.
;-----------------------------------------------------------------------
;
; D I S C L A I M E R N O T I C E
; ------------------- -----------
;
; This document and/or portions of the material and data furnished
; herewith, was developed under sponsorship of the U. S. Government.
; Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior
; University, nor their employees, nor their respective contractors,
; subcontractors, or their employees, makes any warranty, express or
; implied, or assumes any liability or responsibility for accuracy,
; completeness or usefulness of any information, apparatus, product
; or process disclosed, or represents that its use will not infringe
; privately-owned rights. Mention of any product, its manufacturer,
; or suppliers shall not, nor is it intended to, imply approval, dis-
; approval, or fitness for any particular use. The U. S. and the
; University at all times retain the right to use and disseminate same
; for any purpose whatsoever. Such distribution shall be made by the
; National Energy Software Center at the Argonne National Laboratory
; and only subject to the distributee furnishing satisfactory proof
; that he has a valid license from the Intel Corporation in effect.
;
;-----------------------------------------------------------------------
.PSECT PLMRUN_CODE,RD,NOWRT,EXE,GBL,CON,LONG
;
; B = ROL(PATTERN,COUNT)
;
PATTERN=4 ; BYTE OR WORD.
COUNT=8 ; BYTE
.ENTRY ROL.,^M<>
MOVZBL PATTERN(AP),R0
MULL2 #^X01010101,R0 ; REPLICATE BYTE 4 TIMES.
ROTL COUNT(AP),R0,R0
RET
;
; B = ROR(PATTERN,COUNT)
;
.ENTRY ROR.,^M<>
MOVZBL PATTERN(AP),R0
MULL2 #^X01010101,R0 ; REPLICATE BYTE 4 TIMES.
MNEGB COUNT(AP),R1
ROTL R1,R0,R0
RET
;
; W = SHL(PATTERN,COUNT)
;
.ENTRY SHL.,^M<>
MOVZWL PATTERN(AP),R0
ASHL COUNT(AP),R0,R0
RET
;
; W = SHR(PATTERN,COUNT)
;
.ENTRY SHR.,^M<>
MOVZWL PATTERN(AP),R0
MNEGB COUNT(AP),R1
ASHL R1,R0,R0
RET
;
; I = SAL(PATTERN,COUNT)
;
.ENTRY SAL.,^M<>
CVTWL PATTERN(AP),R0
ASHL COUNT(AP),R0,R0
RET
;
; I = SAR(PATTERN,COUNT)
;
.ENTRY SAR.,^M<>
CVTWL PATTERN(AP),R0
MNEGB COUNT(AP),R1
ASHL R1,R0,R0
RET
.END

98
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/skips.mar Normal file
View File

@@ -0,0 +1,98 @@
.TITLE SKIPS. PLM RUNTIME LIBRARY: SKIPB, ET AL.
;-----------------------------------------------------------------------
;
; D I S C L A I M E R N O T I C E
; ------------------- -----------
;
; This document and/or portions of the material and data furnished
; herewith, was developed under sponsorship of the U. S. Government.
; Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior
; University, nor their employees, nor their respective contractors,
; subcontractors, or their employees, makes any warranty, express or
; implied, or assumes any liability or responsibility for accuracy,
; completeness or usefulness of any information, apparatus, product
; or process disclosed, or represents that its use will not infringe
; privately-owned rights. Mention of any product, its manufacturer,
; or suppliers shall not, nor is it intended to, imply approval, dis-
; approval, or fitness for any particular use. The U. S. and the
; University at all times retain the right to use and disseminate same
; for any purpose whatsoever. Such distribution shall be made by the
; National Energy Software Center at the Argonne National Laboratory
; and only subject to the distributee furnishing satisfactory proof
; that he has a valid license from the Intel Corporation in effect.
;
;-----------------------------------------------------------------------
.PSECT PLMRUN_CODE,RD,NOWRT,EXE,GBL,CON,LONG
;
; W = SKIPB(SOURCE,TARGET,COUNT)
;
SOURCE=4 ; POINTER.
TARGET=8 ; BYTE OR WORD.
COUNT=12 ; WORD.
SKIPB.L::
SKIPB.S::
.ENTRY SKIPB.,^M<>
SKPC TARGET(AP),COUNT(AP),@SOURCE(AP)
BNEQ 1$
DECW R0 ; ENTIRE STRING SKIPPED: RETURN 0FFFFH.
RET
1$: SUBW3 R0,COUNT(AP),R0 ; NON-MATCH FOUND: RETURN STRING INDEX.
RET
;
; W = SKIPRB(SOURCE,TARGET,COUNT)
;
SKIPRB.L::
SKIPRB.S::
.ENTRY SKIPRB.,^M<R3>
MOVZWL COUNT(AP),R0
BEQL 3$ ; ENTIRE STRING SKIPPED IF LENGTH=0.
ADDL3 R0,SOURCE(AP),R1
MOVB TARGET(AP),R3
2$: CMPB R3,-(R1)
BNEQ 3$
SOBGTR R0,2$
3$: DECW R0 ; RETURN INDEX OF LAST NON-MATCH.
RET ; (0FFFFH IF ALL MATCHED.)
;
; W = SKIPW(SOURCE,TARGET,COUNT)
;
SKIPW.L::
SKIPW.S::
.ENTRY SKIPW.,^M<R3>
MOVZWL COUNT(AP),R0
BEQL 3$ ; ENTIRE STRING SKIPPED IF LENGTH=0.
MOVL SOURCE(AP),R1
MOVW TARGET(AP),R3
2$: CMPW R3,(R1)+
BNEQ 4$
SOBGTR R0,2$
3$: DECW R0 ; ENTIRE STRING SKIPPED: RETURN 0FFFFH.
RET
4$: SUBW3 R0,COUNT(AP),R0 ; NON-MATCH FOUND: RETURN STRING INDEX.
RET
;
; W = SKIPRW(SOURCE,TARGET,COUNT)
;
SKIPRW.L::
SKIPRW.S::
.ENTRY SKIPRW.,^M<R3>
MOVZWL COUNT(AP),R0
BEQL 3$ ; ENTIRE STRING SKIPPED IF LENGTH=0.
ADDL3 R0,SOURCE(AP),R1
ADDL2 R0,R1
MOVW TARGET(AP),R3
2$: CMPW R3,-(R1)
BNEQ 3$
SOBGTR R0,2$
3$: DECW R0 ; RETURN INDEX OF LAST NON-MATCH.
RET ; (0FFFFH IF ALL MATCHED.)
.END

38
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/special.plm Normal file
View File

@@ -0,0 +1,38 @@
$TITLE ('DQ$SPECIAL to XQ_SPECIAL Interface Routine.')
$LARGE
/*************************************************************************/
/* */
/* D I S C L A I M E R N O T I C E */
/* ------------------- ----------- */
/* */
/* This document and/or portions of the material and data furnished */
/* herewith, was developed under sponsorship of the U. S. Government. */
/* Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior */
/* University, nor their employees, nor their respective contractors, */
/* subcontractors, or their employees, makes any warranty, express or */
/* implied, or assumes any liability or responsibility for accuracy, */
/* completeness or usefulness of any information, apparatus, product */
/* or process disclosed, or represents that its use will not infringe */
/* privately-owned rights. Mention of any product, its manufacturer, */
/* or suppliers shall not, nor is it intended to, imply approval, dis- */
/* approval, or fitness for any particular use. The U. S. and the */
/* University at all times retain the right to use and disseminate same */
/* for any purpose whatsoever. Such distribution shall be made by the */
/* National Energy Software Center at the Argonne National Laboratory */
/* and only subject to the distributee furnishing satisfactory proof */
/* that he has a valid license from the Intel Corporation in effect. */
/* */
/*************************************************************************/
DQ_SPECIAL: do;
XQ_SPECIAL: procedure (type$p,conn$p,excep$p) external;
declare (type$p,conn$p,excep$p) pointer;
end;
DQ$SPECIAL: procedure (type,parameter$p,excep$p) public;
declare type byte, (parameter$p,excep$p) pointer;
call XQ_SPECIAL(@type,parameter$p,excep$p);
end;
end DQ_SPECIAL;

47
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/systemid.plm Normal file
View File

@@ -0,0 +1,47 @@
$TITLE ('UDI GET SYSTEM ID')
$LARGE
/*************************************************************************/
/* */
/* D I S C L A I M E R N O T I C E */
/* ------------------- ----------- */
/* */
/* This document and/or portions of the material and data furnished */
/* herewith, was developed under sponsorship of the U. S. Government. */
/* Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior */
/* University, nor their employees, nor their respective contractors, */
/* subcontractors, or their employees, makes any warranty, express or */
/* implied, or assumes any liability or responsibility for accuracy, */
/* completeness or usefulness of any information, apparatus, product */
/* or process disclosed, or represents that its use will not infringe */
/* privately-owned rights. Mention of any product, its manufacturer, */
/* or suppliers shall not, nor is it intended to, imply approval, dis- */
/* approval, or fitness for any particular use. The U. S. and the */
/* University at all times retain the right to use and disseminate same */
/* for any purpose whatsoever. Such distribution shall be made by the */
/* National Energy Software Center at the Argonne National Laboratory */
/* and only subject to the distributee furnishing satisfactory proof */
/* that he has a valid license from the Intel Corporation in effect. */
/* */
/*************************************************************************/
DQ_SYSTEM$ID: do;
$INCLUDE (PLM$UDI:EXCEPT.LIT)
declare PTR literally 'POINTER';
declare system_id (*) byte data ('VAX/VMS');
DQ$GET$SYSTEM$ID: procedure (id$p, excep$p) public;
declare (id$p,excep$p) PTR;
declare (id based id$p) (1) byte;
declare (status based excep$p) word;
id(0)=size(system_id);
call MOVE (size(system_id), @system_id, @id(1));
status=E$OK;
end DQ$GET$SYSTEM$ID;
end DQ_SYSTEM$ID;

38
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/truncate.plm Normal file
View File

@@ -0,0 +1,38 @@
$TITLE ('DQ$TRUNCATE to XQ_TRUNCATE Interface Routine.')
$LARGE
/*************************************************************************/
/* */
/* D I S C L A I M E R N O T I C E */
/* ------------------- ----------- */
/* */
/* This document and/or portions of the material and data furnished */
/* herewith, was developed under sponsorship of the U. S. Government. */
/* Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior */
/* University, nor their employees, nor their respective contractors, */
/* subcontractors, or their employees, makes any warranty, express or */
/* implied, or assumes any liability or responsibility for accuracy, */
/* completeness or usefulness of any information, apparatus, product */
/* or process disclosed, or represents that its use will not infringe */
/* privately-owned rights. Mention of any product, its manufacturer, */
/* or suppliers shall not, nor is it intended to, imply approval, dis- */
/* approval, or fitness for any particular use. The U. S. and the */
/* University at all times retain the right to use and disseminate same */
/* for any purpose whatsoever. Such distribution shall be made by the */
/* National Energy Software Center at the Argonne National Laboratory */
/* and only subject to the distributee furnishing satisfactory proof */
/* that he has a valid license from the Intel Corporation in effect. */
/* */
/*************************************************************************/
DQ_TRUNCATE: do;
XQ_TRUNCATE: procedure (conn$p,excep$p) external;
declare (conn$p,excep$p) pointer;
end;
DQ$TRUNCATE: procedure (conn,excep$p) public;
declare conn word, excep$p pointer;
call XQ_TRUNCATE(@conn,excep$p);
end;
end DQ_TRUNCATE;

154
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/udi.def Normal file
View File

@@ -0,0 +1,154 @@
/* External declarations for UDI service routines. */
$SAVE NOLIST
/*************************************************************************/
/* */
/* D I S C L A I M E R N O T I C E */
/* ------------------- ----------- */
/* */
/* This document and/or portions of the material and data furnished */
/* herewith, was developed under sponsorship of the U. S. Government. */
/* Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior */
/* University, nor their employees, nor their respective contractors, */
/* subcontractors, or their employees, makes any warranty, express or */
/* implied, or assumes any liability or responsibility for accuracy, */
/* completeness or usefulness of any information, apparatus, product */
/* or process disclosed, or represents that its use will not infringe */
/* privately-owned rights. Mention of any product, its manufacturer, */
/* or suppliers shall not, nor is it intended to, imply approval, dis- */
/* approval, or fitness for any particular use. The U. S. and the */
/* University at all times retain the right to use and disseminate same */
/* for any purpose whatsoever. Such distribution shall be made by the */
/* National Energy Software Center at the Argonne National Laboratory */
/* and only subject to the distributee furnishing satisfactory proof */
/* that he has a valid license from the Intel Corporation in effect. */
/* */
/*-----------------------------------------------------------------------*/
/* */
/* R E V I S I O N H I S T O R Y */
/* */
/* 10JAN82 Alex Hunter 1. Added declaration for DQ$SET$DELIMITERS. */
/* */
/*************************************************************************/
DECLARE CONNECTION literally 'WORD';
DQ$ALLOCATE: PROCEDURE (size,excep$p) WORD EXTERNAL;
DECLARE size WORD, excep$p POINTER;
END;
DQ$ATTACH: PROCEDURE (path$p,excep$p) CONNECTION EXTERNAL;
DECLARE (path$p,excep$p) POINTER;
END;
DQ$CHANGE$EXTENSION: PROCEDURE (path$p,extension$p,excep$p) EXTERNAL;
DECLARE (path$p,extension$p,excep$p) POINTER;
END;
DQ$CLOSE: PROCEDURE (conn,excep$p) EXTERNAL;
DECLARE conn CONNECTION, excep$p POINTER;
END;
DQ$CREATE: PROCEDURE (path$p,excep$p) CONNECTION EXTERNAL;
DECLARE (path$p,excep$p) POINTER;
END;
DQ$DECODE$EXCEPTION: PROCEDURE (exception$code,message$p,excep$p)
EXTERNAL;
DECLARE exception$code WORD,
(message$p,excep$p) POINTER;
END;
DQ$DELETE: PROCEDURE (path$p,excep$p) EXTERNAL;
DECLARE (path$p,excep$p) POINTER;
END;
DQ$DETACH: PROCEDURE (conn,excep$p) EXTERNAL;
DECLARE conn CONNECTION, excep$p POINTER;
END;
DQ$EXIT: PROCEDURE (completion$code) EXTERNAL;
DECLARE completion$code WORD;
END;
DQ$FREE: PROCEDURE (segment,excep$p) EXTERNAL;
DECLARE segment WORD, excep$p POINTER;
END;
DQ$GET$ARGUMENT: PROCEDURE (argument$p,excep$p) BYTE EXTERNAL;
DECLARE (argument$p,excep$p) POINTER;
END;
DQ$GET$CONNECTION$STATUS: PROCEDURE (conn,info$p,excep$p) EXTERNAL;
DECLARE conn CONNECTION, (info$p,excep$p) POINTER;
END;
DQ$GET$EXCEPTION$HANDLER: PROCEDURE (handler$p,excep$p) EXTERNAL;
DECLARE (handler$p,excep$p) POINTER;
END;
DQ$GET$SIZE: PROCEDURE (segbase,excep$p) WORD EXTERNAL;
DECLARE segbase WORD, excep$p POINTER;
END;
DQ$GET$SYSTEM$ID: PROCEDURE (id$p,excep$p) EXTERNAL;
DECLARE (id$p,excep$p) POINTER;
END;
DQ$GET$TIME: PROCEDURE (dt$p,excep$p) EXTERNAL;
DECLARE (dt$p,excep$p) POINTER;
END;
DQ$OPEN: PROCEDURE (conn,access,num$buf,excep$p) EXTERNAL;
DECLARE conn CONNECTION, access BYTE, num$buf BYTE,
excep$p POINTER;
END;
DQ$OVERLAY: PROCEDURE (name$p,excep$p) EXTERNAL;
DECLARE (name$p,excep$p) POINTER;
END;
DQ$READ: PROCEDURE (conn,buf$p,count,excep$p) WORD EXTERNAL;
DECLARE conn CONNECTION, buf$p POINTER, count WORD,
excep$p POINTER;
END;
DQ$RENAME: PROCEDURE (old$p,new$p,excep$p) EXTERNAL;
DECLARE (old$p,new$p,excep$p) POINTER;
END;
DQ$SEEK: PROCEDURE (conn,mode,high$offset,low$offset,excep$p) EXTERNAL;
DECLARE conn CONNECTION, mode BYTE, low$offset WORD,
high$offset WORD, excep$p POINTER;
END;
DQ$SET$DELIMITERS: PROCEDURE (delimiter$set$p,excep$p) EXTERNAL;
DECLARE (delimiter$set$p,excep$p) POINTER;
END;
DQ$SPECIAL: PROCEDURE (type,parameter$p,excep$p) EXTERNAL;
DECLARE type BYTE, parameter$p POINTER, excep$p POINTER;
END;
DQ$SWITCH$BUFFER: PROCEDURE (buffer$p,excep$p) WORD EXTERNAL;
DECLARE (buffer$p,excep$p) POINTER;
END;
DQ$TRAP$CC: PROCEDURE (handler$p,excep$p) EXTERNAL;
DECLARE (handler$p,excep$p) POINTER;
END;
DQ$TRAP$EXCEPTION: PROCEDURE (handler$p,excep$p) EXTERNAL;
DECLARE (handler$p,excep$p) POINTER;
END;
DQ$TRUNCATE: PROCEDURE (conn,excep$p) EXTERNAL;
DECLARE conn CONNECTION, excep$p POINTER;
END;
DQ$WRITE: PROCEDURE (conn,buf$p,count,excep$p) EXTERNAL;
DECLARE conn CONNECTION, buf$p POINTER,
count WORD, excep$p POINTER;
END;
$RESTORE

39
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/udimsgs.msg Normal file
View File

@@ -0,0 +1,39 @@
.TITLE UDIMSGS Error and Warning Messages
!-----------------------------------------------------------------------
!
! D I S C L A I M E R N O T I C E
! ------------------- -----------
!
! This document and/or portions of the material and data furnished
! herewith, was developed under sponsorship of the U. S. Government.
! Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior
! University, nor their employees, nor their respective contractors,
! subcontractors, or their employees, makes any warranty, express or
! implied, or assumes any liability or responsibility for accuracy,
! completeness or usefulness of any information, apparatus, product
! or process disclosed, or represents that its use will not infringe
! privately-owned rights. Mention of any product, its manufacturer,
! or suppliers shall not, nor is it intended to, imply approval, dis-
! approval, or fitness for any particular use. The U. S. and the
! University at all times retain the right to use and disseminate same
! for any purpose whatsoever. Such distribution shall be made by the
! National Energy Software Center at the Argonne National Laboratory
! and only subject to the distributee furnishing satisfactory proof
! that he has a valid license from the Intel Corporation in effect.
!
!-----------------------------------------------------------------------
.FACILITY UDI,132
OK <Successful completion>/SUCCESS
WARNINGS <Warnings were issued>/WARNING
ERRORS <Errors were detected>/ERROR
FATAL <Fatal errors detected>/FATAL
ABORT <Execution aborted>/SEVERE
.BASE 101
BADINDSYN <Bad syntax for indirect command line file>/SEVERE
INDNOTLAS <Indirect command line file spec must be last>/SEVERE
BADINDFIL <Unable to read indirect command line file>/SEVERE
INDTOOBIG <Indirect command file is too long>/SEVERE
.END

42
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/write.plm Normal file
View File

@@ -0,0 +1,42 @@
$TITLE ('DQ$WRITE to XQ_WRITE Interface Routine.')
$LARGE
/*************************************************************************/
/* */
/* D I S C L A I M E R N O T I C E */
/* ------------------- ----------- */
/* */
/* This document and/or portions of the material and data furnished */
/* herewith, was developed under sponsorship of the U. S. Government. */
/* Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior */
/* University, nor their employees, nor their respective contractors, */
/* subcontractors, or their employees, makes any warranty, express or */
/* implied, or assumes any liability or responsibility for accuracy, */
/* completeness or usefulness of any information, apparatus, product */
/* or process disclosed, or represents that its use will not infringe */
/* privately-owned rights. Mention of any product, its manufacturer, */
/* or suppliers shall not, nor is it intended to, imply approval, dis- */
/* approval, or fitness for any particular use. The U. S. and the */
/* University at all times retain the right to use and disseminate same */
/* for any purpose whatsoever. Such distribution shall be made by the */
/* National Energy Software Center at the Argonne National Laboratory */
/* and only subject to the distributee furnishing satisfactory proof */
/* that he has a valid license from the Intel Corporation in effect. */
/* */
/*************************************************************************/
DQ_WRITE: do;
$INCLUDE (PLM$UDI:DESCRIPT.LIT)
XQ_WRITE: procedure (conn$p,buf$d$p,excep$p) external;
declare (conn$p,buf$d$p,excep$p) pointer;
end;
DQ$WRITE: procedure (conn,buf$p,count,excep$p) public;
declare conn word, buf$p pointer, count word, excep$p pointer;
declare buf$d descriptor initial(0,DSC$K_DTYPE_T,DSC$K_CLASS_S);
buf$d.length=count; buf$d.ptr=buf$p;
call XQ_WRITE(@conn,@buf$d,excep$p);
end;
end DQ_WRITE;

42
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/xlat.mar Normal file
View File

@@ -0,0 +1,42 @@
.TITLE XLAT. PLM RUNTIME LIBRARY: XLAT.
;-----------------------------------------------------------------------
;
; D I S C L A I M E R N O T I C E
; ------------------- -----------
;
; This document and/or portions of the material and data furnished
; herewith, was developed under sponsorship of the U. S. Government.
; Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior
; University, nor their employees, nor their respective contractors,
; subcontractors, or their employees, makes any warranty, express or
; implied, or assumes any liability or responsibility for accuracy,
; completeness or usefulness of any information, apparatus, product
; or process disclosed, or represents that its use will not infringe
; privately-owned rights. Mention of any product, its manufacturer,
; or suppliers shall not, nor is it intended to, imply approval, dis-
; approval, or fitness for any particular use. The U. S. and the
; University at all times retain the right to use and disseminate same
; for any purpose whatsoever. Such distribution shall be made by the
; National Energy Software Center at the Argonne National Laboratory
; and only subject to the distributee furnishing satisfactory proof
; that he has a valid license from the Intel Corporation in effect.
;
;-----------------------------------------------------------------------
.PSECT PLMRUN_CODE,RD,NOWRT,EXE,GBL,CON,LONG
;
; CALL XLAT(SOURCE,DESTINATION,COUNT,TABLE)
;
SOURCE=4 ; POINTER.
DESTINATION=8 ; POINTER.
COUNT=12 ; WORD (UNSIGNED).
TABLE=16 ; POINTER.
XLAT.S::
XLAT.L::
.ENTRY XLAT.,^M<R2,R3,R4,R5>
MOVTC COUNT(AP),@SOURCE(AP),#0,@TABLE(AP),COUNT(AP),-
@DESTINATION(AP)
RET
.END

102
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/xqcommon.for Normal file
View File

@@ -0,0 +1,102 @@
C***********************************************************************
C
C XQCOMMON.FOR
C
C
C D I S C L A I M E R N O T I C E
C ------------------- -----------
C
C This document and/or portions of the material and data furnished
C herewith, was developed under sponsorship of the U. S. Government.
C Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior
C University, nor their employees, nor their respective contractors,
C subcontractors, or their employees, makes any warranty, express or
C implied, or assumes any liability or responsibility for accuracy,
C completeness or usefulness of any information, apparatus, product
C or process disclosed, or represents that its use will not infringe
C privately-owned rights. Mention of any product, its manufacturer,
C or suppliers shall not, nor is it intended to, imply approval, dis-
C approval, or fitness for any particular use. The U. S. and the
C University at all times retain the right to use and disseminate same
C for any purpose whatsoever. Such distribution shall be made by the
C National Energy Software Center at the Argonne National Laboratory
C and only subject to the distributee furnishing satisfactory proof
C that he has a valid license from the Intel Corporation in effect.
C
C-----------------------------------------------------------------------
C
C This include-file contains global definitions for XQIO.FOR,
C which consists of UDI-to-VMS I/O interface routines for the
C PL/M-VAX runtime library.
C
C-----------------------------------------------------------------------
C
C R E V I S I O N H I S T O R Y
C
C 14OCT81 Alex Hunter 1. Added disclaimer notice.
C 12JAN82 Alex Hunter 1. Allocate core dynamically.
C 03FEB82 Alex Hunter 1. Change name of common blocks.
C
C***********************************************************************
IMPLICIT INTEGER*2 (A-Z)
PARAMETER CONN_MIN=20,CONN_MAX=31 ! 12 connections max.
PARAMETER CHUNK_SIZE=8192 ! Core file basic allocation
! unit in bytes (should be a
! multiple of 512).
PARAMETER MAX_CHUNKS=1000 ! Max chunks per core file.
PARAMETER MAX_CORE_FILE_SIZE = CHUNK_SIZE * MAX_CHUNKS
PARAMETER OUTPUT_RECL=510 ! 1 block - 2 control bytes.
PARAMETER MAX_INPUT=512 ! Max bytes expected on input.
PARAMETER CR='0D'X,LF='0A'X
CHARACTER*45 FILENAME(CONN_MIN:CONN_MAX)
CHARACTER*2 CRLF
CHARACTER*1 XCR,XLF
EQUIVALENCE (XCR,CRLF(1:1)),(XLF,CRLF(2:2))
COMMON /XQ_CHARS/ CRLF,FILENAME
DATA XCR,XLF/CR,LF/
INTEGER*4 CHUNK_ADDRESS(0:MAX_CHUNKS-1,CONN_MIN:CONN_MAX)
BYTE TEMPORARY_BUFFER(MAX_INPUT)
COMMON /XQ_CORE/ CHUNK_ADDRESS,TEMPORARY_BUFFER
PARAMETER CHUNK_ADDRESS_DIMS = MAX_CHUNKS*(CONN_MIN-CONN_MAX+1)
!!!! DATA CHUNK_ADDRESS /12000*0/
!!!! Note: by letting the linker create demand-zero pages for
!!!! the chunk address table (instead of explicitly initializing
!!!! the table to zeroes), we save almost 100 blocks in the
!!!! image file. (But make sure the DATA statement gets re-instated
!!!! if you use this code on some other system!)
BYTE STATE(CONN_MIN:CONN_MAX)
PARAMETER STATE_UNATTACHED=0,STATE_ATTACHED=1,STATE_OPEN=2
INTEGER*4 MARKER(CONN_MIN:CONN_MAX),LENGTH(CONN_MIN:CONN_MAX)
INTEGER*2 ACCESS_RIGHTS(CONN_MIN:CONN_MAX)
PARAMETER AR_DELETE=1,AR_READ=2,AR_WRITE=4,AR_UPDATE=8
INTEGER*2 SEEK_CAPABILITY(CONN_MIN:CONN_MAX)
PARAMETER SC_FORWARD=1,SC_BACKWARD=2
BYTE ACCESS_MODE(CONN_MIN:CONN_MAX)
PARAMETER AM_READ=1,AM_WRITE=2,AM_UPDATE=3
BYTE TYPE(CONN_MIN:CONN_MAX)
PARAMETER NORMAL=0,WORK_FILE=1,INTERACTIVE=2,BYTE_BUCKET=3
LOGICAL*1 MODIFIED(CONN_MIN:CONN_MAX)
BYTE SPECIAL_MODE(CONN_MIN:CONN_MAX)
PARAMETER TRANSPARENT=1,LINE_EDITED=2,TRANSPARENT_NOWAIT=3
LOGICAL*4 TT_CHANNEL_ASSIGNED
INTEGER*2 TT_CHANNEL
COMMON /XQ_COMMON/ TT_CHANNEL_ASSIGNED,
# MARKER,LENGTH,ACCESS_RIGHTS,SEEK_CAPABILITY,
# TT_CHANNEL,ACCESS_MODE,TYPE,MODIFIED,STATE,
# SPECIAL_MODE
DATA TT_CHANNEL_ASSIGNED/.FALSE./

10
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/xqio.bld Normal file
View File

@@ -0,0 +1,10 @@
$SET VERIFY
$!
$! Command file to build the XQIO package and insert the
$! object into the PLMRUN library.
$!
$@LOGNAMES
$!
$FOR/NOLIS/DEB/NOCHECK XQIO
$LIB PLMRUN XQIO
$SET NOVERIFY

945
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/xqio.for Normal file
View File

@@ -0,0 +1,945 @@
C***********************************************************************
C
C XQIO.FOR
C
C
C D I S C L A I M E R N O T I C E
C ------------------- -----------
C
C This document and/or portions of the material and data furnished
C herewith, was developed under sponsorship of the U. S. Government.
C Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior
C University, nor their employees, nor their respective contractors,
C subcontractors, or their employees, makes any warranty, express or
C implied, or assumes any liability or responsibility for accuracy,
C completeness or usefulness of any information, apparatus, product
C or process disclosed, or represents that its use will not infringe
C privately-owned rights. Mention of any product, its manufacturer,
C or suppliers shall not, nor is it intended to, imply approval, dis-
C approval, or fitness for any particular use. The U. S. and the
C University at all times retain the right to use and disseminate same
C for any purpose whatsoever. Such distribution shall be made by the
C National Energy Software Center at the Argonne National Laboratory
C and only subject to the distributee furnishing satisfactory proof
C that he has a valid license from the Intel Corporation in effect.
C
C-----------------------------------------------------------------------
C
C XQIO -- UDI I/O PACKAGE FOR VAX/VMS UTILIZING THE
C "CORE FILE" CONCEPT.
C
C-----------------------------------------------------------------------
C
C H001 20MAY81 ALEX HUNTER 1. WRITTEN.
C H002 09JUN81 ALEX HUNTER 1. IMPLEMENTED DQ$SPECIAL.
C H003 10JUN81 ALEX HUNTER 1. DQ$EXIT CALLS LIB$STOP.
C H004 08JAN82 ALEX HUNTER 1. TREAT 'LIST:...' AS INTER-
C ACTIVE (NON-CORE FILE) ON
C OUTPUT.
C H005 12JAN82 Alex Hunter 1. Allocate core dynamically.
C H006 31JAN82 Alex Hunter 1. Add indirect command file completion
C codes to DQ$EXIT.
C 2. Handle EOF on :CI:.
C H007 03FEB82 Alex Hunter 1. Change routine names.
C H008 06FEB82 Alex Hunter 1. Use local copies of RMSDEF.FOR and
C IODEF.FOR include files.
C
C-----------------------------------------------------------------------
INTEGER*2 FUNCTION DQATTACH (PATH,STATUS)
INCLUDE 'XQCOMMON.FOR/NOLIST'
INCLUDE 'EXCEPT.FOR/NOLIST'
BYTE PATH(*)
INTEGER*2 STATUS
INTEGER*4 N
INTEGER*4 DESCRIPTOR(2)
DATA DESCRIPTOR /1,0/
CHARACTER*45 XQ___PATH,FULLY_QUALIFIED_NAME
LOGICAL*4 FILE_EXISTS,EOF,XQ___READ,XQ___ENSURE_ALLOCATED
CHARACTER*10 CC
DQATTACH=0
DO CONN=CONN_MIN,CONN_MAX
IF (STATE(CONN).EQ.STATE_UNATTACHED) GO TO 100
ENDDO
STATUS=E$CONTEXT
RETURN
100 FILENAME(CONN)=XQ___PATH(PATH,STATUS)
IF (STATUS.NE.E$OK) RETURN
LENGTH(CONN)=0
MARKER(CONN)=0
IF (FILENAME(CONN)(1:3).EQ.'BB:') THEN
TYPE(CONN)=BYTE_BUCKET
ACCESS_RIGHTS(CONN)=AR_READ+AR_WRITE+AR_UPDATE
SEEK_CAPABILITY(CONN)=SC_FORWARD+SC_BACKWARD
ELSE
INQUIRE (FILE=FILENAME(CONN),NAME=FULLY_QUALIFIED_NAME,
# EXIST=FILE_EXISTS,CARRIAGECONTROL=CC,ERR=900)
IF (.NOT.FILE_EXISTS) THEN
STATUS=E$FNEXIST
RETURN
ENDIF
OPEN (UNIT=CONN,FILE=FILENAME(CONN),STATUS='OLD',
# ACCESS='SEQUENTIAL',READONLY,ERR=910)
IF (FILENAME(CONN)(1:3).EQ.'CI:' .OR.
# FULLY_QUALIFIED_NAME(1:3).EQ.'_TT' .OR.
# FULLY_QUALIFIED_NAME.EQ.'SYS$INPUT:' .OR.
# FULLY_QUALIFIED_NAME.EQ.'SYS$COMMAND:') THEN
TYPE(CONN)=INTERACTIVE
ACCESS_RIGHTS(CONN)=AR_READ
SEEK_CAPABILITY(CONN)=0
SPECIAL_MODE(CONN)=LINE_EDITED
ELSE
TYPE(CONN)=NORMAL
ACCESS_RIGHTS(CONN)=AR_DELETE+AR_READ+AR_WRITE+AR_UPDATE
SEEK_CAPABILITY(CONN)=SC_FORWARD+SC_BACKWARD
DO WHILE (.TRUE.)
! Ensure room for max size record + CRLF.
IF (.NOT.XQ___ENSURE_ALLOCATED(CONN,
# LENGTH(CONN)+MAX_INPUT+1))
# THEN
STATUS=E$MEM ! Can't get core.
CLOSE (UNIT=CONN)
RETURN
ENDIF
IF (LENGTH(CONN)/CHUNK_SIZE.EQ.
# (LENGTH(CONN)+MAX_INPUT-1)/CHUNK_SIZE)
# THEN
! Record is guaranteed to fit in current chunk.
DESCRIPTOR(2) =
# CHUNK_ADDRESS(LENGTH(CONN)/CHUNK_SIZE,CONN) +
# MOD(LENGTH(CONN),CHUNK_SIZE)
EOF=XQ___READ(CONN,DESCRIPTOR,N)
ELSE
! Record might cross chunk boundary, so read it
! into a temporary buffer and then copy it to the
! core file.
EOF=XQ___READ(CONN,%DESCR(TEMPORARY_BUFFER),N)
CALL XQ___MOVE_TO_FILE (CONN,TEMPORARY_BUFFER,
# LENGTH(CONN),N)
ENDIF
IF (EOF) GO TO 200
LENGTH(CONN)=LENGTH(CONN)+N
IF (CC.NE.'NONE') THEN
CALL XQ___MOVE_TO_FILE(CONN,%REF(CRLF),LENGTH(CONN),2)
LENGTH(CONN)=LENGTH(CONN)+2
ENDIF
ENDDO
200 CLOSE (UNIT=CONN)
ENDIF
ENDIF
MODIFIED(CONN)=.FALSE.
STATE(CONN)=STATE_ATTACHED
STATUS=E$OK
DQATTACH = CONN
RETURN
900 CONTINUE
910 CONTINUE
STATUS=E$FACCESS
RETURN
END
C-----------------------------------------------------------------------
LOGICAL*4 FUNCTION XQ___READ (CONN,BUFFER,N)
INCLUDE 'XQCOMMON.FOR/NOLIST'
CHARACTER*1 BUFFER
INTEGER*4 N
READ(CONN,1000,END=200) N,BUFFER(1:N)
1000 FORMAT(Q,A)
XQ___READ=.FALSE.
RETURN
200 XQ___READ=.TRUE.
N=0
RETURN
END
C-----------------------------------------------------------------------
INTEGER*2 FUNCTION DQCREATE (PATH,STATUS)
INCLUDE 'XQCOMMON.FOR/NOLIST'
INCLUDE 'EXCEPT.FOR/NOLIST'
BYTE PATH(*)
INTEGER*2 STATUS
CHARACTER*45 XQ___PATH,FULLY_QUALIFIED_NAME
LOGICAL*4 FILE_EXISTS
DQCREATE = 0
DO CONN=CONN_MIN,CONN_MAX
IF (STATE(CONN).EQ.STATE_UNATTACHED) GO TO 100
ENDDO
STATUS=E$CONTEXT
RETURN
100 FILENAME(CONN)=XQ___PATH(PATH,STATUS)
IF (STATUS.NE.E$OK) RETURN
IF (FILENAME(CONN)(1:5).EQ.'WORK:') THEN
TYPE(CONN)=WORK_FILE
ACCESS_RIGHTS(CONN)=AR_READ+AR_WRITE+AR_UPDATE
SEEK_CAPABILITY(CONN)=SC_FORWARD+SC_BACKWARD
ELSEIF (FILENAME(CONN)(1:3).EQ.'BB:') THEN
TYPE(CONN)=BYTE_BUCKET
ACCESS_RIGHTS(CONN)=AR_READ+AR_WRITE+AR_UPDATE
SEEK_CAPABILITY(CONN)=SC_FORWARD+SC_BACKWARD
ELSE
INQUIRE (FILE=FILENAME(CONN),NAME=FULLY_QUALIFIED_NAME,
# EXIST=FILE_EXISTS,ERR=900)
IF (FILENAME(CONN)(1:3).EQ.'CO:' .OR.
# FILENAME(CONN)(1:5).EQ.'LIST:' .OR.
# FULLY_QUALIFIED_NAME(1:3).EQ.'_TT' .OR.
# FULLY_QUALIFIED_NAME.EQ.'SYS$OUTPUT:' .OR.
# FULLY_QUALIFIED_NAME.EQ.'SYS$ERROR:') THEN
TYPE(CONN)=INTERACTIVE
ACCESS_RIGHTS(CONN)=AR_WRITE
SEEK_CAPABILITY(CONN)=0
SPECIAL_MODE(CONN)=LINE_EDITED
OPEN (UNIT=CONN,FILE=FILENAME(CONN),STATUS='UNKNOWN',
# ERR=900)
ELSE
TYPE(CONN)=NORMAL
ACCESS_RIGHTS(CONN)=AR_DELETE+AR_READ+AR_WRITE+AR_UPDATE
SEEK_CAPABILITY(CONN)=SC_FORWARD+SC_BACKWARD
ENDIF
ENDIF
LENGTH(CONN)=0
MARKER(CONN)=0
MODIFIED(CONN)=.FALSE.
STATE(CONN)=STATE_ATTACHED
STATUS=E$OK
DQCREATE=CONN
RETURN
900 STATUS=E$FACCESS
RETURN
END
C-----------------------------------------------------------------------
CHARACTER*45 FUNCTION XQ___PATH (PATH,STATUS)
IMPLICIT INTEGER*2 (A-Z)
INCLUDE 'EXCEPT.FOR/NOLIST'
BYTE PATH(*)
INTEGER*2 STATUS
XQ___PATH=' '
N=PATH(1)
IF (N.LE.0 .OR. N.GT.45) THEN
STATUS=E$SYNTAX
RETURN
ENDIF
DO I=1,N
XQ___PATH(I:I)=CHAR(PATH(I+1))
ENDDO
IF (XQ___PATH(1:1).EQ.':') XQ___PATH=XQ___PATH(2:)
STATUS=E$OK
RETURN
END
C-----------------------------------------------------------------------
SUBROUTINE DQDELETE (PATH,STATUS)
INCLUDE 'XQCOMMON.FOR/NOLIST'
INCLUDE 'EXCEPT.FOR/NOLIST'
BYTE PATH(*)
INTEGER*2 STATUS
CHARACTER*45 XQ___PATH,FILE
FILE=XQ___PATH(PATH,STATUS)
IF (STATUS.NE.E$OK) RETURN
OPEN (UNIT=99,FILE=FILE,STATUS='OLD',ERR=900)
CLOSE (UNIT=99,DISP='DELETE',ERR=950)
STATUS=E$OK
RETURN
900 STATUS=E$FNEXIST
RETURN
950 STATUS=E$FACCESS
RETURN
END
C-----------------------------------------------------------------------
SUBROUTINE DQRENAME (OLD,NEW,STATUS)
INCLUDE 'XQCOMMON.FOR/NOLIST'
INCLUDE 'EXCEPT.FOR/NOLIST'
INCLUDE 'RMSDEF.FOR/NOLIST'
BYTE OLD(*), NEW(*)
INTEGER*2 STATUS
INTEGER*4 XQ___RENAME,IRMS
CHARACTER*45 XQ___PATH,OLD_FILE,NEW_FILE
INTEGER*4 RMSCODE(10)
DATA RMSCODE
//RMS$_SUC,RMS$_DEV,RMS$_DIR,RMS$_FEX,RMS$_FNF,RMS$_FNM
,,RMS$_IDR,RMS$_PRV,RMS$_SUP,RMS$_SYN
//
INTEGER*2 UDICODE(10)
DATA UDICODE
//E$OK,E$SUPPORT,E$SYNTAX,E$FEXIST,E$FNEXIST,E$SYNTAX
,,E$CROSSFS,E$FACCESS,E$SUPPORT,E$SYNTAX
//
OLD_FILE=XQ___PATH(OLD,STATUS)
IF (STATUS.NE.E$OK) RETURN
NEW_FILE=XQ___PATH(NEW,STATUS)
IF (STATUS.NE.E$OK) RETURN
IRMS=XQ___RENAME(OLD_FILE,NEW_FILE)
DO I=1,10
IF (IRMS.EQ.RMSCODE(I)) THEN
STATUS=UDICODE(I)
RETURN
ENDIF
ENDDO
CALL LIB$SIGNAL(%VAL(IRMS))
STATUS=E$FACCESS ! For lack of anything better.
RETURN
END
C-----------------------------------------------------------------------
SUBROUTINE XQ_DETACH (CONN,STATUS)
INCLUDE 'XQCOMMON.FOR/NOLIST'
INCLUDE 'EXCEPT.FOR/NOLIST'
INTEGER*2 CONN,STATUS
INTEGER*4 I,N
INTEGER*4 DESCRIPTOR(2)
DATA DESCRIPTOR /1,0/
IF (CONN.LT.CONN_MIN .OR. CONN.GT.CONN_MAX) THEN
STATUS=E$PARAM
RETURN
ELSEIF (STATE(CONN).EQ.STATE_UNATTACHED) THEN
STATUS=E$EXIST
RETURN
ENDIF
IF (STATE(CONN).EQ.STATE_OPEN) CALL XQ_CLOSE(CONN,STATUS)
STATE(CONN)=STATE_UNATTACHED
IF (TYPE(CONN).EQ.NORMAL) THEN
IF (MODIFIED(CONN)) THEN
OPEN (UNIT=CONN,FILE=FILENAME(CONN),STATUS='NEW',
# FORM='FORMATTED',CARRIAGECONTROL='NONE',
# ORGANIZATION='SEQUENTIAL',RECL=OUTPUT_RECL,
# RECORDTYPE='VARIABLE',ERR=900)
DO I=0,LENGTH(CONN)-1,OUTPUT_RECL
N = MIN(LENGTH(CONN)-I,OUTPUT_RECL) ! Next record size.
IF (I/CHUNK_SIZE.EQ.(I+N-1)/CHUNK_SIZE) THEN
! Next record lies entirely within one chunk,
! so we can write it out directly.
DESCRIPTOR(2) =
# CHUNK_ADDRESS(I/CHUNK_SIZE,CONN) +
# MOD(I,CHUNK_SIZE)
CALL XQ___WRITE(CONN,DESCRIPTOR,N)
ELSE
! Next record crosses a chunk boundary, so first
! copy it to a temporary buffer before writing it out.
CALL XQ___MOVE_FROM_FILE(CONN,I,TEMPORARY_BUFFER,N)
CALL XQ___WRITE(CONN,%DESCR(TEMPORARY_BUFFER),N)
ENDIF
ENDDO
CLOSE (UNIT=CONN)
ENDIF
ELSEIF (TYPE(CONN).EQ.INTERACTIVE) THEN
CLOSE (UNIT=CONN)
ENDIF
STATUS=E$OK
RETURN
900 STATUS=E$FACCESS
RETURN
END
C-----------------------------------------------------------------------
SUBROUTINE XQ___WRITE (CONN,BUFFER,N)
INCLUDE 'XQCOMMON.FOR/NOLIST'
CHARACTER*1 BUFFER
INTEGER*4 N
WRITE(CONN,1001) BUFFER(1:N)
1001 FORMAT(A)
RETURN
END
C-----------------------------------------------------------------------
SUBROUTINE XQ_GET CONNECTION STATUS (CONN,INFO,STATUS)
INCLUDE 'XQCOMMON.FOR/NOLIST'
INCLUDE 'EXCEPT.FOR/NOLIST'
INTEGER*2 CONN,STATUS
BYTE INFO(7)
INTEGER*4 FILE_PTR
BYTE FP(4)
EQUIVALENCE (FILE_PTR,FP)
IF (CONN.LT.CONN_MIN .OR. CONN.GT.CONN_MAX) THEN
STATUS=E$PARAM
RETURN
ELSEIF (STATE(CONN).EQ.STATE_UNATTACHED) THEN
STATUS=E$EXIST
RETURN
ENDIF
FILE_PTR=MARKER(CONN)
INFO(1)=STATE(CONN).EQ.STATE_OPEN
INFO(2)=ACCESS_RIGHTS(CONN)
INFO(3)=SEEK_CAPABILITY(CONN)
INFO(4)=FP(1)
INFO(5)=FP(2)
INFO(6)=FP(3)
INFO(7)=FP(4)
STATUS=E$OK
RETURN
END
C-----------------------------------------------------------------------
SUBROUTINE XQ_OPEN (CONN,ACCESS,NUMBUF,STATUS)
INCLUDE 'XQCOMMON.FOR/NOLIST'
INCLUDE 'EXCEPT.FOR/NOLIST'
INTEGER*2 CONN,STATUS
BYTE ACCESS,NUMBUF
IF (CONN.LT.CONN_MIN .OR. CONN.GT.CONN_MAX) THEN
STATUS=E$PARAM
RETURN
ELSEIF (STATE(CONN).EQ.STATE_UNATTACHED) THEN
STATUS=E$EXIST
ELSEIF (STATE(CONN).EQ.STATE_OPEN) THEN
STATUS=E$OPEN
RETURN
ELSEIF (ACCESS.LT.1 .OR. ACCESS.GT.3) THEN
STATUS=E$PARAM
RETURN
ENDIF
ACCESS_MODE(CONN)=ACCESS
IF (ACCESS.EQ.AM_WRITE .OR. ACCESS.EQ.AM_UPDATE) THEN
MODIFIED(CONN)=.TRUE.
ENDIF
MARKER(CONN)=0
STATE(CONN)=STATE_OPEN
STATUS=E$OK
RETURN
END
C-----------------------------------------------------------------------
SUBROUTINE XQ_SEEK (CONN,MODE,HIGH_OFFSET,LOW_OFFSET,STATUS)
INCLUDE 'XQCOMMON.FOR/NOLIST'
INCLUDE 'EXCEPT.FOR/NOLIST'
INTEGER*2 CONN,HIGH_OFFSET,LOW_OFFSET,STATUS
BYTE MODE
INTEGER*4 OFFSET
INTEGER*2 OFF(2)
EQUIVALENCE (OFFSET,OFF)
INTEGER*4 I
LOGICAL*4 XQ___ENSURE_ALLOCATED
BYTE ZEROES(512)
DATA ZEROES /512*0/
IF (CONN.LT.CONN_MIN .OR. CONN.GT.CONN_MAX) THEN
STATUS=E$PARAM
RETURN
ELSEIF (STATE(CONN).EQ.STATE_UNATTACHED) THEN
STATUS=E$EXIST
RETURN
ELSEIF (STATE(CONN).NE.STATE_OPEN) THEN
STATUS=E$NOPEN
RETURN
ENDIF
IF (TYPE(CONN).EQ.BYTE_BUCKET) GO TO 999
OFF(1)=LOW_OFFSET
OFF(2)=HIGH_OFFSET
GO TO (100,200,300,400), MODE
STATUS=E$PARAM
RETURN
C
C------ MODE 1: SEEK BACKWARD.
C
100 IF ((SEEK_CAPABILITY(CONN).AND.SC_BACKWARD).EQ.0) THEN
STATUS=E$SUPPORT
RETURN
ENDIF
MARKER(CONN)=MAX(MARKER(CONN)-OFFSET,0)
GO TO 999
C
C------ MODE 2: SEEK ABSOLUTE.
C
200 IF (SEEK_CAPABILITY(CONN).NE.SC_FORWARD+SC_BACKWARD) THEN
STATUS=E$SUPPORT
RETURN
ENDIF
MARKER(CONN)=OFFSET
GO TO 950
C
C------ MODE 3: SEEK FORWARD.
C
300 IF ((SEEK_CAPABILITY(CONN).AND.SC_FORWARD).EQ.0) THEN
STATUS=E$SUPPORT
RETURN
ENDIF
MARKER(CONN)=MARKER(CONN)+OFFSET
GO TO 950
C
C------ MODE 4: SEEK BACKWARD FROM END OF FILE.
C
400 IF ((SEEK_CAPABILITY(CONN).AND.SC_BACKWARD).EQ.0) THEN
STATUS=E$SUPPORT
RETURN
ENDIF
MARKER(CONN)=MAX(LENGTH(CONN)-OFFSET,0)
GO TO 999
C
C------ TEST IF FILE NEEDS TO BE EXTENDED WITH NULLS.
C
950 IF (ACCESS_MODE(CONN).EQ.AM_READ) THEN
MARKER(CONN)=MIN(MARKER(CONN),LENGTH(CONN))
ELSEIF (MARKER(CONN).GT.LENGTH(CONN)) THEN
IF (.NOT.XQ___ENSURE_ALLOCATED(CONN,MARKER(CONN)-1)) THEN
STATUS=E$MEM ! Can't get core.
MARKER(CONN)=LENGTH(CONN)
RETURN
ENDIF
DO I=LENGTH(CONN),MARKER(CONN)-1,512
CALL XQ___MOVE_TO_FILE(CONN,ZEROES,I,
# MIN(MARKER(CONN)-I,512))
ENDDO
LENGTH(CONN)=MARKER(CONN)
ENDIF
999 STATUS=E$OK
RETURN
END
C-----------------------------------------------------------------------
INTEGER*2 FUNCTION XQ_READ (CONN,BUF,STATUS)
INCLUDE 'XQCOMMON.FOR/NOLIST'
INCLUDE 'EXCEPT.FOR/NOLIST'
INCLUDE 'IODEF.FOR/NOLIST'
INTEGER*2 CONN,STATUS
CHARACTER*(*) BUF
INTEGER*4 N,K
INTEGER*4 NO_TERMINATORS(2), IO_FUNCTION_CODE
DATA NO_TERMINATORS/0,0/
INTEGER*2 IOSB(4)
LOGICAL*4 SS,SYS$ASSIGN
IF (CONN.LT.CONN_MIN .OR. CONN.GT.CONN_MAX) THEN
STATUS=E$PARAM
RETURN
ELSEIF (STATE(CONN).EQ.STATE_UNATTACHED) THEN
STATUS=E$EXIST
RETURN
ELSEIF (STATE(CONN).NE.STATE_OPEN) THEN
STATUS=E$NOPEN
RETURN
ELSEIF (ACCESS_MODE(CONN).EQ.AM_WRITE) THEN
STATUS=E$OWRITE
RETURN
ENDIF
IF (TYPE(CONN).EQ.INTERACTIVE) THEN
IF (SPECIAL_MODE(CONN).EQ.LINE_EDITED) THEN
READ(CONN,1002,END=999) N,BUF(1:MIN(N,LEN(BUF)-2))
1002 FORMAT(Q,A)
K=MIN(N+2,LEN(BUF))
BUF(K-1:K)=CRLF
ELSE ! --- TRANSPARENT.
IF (.NOT.TT_CHANNEL_ASSIGNED) THEN
SS=SYS$ASSIGN('TT',TT_CHANNEL,,)
IF (.NOT.SS) CALL LIB$SIGNAL(%VAL(SS))
TT_CHANNEL_ASSIGNED=.TRUE.
ENDIF
IO_FUNCTION_CODE=IO$_READVBLK+IO$M_NOECHO+IO$M_NOFILTR
IF (SPECIAL_MODE(CONN).EQ.TRANSPARENT_NOWAIT) THEN
IO_FUNCTION_CODE=IO_FUNCTION_CODE+IO$M_TIMED
ENDIF
CALL SYS$QIOW(,%VAL(TT_CHANNEL),%VAL(IO_FUNCTION_CODE),
# IOSB,,,%REF(BUF),%VAL(LEN(BUF)),%VAL(0),
# %REF(NO_TERMINATORS),,)
K=IOSB(2) ! # BYTES ACTUALLY READ.
ENDIF
ELSEIF (TYPE(CONN).EQ.BYTE_BUCKET) THEN
999 K=0 ! End of file.
ELSE
K=MIN(LEN(BUF),LENGTH(CONN)-MARKER(CONN))
CALL XQ___MOVE_FROM_FILE(CONN,MARKER(CONN),%REF(BUF),K)
MARKER(CONN)=MARKER(CONN)+K
ENDIF
STATUS=E$OK
XQ_READ=K
RETURN
END
C-----------------------------------------------------------------------
SUBROUTINE XQ_WRITE (CONN,BUF,STATUS)
INCLUDE 'XQCOMMON.FOR/NOLIST'
INCLUDE 'EXCEPT.FOR/NOLIST'
INTEGER*2 CONN,STATUS
CHARACTER*(*) BUF
INTEGER*4 I
LOGICAL*4 XQ___ENSURE_ALLOCATED
IF (CONN.LT.CONN_MIN .OR. CONN.GT.CONN_MAX) THEN
STATUS=E$PARAM
RETURN
ELSEIF (STATE(CONN).EQ.STATE_UNATTACHED) THEN
STATUS=E$EXIST
RETURN
ELSEIF (STATE(CONN).NE.STATE_OPEN) THEN
STATUS=E$NOPEN
RETURN
ELSEIF (ACCESS_MODE(CONN).EQ.AM_READ) THEN
STATUS=E$OREAD
RETURN
ENDIF
IF (TYPE(CONN).EQ.INTERACTIVE) THEN
DO I=1,LEN(BUF),80
WRITE(CONN,1003) BUF(I:MIN(LEN(BUF),I+79))
ENDDO
1003 FORMAT('+',A,$)
ELSEIF (TYPE(CONN).EQ.BYTE_BUCKET) THEN
! NO-OP.
ELSE
IF (.NOT.XQ___ENSURE_ALLOCATED(CONN,MARKER(CONN)+LEN(BUF)-1))
# THEN
STATUS=E$MEM ! Can't get core.
RETURN
ENDIF
CALL XQ___MOVE_TO_FILE(CONN,%REF(BUF),MARKER(CONN),LEN(BUF))
MARKER(CONN)=MARKER(CONN)+LEN(BUF)
LENGTH(CONN)=MAX(LENGTH(CONN),MARKER(CONN))
ENDIF
STATUS=E$OK
RETURN
END
C-----------------------------------------------------------------------
SUBROUTINE XQ_TRUNCATE (CONN,STATUS)
INCLUDE 'XQCOMMON.FOR/NOLIST'
INCLUDE 'EXCEPT.FOR/NOLIST'
INTEGER*2 CONN,STATUS
IF (CONN.LT.CONN_MIN .OR. CONN.GT.CONN_MAX) THEN
STATUS=E$PARAM
RETURN
ELSEIF (STATE(CONN).EQ.STATE_UNATTACHED) THEN
STATUS=E$EXIST
RETURN
ELSEIF (STATE(CONN).NE.STATE_OPEN) THEN
STATUS=E$NOPEN
RETURN
ELSEIF (ACCESS_MODE(CONN).EQ.AM_READ) THEN
STATUS=E$OREAD
RETURN
ENDIF
LENGTH(CONN)=MARKER(CONN)
STATUS=E$OK
RETURN
END
C-----------------------------------------------------------------------
SUBROUTINE XQ_CLOSE (CONN,STATUS)
INCLUDE 'XQCOMMON.FOR/NOLIST'
INCLUDE 'EXCEPT.FOR/NOLIST'
INTEGER*2 CONN,STATUS
IF (CONN.LT.CONN_MIN .OR. CONN.GT.CONN_MAX) THEN
STATUS=E$PARAM
RETURN
ELSEIF (STATE(CONN).EQ.STATE_UNATTACHED) THEN
STATUS=E$EXIST
RETURN
ELSEIF (STATE(CONN).NE.STATE_OPEN) THEN
STATUS=E$NOPEN
RETURN
ENDIF
STATE(CONN)=STATE_ATTACHED
STATUS=E$OK
RETURN
END
C-----------------------------------------------------------------------
SUBROUTINE XQ_SPECIAL (TYP,PARAMETER,STATUS)
INCLUDE 'XQCOMMON.FOR/NOLIST'
INCLUDE 'EXCEPT.FOR/NOLIST'
BYTE TYP
INTEGER*2 PARAMETER,STATUS
INTEGER*2 CONN
GO TO (100,200,300), TYP
STATUS=E$PARAM
RETURN
100 CONTINUE
200 CONTINUE
300 CONTINUE
CONN=PARAMETER
IF (CONN.LT.CONN_MIN .OR. CONN.GT.CONN_MAX) THEN
STATUS=E$PARAM
RETURN
ELSEIF (STATE(CONN).EQ.STATE_UNATTACHED) THEN
STATUS=E$EXIST
RETURN
ELSEIF (TYPE(CONN).NE.INTERACTIVE) THEN
STATUS=E$SUPPORT
RETURN
ENDIF
SPECIAL_MODE(CONN)=TYP
STATUS=E$OK
RETURN
END
C-----------------------------------------------------------------------
SUBROUTINE XQ_EXIT (COMPLETION_CODE)
INCLUDE 'XQCOMMON.FOR/NOLIST'
INCLUDE 'EXCEPT.FOR/NOLIST'
INTEGER*2 COMPLETION_CODE
INTEGER*2 STATUS
EXTERNAL UDI_OK,UDI_WARNINGS,UDI_ERRORS,UDI_FATAL,UDI_ABORT
EXTERNAL UDI_BADINDSYN,UDI_INDNOTLAS,UDI_BADINDFIL,UDI_INDTOOBIG
DO CONN=CONN_MIN,CONN_MAX
IF (STATE(CONN).NE.STATE_UNATTACHED) THEN
CALL XQ_DETACH(CONN,STATUS)
ENDIF
ENDDO
GO TO (1,2,3,4), COMPLETION_CODE+1
GO TO (101,102,103,104), COMPLETION_CODE-100
CALL LIB$SIGNAL(UDI_ABORT)
1 CALL EXIT
2 CALL LIB$SIGNAL(UDI_WARNINGS)
CALL EXIT
3 CALL LIB$SIGNAL(UDI_ERRORS)
CALL EXIT
4 CALL LIB$SIGNAL(UDI_FATAL)
CALL EXIT
101 CALL LIB$SIGNAL(UDI_BADINDSYN)
CALL EXIT
102 CALL LIB$SIGNAL(UDI_INDNOTLAS)
CALL EXIT
103 CALL LIB$SIGNAL(UDI_BADINDFIL)
CALL EXIT
104 CALL LIB$SIGNAL(UDI_INDTOOBIG)
CALL EXIT
END
LOGICAL*4 FUNCTION XQ___ENSURE_ALLOCATED (CONN, BYTE_INDEX)
C-----------------------------------------------------------------------
C
C This function is called to ensure that enough core is allocated
C to contain bytes 0..BYTE_INDEX for connection CONN.
C
C Returns .TRUE. if enough core is allocated.
C Returns .FALSE. if core not available, or chunk table size
C would be exceeded.
C
C Assumes CONN is a valid connection number.
C Assumes BYTE_INDEX > 0.
C Assumes chunks are consecutively allocated from chunk 0 up.
C
C-----------------------------------------------------------------------
INCLUDE 'XQCOMMON.FOR/NOLIST'
INTEGER*2 CONN ! Connection token.
INTEGER*4 BYTE_INDEX ! Highest byte index necessary to be
! allocated.
INTEGER*4 CHUNK
LOGICAL*4 LIB$GET_VM
IF (BYTE_INDEX.GE.MAX_CORE_FILE_SIZE) THEN
XQ___ENSURE_ALLOCATED=.FALSE. ! Chunk table size exceeded.
RETURN
ENDIF
IF (CHUNK_ADDRESS(BYTE_INDEX/CHUNK_SIZE,CONN).NE.0) THEN
XQ___ENSURE_ALLOCATED=.TRUE. ! Already allocated.
RETURN
ENDIF
! Allocate any missing chunks, up through the highest one needed.
DO CHUNK=0,BYTE_INDEX/CHUNK_SIZE
IF (CHUNK_ADDRESS(CHUNK,CONN).EQ.0) THEN
IF (.NOT.LIB$GET_VM(CHUNK_SIZE,CHUNK_ADDRESS(CHUNK,CONN)))
# THEN
XQ___ENSURE_ALLOCATED=.FALSE. ! Can't get core.
CHUNK_ADDRESS(CHUNK,CONN)=0
RETURN
ENDIF
ENDIF
ENDDO
XQ___ENSURE_ALLOCATED=.TRUE. ! Successfully allocated core.
RETURN
END
SUBROUTINE XQ___MOVE_TO_FILE (CONN, BUFFER, BYTE_INDEX, N_BYTES)
C-----------------------------------------------------------------------
C
C This subroutine is called to copy a bufferful of bytes into
C a core file.
C
C Assumes N_BYTES < 64K.
C Assumes the necessary core in the core file has already been
C allocated.
C
C-----------------------------------------------------------------------
INCLUDE 'XQCOMMON.FOR/NOLIST'
INTEGER*2 CONN ! Connection token.
BYTE BUFFER(0:*) ! Buffer to move from.
INTEGER*4 BYTE_INDEX ! Index in core file to start copying to.
INTEGER*4 N_BYTES ! Number of bytes to move (< 64K).
INTEGER*4 I,N,K,START_INDEX
I = 0 ! Index into buffer.
N = N_BYTES ! Number of bytes left to move.
START_INDEX = BYTE_INDEX ! Core file index to start next move.
DO WHILE (N.GT.0)
K = MIN(N, CHUNK_SIZE-MOD(START_INDEX,CHUNK_SIZE))
! Max bytes we can transfer without crossing chunk boundary.
CALL PLM$MOVE (%VAL(K),
# BUFFER(I),
# %VAL(CHUNK_ADDRESS(START_INDEX/CHUNK_SIZE,CONN)+
# MOD(START_INDEX,CHUNK_SIZE)))
I = I+K
START_INDEX = START_INDEX+K
N = N-K
ENDDO
RETURN
END
SUBROUTINE XQ___MOVE_FROM_FILE (CONN, BYTE_INDEX, BUFFER, N_BYTES)
C-----------------------------------------------------------------------
C
C This subroutine is called to copy a bufferful of bytes out of a
C core file
C
C Assumes N_BYTES < 64K.
C Assumes the necessary core in the core file is already allocated.
C
C-----------------------------------------------------------------------
INCLUDE 'XQCOMMON.FOR/NOLIST'
INTEGER*2 CONN ! Connection token.
INTEGER*4 BYTE_INDEX ! Index in core file to start copying
! from.
BYTE BUFFER(0:*) ! Buffer to move to.
INTEGER*4 N_BYTES ! Number of bytes to move (< 64K).
INTEGER*4 I,N,K,START_INDEX
I = 0 ! Index into buffer.
N = N_BYTES ! Number of bytes left to move.
START_INDEX = BYTE_INDEX ! Core file index to start next move.
DO WHILE (N.GT.0)
K = MIN(N,CHUNK_SIZE-MOD(START_INDEX,CHUNK_SIZE))
! Max bytes we can transfer without crossing chunk boundary.
CALL PLM$MOVE (%VAL(K),
# %VAL(CHUNK_ADDRESS(START_INDEX/CHUNK_SIZE,CONN)+
# MOD(START_INDEX,CHUNK_SIZE)),
# BUFFER(I))
I = I+K
START_INDEX = START_INDEX+K
N = N-K
ENDDO
RETURN
END

215
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/basics.for Normal file
View File

@@ -0,0 +1,215 @@
C***********************************************************************
C
C BASICS.FOR
C
C
C D I S C L A I M E R N O T I C E
C ------------------- -----------
C
C This document and/or portions of the material and data furnished
C herewith, was developed under sponsorship of the U. S. Government.
C Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior
C University, nor their employees, nor their respective contractors,
C subcontractors, or their employees, makes any warranty, express or
C implied, or assumes any liability or responsibility for accuracy,
C completeness or usefulness of any information, apparatus, product
C or process disclosed, or represents that its use will not infringe
C privately-owned rights. Mention of any product, its manufacturer,
C or suppliers shall not, nor is it intended to, imply approval, dis-
C approval, or fitness for any particular use. The U. S. and the
C University at all times retain the right to use and disseminate same
C for any purpose whatsoever. Such distribution shall be made by the
C National Energy Software Center at the Argonne National Laboratory
C and only subject to the distributee furnishing satisfactory proof
C that he has a valid license from the Intel Corporation in effect.
C
C
C-----------------------------------------------------------------------
C
C This module of the PL/M-VAX compiler parses and generates code for
C the following 'basic' statement types: assignment statements,
C call statements, goto statements, return statements, and i8086-
C dependent statements.
C
C-----------------------------------------------------------------------
C
C R E V I S I O N H I S T O R Y
C
C 08SEP81 Alex Hunter 1. Use DO-WHILE (cosmetic change). (V5.1)
C 21OCT81 Alex Hunter 1. Basic block analysis. (V5.5)
C 10NOV81 Alex Hunter 1. Add EFFECTS module. (V6.0)
C 14JAN82 Alex Hunter 1. Treat GOTO <keyword> as GOTO <identifier>.
C (V6.5)
C
C***********************************************************************
INTEGER*2 FUNCTION ASSIGNMENT_STATEMENT(N)
INCLUDE 'PLMCOM.FOR/NOLIST'
CODE=NULL
10 CALL MUSTBE(ID)
CALL LOOKUP_SYMBOL
IF (SYMBOL_KIND(SYMBOL_INDEX).EQ.S_PROC) THEN
CALL ERROR('PROCEDURE ILLEGAL AS LEFTHAND SIDE OF ASSIGNMENT: '
# //SYMBOL_PLM_ID(SYMBOL_INDEX))
ENDIF
LHS=VARIABLE_REFERENCE(0)
CODE=MAKE_NODE(OP_ALSO,CODE,MAKE_NODE(OP_MOV,NULL,LHS,0,0,0),
# 0,0,0)
IF (TT.EQ.D_COMMA) THEN
CALL GETTOK
GO TO 10
ENDIF
CALL MATCH(D_EQ)
RHS=EXPRESSION(1)
OPNODE_OPND1(OPNODE_OPND2(CODE))=RHS
CALL DETERMINE_EFFECTS_OF_ASSIGNMENT(LHS)
CODE1=OPNODE_OPND1(CODE)
DO WHILE (CODE1.NE.NULL)
OPNODE_OPND1(OPNODE_OPND2(CODE1))=REPLICA(RHS)
LHS=OPNODE_OPND2(OPNODE_OPND2(CODE1))
CALL DETERMINE_EFFECTS_OF_ASSIGNMENT(LHS)
CODE1=OPNODE_OPND1(CODE1)
ENDDO
CALL MATCH(D_SEMI)
ASSIGNMENT_STATEMENT=CODE
RETURN
END
C----------------------------------------------------
INTEGER*2 FUNCTION CALL_STATEMENT(N)
INCLUDE 'PLMCOM.FOR/NOLIST'
INTEGER*2 ARGS(100)
CALL MATCH(K_CALL)
CALL MUSTBE(ID)
CALL LOOKUP_SYMBOL
PROC_IX=SYMBOL_INDEX
IF (SYMBOL_KIND(PROC_IX).EQ.S_PROC) THEN
IF (SYMBOL_TYPE(PROC_IX).NE.0) THEN
CALL WARN('TYPED PROCEDURE USED IN CALL STATEMENT: '//
# SYMBOL_PLM_ID(PROC_IX))
ENDIF
PROC_BASE=NULL
CALL GETTOK
ELSE
PROC_BASE=DATA_REFERENCE(0,2)
IF (NODE_TYPE(PROC_BASE).NE.S_PTR.AND.
# NODE_TYPE(PROC_BASE).NE.S_WORD.AND.
# NODE_TYPE(PROC_BASE).NE.S_LONG) THEN
CALL WARN('INDIRECT CALL THRU NON-WORD/POINTER '//
# 'PROBABLY WON''T WORK')
ENDIF
PROC_IX=0
ENDIF
ARGLIST=NULL
NARGS=0
IF (TT.EQ.D_LP) THEN
10 CALL GETTOK
NARGS=NARGS+1
ARGLIST=MAKE_NODE(OP_ARG,ARGLIST,EXPRESSION(1),0,0,0)
IF (TT.EQ.D_COMMA) GO TO 10
CALL MATCH(D_RP)
ENDIF
IF (PROC_IX.NE.0.AND.NARGS.NE.SYMBOL_LIST_SIZE(PROC_IX)) THEN
CALL WARN('WRONG NUMBER OF ARGS TO '//
# SYMBOL_PLM_ID(PROC_IX))
ENDIF
PROC=MAKE_ATOM(PROC_IX,0,PROC_BASE,NULL,S_BYTE,0,0)
CODE=MAKE_NODE(OP_CALL,PROC,ARGLIST,0,0,0)
CODE=MAKE_NODE(OP_MOV,CODE,R0,0,0,0)
NODE_TYPE(R0)=S_BYTE
CALL DETERMINE_EFFECTS_OF_CALLING(PROC_IX)
CALL MATCH(D_SEMI)
CALL_STATEMENT=CODE
RETURN
END
C----------------------------------------------------
INTEGER*2 FUNCTION GOTO_STATEMENT(N)
INCLUDE 'PLMCOM.FOR/NOLIST'
IF (TT.EQ.K_GO) THEN
CALL GETTOK
CALL MATCH(K_TO)
ELSE
CALL MATCH(K_GOTO)
ENDIF
CALL BREAK
IF (TT.LT.101.OR.TT.GT.199) CALL MUSTBE(ID)
H=HASH(IDENTIFIER)
SYMBOL_INDEX=HASH_BUCKET(H)
10 IF (SYMBOL_INDEX.GE.SYMBOL_TOP(BLOCK_LEVEL-1)+1) THEN
IF (SYMBOL_PLM_ID(SYMBOL_INDEX).EQ.IDENTIFIER) THEN
GO TO 20
ENDIF
SYMBOL_INDEX=SYMBOL_CHAIN(SYMBOL_INDEX)
GO TO 10
ENDIF
CALL ENTER_SYMBOL
SYMBOL_KIND(SYMBOL_INDEX)=S_LABEL
SYMBOL_REF(SYMBOL_INDEX)=S_UNRESOLVED
20 IF (SYMBOL_REF(SYMBOL_INDEX).EQ.S_EXT) THEN
CALL EMIT('JMP '//SYMBOL_VAX_ID(SYMBOL_INDEX))
ELSE
CALL EMIT('BRW '//SYMBOL_VAX_ID(SYMBOL_INDEX))
ENDIF
PATH=.FALSE.
CALL GETTOK
CALL MATCH(D_SEMI)
GOTO_STATEMENT=NULL
RETURN
END
C----------------------------------------------------
INTEGER*2 FUNCTION RETURN_STATEMENT(N)
INCLUDE 'PLMCOM.FOR/NOLIST'
CALL MATCH(K_RETURN)
TYPE=SYMBOL_TYPE(PROC_INDEX(PROC_LEVEL))
IF (TT.NE.D_SEMI) THEN
IF (TYPE.EQ.0) THEN
CALL ERROR('CAN''T RETURN VALUE FROM UNTYPED PROCEDURE')
TYPE=S_LONG
ENDIF
RESULT=MAKE_NODE(OP_BYTE+TYPE-S_BYTE,EXPRESSION(1),NULL,0,0,0)
RESULT=MAKE_NODE(OP_MOV,RESULT,R0,0,0,0)
NODE_TYPE(R0)=TYPE
BASIC_BLOCK=MAKE_NODE(OP_THEN,BASIC_BLOCK,RESULT,0,0,0)
ELSEIF (TYPE.NE.0) THEN
CALL ERROR('MUST RETURN VALUE FROM TYPED PROCEDURE')
ENDIF
CALL BREAK
CALL MATCH(D_SEMI)
CALL EMIT('RET')
PATH=.FALSE.
RETURN_STATEMENT=NULL
RETURN
END
C----------------------------------------------------
INTEGER*2 FUNCTION i8086_DEPENDENT_STATEMENTS(N)
INCLUDE 'PLMCOM.FOR/NOLIST'
CALL GETTOK
CALL MATCH(D_SEMI)
CALL WARN('8086 DEPENDENT STATEMENT IGNORED')
i8086_DEPENDENT_STATEMENTS=NULL
RETURN
END

119
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/block.for Normal file
View File

@@ -0,0 +1,119 @@
C***********************************************************************
C
C BLOCK.FOR
C
C
C D I S C L A I M E R N O T I C E
C ------------------- -----------
C
C This document and/or portions of the material and data furnished
C herewith, was developed under sponsorship of the U. S. Government.
C Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior
C University, nor their employees, nor their respective contractors,
C subcontractors, or their employees, makes any warranty, express or
C implied, or assumes any liability or responsibility for accuracy,
C completeness or usefulness of any information, apparatus, product
C or process disclosed, or represents that its use will not infringe
C privately-owned rights. Mention of any product, its manufacturer,
C or suppliers shall not, nor is it intended to, imply approval, dis-
C approval, or fitness for any particular use. The U. S. and the
C University at all times retain the right to use and disseminate same
C for any purpose whatsoever. Such distribution shall be made by the
C National Energy Software Center at the Argonne National Laboratory
C and only subject to the distributee furnishing satisfactory proof
C that he has a valid license from the Intel Corporation in effect.
C
C
C-----------------------------------------------------------------------
C
C This module of the PL/M-VAX compiler handles block entries
C and exits.
C
C-----------------------------------------------------------------------
C
C R E V I S I O N H I S T O R Y
C
C 16OCT81 Alex Hunter 1. Added disclaimer notice.
C 14NOV81 Alex Hunter 1. Avoid unnecessary jump if no path. (V6.2)
C 2. Copy symbol serial no. and psect fields.
C
C***********************************************************************
SUBROUTINE BLOCK_BEGIN
INCLUDE 'PLMCOM.FOR/NOLIST'
C
IF (BLOCK_LEVEL.GE.BLOCK_MAX)
# CALL FATAL('BLOCKS NESTED TOO DEEPLY')
BLOCK_LEVEL=BLOCK_LEVEL+1
SYMBOL_TOP(BLOCK_LEVEL)=SYMBOL_TOP(BLOCK_LEVEL-1)
MEMBER_TOP(BLOCK_LEVEL)=MEMBER_TOP(BLOCK_LEVEL-1)
PARAM_TOP(BLOCK_LEVEL)=PARAM_TOP(BLOCK_LEVEL-1)
STRINGS_TOP(BLOCK_LEVEL)=STRINGS_TOP(BLOCK_LEVEL-1)
RETURN
C
C---------------------------
ENTRY BLOCK_END
C---------------------------
IF (BLOCK_LEVEL.EQ.0) CALL BUG('BLOCK LEVEL UNDERFLOW')
DO 10 I=SYMBOL_TOP(BLOCK_LEVEL),SYMBOL_TOP(BLOCK_LEVEL-1)+1,-1
H=HASH(SYMBOL_PLM_ID(I))
HASH_BUCKET(H)=SYMBOL_CHAIN(I)
10 CONTINUE
BLOCK_LEVEL=BLOCK_LEVEL-1
C---------- HANDLE UNRESOLVED LABELS AND UNDEFINED FORWARD REFS
DO 40 I=SYMBOL_TOP(BLOCK_LEVEL)+1,SYMBOL_TOP(BLOCK_LEVEL+1)
IF (SYMBOL_REF(I).EQ.S_FORWARD.OR.
# BLOCK_LEVEL.EQ.0.AND.(SYMBOL_FLAGS(I).AND.S_UNDEF).NE.0) THEN
CALL ERROR('NEVER GOT DEFINED: '//SYMBOL_PLM_ID(I))
ELSEIF (SYMBOL_KIND(I).EQ.S_LABEL.AND.
# (SYMBOL_FLAGS(I).AND.S_UNDEF).NE.0) THEN
! -- UNRESOLVED LABEL. ----
DO 20 J=SYMBOL_TOP(BLOCK_LEVEL-1)+1,SYMBOL_TOP(BLOCK_LEVEL)
IF (SYMBOL_PLM_ID(I).EQ.SYMBOL_PLM_ID(J)) THEN
IF (SYMBOL_KIND(J).NE.S_LABEL) THEN
CALL ERROR('GOTO TARGET NOT A LABEL: '//SYMBOL_PLM_ID(I))
ELSEIF ((SYMBOL_FLAGS(J).AND.S_UNDEF).EQ.0) THEN
IF (SYMBOL_REF(J).EQ.S_EXT) THEN
IF (PATH) CALL GENERATE_LOCAL_LABEL(LL)
IF (PATH) CALL EMIT('BRB '//LOCAL_LABEL(LL,N0))
CALL EMIT_LABEL(I)
CALL EMIT('JMP '//SYMBOL_VAX_ID(J))
IF (PATH) CALL EMIT_LOCAL_LABEL(LL)
ELSE
CALL EMIT1(SYMBOL_VAX_ID(I)(:LNB(SYMBOL_VAX_ID(I)))
# //' = '//
# SYMBOL_VAX_ID(J)(:LNB(SYMBOL_VAX_ID(J))))
ENDIF
ELSE
SYMBOL_REF(I)=SYMBOL_REF(J)
SYMBOL_FLAGS(I)=SYMBOL_FLAGS(J).AND..NOT.S_PUBLIC
GO TO 30
ENDIF
GO TO 40
ENDIF
20 CONTINUE
C---------- LABEL STILL UNRESOLVED -- COPY DOWN TO OUTER BLOCK.
30 SYMBOL_TOP(BLOCK_LEVEL)=SYMBOL_TOP(BLOCK_LEVEL)+1
IX=SYMBOL_TOP(BLOCK_LEVEL)
SYMBOL_PLM_ID(IX)=SYMBOL_PLM_ID(I)
SYMBOL_VAX_ID(IX)=SYMBOL_VAX_ID(I)
SYMBOL_KIND(IX)=SYMBOL_KIND(I)
SYMBOL_TYPE(IX)=SYMBOL_TYPE(I)
SYMBOL_NBR_ELEMENTS(IX)=SYMBOL_NBR_ELEMENTS(I)
SYMBOL_ELEMENT_SIZE(IX)=SYMBOL_ELEMENT_SIZE(I)
SYMBOL_LINK(IX)=SYMBOL_LINK(I)
SYMBOL_LIST_SIZE(IX)=SYMBOL_LIST_SIZE(I)
SYMBOL_REF(IX)=SYMBOL_REF(I)
SYMBOL_BASE(IX)=SYMBOL_BASE(I)
SYMBOL_BASE_MEMBER(IX)=SYMBOL_BASE_MEMBER(I)
SYMBOL_FLAGS(IX)=SYMBOL_FLAGS(I)
SYMBOL_SERIAL_NO(IX)=SYMBOL_SERIAL_NO(I)
SYMBOL_PSECT(IX)=SYMBOL_PSECT(I)
H=HASH(SYMBOL_PLM_ID(I))
SYMBOL_CHAIN(IX)=HASH_BUCKET(H)
HASH_BUCKET(H)=IX
ENDIF
40 CONTINUE
RETURN
END

201
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/branches.for Normal file
View File

@@ -0,0 +1,201 @@
C***********************************************************************
C
C BRANCHES.FOR
C
C
C D I S C L A I M E R N O T I C E
C ------------------- -----------
C
C This document and/or portions of the material and data furnished
C herewith, was developed under sponsorship of the U. S. Government.
C Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior
C University, nor their employees, nor their respective contractors,
C subcontractors, or their employees, makes any warranty, express or
C implied, or assumes any liability or responsibility for accuracy,
C completeness or usefulness of any information, apparatus, product
C or process disclosed, or represents that its use will not infringe
C privately-owned rights. Mention of any product, its manufacturer,
C or suppliers shall not, nor is it intended to, imply approval, dis-
C approval, or fitness for any particular use. The U. S. and the
C University at all times retain the right to use and disseminate same
C for any purpose whatsoever. Such distribution shall be made by the
C National Energy Software Center at the Argonne National Laboratory
C and only subject to the distributee furnishing satisfactory proof
C that he has a valid license from the Intel Corporation in effect.
C
C
C-----------------------------------------------------------------------
C
C This module of the PL/M-VAX compiler generates optimized
C conditional branch code for short-circuit evaluation of
C Boolean expressions.
C
C-----------------------------------------------------------------------
C R E V I S I O N H I S T O R Y
C
C 15OCT81 Alex Hunter 1. Added disclaimer notice. (V5.4)
C 21OCT81 Alex Hunter 1. Use OP_BB opcode. (V5.6)
C 2. Recode the BRANCH2 table.
C
C-----------------------------------------------------------------------
SUBROUTINE BRANCH_TO(NODX,TRUEX,FALSEX,FALL_THRUX)
INCLUDE 'PLMCOM.FOR/NOLIST'
NOD=NODX
TRUE=TRUEX
FALSE=FALSEX
FALL_THRU=FALL_THRUX
IF (NODE(NOD).AND.OPNODE_OP(NOD).EQ.OP_EXT) THEN
CALL GENERATE_LOCAL_LABEL(LL1)
CALL PUSH(TRUE,1)
CALL PUSH(FALSE,1)
CALL PUSH(FALL_THRU,1)
CALL PUSH(NOD,1)
CALL PUSH(LL1,1)
CALL BRANCH_TO2(OPNODE_OPND1(NOD),LL1,FALSE,LL1)
CALL POP(LL1,1)
CALL POP(NOD,1)
CALL POP(FALL_THRU,1)
CALL POP(FALSE,1)
CALL POP(TRUE,1)
CALL EMIT_LOCAL_LABEL(LL1)
CALL BRANCH_TO2(OPNODE_OPND2(NOD),FALSE,TRUE,FALL_THRU)
ELSEIF (NODE(NOD).AND.OPNODE_OP(NOD).EQ.OP_OR) THEN
CALL GENERATE_LOCAL_LABEL(LL1)
CALL PUSH(TRUE,1)
CALL PUSH(FALSE,1)
CALL PUSH(FALL_THRU,1)
CALL PUSH(NOD,1)
CALL PUSH(LL1,1)
CALL BRANCH_TO2(OPNODE_OPND1(NOD),TRUE,LL1,LL1)
CALL POP(LL1,1)
CALL POP(NOD,1)
CALL POP(FALL_THRU,1)
CALL POP(FALSE,1)
CALL POP(TRUE,1)
CALL EMIT_LOCAL_LABEL(LL1)
CALL BRANCH_TO2(OPNODE_OPND2(NOD),TRUE,FALSE,FALL_THRU)
ELSEIF (NODE(NOD).AND.OPNODE_OP(NOD).EQ.OP_NOT) THEN
CALL BRANCH_TO2(OPNODE_OPND1(NOD),FALSE,TRUE,FALL_THRU)
ELSEIF (NODE(NOD).AND.OPNODE_OP(NOD).GE.OP_LT.AND.
# OPNODE_OP(NOD).LE.OP_GE) THEN
CALL PUSH(TRUE,1)
CALL PUSH(FALSE,1)
CALL PUSH(FALL_THRU,1)
CALL PUSH(NOD,1)
OPND1=GET_SOMEWHERE(OPNODE_OPND1(NOD),ANY_WHERE)
CALL POP(NOD,1)
CALL PUSH(NOD,1)
CALL PUSH(OPND1,1)
OPND2=GET_SOMEWHERE(OPNODE_OPND2(NOD),ANY_WHERE)
CALL POP(OPND1,1)
CALL POP(NOD,1)
CALL POP(FALL_THRU,1)
CALL POP(FALSE,1)
CALL POP(TRUE,1)
CALL EMIT_CODE(OPNODE_OP(NOD),OPND2,OPND1,NULL)
CALL EMIT_BRANCH(OPNODE_OP(NOD),OPND1,TRUE,FALSE,FALL_THRU)
ELSE
CALL PUSH(TRUE,1)
CALL PUSH(FALSE,1)
CALL PUSH(FALL_THRU,1)
CALL PUSH(NOD,1)
TEST=GET_SOMEWHERE(NOD,ANY_WHERE)
CALL POP(NOD,1)
CALL POP(FALL_THRU,1)
CALL POP(FALSE,1)
CALL POP(TRUE,1)
IF (ATOM(TEST).AND.ATOM_SUB(TEST).NE.NULL.AND.
# NODE_TYPE(TEST).EQ.S_BYTE) THEN
CALL EMIT_BRANCH(OP_BB,TEST,TRUE,FALSE,FALL_THRU)
ELSEIF (ATOM(TEST).AND.ATOM_SUB(TEST).NE.NULL.AND.
# (NODE_TYPE(TEST).EQ.S_WORD.OR.
# NODE_TYPE(TEST).EQ.S_INTEGER)) THEN
CALL EMIT_CODE(OP_BIT,NULL,MAKE_FIXED(1,NODE_TYPE(TEST)),
# TEST)
CALL EMIT_BRANCH(OP_BNE,NULL,TRUE,FALSE,FALL_THRU)
ELSE
CALL EMIT_BRANCH(OP_BLB,TEST,TRUE,FALSE,FALL_THRU)
ENDIF
ENDIF
RETURN
END
C-----------------------------------------------------------------------
SUBROUTINE BRANCH_TO2(NODX,TRUEX,FALSEX,FALL_THRUX)
IMPLICIT INTEGER*2 (A-Z)
NOD=NODX
TRUE=TRUEX
FALSE=FALSEX
FALL_THRU=FALL_THRUX
CALL BRANCH_TO(NOD,TRUE,FALSE,FALL_THRU)
RETURN
END
C-----------------------------------------------------------------------
SUBROUTINE EMIT_BRANCH(OP,OPND,TRUE,FALSE,FALL_THRU)
INCLUDE 'PLMCOM.FOR/NOLIST'
CHARACTER*80 OPERAND,OPERAND1
CHARACTER*6 BR
CHARACTER*32 LABEL
CHARACTER*6 BRANCH1(1:2,OP_BNE:OP_BB)
DATA BRANCH1/
# 'BNEQ ','BEQL ',
# 'BLBS ','BLBC ',
# 'BBS ','BBC '/
CHARACTER*6 BRANCH2(CX_UNSIGNED:CX_SIGNED,1:2,OP_LT:OP_GE)
DATA BRANCH2/
# 'BLSSU','BLSS ',
# 'BGEQU','BGEQ ',
# 'BGTRU','BGTR ',
# 'BLEQU','BLEQ ',
# 'BEQLU','BEQL ',
# 'BNEQU','BNEQ ',
# 'BNEQU','BNEQ ',
# 'BEQLU','BEQL ',
# 'BLEQU','BLEQ ',
# 'BGTRU','BGTR ',
# 'BGEQU','BGEQ ',
# 'BLSSU','BLSS '/
IF (FALL_THRU.EQ.FALSE) THEN
BRANCH=TRUE
TF=1
ELSEIF (FALL_THRU.EQ.TRUE) THEN
BRANCH=FALSE
TF=2
ELSE
CALL BUG('EB-0')
ENDIF
LABEL=LOCAL_LABEL(BRANCH,L1)
IF (OP.GE.OP_LT.AND.OP.LE.OP_GE) THEN
BR=BRANCH2(CONTEXT(NODE_TYPE(OPND)),TF,OP)
ELSE
BR=BRANCH1(TF,OP)
ENDIF
IF (OP.EQ.OP_BLB) THEN
OPERAND1=OPERAND(OPND,N1)
CALL EMIT(BR//' '//OPERAND1(:N1)//','//LABEL(:L1))
ELSEIF (OP.EQ.OP_BB) THEN
OPERAND1=OPERAND(OPND,N1)
CALL EMIT(BR//' #0,'//OPERAND1(:N1)//','//LABEL(:L1))
ELSE
CALL EMIT(BR//' '//LABEL(:L1))
ENDIF
RETURN
END

53
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/break.for Normal file
View File

@@ -0,0 +1,53 @@
C***********************************************************************
C
C BREAK.FOR
C
C
C D I S C L A I M E R N O T I C E
C ------------------- -----------
C
C This document and/or portions of the material and data furnished
C herewith, was developed under sponsorship of the U. S. Government.
C Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior
C University, nor their employees, nor their respective contractors,
C subcontractors, or their employees, makes any warranty, express or
C implied, or assumes any liability or responsibility for accuracy,
C completeness or usefulness of any information, apparatus, product
C or process disclosed, or represents that its use will not infringe
C privately-owned rights. Mention of any product, its manufacturer,
C or suppliers shall not, nor is it intended to, imply approval, dis-
C approval, or fitness for any particular use. The U. S. and the
C University at all times retain the right to use and disseminate same
C for any purpose whatsoever. Such distribution shall be made by the
C National Energy Software Center at the Argonne National Laboratory
C and only subject to the distributee furnishing satisfactory proof
C that he has a valid license from the Intel Corporation in effect.
C
C
C-----------------------------------------------------------------------
C
C This module of the PL/M-VAX compiler handles breaks between
C basic blocks.
C
C-----------------------------------------------------------------------
C R E V I S I O N H I S T O R Y
C
C 15OCT81 Alex Hunter 1. Added disclaimer notice. (V5.4)
C 21OCT81 Alex Hunter 1. Basic block analysis. (V5.5)
C
C-----------------------------------------------------------------------
SUBROUTINE BREAK
INCLUDE 'PLMCOM.FOR/NOLIST'
CALL MASSAGE(BASIC_BLOCK,0)
CALL GET_SOMEWHERE(BASIC_BLOCK,ANY_WHERE)
BASIC_BLOCK=NULL
END_OF_BASIC_BLOCK=.FALSE.
NEXT_NODE=NODE_MIN
NEXT_ATOM=FIRST_FREE_ATOM
NEXT_FIXED=FIX_MIN
NEXT_FLOAT=FLT_MIN
NEXT_CONSTANT=CON_MIN
CALL FREE_REGS
RETURN
END

218
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/builtins.for Normal file
View File

@@ -0,0 +1,218 @@
C***********************************************************************
C
C BUILTINS.FOR
C
C
C D I S C L A I M E R N O T I C E
C ------------------- -----------
C
C This document and/or portions of the material and data furnished
C herewith, was developed under sponsorship of the U. S. Government.
C Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior
C University, nor their employees, nor their respective contractors,
C subcontractors, or their employees, makes any warranty, express or
C implied, or assumes any liability or responsibility for accuracy,
C completeness or usefulness of any information, apparatus, product
C or process disclosed, or represents that its use will not infringe
C privately-owned rights. Mention of any product, its manufacturer,
C or suppliers shall not, nor is it intended to, imply approval, dis-
C approval, or fitness for any particular use. The U. S. and the
C University at all times retain the right to use and disseminate same
C for any purpose whatsoever. Such distribution shall be made by the
C National Energy Software Center at the Argonne National Laboratory
C and only subject to the distributee furnishing satisfactory proof
C that he has a valid license from the Intel Corporation in effect.
C
C
C-----------------------------------------------------------------------
C
C This module of the PL/M-VAX compiler handles those built-in
C functions which potentially generate in-line code.
C
C-----------------------------------------------------------------------
C
C R E V I S I O N H I S T O R Y
C
C 29SEP81 Alex Hunter 1. Implement the FIRST function. (V5.3)
C 2. Allow LENGTH,FIRST,LAST,SIZE to be >64K.
C 3. Choose correct value of SP for STACK$PTR.
C 21OCT81 Alex Hunter 1. Implement %_signed and %_unsigned. (V5.5)
C 10NOV81 Alex Hunter 1. Determine procedure side effects. (V6.0)
C 12NOV81 Alex Hunter 1. Implement LAST(MEMORY), et al. (V6.1)
C
C***********************************************************************
INTEGER*2 FUNCTION BUILTIN_FUNCTION(DPIX)
INCLUDE 'PLMCOM.FOR/NOLIST'
INTEGER*4 LENGTH,SIZE,LOWER_BOUND
COMMON /BUILTINS/ SYM_SUBS,MEM_SUBS
PIX=DPIX
IF (SYMBOL_PLM_ID(PIX).EQ.'LENGTH'.OR.
# SYMBOL_PLM_ID(PIX).EQ.'FIRST'.OR.
# SYMBOL_PLM_ID(PIX).EQ.'LAST') THEN
CALL MATCH(D_LP)
IF (TT.EQ.FIXCON.OR.TT.EQ.FLOATCON.OR.TT.EQ.STRCON) THEN
LENGTH=1
LOWER_BOUND=0
CALL GETTOK
ELSE
CALL MUSTBE(ID)
CALL LOOKUP_SYMBOL
CALL PUSH(PIX,1)
ARG=DATA_REFERENCE(0,.TRUE.)
CALL POP(PIX,1)
IF ((SYMBOL_FLAGS(SYMBOL_INDEX).AND.S_SPECIAL).NE.0.AND.
# SYMBOL_PLM_ID(PIX).NE.'FIRST') THEN
IF (SYMBOL_PLM_ID(SYMBOL_INDEX).EQ.'MEMORY') THEN
IF (SYMBOL_PLM_ID(PIX).EQ.'LENGTH') THEN
SYM=SYM_MLEN
ELSE
SYM=SYM_MLAST
ENDIF
ELSE
IF (SYMBOL_PLM_ID(PIX).EQ.'LENGTH') THEN
SYM=SYM_SLEN
ELSE
SYM=SYM_SLAST
ENDIF
ENDIF
BUILTIN_FUNCTION=MAKE_ATOM(SYM,0,NULL,NULL,S_LONG,0,0)
GO TO 10
ELSEIF (MEMBER_INDEX.EQ.0) THEN
IF (SYM_SUBS.EQ.NULL) THEN
LENGTH=SYMBOL_NBR_ELEMENTS(SYMBOL_INDEX)
LOWER_BOUND=SYMBOL_LOWER_BOUND(SYMBOL_INDEX)
ELSE
LENGTH=1
LOWER_BOUND=0
ENDIF
ELSE
IF (MEM_SUBS.EQ.NULL) THEN
LENGTH=MEMBER_NBR_ELEMENTS(MEMBER_INDEX)
LOWER_BOUND=MEMBER_LOWER_BOUND(MEMBER_INDEX)
ELSE
LENGTH=1
LOWER_BOUND=0
ENDIF
ENDIF
ENDIF
IF (SYMBOL_PLM_ID(PIX).EQ.'LENGTH') THEN
BUILTIN_FUNCTION=MAKE_FIXED(LENGTH,S_LONG)
ELSEIF (SYMBOL_PLM_ID(PIX).EQ.'FIRST') THEN
BUILTIN_FUNCTION=MAKE_FIXED(LOWER_BOUND,S_LONG)
ELSE
BUILTIN_FUNCTION=MAKE_FIXED(LOWER_BOUND+LENGTH-1,S_LONG)
ENDIF
10 CALL MATCH(D_RP)
ELSEIF (SYMBOL_PLM_ID(PIX).EQ.'SIZE') THEN
CALL MATCH(D_LP)
IF (TT.EQ.FIXCON) THEN
IF (FIXVAL.LE.255) THEN
SIZE=1
ELSEIF (FIXVAL.LE.'FFFF'X) THEN
SIZE=2
ELSE
SIZE=4
ENDIF
CALL GETTOK
ELSEIF (TT.EQ.FLOATCON) THEN
SIZE=4
CALL GETTOK
ELSEIF (TT.EQ.STRCON) THEN
SIZE=STRLEN
CALL GETTOK
ELSE
CALL MUSTBE(ID)
CALL LOOKUP_SYMBOL
CALL PUSH(PIX,1)
ARG=DATA_REFERENCE(0,.TRUE.)
CALL POP(PIX,1)
IF ((SYMBOL_FLAGS(SYMBOL_INDEX).AND.S_SPECIAL).NE.0) THEN
IF (SYMBOL_PLM_ID(SYMBOL_INDEX).EQ.'MEMORY') THEN
SYM=SYM_MSIZ
ELSE
SYM=SYM_SSIZ
ENDIF
BUILTIN_FUNCTION=MAKE_ATOM(SYM,0,NULL,NULL,S_LONG,0,0)
GO TO 20
ELSEIF (MEMBER_INDEX.EQ.0) THEN
IF (SYM_SUBS.EQ.NULL) THEN
SIZE=SYMBOL_NBR_ELEMENTS(SYMBOL_INDEX)
SIZE=SIZE*SYMBOL_ELEMENT_SIZE(SYMBOL_INDEX)
ELSE
SIZE=SYMBOL_ELEMENT_SIZE(SYMBOL_INDEX)
ENDIF
ELSE
IF (MEM_SUBS.EQ.NULL) THEN
SIZE=MEMBER_NBR_ELEMENTS(MEMBER_INDEX)*
# MEMBER_ELEMENT_SIZE(MEMBER_INDEX)
ELSE
SIZE=MEMBER_ELEMENT_SIZE(MEMBER_INDEX)
ENDIF
ENDIF
ENDIF
BUILTIN_FUNCTION=MAKE_FIXED(SIZE,S_LONG)
20 CALL MATCH(D_RP)
ELSEIF (SYMBOL_PLM_ID(PIX).EQ.'STACKPTR') THEN
IF (MODEL.EQ.2 .OR. MODEL.EQ.4) THEN
SP=14
ELSE
SP=10
ENDIF
BUILTIN_FUNCTION=MAKE_REGISTER(SP,S_PTR)
ELSEIF (SYMBOL_PLM_ID(PIX).EQ.'FRAMEPTR') THEN
BUILTIN_FUNCTION=MAKE_REGISTER(13,S_PTR)
ELSEIF (SYMBOL_PLM_ID(PIX)(1:2).EQ.'$_' .OR.
# SYMBOL_PLM_ID(PIX).EQ.'DOUBLE' .OR.
# SYMBOL_PLM_ID(PIX).EQ.'LOW' .OR.
# SYMBOL_PLM_ID(PIX).EQ.'FLOAT' .OR.
# SYMBOL_PLM_ID(PIX).EQ.'FIX' .OR.
# SYMBOL_PLM_ID(PIX).EQ.'INT' .OR.
# SYMBOL_PLM_ID(PIX).EQ.'SIGNED' .OR.
# SYMBOL_PLM_ID(PIX).EQ.'UNSIGN') THEN
CALL MATCH(D_LP)
CALL PUSH(PIX,1)
ARG=EXPRESSION(1)
CALL POP(PIX,1)
CALL MATCH(D_RP)
IF (SYMBOL_PLM_ID(PIX).EQ.'$_SIGNED') THEN
BUILTIN_FUNCTION=MAKE_NODE(OP_SIGNED,ARG,NULL,0,0,0)
ELSEIF (SYMBOL_PLM_ID(PIX).EQ.'$_UNSIGNED') THEN
BUILTIN_FUNCTION=MAKE_NODE(OP_UNSIGNED,ARG,NULL,0,0,0)
ELSE
IF (SYMBOL_PLM_ID(PIX).EQ.'INT' .OR.
# SYMBOL_PLM_ID(PIX).EQ.'SIGNED') THEN
ARG=MAKE_NODE(OP_WORD,ARG,NULL,S_WORD,0,0)
ELSEIF (SYMBOL_PLM_ID(PIX).EQ.'UNSIGN') THEN
ARG=MAKE_NODE(OP_INTEGER,ARG,NULL,S_INTEGER,0,0)
ENDIF
BUILTIN_FUNCTION=MAKE_NODE(OP_BYTE+SYMBOL_TYPE(PIX)-S_BYTE,
# ARG,NULL,SYMBOL_TYPE(PIX),0,0)
ENDIF
ELSE
CALL ERROR('UNIMPLEMENTED BUILTIN FUNCTION: '//
# SYMBOL_PLM_ID(PIX))
BUILTIN_FUNCTION=NULL
ENDIF
CALL DETERMINE_EFFECTS_OF_CALLING(PIX)
RETURN
END

372
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/coerce.for Normal file
View File

@@ -0,0 +1,372 @@
C***********************************************************************
C
C COERCE.FOR
C
C
C D I S C L A I M E R N O T I C E
C ------------------- -----------
C
C This document and/or portions of the material and data furnished
C herewith, was developed under sponsorship of the U. S. Government.
C Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior
C University, nor their employees, nor their respective contractors,
C subcontractors, or their employees, makes any warranty, express or
C implied, or assumes any liability or responsibility for accuracy,
C completeness or usefulness of any information, apparatus, product
C or process disclosed, or represents that its use will not infringe
C privately-owned rights. Mention of any product, its manufacturer,
C or suppliers shall not, nor is it intended to, imply approval, dis-
C approval, or fitness for any particular use. The U. S. and the
C University at all times retain the right to use and disseminate same
C for any purpose whatsoever. Such distribution shall be made by the
C National Energy Software Center at the Argonne National Laboratory
C and only subject to the distributee furnishing satisfactory proof
C that he has a valid license from the Intel Corporation in effect.
C
C
C-----------------------------------------------------------------------
C
C This module of the PL/M-VAX compiler coerces nodes of a code
C tree to the proper type, according to the implicit type coercion
C rules.
C
C-----------------------------------------------------------------------
C R E V I S I O N H I S T O R Y
C
C 15OCT81 Alex Hunter 1. Added disclaimer notice. (V5.4)
C
C-----------------------------------------------------------------------
SUBROUTINE COERCE_TYPES(NODX)
INCLUDE 'PLMCOM.FOR/NOLIST'
INTEGER*2 CVT_TYPE(OP_B2W:OP_P2L)
DATA CVT_TYPE/
# S_WORD,S_INTEGER, S_LONG, S_REAL, S_BYTE,
# S_LONG, S_BYTE, S_REAL, S_LONG, S_LONG,
# S_INTEGER, S_WORD, S_REAL, S_BYTE, S_BYTE,
# S_INTEGER, S_DOUBLE, S_QUAD, S_DOUBLE, S_BYTE,
# S_INTEGER, S_REAL, S_LONG, S_LONG, S_DOUBLE,
# S_PTR, S_LONG/
INTEGER*2 MUL_TYPE(1:7,1:7)
DATA MUL_TYPE
// S_WORD,S_LONG,S_INTEGER,0,S_REAL,S_LONG,S_DOUBLE
,, S_LONG,S_LONG,S_LONG,0,S_REAL,S_LONG,S_DOUBLE
,, S_INTEGER,S_LONG,S_INTEGER,0,S_REAL,S_LONG,S_DOUBLE
,, 0,0,0,0,0,0,0
,, S_REAL,S_REAL,S_REAL,0,S_REAL,S_DOUBLE,S_DOUBLE
,, S_LONG,S_LONG,S_LONG,0,S_DOUBLE,S_LONG,S_DOUBLE
,, S_DOUBLE,S_DOUBLE,S_DOUBLE,0,S_DOUBLE,S_DOUBLE,S_DOUBLE
//
INTEGER*2 ADD_TYPE(1:7,1:7)
DATA ADD_TYPE
// S_BYTE,S_WORD,S_INTEGER,S_PTR,S_REAL,S_LONG,S_DOUBLE
,, S_WORD,S_WORD,S_INTEGER,S_PTR,S_REAL,S_LONG,S_DOUBLE
,, S_INTEGER,S_INTEGER,S_INTEGER,S_PTR,S_REAL,S_LONG,S_DOUBLE
,, S_PTR,S_PTR,S_PTR,0,0,S_PTR,0
,, S_REAL,S_REAL,S_REAL,0,S_REAL,S_DOUBLE,S_DOUBLE
,, S_LONG,S_LONG,S_LONG,S_PTR,S_DOUBLE,S_LONG,S_DOUBLE
,, S_DOUBLE,S_DOUBLE,S_DOUBLE,0,S_DOUBLE,S_DOUBLE,S_DOUBLE
//
INTEGER*2 OPND_TYPE(1:7,1:7)
DATA OPND_TYPE
// S_BYTE,S_WORD,S_INTEGER,S_PTR,S_REAL,S_LONG,S_DOUBLE
,, S_WORD,S_WORD,S_INTEGER,S_PTR,S_REAL,S_LONG,S_DOUBLE
,, S_INTEGER,S_INTEGER,S_INTEGER,S_PTR,S_REAL,S_LONG,S_DOUBLE
,, S_LONG,S_LONG,S_LONG,0,0,S_LONG,0
,, S_REAL,S_REAL,S_REAL,0,S_REAL,S_DOUBLE,S_DOUBLE
,, S_LONG,S_LONG,S_LONG,S_PTR,S_DOUBLE,S_LONG,S_DOUBLE
,, S_DOUBLE,S_DOUBLE,S_DOUBLE,0,S_DOUBLE,S_DOUBLE,S_DOUBLE
//
NOD=NODX
IF (NOD.EQ.NULL) RETURN
IF (CONSTANT(NOD)) RETURN
IF (REGISTER(NOD)) RETURN
IF (FLOATLIT(NOD)) THEN
RETURN
ELSEIF (FIXLIT(NOD)) THEN
IF (NODE_TYPE(NOD).EQ.0) THEN
IF (NODE_CONTEXT(NOD).EQ.CX_SIGNED) THEN
NODE_TYPE(NOD)=S_INTEGER
ELSEIF (FIXED_VAL(NOD).GE.0.AND.FIXED_VAL(NOD).LE.255) THEN
NODE_TYPE(NOD)=S_BYTE
ELSE
NODE_TYPE(NOD)=S_WORD
ENDIF
ENDIF
RETURN
ELSEIF (ATOM(NOD)) THEN
CALL PUSH(NOD,1)
CALL COERCE_TYPES2(ATOM_BASE(NOD))
CALL POP(NOD,1)
ATOM_BASE(NOD)=FORCE_TYPE(ATOM_BASE(NOD),S_PTR)
CALL PUSH(NOD,1)
CALL COERCE_TYPES2(ATOM_SUB(NOD))
CALL POP(NOD,1)
ATOM_SUB(NOD)=FORCE_TYPE(ATOM_SUB(NOD),S_LONG)
RETURN
ENDIF
C ---- NODE IS AN OPNODE.
CALL PUSH(NOD,1)
CALL COERCE_TYPES2(OPNODE_OPND1(NOD))
CALL POP(NOD,1)
CALL PUSH(NOD,1)
CALL COERCE_TYPES2(OPNODE_OPND2(NOD))
CALL POP(NOD,1)
IF (OPNODE_OP(NOD).EQ.OP_ASSN.OR.OPNODE_OP(NOD).EQ.OP_MOV) THEN
NODE_TYPE(NOD)=NODE_TYPE(OPNODE_OPND2(NOD))
OPNODE_OPND1(NOD)=FORCE_TYPE(OPNODE_OPND1(NOD),NODE_TYPE(NOD))
ELSEIF (OPNODE_OP(NOD).EQ.OP_LOC) THEN
NODE_TYPE(NOD)=S_PTR
ELSEIF (OPNODE_OP(NOD).GT.100) THEN
NODE_TYPE(NOD)=CVT_TYPE(OPNODE_OP(NOD))
ELSEIF (OPNODE_OP(NOD).EQ.OP_CALL) THEN
NODE_TYPE(NOD)=NODE_TYPE(OPNODE_OPND1(NOD))
ELSEIF (OPNODE_OP(NOD).EQ.OP_ARG) THEN
IF (BYTE_SIZE(NODE_TYPE(OPNODE_OPND2(NOD))).EQ.4) THEN
NODE_TYPE(NOD)=NODE_TYPE(OPNODE_OPND2(NOD))
ELSE
NODE_TYPE(NOD)=S_LONG
OPNODE_OPND2(NOD)=FORCE_TYPE(OPNODE_OPND2(NOD),S_LONG)
ENDIF
ELSEIF (OPNODE_OP(NOD).GT.80.AND.OPNODE_OP(NOD).LT.100) THEN
NODE_TYPE(NOD)=OPNODE_OP(NOD)-80
OPNODE_OPND1(NOD)=FORCE_TYPE(OPNODE_OPND1(NOD),NODE_TYPE(NOD))
OPNODE_OP(NOD)=OP_NOP
ELSEIF (OPNODE_OP(NOD).EQ.OP_THEN.OR.OPNODE_OP(NOD).EQ.OP_ALSO)
# THEN
RETURN
ELSEIF (OPNODE_OPND2(NOD).EQ.NULL) THEN
NODE_TYPE(NOD)=NODE_TYPE(OPNODE_OPND1(NOD))
ELSE
IF (OPNODE_OP(NOD).EQ.OP_MUL.OR.OPNODE_OP(NOD).EQ.OP_DIV) THEN
NODE_TYPE(NOD)=MUL_TYPE(NODE_TYPE(OPNODE_OPND1(NOD)),
# NODE_TYPE(OPNODE_OPND2(NOD)))
OPND1_TYPE=NODE_TYPE(NOD)
OPND2_TYPE=NODE_TYPE(NOD)
ELSEIF (OPNODE_OP(NOD).EQ.OP_ADWC.OR.OPNODE_OP(NOD).EQ.OP_SBWC)
# THEN
NODE_TYPE(NOD)=S_LONG
OPND1_TYPE=S_LONG
OPND2_TYPE=S_LONG
ELSEIF (OPNODE_OP(NOD).EQ.OP_MOD) THEN
NODE_TYPE(NOD)=S_LONG
OPND1_TYPE=S_QUAD
OPND2_TYPE=S_LONG
ELSE
NODE_TYPE(NOD)=ADD_TYPE(NODE_TYPE(OPNODE_OPND1(NOD)),
# NODE_TYPE(OPNODE_OPND2(NOD)))
OPND1_TYPE=OPND_TYPE(NODE_TYPE(OPNODE_OPND1(NOD)),
# NODE_TYPE(OPNODE_OPND2(NOD)))
OPND2_TYPE=OPND_TYPE(NODE_TYPE(OPNODE_OPND2(NOD)),
# NODE_TYPE(OPNODE_OPND1(NOD)))
ENDIF
IF (NODE_TYPE(NOD).EQ.0) THEN
CALL WARN('ILLEGAL MIXING OF TYPES')
NODE_TYPE(NOD)=NODE_TYPE(OPNODE_OPND1(NOD))
OPND1_TYPE=NODE_TYPE(OPNODE_OPND1(NOD))
OPND2_TYPE=NODE_TYPE(OPNODE_OPND2(NOD))
ENDIF
OPNODE_OPND1(NOD)=FORCE_TYPE(OPNODE_OPND1(NOD),OPND1_TYPE)
OPNODE_OPND2(NOD)=FORCE_TYPE(OPNODE_OPND2(NOD),OPND2_TYPE)
IF (OPNODE_OP(NOD).GE.OP_LT.AND.OPNODE_OP(NOD).LE.OP_GE) THEN
NODE_TYPE(NOD)=S_BYTE
ELSEIF (OPNODE_OP(NOD).EQ.OP_AND) THEN
OPNODE_OP(NOD)=OP_EXT
NEW_OPND2=MAKE_NODE(OP_NOT,OPNODE_OPND2(NOD),NULL,0,0,0)
NODE_TYPE(NEW_OPND2)=OPND2_TYPE
NODE_CONTEXT(NEW_OPND2)=NODE_CONTEXT(OPNODE_OPND2(NOD))
OPNODE_OPND2(NOD)=NEW_OPND2
ENDIF
ENDIF
RETURN
END
C-----------------------------------------------------------------------
SUBROUTINE COERCE_TYPES2(NODX)
CALL COERCE_TYPES(NODX)
RETURN
END
C-----------------------------------------------------------------------
INTEGER*2 FUNCTION FORCE_TYPE(NODX,TYPEX)
INCLUDE 'PLMCOM.FOR/NOLIST'
NOD=NODX
TYPE=TYPEX
IF (NOD.EQ.NULL.OR.NODE_TYPE(NOD).EQ.TYPE) THEN
FORCE_TYPE=NOD
RETURN
ENDIF
GOTO (1000,2000,3000,4000,5000,6000,70000,80000), NODE_TYPE(NOD)
CALL BUG('FT-0')
1000 GOTO (9000,1200,1300,1400,1500,1600,1700,1800), TYPE
CALL BUG('FT-1')
1200 OP=OP_B2W
GOTO 8000
1300 OP=OP_B2I
GOTO 8000
1400 OP1=OP_B2L
OP2=OP_L2P
GOTO 7000
1500 OP1=OP_B2L
OP2=OP_L2R
GOTO 7000
1600 OP=OP_B2L
GOTO 8000
1700 OP1=OP_B2L
OP2=OP_L2D
GO TO 7000
1800 OP1=OP_B2L
OP2=OP_L2Q
GO TO 7000
2000 GOTO (2100,9000,9000,2400,2500,2600,2700,2800), TYPE
CALL BUG('FT-2')
2100 OP=OP_W2B
GOTO 8000
2400 OP1=OP_W2L
OP2=OP_L2P
GOTO 7000
2500 OP1=OP_W2L
OP2=OP_L2R
GOTO 7000
2600 OP=OP_W2L
GOTO 8000
2700 OP1=OP_W2L
OP2=OP_L2D
GO TO 7000
2800 OP1=OP_W2L
OP2=OP_L2Q
GO TO 7000
3000 GOTO (3100,9000,9000,3400,3500,3600,3700,3800), TYPE
CALL BUG('FT-3')
3100 OP=OP_I2B
GOTO 8000
3400 OP1=OP_I2L
OP2=OP_L2P
GOTO 7000
3500 OP=OP_I2R
GOTO 8000
3600 OP=OP_I2L
GOTO 8000
3700 OP=OP_I2D
GO TO 8000
3800 OP1=OP_I2L
OP2=OP_L2Q
GO TO 7000
4000 GOTO (4100,4200,4300,9000,8500,4600,8500,4800), TYPE
CALL BUG('FT-4')
4100 OP1=OP_P2L
OP2=OP_L2B
GOTO 7000
4200 CONTINUE
4300 OP1=OP_P2L
OP2=OP_L2W
GOTO 7000
4600 OP=OP_P2L
GOTO 8000
4800 OP1=OP_P2L
OP2=OP_L2Q
GOTO 7000
5000 GOTO (5100,5200,5300,8500,9000,5600,5700,5800), TYPE
CALL BUG('FT-5')
5100 OP=OP_R2B
GOTO 8000
5200 OP=OP_R2W
GOTO 8000
5300 OP=OP_R2I
GOTO 8000
5600 OP=OP_R2L
GOTO 8000
5700 OP=OP_R2D
GO TO 8000
5800 OP1=OP_R2L
OP2=OP_L2Q
GO TO 7000
6000 GOTO (6100,6200,6300,6400,6500,9000,6700,6800), TYPE
CALL BUG('FT-6')
6100 OP=OP_L2B
GOTO 8000
6200 CONTINUE
6300 OP=OP_L2W
GOTO 8000
6400 OP=OP_L2P
GOTO 8000
6500 OP=OP_L2R
GOTO 8000
6700 OP=OP_L2D
GO TO 8000
6800 OP=OP_L2Q
GO TO 8000
70000 GOTO (71000,72000,73000,8500,75000,76000,9000,78000), TYPE
CALL BUG('FT-7')
71000 OP=OP_D2B
GOTO 8000
72000 OP=OP_D2I
GO TO 8000
73000 OP=OP_D2I
GO TO 8000
75000 OP=OP_D2R
GO TO 8000
76000 OP=OP_D2L
GO TO 8000
78000 OP1=OP_D2L
OP2=OP_L2Q
GO TO 8000
80000 GOTO (81000,82000,83000,84000,85000,86000,87000,9000), TYPE
CALL BUG('FT-8')
81000 OP2=OP_L2B
GO TO 80999
82000 CONTINUE
83000 OP2=OP_L2W
GO TO 80999
84000 OP2=OP_L2P
GO TO 80999
85000 OP2=OP_L2R
GO TO 80999
86000 OP=OP_Q2L
GO TO 8000
87000 OP2=OP_L2D
80999 OP1=OP_Q2L
GO TO 7000
7000 FORCE_TYPE=MAKE_NODE(OP2,MAKE_NODE(OP1,NOD,NULL,S_LONG,0,0),
# NULL,TYPE,0,0)
RETURN
8000 FORCE_TYPE=MAKE_NODE(OP,NOD,NULL,TYPE,0,0)
RETURN
8500 CALL WARN('ILLEGAL TYPE CONVERSION')
9000 NODE_TYPE(NOD)=TYPE
FORCE_TYPE=NOD
RETURN
END

12
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/comlist.com Normal file
View File

@@ -0,0 +1,12 @@
$SET VERIFY
$!
$! COMLIST.COM
$!
$! Command file to produce short listings for the PL/M-VAX
$! compiler.
$!
$! 02FEB82 Alex Hunter 1. Original version.
$!
$PRI/HEAD *.FOR
$PRI CONTROL
$SET NOVERIFY

148
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/context.for Normal file
View File

@@ -0,0 +1,148 @@
C***********************************************************************
C
C CONTEXT.FOR
C
C
C D I S C L A I M E R N O T I C E
C ------------------- -----------
C
C This document and/or portions of the material and data furnished
C herewith, was developed under sponsorship of the U. S. Government.
C Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior
C University, nor their employees, nor their respective contractors,
C subcontractors, or their employees, makes any warranty, express or
C implied, or assumes any liability or responsibility for accuracy,
C completeness or usefulness of any information, apparatus, product
C or process disclosed, or represents that its use will not infringe
C privately-owned rights. Mention of any product, its manufacturer,
C or suppliers shall not, nor is it intended to, imply approval, dis-
C approval, or fitness for any particular use. The U. S. and the
C University at all times retain the right to use and disseminate same
C for any purpose whatsoever. Such distribution shall be made by the
C National Energy Software Center at the Argonne National Laboratory
C and only subject to the distributee furnishing satisfactory proof
C that he has a valid license from the Intel Corporation in effect.
C
C
C-----------------------------------------------------------------------
C
C This module of the PL/M-VAX compiler resolves the signed/unsigned
C context for all the nodes of a code tree, and performs any implicit
C context coercions required.
C
C-----------------------------------------------------------------------
C R E V I S I O N H I S T O R Y
C
C 15OCT81 Alex Hunter 1. Added disclaimer notice. (V5.4)
C 21OCT81 Alex Hunter 1. Add OP_SIGNED and OP_UNSIGNED. (V5.5)
C
C-----------------------------------------------------------------------
SUBROUTINE RESOLVE_CONTEXT(NODX)
INCLUDE 'PLMCOM.FOR/NOLIST'
NOD=NODX
IF (NOD.EQ.NULL) RETURN
IF (CONSTANT(NOD)) RETURN
IF (LITERAL(NOD)) RETURN
IF (REGISTER(NOD)) RETURN
IF (ATOM(NOD)) THEN
CALL PUSH(NOD,1)
CALL RESOLVE_CONTEXT2(ATOM_BASE(NOD))
CALL POP(NOD,1)
IF (NODE_CONTEXT(ATOM_BASE(NOD)).EQ.0)
# CALL SET_CONTEXT(ATOM_BASE(NOD),CX_UNSIGNED)
CALL PUSH(NOD,1)
CALL RESOLVE_CONTEXT2(ATOM_SUB(NOD))
CALL POP(NOD,1)
IF (NODE_CONTEXT(ATOM_SUB(NOD)).EQ.0)
# CALL SET_CONTEXT(ATOM_SUB(NOD),CX_UNSIGNED)
RETURN
ENDIF
CALL PUSH(NOD,1)
CALL RESOLVE_CONTEXT2(OPNODE_OPND1(NOD))
CALL POP(NOD,1)
CALL PUSH(NOD,1)
CALL RESOLVE_CONTEXT2(OPNODE_OPND2(NOD))
CALL POP(NOD,1)
IF (OPNODE_OPND1(NOD).EQ.NULL) THEN
NODE_CONTEXT(NOD)=NODE_CONTEXT(OPNODE_OPND2(NOD))
RETURN
ELSEIF (OPNODE_OP(NOD).GT.80.AND.OPNODE_OP(NOD).LT.100) THEN
NODE_CONTEXT(NOD)=CONTEXT(OPNODE_OP(NOD)-80)
IF (NODE_CONTEXT(OPNODE_OPND1(NOD)).EQ.0) THEN
CALL SET_CONTEXT(OPNODE_OPND1(NOD),NODE_CONTEXT(NOD))
ENDIF
RETURN
ELSEIF (OPNODE_OP(NOD).EQ.OP_SIGNED) THEN
NODE_CONTEXT(NOD)=CX_SIGNED
IF (NODE_CONTEXT(OPNODE_OPND1(NOD)).EQ.0) THEN
CALL SET_CONTEXT(OPNODE_OPND1(NOD),CX_SIGNED)
ENDIF
OPNODE_OP(NOD)=OP_NOP
ELSEIF (OPNODE_OP(NOD).EQ.OP_UNSIGNED) THEN
NODE_CONTEXT(NOD)=CX_UNSIGNED
IF (NODE_CONTEXT(OPNODE_OPND1(NOD)).EQ.0) THEN
CALL SET_CONTEXT(OPNODE_OPND1(NOD),CX_UNSIGNED)
ENDIF
OPNODE_OP(NOD)=OP_NOP
ELSEIF (OPNODE_OPND2(NOD).EQ.NULL.OR.OPNODE_OP(NOD).EQ.OP_CALL)
# THEN
NODE_CONTEXT(NOD)=NODE_CONTEXT(OPNODE_OPND1(NOD))
RETURN
ELSEIF (OPNODE_OP(NOD).EQ.OP_ARG) THEN
IF (NODE_CONTEXT(OPNODE_OPND2(NOD)).EQ.0) THEN
CALL SET_CONTEXT(OPNODE_OPND2(NOD),CX_SIGNED) !DEBATABLE.
ENDIF
RETURN
ENDIF
IF (NODE_CONTEXT(OPNODE_OPND1(NOD)).EQ.0) THEN
NODE_CONTEXT(NOD)=NODE_CONTEXT(OPNODE_OPND2(NOD))
ELSE
NODE_CONTEXT(NOD)=NODE_CONTEXT(OPNODE_OPND1(NOD))
ENDIF
IF (NODE_CONTEXT(NOD).EQ.0) RETURN
IF (NODE_CONTEXT(OPNODE_OPND1(NOD)).EQ.0) THEN
CALL SET_CONTEXT(OPNODE_OPND1(NOD),NODE_CONTEXT(NOD))
ELSEIF (NODE_CONTEXT(OPNODE_OPND2(NOD)).EQ.0) THEN
CALL SET_CONTEXT(OPNODE_OPND2(NOD),NODE_CONTEXT(NOD))
ENDIF
RETURN
END
C--------------------------------------------------------------
SUBROUTINE RESOLVE_CONTEXT2(NODX)
CALL RESOLVE_CONTEXT(NODX)
RETURN
END
C--------------------------------------------------------------
SUBROUTINE SET_CONTEXT(NODX,CNTXTX)
INCLUDE 'PLMCOM.FOR/NOLIST'
NOD=NODX
CNTXT=CNTXTX
10 IF (NOD.EQ.NULL) RETURN
NODE_CONTEXT(NOD)=CNTXT
IF (.NOT. NODE(NOD)) RETURN
CALL PUSH(NOD,1)
CALL SET_CONTEXT2(OPNODE_OPND1(NOD),CNTXT)
CALL POP(NOD,1)
NOD=OPNODE_OPND2(NOD)
GO TO 10
END
C--------------------------------------------------------------
SUBROUTINE SET_CONTEXT2(NODX,CNTXTX)
CALL SET_CONTEXT(NODX,CNTXTX)
RETURN
END

1093
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/control.plm Normal file
View File

File diff suppressed because it is too large Load Diff

2687
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/control.tmp Normal file
View File

File diff suppressed because it is too large Load Diff

150
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/counts.for Normal file
View File

@@ -0,0 +1,150 @@
C***********************************************************************
C
C COUNTS.FOR
C
C D I S C L A I M E R N O T I C E
C ------------------- -----------
C
C This document and/or portions of the material and data furnished
C herewith, was developed under sponsorship of the U. S. Government.
C Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior
C University, nor their employees, nor their respective contractors,
C subcontractors, or their employees, makes any warranty, express or
C implied, or assumes any liability or responsibility for accuracy,
C completeness or usefulness of any information, apparatus, product
C or process disclosed, or represents that its use will not infringe
C privately-owned rights. Mention of any product, its manufacturer,
C or suppliers shall not, nor is it intended to, imply approval, dis-
C approval, or fitness for any particular use. The U. S. and the
C University at all times retain the right to use and disseminate same
C for any purpose whatsoever. Such distribution shall be made by the
C National Energy Software Center at the Argonne National Laboratory
C and only subject to the distributee furnishing satisfactory proof
C that he has a valid license from the Intel Corporation in effect.
C
C
C-----------------------------------------------------------------------
C
C This module of the PL/M-VAX compiler computes reference counts
C for the nodes of a code tree.
C
C-----------------------------------------------------------------------
C
C R E V I S I O N H I S T O R Y
C
C 08SEP81 Alex Hunter 1. Written. (V5.1)
C 28SEP81 Alex Hunter 2. STACKPTR caused CRC-0 bug. (V5.3)
C 15OCT81 Alex Hunter 1. Experimental version. (V5.4)
C 23OCT81 Alex Hunter 1. Compute correct reference counts for
C operand 1 of OP_LOC and LHS of OP_MOV
C and OP_ASSN. (V5.6)
C 10NOV81 Alex Hunter 1. Implement DBG assumption. (V6.0)
C 08FEB82 Alex Hunter 1. Correct count for merged ARG opnodes. (V6.7)
C
C***********************************************************************
SUBROUTINE COMPUTE_REFERENCE_COUNTS (NODX)
INCLUDE 'PLMCOM.FOR/NOLIST'
NOD = NODX ! Call by value.
IF (NOD.EQ.NULL .OR. REGISTER(NOD)) THEN
RETURN
ELSEIF (LITERAL(NOD) .OR. CONSTANT(NOD)) THEN
NODE_REFCT(NOD) = NODE_REFCT(NOD) + 1
ELSEIF (ATOM(NOD)) THEN
NODE_REFCT(NOD) = NODE_REFCT(NOD) + 1
CALL PUSH(NOD,1)
CALL COMPUTE_REFERENCE_COUNTS2 (ATOM_BASE(NOD))
CALL POP(NOD,1)
CALL PUSH(NOD,1)
CALL COMPUTE_REFERENCE_COUNTS2 (ATOM_SUB(NOD))
CALL POP(NOD,1)
ELSEIF (NODE(NOD)) THEN
NODE_REFCT(NOD) = NODE_REFCT(NOD) + 1
IF (NODE_REFCT(NOD).EQ.1.OR.OPNODE_OP(NOD).EQ.OP_ARG) THEN
CALL PUSH(NOD,1)
IF (OPNODE_OP(NOD).EQ.OP_LOC) THEN
CALL COMPUTE_ATOM_REFERENCE_COUNTS (OPNODE_OPND1(NOD))
ELSE
CALL COMPUTE_REFERENCE_COUNTS2 (OPNODE_OPND1(NOD))
ENDIF
CALL POP(NOD,1)
CALL PUSH(NOD,1)
IF (OPNODE_OP(NOD).EQ.OP_MOV .OR. OPNODE_OP(NOD).EQ.OP_ASSN)
# THEN
CALL COMPUTE_ATOM_REFERENCE_COUNTS (OPNODE_OPND2(NOD))
ELSE
CALL COMPUTE_REFERENCE_COUNTS2 (OPNODE_OPND2(NOD))
ENDIF
CALL POP(NOD,1)
ENDIF
ELSE
CALL BUG ('CRC-0 -- Invalid kind of node.')
ENDIF
RETURN
END
C-----------------------------------------------------------------------
SUBROUTINE COMPUTE_REFERENCE_COUNTS2 (NODX)
IMPLICIT INTEGER*2 (A-Z)
CALL COMPUTE_REFERENCE_COUNTS (NODX)
RETURN
END
C-----------------------------------------------------------------------
SUBROUTINE COMPUTE_ATOM_REFERENCE_COUNTS (NODX)
INCLUDE 'PLMCOM.FOR/NOLIST'
NOD = NODX ! Call by value.
IF (ATOM(NOD)) THEN
CALL PUSH(NOD,1)
CALL COMPUTE_REFERENCE_COUNTS (ATOM_BASE(NOD))
CALL POP(NOD,1)
CALL PUSH(NOD,1)
CALL COMPUTE_REFERENCE_COUNTS (ATOM_SUB(NOD))
CALL POP(NOD,1)
ENDIF
RETURN
END
C-----------------------------------------------------------------------
SUBROUTINE DECREMENT_VALUE_COUNTS (NODX)
INCLUDE 'PLMCOM.FOR/NOLIST'
NOD = NODX ! Call by value.
CALL DECREMENT_REFERENCE_COUNTS(NOD)
IF (ATOM(NOD)) THEN
CALL DECREMENT_REFERENCE_COUNTS(ATOM_BASE(NOD))
CALL DECREMENT_REFERENCE_COUNTS(ATOM_SUB(NOD))
ENDIF
RETURN
END
C-----------------------------------------------------------------------
SUBROUTINE DECREMENT_REFERENCE_COUNTS (NODX)
INCLUDE 'PLMCOM.FOR/NOLIST'
NOD = NODX ! Call by value.
IF (NOD.EQ.NULL .OR. REGISTER(NOD)) RETURN
NODE_REFCT(NOD) = NODE_REFCT(NOD) - 1
IF (ASSUME_DBG) WRITE(OUT,1001) NOD, NODE_REFCT(NOD)
1001 FORMAT(' ;*DRC* nod',I6,' refct decremented to',I6)
IF (NODE_REFCT(NOD).EQ.-1) THEN
CALL BUG('DRC -- Node reference count decremented to -1.')
ENDIF
IF (NODE_REFCT(NOD).EQ.0 .AND. NODE_REG(NOD).NE.0) THEN
IF (ASSUME_DBG) WRITE(OUT,1002) NODE_REG(NOD)
1002 FORMAT(' ;*DRC* register ',I2,' can be reused...')
CALL FREE_REG(NODE_REG(NOD))
ENDIF
RETURN
END

177
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/data.for Normal file
View File

@@ -0,0 +1,177 @@
C***********************************************************************
C
C DATA.FOR
C
C
C D I S C L A I M E R N O T I C E
C ------------------- -----------
C
C This document and/or portions of the material and data furnished
C herewith, was developed under sponsorship of the U. S. Government.
C Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior
C University, nor their employees, nor their respective contractors,
C subcontractors, or their employees, makes any warranty, express or
C implied, or assumes any liability or responsibility for accuracy,
C completeness or usefulness of any information, apparatus, product
C or process disclosed, or represents that its use will not infringe
C privately-owned rights. Mention of any product, its manufacturer,
C or suppliers shall not, nor is it intended to, imply approval, dis-
C approval, or fitness for any particular use. The U. S. and the
C University at all times retain the right to use and disseminate same
C for any purpose whatsoever. Such distribution shall be made by the
C National Energy Software Center at the Argonne National Laboratory
C and only subject to the distributee furnishing satisfactory proof
C that he has a valid license from the Intel Corporation in effect.
C
C
C-----------------------------------------------------------------------
C
C This module of the PL/M-VAX compiler handles the INITIAL and
C DATA attributes of a declaration.
C
C-----------------------------------------------------------------------
C
C R E V I S I O N H I S T O R Y
C
C 29SEP81 Alex Hunter 1. Allow DATA attribute with EXTERNAL. (V5.3)
C 14NOV81 Alex Hunter 1. Change psect if constant data is to be
C placed in $PLM_ROM. (V6.2)
C
C***********************************************************************
SUBROUTINE INITIALIZATION(REF,THIS_PSECT)
INCLUDE 'PLMCOM.FOR/NOLIST'
INTEGER*4 BLOCK_SIZE
LOGICAL*2 NO_MORE_DATA,STRINGLEFT
COMMON /INITDATA/ NO_MORE_DATA,STRINGLEFT,BLOCK_SIZE
IF ((ROM_FLAG.OR.MODEL.EQ.4).AND.TT.EQ.K_DATA) THEN
THIS_PSECT=P_CONSTANTS ! Place data in $PLM_ROM.
ENDIF
IF (REF.EQ.S_EXT .AND. TT.EQ.K_DATA) THEN
CALL GETTOK
NO_MORE_DATA=.TRUE.
ELSEIF (TT.EQ.K_INITIAL.OR.TT.EQ.K_DATA) THEN
CALL GETTOK
CALL MATCH(D_LP)
NO_MORE_DATA=.FALSE.
STRINGLEFT=.FALSE.
ELSE
NO_MORE_DATA=.TRUE.
ENDIF
RETURN
C--------------------------------
ENTRY POST_INITIALIZATION
C--------------------------------
IF (NO_MORE_DATA) RETURN
CALL ERROR('TOO MUCH DATA IN INITIALIZATION LIST')
10 CALL INITIAL_DATA(S_WORD)
IF (.NOT.NO_MORE_DATA) GO TO 10
RETURN
END
C------------------------------------------------------------------
SUBROUTINE INITIAL_DATA(TYPE)
INCLUDE 'PLMCOM.FOR/NOLIST'
INTEGER*4 BLOCK_SIZE
LOGICAL*2 NO_MORE_DATA,STRINGLEFT
COMMON /INITDATA/ NO_MORE_DATA,STRINGLEFT,BLOCK_SIZE
CHARACTER*300 STRING1
COMMON /FLUSH_A/ S_INDEX,S_NEXT
COMMON /FLUSH_AC/ STRING1
CHARACTER*80 OPERAND,OPERAND1,RESTRICTED_LOCATION_REFERENCE
CHARACTER*7 DATA_POP(S_BYTE:S_QUAD)
DATA DATA_POP
// '.BYTE','.WORD','.WORD','.LONG','.FLOAT','.LONG','.DOUBLE'
,, '.QUAD'
//
BS = BYTE_SIZE(TYPE)
IF (NO_MORE_DATA) THEN
BLOCK_SIZE=BLOCK_SIZE+BS
RETURN
ENDIF
IF (STRINGLEFT.OR.TT.EQ.STRCON) THEN
IF (.NOT.STRINGLEFT) THEN
STRING1=STRING
S_INDEX=1
S_NEXT=1
S_LENGTH=STRLEN
STRINGLEFT=.TRUE.
ENDIF
S_NEXT=S_NEXT+BS
IF (S_NEXT-S_INDEX.GE.32) CALL FLUSH_ASCII
IF (S_NEXT.LE.S_LENGTH) RETURN
CALL FLUSH_ASCII
STRINGLEFT=.FALSE.
CALL GETTOK
ELSE
CALL BREAK
CONST=EXPRESSION(0)
CALL RESOLVE_CONTEXT(CONST)
IF (NODE_CONTEXT(CONST).EQ.0)
# CALL SET_CONTEXT(CONST,CONTEXT(TYPE))
CALL COERCE_TYPES(CONST)
CONST=FORCE_TYPE(CONST,TYPE)
CONST=FOLD_CONSTANTS(CONST)
IF (NODE(CONST).AND.OPNODE_OP(CONST).GT.100.AND.
# OPNODE_OP(CONST).LT.OP_L2P) THEN
CONST=OPNODE_OPND1(CONST)
ENDIF
IF (NODE(CONST).AND.OPNODE_OP(CONST).EQ.OP_LOC) THEN
OPERAND1=RESTRICTED_LOCATION_REFERENCE(CONST,N1)
CALL EMIT(DATA_POP(TYPE)//' '//OPERAND1(:N1))
ELSEIF (LITERAL(CONST)) THEN
OPERAND1=OPERAND(CONST,N1)
CALL EMIT(DATA_POP(TYPE)//' '//OPERAND1(2:N1))
ELSE
CALL ERROR('INITIALIZATION LIST ELEMENT NOT A CONSTANT')
CALL EMIT(DATA_POP(TYPE)//' 0')
ENDIF
ENDIF
IF (TT.EQ.D_COMMA) THEN
CALL GETTOK
IF (TT.NE.D_RP) RETURN ! ALLOW ',)' AT END OF LIST.
ENDIF
CALL MATCH(D_RP)
NO_MORE_DATA=.TRUE.
RETURN
END
C-----------------------------------------------------------------
SUBROUTINE FLUSH_ASCII
IMPLICIT INTEGER*2 (A-Z)
CHARACTER*300 STRING1
COMMON /FLUSH_A/ S_INDEX,S_NEXT
COMMON /FLUSH_AC/ STRING1
IF (S_NEXT.GT.S_INDEX) THEN
CALL EMIT('.ASCII `'//STRING1(S_INDEX:S_NEXT-1)//'`')
S_INDEX=S_NEXT
ENDIF
RETURN
END

687
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/decls.for Normal file
View File

@@ -0,0 +1,687 @@
C***********************************************************************
C
C DECLS.FOR
C
C
C D I S C L A I M E R N O T I C E
C ------------------- -----------
C
C This document and/or portions of the material and data furnished
C herewith, was developed under sponsorship of the U. S. Government.
C Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior
C University, nor their employees, nor their respective contractors,
C subcontractors, or their employees, makes any warranty, express or
C implied, or assumes any liability or responsibility for accuracy,
C completeness or usefulness of any information, apparatus, product
C or process disclosed, or represents that its use will not infringe
C privately-owned rights. Mention of any product, its manufacturer,
C or suppliers shall not, nor is it intended to, imply approval, dis-
C approval, or fitness for any particular use. The U. S. and the
C University at all times retain the right to use and disseminate same
C for any purpose whatsoever. Such distribution shall be made by the
C National Energy Software Center at the Argonne National Laboratory
C and only subject to the distributee furnishing satisfactory proof
C that he has a valid license from the Intel Corporation in effect.
C
C
C-----------------------------------------------------------------------
C
C This module of the PL/M-VAX compiler processes declarations at
C the beginning of a procedure or block.
C
C-----------------------------------------------------------------------
C
C R E V I S I O N H I S T O R Y
C
C 13SEP81 Alex Hunter 1. Implement ALIGN control. (V5.2)
C 29SEP81 Alex Hunter 1. Change call to INITIALIZATION. (V5.3)
C 2. Reduce macro body size by 1.
C 3. Allow dimensions >64K.
C 4. Allow structure member arrays to have
C explicit lower bounds.
C 21OCT81 Alex Hunter 1. Set S_OVERLAID attribute properly. (V5.5)
C 28OCT81 Alex Hunter 1. Allow keywords to be re-declared. (V5.7)
C 12NOV81 Alex Hunter 1. Implement psect numbers. (V6.1)
C 2. Allow PUBLIC AT(.MEMORY).
C 3. Allow AT(arg) and AT(dynamic).
C 4. Allow structure array to be implicitly
C dimensioned.
C 14NOV81 Alex Hunter 1. Add this_psect arg to INITIALIZATION.
C (V6.2)
C 14JAN82 Alex Hunter 1. Fix minor bug from V5.7. (V6.5)
C
C***********************************************************************
C --- Compile me with /NOCHECK please!!
SUBROUTINE DECLARATIONS
INCLUDE 'PLMCOM.FOR/NOLIST'
10 IF (TT.EQ.K_DECLARE) THEN
CALL DECLARE_STATEMENT
ELSEIF (TT.EQ.K_PROCEDURE) THEN
CALL PROCEDURE_DEFINITION
ELSEIF (TT.EQ.K_COMMON) THEN
CALL COMMON_STATEMENT
ELSE
RETURN
ENDIF
GO TO 10
END
C----------------------------------------------------
SUBROUTINE DECLARE_STATEMENT
INCLUDE 'PLMCOM.FOR/NOLIST'
CALL MATCH(K_DECLARE)
10 CALL DECLARE_ELEMENT(P_DATA)
IF (TT.EQ.D_COMMA) THEN
CALL GETTOK
GO TO 10
ENDIF
CALL MATCH(D_SEMI)
RETURN
END
C----------------------------------------------------
SUBROUTINE COMMON_STATEMENT
INCLUDE 'PLMCOM.FOR/NOLIST'
CHARACTER*32 COMMON_NAME
CALL MATCH(K_COMMON)
COMMON_NAME='.BLANK.'
IF (TT.EQ.D_SLASH) THEN
CALL GETTOK
IF (TT.NE.D_SLASH) THEN
CALL MUSTBE(ID)
COMMON_NAME=IDENTIFIER
CALL GETTOK
ENDIF
CALL MATCH(D_SLASH)
ENDIF
COMMON_PSECT=SETUP_COMMON_PSECT(COMMON_NAME)
10 CALL DECLARE_ELEMENT(COMMON_PSECT)
IF (TT.EQ.D_COMMA) THEN
CALL GETTOK
GO TO 10
ENDIF
CALL MATCH(D_SEMI)
RETURN
END
C----------------------------------------------------
SUBROUTINE DECLARE_ELEMENT(DEFAULT_PSECT)
INCLUDE 'PLMCOM.FOR/NOLIST'
LOGICAL*4 FACTORED_LIST
INTEGER*2 KIND,TYPE,
# LINK,LIST_SIZE,REF,BASE,BASE_MEMBER,FLAGS
INTEGER*2 INDEX(32),REFX(32),BASEX(32),BASE_MEMBERX(32)
COMMON/DECLS/KIND,TYPE,NBR_ELEMENTS,ELEMENT_SIZE,
# LINK,LIST_SIZE,REF,BASE,BASE_MEMBER,FLAGS
LOGICAL*2 NO_MORE_DATA,STRINGLEFT
INTEGER*4 BLOCK_SIZE,NBR_ELEMENTS,LOWER_BOUND,IFSD,ELEMENT_SIZE
COMMON /INITDATA/ NO_MORE_DATA,STRINGLEFT,BLOCK_SIZE
COMMON /AT_FLAG/ AT,ATM
CHARACTER*10 STRING10
CHARACTER*80 OPERAND,OPERAND1
CHARACTER*32 PUBLIQUE
CHARACTER*4 ALIGNMENT(1:8)
DATA ALIGNMENT
# /'BYTE','WORD','----','LONG','----','----','----','LONG'/
C
FLAGS=0
N=0
REF=0
THIS_PSECT=DEFAULT_PSECT
IF (TT.EQ.D_LP) THEN
CALL GETTOK
FACTORED_LIST=.TRUE.
ELSE
FACTORED_LIST=.FALSE.
ENDIF
10 CONTINUE
IF (TT.LT.101.OR.TT.GT.199) CALL MUSTBE(ID)
IF (N.GE.32) THEN
CALL ERROR('TOO MANY ELEMENTS IN FACTORED LIST')
ELSE
CALL ENTER_SYMBOL
IF (SYMBOL_REF(SYMBOL_INDEX).EQ.S_ARG)
# SYMBOL_FLAGS(SYMBOL_INDEX)=0
N=N+1
INDEX(N)=SYMBOL_INDEX
ENDIF
CALL GETTOK
IF (TT.EQ.K_BASED) THEN
CALL GETTOK
CALL SIMPLE_VARIABLE(BTYPE)
REFX(N)=S_BASED
BASEX(N)=SYMBOL_INDEX
BASE_MEMBERX(N)=MEMBER_INDEX
IF (MEMBER_INDEX.EQ.0) THEN
IF (BTYPE.NE.S_WORD.AND.BTYPE.NE.S_PTR.AND.
# BTYPE.NE.S_LONG) THEN
CALL ERROR('BASE SPECIFIER NOT LONG/ADDRESS/POINTER: '
# //SYMBOL_PLM_ID(SYMBOL_INDEX))
ENDIF
ELSE
IF (BTYPE.NE.S_WORD.AND.BTYPE.NE.S_PTR.AND.
# BTYPE.NE.S_LONG) THEN
CALL ERROR('BASE SPECIFIER NOT LONG/ADDRESS/POINTER: '
# //SYMBOL_PLM_ID(SYMBOL_INDEX)//'.'//
# MEMBER_PLM_ID(MEMBER_INDEX))
ENDIF
ENDIF
ELSE
REFX(N)=S_STATIC
BASEX(N)=0
BASE_MEMBERX(N)=0
ENDIF
IF (FACTORED_LIST) THEN
IF (TT.EQ.D_COMMA) THEN
CALL GETTOK
GO TO 10
ENDIF
CALL MATCH(D_RP)
ENDIF
LINK=0
NO_MORE_DATA=.TRUE.
IF (TT.EQ.K_LITERALLY) THEN
CALL GETTOK
CALL MUSTBE(STRCON)
CCCC STRLEN=STRLEN+1 ! Is this necessary?
S_TOP=STRINGS_TOP(BLOCK_LEVEL)
IF (S_TOP+STRLEN.GT.STRINGS_MAX)
# CALL FATAL('STRING SPACE EXHAUSTED')
STRINGS(S_TOP+1:S_TOP+STRLEN)=STRING
STRINGS_TOP(BLOCK_LEVEL)=S_TOP+STRLEN
KIND=S_MACRO
TYPE=0
NBR_ELEMENTS=0
ELEMENT_SIZE=STRLEN
LINK=S_TOP+1
LIST_SIZE=0
DO J=1,N
IF (BASEX(J).NE.0) THEN
CALL ERROR('LITERAL CANNOT BE BASED: '//
# SYMBOL_PLM_ID(INDEX(J)))
ENDIF
REFX(J)=0
BASEX(J)=0
BASE_MEMBERX(J)=0
ENDDO
CC--- CALL GETTOK -- DONE LATER, CAUSE NEXT TOKEN MIGHT BE THIS
CC MACR0!!
ELSEIF (TT.EQ.K_LABEL) THEN
CALL GETTOK
REF=S_FORWARD
IF (TT.EQ.K_PUBLIC) THEN
FLAGS=FLAGS.OR.S_PUBLIC
CALL GETTOK
ELSEIF (TT.EQ.K_EXTERNAL) THEN
REF=S_EXT
CALL GETTOK
ENDIF
IF (REF.NE.S_EXT) THEN
FLAGS=FLAGS.OR.S_UNDEF
ENDIF
KIND=S_LABEL
TYPE=0
NBR_ELEMENTS=0
ELEMENT_SIZE=0
LINK=0
LIST_SIZE=0
DO J=1,N
IF (BASEX(J).NE.0) THEN
CALL ERROR('LABEL CANNOT BE BASED: '//
# SYMBOL_PLM_ID(INDEX(J)))
ENDIF
REFX(J)=S_STATIC
BASEX(J)=0
BASE_MEMBERX(J)=0
ENDDO
ELSE
IF (TT.EQ.D_LP) THEN
KIND=S_ARRAY
CALL DIMENSION(NBR_ELEMENTS,LOWER_BOUND)
ELSE
NBR_ELEMENTS=1
LOWER_BOUND=0
KIND=S_SCALAR
ENDIF
CALL VARIABLE_TYPE
CALL VARIABLE_ATTRIBUTES(FLAGS,REF,THIS_PSECT)
CALL INITIALIZATION(REF,THIS_PSECT)
IF (NBR_ELEMENTS.EQ.-1.AND.N.NE.1) THEN
CALL ERROR('INVALID USE OF IMPLICIT DIMENSION')
NBR_ELEMENTS=0
ENDIF
ENDIF
C
C---- ASSIGN ATTRIBUTES TO THE SYMBOLS.
C
DO 700 J=1,N
I=INDEX(J)
IF (REF.EQ.S_EXT) THEN
SYMBOL_VAX_ID(I)=PUBLIQUE(SYMBOL_PLM_ID(I))
IF (SAME_OVERLAY) FLAGS=FLAGS.OR.S_SAME_OVERLAY
ENDIF
SYMBOL_KIND(I)=KIND
SYMBOL_TYPE(I)=TYPE
SYMBOL_ELEMENT_SIZE(I)=ELEMENT_SIZE
SYMBOL_LINK(I)=LINK
SYMBOL_LIST_SIZE(I)=LIST_SIZE
SYMBOL_PSECT(I)=THIS_PSECT
IF ((REF.EQ.S_EXT.OR.(FLAGS.AND.S_PUBLIC).NE.0) .AND.
# REFX(J).NE.S_STATIC) THEN
CALL ERROR('EXTERNAL/PUBLIC VARIABLE MUST BE STATIC: '//
# SYMBOL_PLM_ID(I))
ENDIF
IF (AT.NE.0.AND.REFX(J).EQ.S_BASED) THEN
CALL ERROR('BASED VARIABLE CANNOT HAVE AT-ATTRIBUTE: '//
# SYMBOL_PLM_ID(I))
ENDIF
IF (REF.EQ.0) THEN
REF1=REFX(J)
ELSE
REF1=REF
ENDIF
IF (REF1.EQ.S_ARG) THEN
IF (NBR_ELEMENTS*ELEMENT_SIZE.GT.4) THEN
CALL WARN('DUBIOUS ARGUMENT OVERLAY: '//
# SYMBOL_PLM_ID(I))
ENDIF
ELSEIF (SYMBOL_REF(I).EQ.S_ARG) THEN
IF (KIND.NE.S_SCALAR.OR.TYPE.EQ.S_STRUC.OR.
# BYTE_SIZE(TYPE).GT.4.OR.REF1.NE.S_STATIC.OR.
# THIS_PSECT.NE.P_DATA) THEN
CALL ERROR('ILLEGAL DECLARATION FOR FORMAL PARAMETER: '//
# SYMBOL_PLM_ID(I))
ENDIF
REF1=S_ARG
SYMBOL_LINK(I)=PROC_LEVEL
ELSE
IF ((PROC_FLAGS(PROC_LEVEL).AND.
# (PROC_EXT.OR.PROC_FORWARD)).NE.0) THEN
CALL ERROR('LOCAL DECLARATION NOT ALLOWED IN EXTERNAL'//
# '/FORWARD PROCEDURE: '//SYMBOL_PLM_ID(I))
ENDIF
IF ((PROC_FLAGS(PROC_LEVEL).AND.PROC_REENT).NE.0.AND.
# REF1.EQ.S_STATIC.AND.THIS_PSECT.EQ.P_DATA) THEN
REF1=S_DYNAMIC
ENDIF
ENDIF
SYMBOL_REF(I)=REF1
SYMBOL_BASE(I)=BASEX(J)
SYMBOL_BASE_MEMBER(I)=BASE_MEMBERX(J)
SYMBOL_FLAGS(I)=FLAGS
700 CONTINUE
C
C---- SET PSECT AND PERFORM ALIGNMENT IF REQUIRED.
C
CALL PSECT(THIS_PSECT)
IF (AT.NE.0.AND.SYMBOL_REF(ATOM_SYM(ATM)).EQ.S_STATIC) THEN
OPERAND1=OPERAND(ATM,N1)
CALL EMIT1('PC.SAVE = .')
CALL EMIT1('. = '//OPERAND1(2:N1))
ENDIF
IF (ALIGN_FLAG .AND. AT.EQ.0 .AND.
# BYTE_SIZE(TYPE).GT.1 .AND. TYPE.NE.S_STRUC) THEN
DO J=1,N
IF (SYMBOL_REF(INDEX(J)).EQ.S_STATIC.AND.
# THIS_PSECT.EQ.P_DATA) THEN
CALL EMIT('.ALIGN '//ALIGNMENT(BYTE_SIZE(TYPE)))
GO TO 801
ENDIF
ENDDO
801 CONTINUE
ENDIF
C
C---- DEFINE SYMBOLS WITH POSSIBLE INITIAL VALUES.
C
OFFSET=0
DO 910 J=1,N
I=INDEX(J)
REF1=SYMBOL_REF(I)
IF (.NOT.NO_MORE_DATA.AND.REF1.NE.S_STATIC) THEN
CALL ERROR('ATTEMPT TO INITIALIZE NON-STATIC VARIABLE: '
# //SYMBOL_PLM_ID(I))
ENDIF
IF (REF1.EQ.S_STATIC) THEN
CALL EMIT_RELDEF4(I,'.',-LOWER_BOUND*ELEMENT_SIZE)
BLOCK_SIZE=0
IF (NBR_ELEMENTS.EQ.-1) THEN ! IMPLICIT DIMENSION.
NBR_ELEMENTS=0
IF (NO_MORE_DATA) THEN
CALL ERROR(
# 'IMPLICIT DIMENSION WITHOUT INITIALIZATION LIST')
ELSEIF (TYPE.EQ.S_STRUC) THEN
901 DO M=LINK,LINK+LIST_SIZE-1
DO M1=1,MEMBER_NBR_ELEMENTS(M)
CALL INITIAL_DATA(MEMBER_TYPE(M))
ENDDO
ENDDO
NBR_ELEMENTS=NBR_ELEMENTS+1
IF (.NOT.NO_MORE_DATA) GO TO 901
ELSE
902 CALL INITIAL_DATA(TYPE)
NBR_ELEMENTS=NBR_ELEMENTS+1
IF (.NOT.NO_MORE_DATA) GO TO 902
ENDIF
ELSEIF (NO_MORE_DATA) THEN ! NO INITIALIZATION.
BLOCK_SIZE=NBR_ELEMENTS*ELEMENT_SIZE
ELSE ! PROCESS INITIAL/DATA.
DO K=1,NBR_ELEMENTS
IF (TYPE.EQ.S_STRUC) THEN
DO M=LINK,LINK+LIST_SIZE-1
DO M1=1,MEMBER_NBR_ELEMENTS(M)
CALL INITIAL_DATA(MEMBER_TYPE(M))
ENDDO
ENDDO
ELSE
CALL INITIAL_DATA(TYPE)
ENDIF
ENDDO
CALL FLUSH_ASCII
ENDIF
IF (BLOCK_SIZE.NE.0) THEN
OPERAND1=STRING10(BLOCK_SIZE,IFSD)
CALL EMIT('.BLKB '//OPERAND1(IFSD:10))
ENDIF
ELSEIF (REF1.EQ.S_BASED) THEN
CALL EMIT_ABSDEF4(SYMBOL_VAX_ID(I),
# -LOWER_BOUND*ELEMENT_SIZE)
ELSEIF (AT.NE.0) THEN
SYMBOL_VAX_ID(I)=SYMBOL_VAX_ID(ATOM_SYM(ATM))
SYMBOL_FLAGS(I)=SYMBOL_FLAGS(ATOM_SYM(ATM)).OR.S_NOTPUBLIC
SYMBOL_DISP(I)=SYMBOL_DISP(I)+SYMBOL_DISP(ATOM_SYM(ATM))+
# ATOM_DISP(ATM)+OFFSET
IF (ATOM_MEM(ATM).NE.0) THEN
SYMBOL_DISP(I)=SYMBOL_DISP(I)+
# MEMBER_OFFSET(ATOM_MEM(ATM))
ENDIF
IF (REF1.EQ.S_ARG) THEN
SYMBOL_LINK(I)=SYMBOL_LINK(ATOM_SYM(ATM))
ENDIF
OFFSET=OFFSET+NBR_ELEMENTS*ELEMENT_SIZE
ELSEIF (REF1.EQ.S_DYNAMIC) THEN
CALL EMIT_ABSDEF4(SYMBOL_VAX_ID(I),
# PROC_DYN_OFF(PROC_LEVEL)-LOWER_BOUND*ELEMENT_SIZE)
PROC_DYN_OFF(PROC_LEVEL)=PROC_DYN_OFF(PROC_LEVEL)+
# NBR_ELEMENTS*ELEMENT_SIZE
ENDIF
SYMBOL_NBR_ELEMENTS(I)=NBR_ELEMENTS
SYMBOL_LOWER_BOUND(I)=LOWER_BOUND
910 CONTINUE
CALL POST_INITIALIZATION
IF (AT.NE.0.AND.SYMBOL_REF(ATOM_SYM(ATM)).EQ.S_STATIC) THEN
CALL EMIT1('. = PC.SAVE')
ENDIF
IF (KIND.EQ.S_MACRO) CALL GETTOK ! WE PROMISED WE WOULD!
RETURN
END
C----------------------------------------------------
SUBROUTINE SIMPLE_VARIABLE(TYPE)
INCLUDE 'PLMCOM.FOR/NOLIST'
C
CALL MUSTBE(ID)
CALL LOOKUP_SYMBOL
IF (SYMBOL_KIND(SYMBOL_INDEX).NE.S_SCALAR.OR.
# SYMBOL_REF(SYMBOL_INDEX).EQ.S_BASED) THEN
CALL ERROR('NOT A SIMPLE VARIABLE: '//
# SYMBOL_PLM_ID(SYMBOL_INDEX))
ENDIF
CALL GETTOK
IF (TT.EQ.D_DOT) THEN
CALL GETTOK
CALL MUSTBE(ID)
CALL LOOKUP_MEMBER
IF (MEMBER_KIND(MEMBER_INDEX).NE.S_SCALAR) THEN
CALL ERROR('NOT A SIMPLE VARIABLE: '//
# SYMBOL_PLM_ID(SYMBOL_INDEX)//'.'//
# MEMBER_PLM_ID(MEMBER_INDEX))
ENDIF
CALL GETTOK
ELSE
MEMBER_INDEX=0
IF (SYMBOL_TYPE(SYMBOL_INDEX).EQ.S_STRUC) THEN
CALL ERROR('NOT A FULLY QUALIFIED REFERENCE: '//
# SYMBOL_PLM_ID(SYMBOL_INDEX))
ENDIF
ENDIF
IF (MEMBER_INDEX.EQ.0) THEN
TYPE = SYMBOL_TYPE(SYMBOL_INDEX)
ELSE
TYPE = MEMBER_TYPE(MEMBER_INDEX)
ENDIF
RETURN
END
C----------------------------------------------------
SUBROUTINE VARIABLE_ATTRIBUTES(FLAGS,REF,THIS_PSECT)
INCLUDE 'PLMCOM.FOR/NOLIST'
INTEGER*4 OFF
COMMON /AT_FLAG/ AT,ATM
AT=0 ! ASSUME NO AT-ATTRIBUTE.
IF (TT.EQ.K_EXTERNAL) THEN
REF = S_EXT
CALL GETTOK
ELSE
IF (TT.EQ.K_PUBLIC) THEN
FLAGS = FLAGS.OR.S_PUBLIC
CALL GETTOK
ENDIF
IF (TT.EQ.K_AT) THEN
CALL GETTOK
CALL MATCH(D_LP)
FLAGS = FLAGS .OR. S_OVERLAID
CALL BREAK
AT=MASSAGE(EXPRESSION(0),CX_UNSIGNED)
IF (NODE(AT).AND.OPNODE_OP(AT).EQ.OP_LOC) THEN
ATM=OPNODE_OPND1(AT)
IF (.NOT.ATOM(ATM).OR.ATOM_BASE(ATM).NE.NULL.OR.
# ATOM_SUB(ATM).NE.NULL) THEN
CALL ERROR('NOT A RESTRICTED LOCATION REFERENCE')
AT=0
ENDIF
SYMBOL_FLAGS(ATOM_SYM(ATM))=SYMBOL_FLAGS(ATOM_SYM(ATM))
# .OR. S_OVERLAID
ATOM_FLAGS(ATM)=ATOM_FLAGS(ATM).AND..NOT.(A_P2L+A_L2P)
# .OR. A_CTIM ! USE COMPILE-TIME ADDR.
# .OR. A_IMMEDIATE
IF (SYMBOL_REF(ATOM_SYM(ATM)).EQ.S_EXT) THEN
IF ((FLAGS.AND.S_PUBLIC).NE.0) THEN
CALL ERROR('PUBLIC ATTRIBUTE CONFLICTS WITH '//
# 'AT-EXTERNAL')
ENDIF
ELSEIF (SYMBOL_REF(ATOM_SYM(ATM)).NE.S_STATIC.AND.
# SYMBOL_REF(ATOM_SYM(ATM)).NE.S_ARG.AND.
# SYMBOL_REF(ATOM_SYM(ATM)).NE.S_DYNAMIC) THEN
CALL ERROR('NOT A RESTRICTED LOCATION REFERENCE')
AT=0
ENDIF
ELSE
CALL ERROR('AT MUST BE LOCATION REFERENCE')
AT=0
ENDIF
CALL MATCH(D_RP)
ENDIF
ENDIF
IF (AT.NE.0) THEN
REF=SYMBOL_REF(ATOM_SYM(ATM))
THIS_PSECT=SYMBOL_PSECT(ATOM_SYM(ATM))
ENDIF
RETURN
END
C----------------------------------------------------
SUBROUTINE DIMENSION(NBR_ELEMENTS,LOWER_BOUND)
INCLUDE 'PLMCOM.FOR/NOLIST'
INTEGER*4 NBR_ELEMENTS,LOWER_BOUND
CALL MATCH(D_LP)
LOWER_BOUND=0
IF (TT.EQ.D_STAR) THEN
NBR_ELEMENTS=-1
CALL GETTOK
ELSE
CALL BREAK
N1=EXPRESSION(0)
CALL RESOLVE_CONTEXT(N1)
IF (NODE_CONTEXT(N1).EQ.0) CALL SET_CONTEXT(N1,CX_SIGNED)
CALL COERCE_TYPES(N1)
N1=FORCE_TYPE(N1,S_LONG)
N1=FOLD_CONSTANTS(N1)
IF (FIXLIT(N1)) THEN
NBR_ELEMENTS=FIXED_VAL(N1)
ELSE
CALL ERROR('ARRAY DIMENSION NOT A CONSTANT')
NBR_ELEMENTS=0
ENDIF
IF (TT.EQ.D_COLON) THEN
CALL GETTOK
LOWER_BOUND=NBR_ELEMENTS
N2=EXPRESSION(0)
CALL RESOLVE_CONTEXT(N2)
IF (NODE_CONTEXT(N2).EQ.0) CALL SET_CONTEXT(N2,CX_SIGNED)
CALL COERCE_TYPES(N2)
N2=FORCE_TYPE(N2,S_LONG)
N2=FOLD_CONSTANTS(N2)
IF (FIXLIT(N2)) THEN
NBR_ELEMENTS=FIXED_VAL(N2)-LOWER_BOUND+1
ELSE
CALL ERROR('UPPER BOUND NOT A CONSTANT')
NBR_ELEMENTS=0
ENDIF
ENDIF
IF (NBR_ELEMENTS.LT.0) THEN
CALL ERROR('ARRAY SIZE IS NEGATIVE')
NBR_ELEMENTS=0
ENDIF
ENDIF
CALL MATCH(D_RP)
RETURN
END
C----------------------------------------------------
SUBROUTINE VARIABLE_TYPE
INCLUDE 'PLMCOM.FOR/NOLIST'
INTEGER*4 NBR_ELEMENTS,ELEMENT_SIZE
COMMON/DECLS/KIND,TYPE,NBR_ELEMENTS,ELEMENT_SIZE,
# LINK,LIST_SIZE,REF,BASE,BASE_MEMBER,FLAGS
IF (TT.EQ.K_STRUCTURE) THEN
CALL STRUCTURE_TYPE
ELSE
CALL BASIC_TYPE(TYPE)
ELEMENT_SIZE = BYTE_SIZE(TYPE)
ENDIF
RETURN
END
C----------------------------------------------------
SUBROUTINE BASIC_TYPE(TYPE)
INCLUDE 'PLMCOM.FOR/NOLIST'
IF (TT.EQ.K_INTEGER) THEN
TYPE = S_INTEGER
CALL GETTOK
ELSEIF (TT.EQ.K_REAL) THEN
TYPE = S_REAL
CALL GETTOK
ELSEIF (TT.EQ.K_POINTER) THEN
TYPE = S_PTR
CALL GETTOK
ELSEIF (TT.EQ.K_WORD.OR.TT.EQ.K_ADDRESS) THEN
TYPE = S_WORD
CALL GETTOK
ELSEIF (TT.EQ.K_BYTE) THEN
TYPE = S_BYTE
CALL GETTOK
ELSEIF (TT.EQ.K_LONG) THEN
TYPE = S_LONG
CALL GETTOK
ELSEIF (TT.EQ.K_DOUBLE) THEN
TYPE = S_DOUBLE
CALL GETTOK
ELSEIF (TT.EQ.K_QUAD) THEN
TYPE = S_QUAD
CALL GETTOK
ELSE
CALL MUSTBE(NT_TYPE)
ENDIF
RETURN
END
C----------------------------------------------------
SUBROUTINE STRUCTURE_TYPE
INCLUDE 'PLMCOM.FOR/NOLIST'
INTEGER*4 NBR_ELEMENTS,ELEMENT_SIZE,OFF
COMMON/DECLS/KIND,TYPE,NBR_ELEMENTS,ELEMENT_SIZE,
# LINK,LIST_SIZE,REF,BASE,BASE_MEMBER,FLAGS
CALL MATCH(K_STRUCTURE)
TYPE = S_STRUC
LINK = MEMBER_TOP(BLOCK_LEVEL)+1
LIST_SIZE = 0
OFF = 0
CALL MATCH(D_LP)
10 CALL MEMBER_ELEMENT(OFF,N)
LIST_SIZE = LIST_SIZE+N
IF (TT.EQ.D_COMMA) THEN
CALL GETTOK
GO TO 10
ENDIF
CALL MATCH(D_RP)
ELEMENT_SIZE = OFF
RETURN
END
C----------------------------------------------------
SUBROUTINE MEMBER_ELEMENT(OFF,N)
INCLUDE 'PLMCOM.FOR/NOLIST'
INTEGER*2 INDEX(32)
INTEGER*4 MNBR,LB,OFF
C
N=0
IF (TT.EQ.D_LP) THEN
10 CALL GETTOK
CALL MUSTBE(ID)
IF (N.GE.32) THEN
CALL ERROR('TOO MANY ELEMENTS IN FACTORED LIST')
ELSE
CALL ENTER_MEMBER
N=N+1
INDEX(N)=MEMBER_INDEX
ENDIF
CALL GETTOK
IF (TT.EQ.D_COMMA) GO TO 10
CALL MATCH(D_RP)
ELSE
CALL ENTER_MEMBER
N=1
INDEX(N)=MEMBER_INDEX
CALL GETTOK
ENDIF
IF (TT.EQ.D_LP) THEN
MKIND = S_ARRAY
CALL DIMENSION(MNBR,LB)
IF (MNBR.EQ.-1) THEN
CALL ERROR('IMPLICIT DIMENSION NOT ALLOWED FOR MEMBER')
MNBR = 0
ENDIF
ELSE
MKIND = S_SCALAR
MNBR = 1
LB=0
ENDIF
CALL BASIC_TYPE(MTYPE)
DO J=1,N
I = INDEX(J)
MEMBER_KIND(I) = MKIND
MEMBER_TYPE(I) = MTYPE
MEMBER_NBR_ELEMENTS(I) = MNBR
MEMBER_LOWER_BOUND(I) = LB
MEMBER_ELEMENT_SIZE(I) = BYTE_SIZE(MTYPE)
MEMBER_OFFSET(I) = OFF-LB*MEMBER_ELEMENT_SIZE(I)
CALL EMIT_ABSDEF4(MEMBER_VAX_ID(I),MEMBER_OFFSET(I))
OFF = OFF+MEMBER_ELEMENT_SIZE(I)*MNBR
ENDDO
RETURN
END

92
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/effects.for Normal file
View File

@@ -0,0 +1,92 @@
C***********************************************************************
C
C EFFECTS.FOR
C
C D I S C L A I M E R N O T I C E
C ------------------- -----------
C
C This document and/or portions of the material and data furnished
C herewith, was developed under sponsorship of the U. S. Government.
C Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior
C University, nor their employees, nor their respective contractors,
C subcontractors, or their employees, makes any warranty, express or
C implied, or assumes any liability or responsibility for accuracy,
C completeness or usefulness of any information, apparatus, product
C or process disclosed, or represents that its use will not infringe
C privately-owned rights. Mention of any product, its manufacturer,
C or suppliers shall not, nor is it intended to, imply approval, dis-
C approval, or fitness for any particular use. The U. S. and the
C University at all times retain the right to use and disseminate same
C for any purpose whatsoever. Such distribution shall be made by the
C National Energy Software Center at the Argonne National Laboratory
C and only subject to the distributee furnishing satisfactory proof
C that he has a valid license from the Intel Corporation in effect.
C
C
C-----------------------------------------------------------------------
C
C This module of the PL/M-VAX compiler determines the side effects
C of storage assignments and procedure calls for use in common
C subexpression elimination and basic block analysis.
C
C-----------------------------------------------------------------------
C
C R E V I S I O N H I S T O R Y
C
C 10NOV81 Alex Hunter 1. Written.
C
C***********************************************************************
SUBROUTINE DETERMINE_EFFECTS_OF_ASSIGNMENT (LHS)
INCLUDE 'PLMCOM.FOR/NOLIST'
IF (ATOM_MEM(LHS).NE.0) THEN
MEMBER_SERIAL_NO(ATOM_MEM(LHS)) =
# MEMBER_SERIAL_NO(ATOM_MEM(LHS)) + 1
ELSE
SYMBOL_SERIAL_NO(ATOM_SYM(LHS)) =
# SYMBOL_SERIAL_NO(ATOM_SYM(LHS)) + 1
ENDIF
IF (ASSUME_EEQ .AND.
# SYMBOL_REF(ATOM_SYM(LHS)).EQ.S_EXT) THEN
EXTERNAL_SERIAL_DELTA = EXTERNAL_SERIAL_DELTA + 1
! Invalidate all externals.
ENDIF
IF (ASSUME_BRO) THEN
BASED_SERIAL_DELTA = BASED_SERIAL_DELTA + 1
! Invalidate all based references.
IF (ATOM_BASE(LHS).NE.NULL) THEN
END_OF_BASIC_BLOCK = .TRUE.
! All bets are off.
ENDIF
ENDIF
IF (.NOT.ASSUME_SWB) THEN
SUBCRIPTED_SERIAL_DELTA = SUBSCRIPTED_SERIAL_DELTA + 1
! Invalidate all array references.
IF (ATOM_SUB(LHS).NE.NULL) THEN
END_OF_BASIC_BLOCK = .TRUE.
! All bets are off.
ENDIF
ENDIF
IF ((SYMBOL_FLAGS(ATOM_SYM(LHS)).AND.S_OVERLAID).NE.0) THEN
OVERLAID_SERIAL_DELTA = OVERLAID_SERIAL_DELTA + 1
! When equivalence chains are implemented, we will
! be able to refine this if ASSUME_SVE is true.
ENDIF
RETURN
END
C-----------------------------------------------------------------------
SUBROUTINE DETERMINE_EFFECTS_OF_CALLING (PROC_IX)
INCLUDE 'PLMCOM.FOR/NOLIST'
IF (ASSUME_PSE .AND.
# (SYMBOL_FLAGS(PROC_IX).AND.S_NO_SIDE_EFFECTS).EQ.0) THEN
SYMBOL_SERIAL_NO(PROC_IX) = SYMBOL_SERIAL_NO(PROC_IX) + 1
END_OF_BASIC_BLOCK = .TRUE.
! All bets are off.
ENDIF
RETURN
END

191
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/emit.for Normal file
View File

@@ -0,0 +1,191 @@
C***********************************************************************
C
C EMIT.FOR
C
C
C D I S C L A I M E R N O T I C E
C ------------------- -----------
C
C This document and/or portions of the material and data furnished
C herewith, was developed under sponsorship of the U. S. Government.
C Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior
C University, nor their employees, nor their respective contractors,
C subcontractors, or their employees, makes any warranty, express or
C implied, or assumes any liability or responsibility for accuracy,
C completeness or usefulness of any information, apparatus, product
C or process disclosed, or represents that its use will not infringe
C privately-owned rights. Mention of any product, its manufacturer,
C or suppliers shall not, nor is it intended to, imply approval, dis-
C approval, or fitness for any particular use. The U. S. and the
C University at all times retain the right to use and disseminate same
C for any purpose whatsoever. Such distribution shall be made by the
C National Energy Software Center at the Argonne National Laboratory
C and only subject to the distributee furnishing satisfactory proof
C that he has a valid license from the Intel Corporation in effect.
C
C
C-----------------------------------------------------------------------
C
C This module of the PL/M-VAX compiler contains routines for emitting
C symbolic code and label definitions.
C
C-----------------------------------------------------------------------
C
C R E V I S I O N H I S T O R Y
C
C 29SEP81 Alex Hunter 1. Add EMIT_ABSDEF4 and EMIT_RELDEF4 entry
C points. (V5.3)
C 12NOV81 Alex Hunter 1. Use symbol_psect attribute. (V6.1)
C 14NOV81 Alex Hunter 1. Change addressing modes. (V6.2)
C 15FEB81 Alex Hunter 1. Change opcode column to permit longer
C code lines. (V6.7)
C
C***********************************************************************
SUBROUTINE EMIT(CODE)
INCLUDE 'PLMCOM.FOR/NOLIST'
CHARACTER*(*) CODE,PC
CHARACTER*32 NAME,LOC_LAB,PUBLIQUE,S1
CHARACTER*10 STRING10,DSTRING
INTEGER*4 IVAL,IFSD,OFFSET,OFFSET4
IF (OBJECT_FLAG) WRITE(OUT,1000) CODE
1000 FORMAT(2X,A)
IF (CODE_FLAG.AND.PRINT_FLAG.AND.LIST_FLAG) THEN
CALL ADVANCE_ONE_LINE
WRITE(LST,2000) CODE
2000 FORMAT(32X,A)
ENDIF
RETURN
C----------------------------------------------------------
ENTRY EMIT_LABEL(IX)
IF ((SYMBOL_FLAGS(IX).AND.S_PUBLIC).NE.0) THEN
S1=PUBLIQUE(SYMBOL_PLM_ID(IX))
IF (OBJECT_FLAG) THEN
IF (MODEL.NE.4) THEN
WRITE(OUT,5002) S1(:LNB(S1))
5002 FORMAT(X,A,'::'/2X,'MOVL #K.,R11')
ELSE IF (.NOT.OVERLAY_FLAG) THEN
WRITE(OUT,1002) S1(:LNB(S1))
1002 FORMAT(X,A,'::'/2X,'MOVAB M.,R11')
ENDIF
ENDIF
IF (CODE_FLAG.AND.PRINT_FLAG.AND.LIST_FLAG) THEN
CALL ADVANCE_ONE_LINE
WRITE(LST,2002) S1(1:LNB(S1))
2002 FORMAT(31X,A,'::')
IF (MODEL.NE.4) THEN
CALL ADVANCE_ONE_LINE
WRITE(LST,4002)
4002 FORMAT(32X,'MOVL #K.,R11')
ELSE IF (.NOT.OVERLAY_FLAG) THEN
CALL ADVANCE_ONE_LINE
WRITE(LST,3002)
3002 FORMAT(32X,'MOVAB M.,R11')
ENDIF
ENDIF
ENDIF
IF (OBJECT_FLAG)
# WRITE(OUT,1003) SYMBOL_VAX_ID(IX)(1:LNB(SYMBOL_VAX_ID(IX)))
1003 FORMAT(X,A,':')
IF (CODE_FLAG.AND.PRINT_FLAG.AND.LIST_FLAG) THEN
CALL ADVANCE_ONE_LINE
WRITE(LST,2003) SYMBOL_VAX_ID(IX)(1:LNB(SYMBOL_VAX_ID(IX)))
2003 FORMAT(31X,A,':')
ENDIF
RETURN
C----------------------------------------------------------
ENTRY EMIT_ABSDEF(NAME,OFF)
IVAL=OFF
GO TO 10
C----------------------------
ENTRY EMIT_ABSDEF4(NAME,OFFSET4)
IVAL=OFFSET4
10 CONTINUE
DSTRING=STRING10(IVAL,IFSD)
IF (OBJECT_FLAG) WRITE(OUT,1001) NAME(1:LNB(NAME)),DSTRING(IFSD:)
1001 FORMAT(X,A,' = ',A)
IF (CODE_FLAG.AND.PRINT_FLAG.AND.LIST_FLAG) THEN
CALL ADVANCE_ONE_LINE
WRITE(LST,2001) NAME(1:LNB(NAME)),DSTRING(IFSD:)
2001 FORMAT(31X,A,' = ',A)
ENDIF
RETURN
C----------------------------------------------------------
ENTRY EMIT_RELDEF(IX,PC,OFFSET2)
OFFSET=OFFSET2
GO TO 20
C----------------------------
ENTRY EMIT_RELDEF4(IX,PC,OFFSET4)
OFFSET=OFFSET4
20 CONTINUE
IF (OFFSET.NE.0) THEN
IVAL=OFFSET
DSTRING=STRING10(IVAL,IFSD)
IF (IVAL.GT.0) THEN
IFSD=IFSD-1
DSTRING(IFSD:IFSD)='+'
ENDIF
ELSE
DSTRING=' '
IFSD=10
ENDIF
IF ((SYMBOL_FLAGS(IX).AND.S_PUBLIC).NE.0) THEN
S1=PUBLIQUE(SYMBOL_PLM_ID(IX))
IF (OBJECT_FLAG)
# WRITE(OUT,1004) S1(:LNB(S1)),PC,
# DSTRING(IFSD:)
1004 FORMAT(X,A,' == ',2A)
IF (CODE_FLAG.AND.PRINT_FLAG.AND.LIST_FLAG) THEN
CALL ADVANCE_ONE_LINE
WRITE(LST,2004) S1(:LNB(S1)),PC,
# DSTRING(IFSD:)
2004 FORMAT(31X,A,' == ',2A)
ENDIF
ENDIF
IF (MODEL.EQ.4.AND..NOT.OVERLAY_FLAG.AND.
# SYMBOL_PSECT(IX).EQ.P_DATA) THEN
IF (OBJECT_FLAG)
# WRITE(OUT,1005) SYMBOL_VAX_ID(IX)(:LNB(SYMBOL_VAX_ID(IX))),
# PC,DSTRING(IFSD:)
1005 FORMAT(X,A,' = ',A,'-M.',A)
IF (CODE_FLAG.AND.PRINT_FLAG.AND.LIST_FLAG) THEN
CALL ADVANCE_ONE_LINE
WRITE(LST,2005) SYMBOL_VAX_ID(IX)(:LNB(SYMBOL_VAX_ID(IX))),
# PC,DSTRING(IFSD:)
2005 FORMAT(31X,A,' = ',A,'-M.',A)
ENDIF
ELSE
IF (OBJECT_FLAG)
# WRITE(OUT,1007) SYMBOL_VAX_ID(IX)(:LNB(SYMBOL_VAX_ID(IX))),
# PC,DSTRING(IFSD:)
1007 FORMAT(X,A,' = ',2A)
IF (CODE_FLAG.AND.PRINT_FLAG.AND.LIST_FLAG) THEN
CALL ADVANCE_ONE_LINE
WRITE(LST,2007) SYMBOL_VAX_ID(IX)(:LNB(SYMBOL_VAX_ID(IX))),
# PC,DSTRING(IFSD:)
2007 FORMAT(31X,A,' = ',2A)
ENDIF
ENDIF
RETURN
C----------------------------------------------------------
ENTRY EMIT_LOCAL_LABEL(LL)
IF (LL.EQ.0) RETURN
LOC_LAB=LOCAL_LABEL(LL,N1)
IF (OBJECT_FLAG) WRITE(OUT,1003) LOC_LAB(:N1)
IF (CODE_FLAG.AND.PRINT_FLAG.AND.LIST_FLAG) THEN
CALL ADVANCE_ONE_LINE
WRITE(LST,2003) LOC_LAB(:N1)
ENDIF
PATH=.TRUE.
RETURN
C----------------------------------------------------------
ENTRY EMIT1(CODE)
IF (OBJECT_FLAG) WRITE(OUT,1006) CODE
1006 FORMAT(X,A)
IF (CODE_FLAG.AND.PRINT_FLAG.AND.LIST_FLAG) THEN
CALL ADVANCE_ONE_LINE
WRITE(LST,2006) CODE
2006 FORMAT(31X,A)
ENDIF
RETURN
END

11
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/errfind.com Normal file
View File

@@ -0,0 +1,11 @@
$! ERRFIND.COM
$!
$! Command file to search a PL/M-VAX source file and display all
$! calls to the ERROR message subroutines.
$! (Requires the WYLBUR text editor.)
$!
$! 02FEB82 Alex Hunter 1. Original version.
$!
$USE 'P1'.FOR
L 'CALL ERROR' OR 'CALL FATAL' OR 'CALL WARN' OR 'CALL BUG'
LO

97
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/error.for Normal file
View File

@@ -0,0 +1,97 @@
C***********************************************************************
C
C ERROR.FOR
C
C
C D I S C L A I M E R N O T I C E
C ------------------- -----------
C
C This document and/or portions of the material and data furnished
C herewith, was developed under sponsorship of the U. S. Government.
C Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior
C University, nor their employees, nor their respective contractors,
C subcontractors, or their employees, makes any warranty, express or
C implied, or assumes any liability or responsibility for accuracy,
C completeness or usefulness of any information, apparatus, product
C or process disclosed, or represents that its use will not infringe
C privately-owned rights. Mention of any product, its manufacturer,
C or suppliers shall not, nor is it intended to, imply approval, dis-
C approval, or fitness for any particular use. The U. S. and the
C University at all times retain the right to use and disseminate same
C for any purpose whatsoever. Such distribution shall be made by the
C National Energy Software Center at the Argonne National Laboratory
C and only subject to the distributee furnishing satisfactory proof
C that he has a valid license from the Intel Corporation in effect.
C
C
C-----------------------------------------------------------------------
C
C This module of the PL/M-VAX compiler processes error messages
C of several degrees of severity.
C
C-----------------------------------------------------------------------
C R E V I S I O N H I S T O R Y
C
C 15OCT81 Alex Hunter 1. Added disclaimer notice. (V5.4)
C
C-----------------------------------------------------------------------
SUBROUTINE ERROR(T)
C
C----- REPORT AN ERROR.
C
INCLUDE 'PLMCOM.FOR/NOLIST'
CHARACTER*(*) T
C
IF (PRINT_FLAG) THEN
CALL ADVANCE_ONE_LINE
WRITE(LST,1000) T(:LNB(T))
ENDIF
IF (.NOT.LISTING_TO_TERMINAL) THEN
CALL TYPE_LAST_SOURCE_LINE
WRITE(7,1000) T(:LNB(T))
ENDIF
1000 FORMAT(' ******** Error: 'A)
IF (OBJECT_FLAG) WRITE(OUT,1003) T(:LNB(T))
1003 FORMAT(' .ERROR ; ',A)
ERRORS=ERRORS+1
RETURN
C--------------------------
ENTRY FATAL(T)
C--------------------------
IF (PRINT_FLAG) THEN
CALL ADVANCE_ONE_LINE
WRITE(LST,1001) T(:LNB(T))
ENDIF
IF (.NOT.LISTING_TO_TERMINAL) THEN
CALL TYPE_LAST_SOURCE_LINE
WRITE(7,1001) T(:LNB(T))
ENDIF
1001 FORMAT(' ******** Fatal Error: ',A)
IF (OBJECT_FLAG) WRITE(OUT,1003) T(:LNB(T))
100 STOP '** COMPILATION ABORTED **'
C--------------------------
ENTRY WARN(T)
C--------------------------
IF (.NOT.WARN_FLAG) RETURN
IF (PRINT_FLAG) THEN
CALL ADVANCE_ONE_LINE
WRITE(LST,1002) T(:LNB(T))
ENDIF
IF (.NOT.LISTING_TO_TERMINAL) THEN
CALL TYPE_LAST_SOURCE_LINE
WRITE(7,1002) T(:LNB(T))
ENDIF
1002 FORMAT(' ******** Warning: ',A)
IF (OBJECT_FLAG) WRITE(OUT,1004) T(:LNB(T))
1004 FORMAT(' .WARN ; ',A)
WARNINGS=WARNINGS+1
RETURN
END
C--------------------------
SUBROUTINE BUG(T)
C--------------------------
IMPLICIT INTEGER*2 (A-Z)
CHARACTER*(*) T
CALL ERROR('COMPILER BUG -- '//T)
200 RETURN
END

13
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/exlist.com Normal file
View File

@@ -0,0 +1,13 @@
$SET VERIFY
$!
$! EXLIST.COM
$!
$! Command file to produce listings for the export version
$! of the PL/M-VAX compiler.
$!
$! 02FEB82 Alex Hunter 1. Deleted PLM$UDI listings.
$!
$PRI/HEAD *.FOR
$PRI CONTROL
$PRI/HEAD PLM.BLD,.CMP,.LNK
$SET NOVERIFY

589
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/exprs.for Normal file
View File

@@ -0,0 +1,589 @@
C***********************************************************************
C
C EXPRS.FOR
C
C
C D I S C L A I M E R N O T I C E
C ------------------- -----------
C
C This document and/or portions of the material and data furnished
C herewith, was developed under sponsorship of the U. S. Government.
C Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior
C University, nor their employees, nor their respective contractors,
C subcontractors, or their employees, makes any warranty, express or
C implied, or assumes any liability or responsibility for accuracy,
C completeness or usefulness of any information, apparatus, product
C or process disclosed, or represents that its use will not infringe
C privately-owned rights. Mention of any product, its manufacturer,
C or suppliers shall not, nor is it intended to, imply approval, dis-
C approval, or fitness for any particular use. The U. S. and the
C University at all times retain the right to use and disseminate same
C for any purpose whatsoever. Such distribution shall be made by the
C National Energy Software Center at the Argonne National Laboratory
C and only subject to the distributee furnishing satisfactory proof
C that he has a valid license from the Intel Corporation in effect.
C
C
C-----------------------------------------------------------------------
C
C This module of the PL/M-VAX compiler parses expressions and
C generates the corresponding code trees.
C
C-----------------------------------------------------------------------
C R E V I S I O N H I S T O R Y
C
C 15OCT81 Alex Hunter 1. Added disclaimer notice. (V5.4)
C 21OCT81 Alex Hunter 1. Basic block anaylsis. (V5.5)
C 10NOV81 Alex Hunter 1. Add calls to EFFECTS module. (V6.0)
C 12NOV81 Alex Hunter 1. Delete reference to S_COMMON. (V6.1)
C
C-----------------------------------------------------------------------
INTEGER*2 FUNCTION PRIMARY(DREFS)
INCLUDE 'PLMCOM.FOR/NOLIST'
REFS=DREFS
IF (TT.EQ.FIXCON) THEN
PRIMARY=MAKE_FIXED(FIXVAL,0)
CALL GETTOK
ELSEIF (TT.EQ.FLOATCON) THEN
PRIMARY=MAKE_FLOAT(FLOATVAL,S_REAL)
CALL GETTOK
ELSEIF (TT.EQ.STRCON) THEN
IF (STRLEN.GT.2) THEN
CALL ERROR('STRING CONSTANT HAS MORE THAN 2 CHARACTERS')
ENDIF
IF (STRLEN.EQ.1) THEN
PRIMARY=MAKE_FIXED2(ICHAR(STRING(1:1)),S_BYTE)
ELSE
PRIMARY=MAKE_FIXED2(ICHAR(STRING(1:1))*256
# +ICHAR(STRING(2:2)),S_WORD)
ENDIF
CALL GETTOK
ELSEIF (TT.EQ.ID) THEN
PRIMARY=VARIABLE_REFERENCE(1)
ELSEIF (TT.EQ.D_DOT.OR.TT.EQ.D_AT) THEN
PRIMARY=LOCATION_REFERENCE(1)
ELSEIF (TT.EQ.D_LP) THEN
CALL GETTOK
PRIMARY=EXPRESSION(1)
CALL MATCH(D_RP)
ELSE
CALL MUSTBE(NT_EXPRESSION)
ENDIF
RETURN
END
C-------------------------------------------------
INTEGER*2 FUNCTION VARIABLE_REFERENCE(DREFS)
INCLUDE 'PLMCOM.FOR/NOLIST'
REFS=DREFS
CALL MUSTBE(ID)
CALL LOOKUP_SYMBOL
GO TO (100,200,200,300,100), SYMBOL_KIND(SYMBOL_INDEX)
100 CALL ERROR('IDENTIFIER ILLEGAL IN THIS CONTEXT: '//
# SYMBOL_PLM_ID(SYMBOL_INDEX))
VARIABLE_REFERENCE=DUMMY
CALL GETTOK
RETURN
C
C---- SCALAR OR ARRAY.
C
200 VARIABLE_REFERENCE=DATA_REFERENCE(REFS,.FALSE.)
RETURN
C
C---- PROCEDURE.
C
300 VARIABLE_REFERENCE=FUNCTION_REFERENCE(REFS)
RETURN
END
C-------------------------------------------------
INTEGER*2 FUNCTION DATA_REFERENCE(DREFS,MODEX)
INCLUDE 'PLMCOM.FOR/NOLIST'
LOGICAL*2 PARTIAL_OK
EQUIVALENCE (PARTIAL_OK,MODE)
COMMON /BUILTINS/ SYM_SUBS,MEM_SUBS
REFS=DREFS
MODE=MODEX
CALL MATCH(ID)
IF (SYMBOL_REF(SYMBOL_INDEX).EQ.S_BASED) THEN
IF (SYMBOL_BASE_MEMBER(SYMBOL_INDEX).EQ.0) THEN
BASE_TYPE=SYMBOL_TYPE(SYMBOL_BASE(SYMBOL_INDEX))
ELSE
BASE_TYPE=MEMBER_TYPE(SYMBOL_BASE_MEMBER(SYMBOL_INDEX))
ENDIF
BASE=MAKE_ATOM(SYMBOL_BASE(SYMBOL_INDEX),
# SYMBOL_BASE_MEMBER(SYMBOL_INDEX),NULL,NULL,
# BASE_TYPE,0,1)
ELSE
BASE=NULL
ENDIF
IF (TT.EQ.D_LP) THEN
IF (SYMBOL_KIND(SYMBOL_INDEX).NE.S_ARRAY) THEN
IF (MODE.EQ.2) GO TO 10
CALL ERROR('NOT AN ARRAY: '//SYMBOL_PLM_ID(SYMBOL_INDEX))
ENDIF
CALL GETTOK
CALL PUSH(BASE,1)
CALL PUSH(REFS,1)
CALL PUSH(MODE,1)
CALL PUSH(SYMBOL_INDEX,1)
SYM_SUBS=EXPRESSION(1)
CALL POP(SYMBOL_INDEX,1)
CALL POP(MODE,1)
CALL POP(REFS,1)
CALL POP(BASE,1)
CALL MATCH(D_RP)
ELSE
IF (SYMBOL_KIND(SYMBOL_INDEX).EQ.S_ARRAY.AND..NOT.PARTIAL_OK)
# THEN
CALL ERROR('SUBSCRIPT MISSING AFTER '//
# SYMBOL_PLM_ID(SYMBOL_INDEX))
ENDIF
10 SYM_SUBS=NULL
ENDIF
IF (TT.EQ.D_DOT) THEN
CALL GETTOK
CALL MUSTBE(ID)
CALL LOOKUP_MEMBER
CALL GETTOK
IF (TT.EQ.D_LP) THEN
IF (MEMBER_KIND(MEMBER_INDEX).NE.S_ARRAY) THEN
IF (MODE.EQ.2) GO TO 20
CALL ERROR('NOT AN ARRAY: '//MEMBER_PLM_ID(MEMBER_INDEX))
ENDIF
CALL GETTOK
CALL PUSH(BASE,1)
CALL PUSH(REFS,1)
CALL PUSH(MODE,1)
CALL PUSH(SYMBOL_INDEX,1)
CALL PUSH(MEMBER_INDEX,1)
CALL PUSH(SYM_SUBS,1)
MEM_SUBS=EXPRESSION(1)
CALL POP(SYM_SUBS,1)
CALL POP(MEMBER_INDEX,1)
CALL POP(SYMBOL_INDEX,1)
CALL POP(MODE,1)
CALL POP(REFS,1)
CALL POP(BASE,1)
CALL MATCH(D_RP)
ELSE
IF (MEMBER_KIND(MEMBER_INDEX).EQ.S_ARRAY.AND.
# .NOT.PARTIAL_OK) THEN
CALL ERROR('SUBSCRIPT MISSING AFTER '//
# MEMBER_PLM_ID(MEMBER_INDEX))
ENDIF
20 MEM_SUBS=NULL
ENDIF
IF (MEMBER_INDEX.EQ.0) THEN
TYPE=SYMBOL_TYPE(SYMBOL_INDEX)
ELSE
TYPE=MEMBER_TYPE(MEMBER_INDEX)
ENDIF
ELSE
IF (SYMBOL_TYPE(SYMBOL_INDEX).EQ.S_STRUC) THEN
IF (.NOT.PARTIAL_OK)
# CALL ERROR('MEMBER NAME MISSING AFTER '//
# SYMBOL_PLM_ID(SYMBOL_INDEX))
SIZ=SYMBOL_ELEMENT_SIZE(SYMBOL_INDEX)
IF (SIZ.EQ.4) THEN
TYPE=S_LONG
ELSEIF (SIZ.EQ.2) THEN
TYPE=S_WORD
ELSE
TYPE=S_BYTE
ENDIF
ELSE
TYPE=SYMBOL_TYPE(SYMBOL_INDEX)
ENDIF
MEMBER_INDEX=0
MEM_SUBS=NULL
ENDIF
IF (SYM_SUBS.EQ.NULL) THEN
SUBS1=NULL
ELSE
IF (SYMBOL_ELEMENT_SIZE(SYMBOL_INDEX).EQ.
# BYTE_SIZE(TYPE)) THEN
SUBS1=SYM_SUBS
ELSEIF (MOD(SYMBOL_ELEMENT_SIZE(SYMBOL_INDEX),
# BYTE_SIZE(TYPE)).EQ.0) THEN
SUBS1=MAKE_NODE(OP_MUL,SYM_SUBS,
# MAKE_FIXED2(SYMBOL_ELEMENT_SIZE(SYMBOL_INDEX)
# /BYTE_SIZE(TYPE),0),
# 0,0,1)
ELSE
SUBSCRIPT=MAKE_NODE(OP_MUL,SYM_SUBS,
# MAKE_FIXED2(SYMBOL_ELEMENT_SIZE(SYMBOL_INDEX),0),
# 0,0,0)
BASE1=MAKE_ATOM(SYMBOL_INDEX,MEMBER_INDEX,BASE,SUBSCRIPT,
# S_BYTE,0,REFS)
BASE=MAKE_NODE(OP_LOC,BASE1,NULL,0,0,0)
DATA_REFERENCE=MAKE_ATOM(0,0,BASE,
# MEM_SUBS,TYPE,0,REFS)
RETURN
ENDIF
ENDIF
IF (MEM_SUBS.EQ.NULL) THEN
SUBSCRIPT=SUBS1
ELSEIF (SUBS1.EQ.NULL) THEN
SUBSCRIPT=MEM_SUBS
ELSE
SUBSCRIPT=MAKE_NODE(OP_ADD,SUBS1,MEM_SUBS,0,0,1)
ENDIF
DATA_REFERENCE=MAKE_ATOM(SYMBOL_INDEX,MEMBER_INDEX,BASE,
# SUBSCRIPT,TYPE,0,REFS)
RETURN
END
C-------------------------------------------------
INTEGER*2 FUNCTION FUNCTION_REFERENCE(DREFS)
INCLUDE 'PLMCOM.FOR/NOLIST'
PROC_IX=SYMBOL_INDEX
IF (SYMBOL_TYPE(PROC_IX).EQ.0) THEN
CALL ERROR('UNTYPED PROCEDURE USED AS FUNCTION: '//
# IDENTIFIER)
ENDIF
CALL GETTOK
IF (SYMBOL_REF(PROC_IX).EQ.S_BUILTIN) THEN
FUNCTION_REFERENCE=BUILTIN_FUNCTION(PROC_IX)
RETURN
ENDIF
ARGLIST=NULL
NARGS=0
IF (TT.EQ.D_LP) THEN
10 CALL GETTOK
CALL PUSH(PROC_IX,1)
CALL PUSH(ARGLIST,1)
CALL PUSH(NARGS,1)
ARG=EXPRESSION(1)
CALL POP(NARGS,1)
CALL POP(ARGLIST,1)
CALL POP(PROC_IX,1)
NARGS=NARGS+1
ARGLIST=MAKE_NODE(OP_ARG,ARGLIST,ARG,0,0,0)
IF (TT.EQ.D_COMMA) GO TO 10
CALL MATCH(D_RP)
ENDIF
IF (NARGS.NE.SYMBOL_LIST_SIZE(PROC_IX)) THEN
CALL ERROR('WRONG NUMBER OF ARGS TO '//
# SYMBOL_PLM_ID(PROC_IX))
ENDIF
PROC=MAKE_ATOM(PROC_IX,0,NULL,NULL,SYMBOL_TYPE(PROC_IX),0,0)
FUNCTION_REFERENCE=MAKE_NODE(OP_CALL,PROC,ARGLIST,0,0,0)
CALL DETERMINE_EFFECTS_OF_CALLING(PROC_IX)
RETURN
END
C-------------------------------------------------
INTEGER*2 FUNCTION LOCATION_REFERENCE(DREFS)
INCLUDE 'PLMCOM.FOR/NOLIST'
CHARACTER*80 OPERAND,OPERAND1,RESTRICTED_LOCATION_REFERENCE
LOGICAL*2 CONSTANT_LIST
CHARACTER*7 DATA_POP(S_BYTE:S_QUAD)
DATA DATA_POP
// '.BYTE','.WORD','.WORD','.LONG','.FLOAT','.LONG','.DOUBLE'
,, '.QUAD'
//
REFS=DREFS
IF (TT.EQ.D_DOT) THEN
TYPE=S_LONG
CALL GETTOK
ELSE
CALL MATCH(D_AT)
TYPE=S_PTR
ENDIF
IF (TT.EQ.ID) THEN
CALL LOOKUP_SYMBOL
OPND1=DATA_REFERENCE(REFS,.TRUE.)
IF (ATOM(OPND1) .AND. ATOM_SYM(OPND1).NE.0 .AND.
# SYMBOL_KIND(ATOM_SYM(OPND1)).EQ.S_PROC) THEN
ATOM_FLAGS(OPND1)=ATOM_FLAGS(OPND1).OR.A_VECTOR
ENDIF
IF (NODE_TYPE(OPND1).EQ.0) NODE_TYPE(OPND1)=S_BYTE
! ABOVE IS FOR .<UNTYPED PROCEDURE>
ELSE
OLD_PSECT=PSECT(P_CONSTANTS)
CALL GENERATE_LOCAL_LABEL(LLC)
CALL EMIT_LOCAL_LABEL(LLC)
IF (TT.EQ.D_LP) THEN
CALL GETTOK
CONSTANT_LIST=.TRUE.
ELSE
CONSTANT_LIST=.FALSE.
ENDIF
10 CONTINUE
IF (TT.EQ.STRCON) THEN
CALL EMIT('.ASCII `'//STRING(:STRLEN)//'`')
CALL GETTOK
ELSE
CALL PUSH(CONSTANT_LIST,1)
CALL PUSH(OLD_PSECT,1)
CALL PUSH(LLC,1)
CALL PUSH(TYPE,1)
CONST=EXPRESSION(0)
CALL POP(TYPE,1)
CALL POP(LLC,1)
CALL POP(OLD_PSECT,1)
CALL POP(CONSTANT_LIST,1)
CALL RESOLVE_CONTEXT(CONST)
IF (NODE_CONTEXT(CONST).EQ.0)
# CALL SET_CONTEXT(CONST,CX_UNSIGNED)
CALL COERCE_TYPES(CONST)
CONST=FOLD_CONSTANTS(CONST)
IF (NODE(CONST).AND.OPNODE_OP(CONST).EQ.OP_LOC) THEN
OPERAND1=RESTRICTED_LOCATION_REFERENCE(CONST,N1)
CALL EMIT(DATA_POP(NODE_TYPE(CONST))//' '//OPERAND1(:N1))
ELSEIF (.NOT.LITERAL(CONST)) THEN
CALL ERROR('CONSTANT LIST ELEMENT NOT A CONSTANT')
ELSE
OPERAND1=OPERAND(CONST,N1)
CALL EMIT(DATA_POP(NODE_TYPE(CONST))//' '//
# OPERAND1(2:N1))
ENDIF
ENDIF
IF (CONSTANT_LIST) THEN
IF (TT.EQ.D_COMMA) THEN
CALL GETTOK
GO TO 10
ENDIF
CALL MATCH(D_RP)
ENDIF
XX=PSECT(OLD_PSECT)
OPND1=MAKE_CONSTANT(LLC,S_BYTE)
ENDIF
LOCATION_REFERENCE=MAKE_NODE(OP_LOC,OPND1,NULL,0,0,REFS)
IF (TYPE.EQ.S_LONG) THEN
LOCATION_REFERENCE=MAKE_NODE(OP_LONG,LOCATION_REFERENCE,
# NULL,0,0,REFS)
ENDIF
RETURN
END
C-------------------------------------------------
INTEGER*2 FUNCTION EXPRESSION(DREFS)
INCLUDE 'PLMCOM.FOR/NOLIST'
LOGICAL*1 CANT_BE_ASSN
REFS=DREFS
CANT_BE_ASSN = TT.EQ.D_LP
CALL PUSH(REFS,1)
OPND1=LOGICAL_FACTOR(REFS)
CALL POP(REFS,1)
IF (TT.EQ.D_ASSN.AND.ATOM(OPND1).AND..NOT.CANT_BE_ASSN) THEN
CALL GETTOK
CALL PUSH(OPND1,1)
CALL PUSH(REFS,1)
RHS=LOGICAL_EXPRESSION(REFS)
CALL POP(REFS,1)
CALL POP(OPND1,1)
EXPRESSION=MAKE_NODE(OP_ASSN,RHS,OPND1,0,0,0)
CALL DETERMINE_EFFECTS_OF_ASSIGNMENT(OPND1)
RETURN
ENDIF
10 IF (TT.EQ.K_OR.OR.TT.EQ.K_XOR) THEN
IF (TT.EQ.K_OR) OP=OP_OR
IF (TT.EQ.K_XOR) OP=OP_XOR
CALL GETTOK
CALL PUSH(OP,1)
CALL PUSH(REFS,1)
CALL PUSH(OPND1,1)
OPND2=LOGICAL_FACTOR(REFS)
CALL POP(OPND1,1)
CALL POP(REFS,1)
CALL POP(OP,1)
OPND1=MAKE_NODE(OP,OPND1,OPND2,S_BYTE,0,REFS)
ELSE
EXPRESSION=OPND1
RETURN
ENDIF
GO TO 10
END
C-------------------------------------------------
INTEGER*2 FUNCTION LOGICAL_EXPRESSION(DREFS)
INCLUDE 'PLMCOM.FOR/NOLIST'
REFS=DREFS
CALL PUSH(REFS,1)
OPND1=LOGICAL_FACTOR(REFS)
CALL POP(REFS,1)
10 IF (TT.EQ.K_OR.OR.TT.EQ.K_XOR) THEN
IF (TT.EQ.K_OR) OP=OP_OR
IF (TT.EQ.K_XOR) OP=OP_XOR
CALL GETTOK
CALL PUSH(OP,1)
CALL PUSH(REFS,1)
CALL PUSH(OPND1,1)
OPND2=LOGICAL_FACTOR(REFS)
CALL POP(OPND1,1)
CALL POP(REFS,1)
CALL POP(OP,1)
OPND1=MAKE_NODE(OP,OPND1,OPND2,S_BYTE,0,REFS)
ELSE
LOGICAL_EXPRESSION=OPND1
RETURN
ENDIF
GO TO 10
END
C-------------------------------------------------
INTEGER*2 FUNCTION LOGICAL_FACTOR(DREFS)
INCLUDE 'PLMCOM.FOR/NOLIST'
REFS=DREFS
CALL PUSH(REFS,1)
OPND1=LOGICAL_SECONDARY(REFS)
CALL POP(REFS,1)
10 IF (TT.EQ.K_AND) THEN
CALL GETTOK
CALL PUSH(REFS,1)
CALL PUSH(OPND1,1)
OPND2=LOGICAL_SECONDARY(REFS)
CALL POP(OPND1,1)
CALL POP(REFS,1)
OPND1=MAKE_NODE(OP_AND,OPND1,OPND2,0,0,REFS)
ELSE
LOGICAL_FACTOR=OPND1
RETURN
ENDIF
GO TO 10
END
C-------------------------------------------------
INTEGER*2 FUNCTION LOGICAL_SECONDARY(DREFS)
INCLUDE 'PLMCOM.FOR/NOLIST'
REFS=DREFS
IF (TT.EQ.K_NOT) THEN
CALL GETTOK
CALL PUSH(REFS,1)
OPND1=LOGICAL_PRIMARY(REFS)
CALL POP(REFS,1)
LOGICAL_SECONDARY=MAKE_NODE(OP_NOT,OPND1,NULL,0,0,REFS)
ELSE
LOGICAL_SECONDARY=LOGICAL_PRIMARY(REFS)
ENDIF
RETURN
END
C-------------------------------------------------
INTEGER*2 FUNCTION LOGICAL_PRIMARY(DREFS)
INCLUDE 'PLMCOM.FOR/NOLIST'
REFS=DREFS
CALL PUSH(REFS,1)
OPND1=ARITHMETIC_EXPRESSION(REFS)
CALL POP(REFS,1)
IF (TT.GE.D_LT.AND.TT.LE.D_GE) THEN
OP=TT-D_LT+OP_LT
CALL GETTOK
CALL PUSH(OP,1)
CALL PUSH(REFS,1)
CALL PUSH(OPND1,1)
OPND2=ARITHMETIC_EXPRESSION(REFS)
CALL POP(OPND1,1)
CALL POP(REFS,1)
CALL POP(OP,1)
OPND1=MAKE_NODE(OP,OPND1,OPND2,0,0,REFS)
ENDIF
LOGICAL_PRIMARY=OPND1
RETURN
END
C-------------------------------------------------
INTEGER*2 FUNCTION ARITHMETIC_EXPRESSION(DREFS)
INCLUDE 'PLMCOM.FOR/NOLIST'
REFS=DREFS
CALL PUSH(REFS,1)
OPND1=TERM(REFS)
CALL POP(REFS,1)
10 IF (TT.EQ.D_PLUS.OR.TT.EQ.D_MINUS.OR.TT.EQ.K_PLUS.OR.
# TT.EQ.K_MINUS) THEN
IF (TT.EQ.D_PLUS) THEN
OP=OP_ADD
ELSEIF (TT.EQ.D_MINUS) THEN
OP=OP_SUB
ELSEIF (TT.EQ.K_PLUS) THEN
OP=OP_ADWC
CALL WARN('PLUS PROBABLY WON''T WORK')
ELSE
OP=OP_SBWC
CALL WARN('MINUS PROBABLY WON''T WORK')
ENDIF
CALL GETTOK
CALL PUSH(OP,1)
CALL PUSH(REFS,1)
CALL PUSH(OPND1,1)
OPND2=TERM(REFS)
CALL POP(OPND1,1)
CALL POP(REFS,1)
CALL POP(OP,1)
OPND1=MAKE_NODE(OP,OPND1,OPND2,0,0,REFS)
ELSE
ARITHMETIC_EXPRESSION=OPND1
RETURN
ENDIF
GO TO 10
END
C-------------------------------------------------
INTEGER*2 FUNCTION TERM(DREFS)
INCLUDE 'PLMCOM.FOR/NOLIST'
REFS=DREFS
CALL PUSH(REFS,1)
OPND1=SECONDARY(REFS)
CALL POP(REFS,1)
10 IF (TT.EQ.D_STAR.OR.TT.EQ.D_SLASH.OR.TT.EQ.K_MOD) THEN
IF (TT.EQ.D_STAR) OP=OP_MUL
IF (TT.EQ.D_SLASH) OP=OP_DIV
IF (TT.EQ.K_MOD) OP=OP_MOD
CALL GETTOK
CALL PUSH(OP,1)
CALL PUSH(REFS,1)
CALL PUSH(OPND1,1)
OPND2=SECONDARY(REFS)
CALL POP(OPND1,1)
CALL POP(REFS,1)
CALL POP(OP,1)
OPND1=MAKE_NODE(OP,OPND1,OPND2,0,0,REFS)
ELSE
TERM=OPND1
RETURN
ENDIF
GO TO 10
END
C-------------------------------------------------
INTEGER*2 FUNCTION SECONDARY(DREFS)
INCLUDE 'PLMCOM.FOR/NOLIST'
REFS=DREFS
IF (TT.EQ.D_MINUS) THEN
CALL GETTOK
CALL PUSH(REFS,1)
OPND1=PRIMARY(REFS)
CALL POP(REFS,1)
SECONDARY=MAKE_NODE(OP_NEG,OPND1,NULL,0,0,REFS)
ELSE
IF (TT.EQ.D_PLUS) CALL GETTOK
SECONDARY=PRIMARY(REFS)
ENDIF
RETURN
END
C-------------------------------------------------
CHARACTER*80 FUNCTION RESTRICTED_LOCATION_REFERENCE(NOD,N)
INCLUDE 'PLMCOM.FOR/NOLIST'
CHARACTER*80 OPERAND
ATM=OPNODE_OPND1(NOD)
IF (.NOT.ATOM(ATM).OR.ATOM_BASE(ATM).NE.NULL.OR.
# ATOM_SUB(ATM).NE.NULL.OR.
# (SYMBOL_REF(ATOM_SYM(ATM)).NE.S_STATIC.AND.
# SYMBOL_REF(ATOM_SYM(ATM)).NE.S_LOCAL.AND.
# SYMBOL_REF(ATOM_SYM(ATM)).NE.S_FORWARD.AND.
# SYMBOL_REF(ATOM_SYM(ATM)).NE.S_EXT)) THEN
CALL ERROR('NOT A RESTRICTED LOCATION REFERENCE')
ENDIF
ATOM_FLAGS(ATM)=ATOM_FLAGS(ATM).OR.A_IMMEDIATE
RESTRICTED_LOCATION_REFERENCE=OPERAND(ATM,N)
RESTRICTED_LOCATION_REFERENCE=RESTRICTED_LOCATION_REFERENCE(2:N)
N=N-1
RETURN
END

578
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/fold.for Normal file
View File

@@ -0,0 +1,578 @@
C***********************************************************************
C
C FOLD.FOR
C
C
C D I S C L A I M E R N O T I C E
C ------------------- -----------
C
C This document and/or portions of the material and data furnished
C herewith, was developed under sponsorship of the U. S. Government.
C Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior
C University, nor their employees, nor their respective contractors,
C subcontractors, or their employees, makes any warranty, express or
C implied, or assumes any liability or responsibility for accuracy,
C completeness or usefulness of any information, apparatus, product
C or process disclosed, or represents that its use will not infringe
C privately-owned rights. Mention of any product, its manufacturer,
C or suppliers shall not, nor is it intended to, imply approval, dis-
C approval, or fitness for any particular use. The U. S. and the
C University at all times retain the right to use and disseminate same
C for any purpose whatsoever. Such distribution shall be made by the
C National Energy Software Center at the Argonne National Laboratory
C and only subject to the distributee furnishing satisfactory proof
C that he has a valid license from the Intel Corporation in effect.
C
C
C-----------------------------------------------------------------------
C
C This module of the PL/M-VAX compiler examines a code tree and
C folds operator nodes having all constant operands. Some binary
C operator nodes having one constant operand are also simplified.
C Constant displacements within atom base and subscript subtrees
C are extracted and incorporated into the atom's displacement
C field.
C
C-----------------------------------------------------------------------
C R E V I S I O N H I S T O R Y
C
C 15OCT81 Alex Hunter 1. Added disclaimer notice. (V5.4)
C 09NOV81 Alex Hunter 1. Implement CTE assumption. (V5.9)
C
C-----------------------------------------------------------------------
C!!!!! COMPILE ME WITH /NOCHECK PLEASE!!!!!!!!!
C
INTEGER*2 FUNCTION FOLD_CONSTANTS(NODX)
INCLUDE 'PLMCOM.FOR/NOLIST'
INTEGER*4 I,I1,I2
REAL*8 R,R1,R2
INTEGER*4 MASK(S_BYTE:S_QUAD)
DATA MASK/'FF'X,'FFFF'X,'FFFFFFFF'X,'FFFFFFFF'X,
# 'FFFFFFFF'X,'FFFFFFFF'X,'FFFFFFFF'X,'FFFFFFFF'X/
NOD=NODX
1 IF (NOD.EQ.NULL) GO TO 9000
IF (LITERAL(NOD)) GO TO 9000
IF (CONSTANT(NOD)) GO TO 9000
IF (REGISTER(NOD)) GO TO 9000
IF (ATOM(NOD)) THEN
CALL PUSH(NOD,1)
BASE=FOLD_CONSTANTS2(ATOM_BASE(NOD))
CALL POP(NOD,1)
ATOM_BASE(NOD)=BASE
CALL PUSH(NOD,1)
CALL PUSH(BASE,1)
SUB=FOLD_CONSTANTS2(ATOM_SUB(NOD))
CALL POP(BASE,1)
CALL POP(NOD,1)
ATOM_SUB(NOD)=SUB
IF (NODE(BASE).AND.OPNODE_OP(BASE).EQ.OP_L2P) THEN
ATOM_FLAGS(NOD)=ATOM_FLAGS(NOD).OR.A_L2P
ATOM_BASE(NOD)=OPNODE_OPND1(BASE)
ENDIF
ELEMENT_SIZE=BYTE_SIZE(NODE_TYPE(NOD))
NOD1=ATOM_SUB(NOD)
IF (NODE(NOD1).AND.OPNODE_OP(NOD1).GT.100)
# NOD1=OPNODE_OPND1(NOD1)
IF (NODE(NOD1).AND.OPNODE_OP(NOD1).EQ.OP_MUL.AND.
# FIXLIT(OPNODE_OPND2(NOD1))) THEN
FACTOR=FIXED_VAL(OPNODE_OPND2(NOD1))
OPNODE_OPND1(NOD1)=EXTRACT_DISPLACEMENT(OPNODE_OPND1(NOD1)
# ,DISP)
ATOM_DISP(NOD)=ATOM_DISP(NOD)+DISP*FACTOR*ELEMENT_SIZE
ELSE
ATOM_SUB(NOD)=EXTRACT_DISPLACEMENT(ATOM_SUB(NOD),DISP)
ATOM_DISP(NOD)=ATOM_DISP(NOD)+DISP*ELEMENT_SIZE
ENDIF
! Check for special case of symbol(const).member(const) where
! size(symbol_element).ne.0 modulo size(member_element).
IF (ATOM_SYM(NOD).EQ.0 .AND. ATOM_MEM(NOD).EQ.0 .AND.
# ATOM_SUB(NOD).EQ.NULL .AND. NODE(ATOM_BASE(NOD)) .AND.
# OPNODE_OP(ATOM_BASE(NOD)).EQ.OP_LOC .AND.
# ATOM(OPNODE_OPND1(ATOM_BASE(NOD))) .AND.
# ATOM_SUB(OPNODE_OPND1(ATOM_BASE(NOD))).EQ.NULL ) THEN
NOD1=OPNODE_OPND1(ATOM_BASE(NOD))
NODE_TYPE(NOD1)=NODE_TYPE(NOD)
ATOM_DISP(NOD1)=ATOM_DISP(NOD1)+ATOM_DISP(NOD)
FOLD_CONSTANTS=NOD1
RETURN
ENDIF
GO TO 9000
ENDIF
C-------------- NODE MUST BE AN OPNODE.
IF (OPNODE_OP(NOD).EQ.OP_NOP .OR.
# (OPNODE_OP(NOD).EQ.OP_L2P .OR.
# OPNODE_OP(NOD).EQ.OP_P2L)) THEN
NOD=OPNODE_OPND1(NOD)
GO TO 1
ENDIF
IF (.NOT.ASSUME_CTE) RETURN
CALL PUSH(NOD,1)
OPND1=FOLD_CONSTANTS2(OPNODE_OPND1(NOD))
CALL POP(NOD,1)
OPNODE_OPND1(NOD)=OPND1
CALL PUSH(NOD,1)
CALL PUSH(OPND1,1)
OPND2=FOLD_CONSTANTS2(OPNODE_OPND2(NOD))
CALL POP(OPND1,1)
CALL POP(NOD,1)
OPNODE_OPND2(NOD)=OPND2
OP=OPNODE_OP(NOD)
IF (OP.EQ.OP_CALL.OR.OP.EQ.OP_ARG.OR.OP.EQ.OP_THEN.OR.
# OP.EQ.OP_ALSO) GO TO 9000
CC IF (OP.EQ.OP_P2L) THEN
CC IF (NODE(OPND1).AND.OPNODE_OP(OPND1).EQ.OP_LOC.AND.
CC # ATOM(OPNODE_OPND1(OPND1))) THEN
CC ATOM_FLAGS(OPNODE_OPND1(OPND1))=
CC # ATOM_FLAGS(OPNODE_OPND1(OPND1)).OR.A_P2L
CC NODE_TYPE(OPND1)=S_LONG
CC FOLD_CONSTANTS=OPND1
CC RETURN
CC ELSE
CC GO TO 9000
CC ENDIF
CC ENDIF
IF (.NOT.LITERAL(OPND1).AND..NOT.LITERAL(OPND2)) GO TO 9000
TYPE=NODE_TYPE(NOD)
TYPE1=NODE_TYPE(OPNODE_OPND1(NOD))
TYPE2=NODE_TYPE(OPNODE_OPND2(NOD))
IF (LITERAL(OPND1)) THEN
IF (TYPE1.EQ.S_REAL.OR.TYPE1.EQ.S_DOUBLE) THEN
R1=FLOAT_VAL(OPND1)
ELSE
I1=FIXED_VAL(OPND1).AND.MASK(TYPE1)
ENDIF
ENDIF
IF (LITERAL(OPND2)) THEN
IF (TYPE2.EQ.S_REAL.OR.TYPE2.EQ.S_DOUBLE) THEN
R2=FLOAT_VAL(OPND2)
ELSE
I2=FIXED_VAL(OPND2).AND.MASK(TYPE1)
ENDIF
ENDIF
IF (LITERAL(OPND1).AND.(LITERAL(OPND2).OR.OPND2.EQ.NULL)) THEN
IF (TYPE1.NE.S_REAL.AND.TYPE1.NE.S_DOUBLE) THEN
GO TO (10,20,30,40,50,60,70,80,90,100,110,120,130,140,
# 150,160,170,180,190,200), OP
ELSE
GO TO (15,25,35,45,55,65,75,85,95,105,115,125,135,145,
# 155,165,175,185,195,205), OP
ENDIF
GO TO (1010,1020,1030,1040,1050,1060,1070,1080,1090,1100,
# 1110,1120,1130,1140,1150,1160,1170,1180,1190,1200,
# 1210,1220,1230,1240,1250,1260,1270), OP-100
CALL BUG('FC-1')
ENDIF
C---------- BINARY OPERATION WITH EXACTLY ONE LITERAL OPERAND.
IF (LITERAL(OPND1)) THEN
LITOPND=OPND1
OPND=OPND2
I=I1
R=R1
ELSE
LITOPND=OPND2
OPND=OPND1
I=I2
R=R2
ENDIF
IF (TYPE1.NE.S_REAL.AND.TYPE1.NE.S_DOUBLE) THEN
GO TO (13,23,33,43,53,63,73,83,93,103,113), OP
IF (OP.EQ.20) GO TO 203
ELSE
GO TO (18,28,38,48,58,68,78,88,98,108,118), OP
IF (OP.EQ.20) GO TO 208
ENDIF
GO TO 9000
C--------- SIMPLIFY BINARY OPERATIONS WITH ONE CONSTANT OPERAND.
13 IF (I.EQ.0) GO TO 9100 ! ADD
IF (FIXLIT(OPND1)) THEN
FOLD_CONSTANTS=FOLD_LOC_REF(NOD,OPND2,I)
ELSE
FOLD_CONSTANTS=FOLD_LOC_REF(NOD,OPND1,I)
ENDIF
RETURN
18 IF (R.EQ.0.0) GO TO 9100
GO TO 9000
23 IF (FIXLIT(OPND1).AND.I1.EQ.0) GO TO 9300 ! SUB
IF (FIXLIT(OPND2).AND.I2.EQ.0) GO TO 9100
IF (FIXLIT(OPND2)) THEN
FOLD_CONSTANTS=FOLD_LOC_REF(NOD,OPND1,-I)
RETURN
ENDIF
GO TO 9000
28 IF (FLOATLIT(OPND1).AND.R1.EQ.0.0) GO TO 9300
IF (FLOATLIT(OPND2).AND.R2.EQ.0.0) GO TO 9100
GO TO 9000
33 IF (I.EQ.0) GO TO 9200 ! MUL
IF (I.EQ.1) GO TO 9100
IF (I.EQ.-1) GO TO 9300
GO TO 9000
38 IF (R.EQ.0.0) GO TO 9200
IF (R.EQ.1.0) GO TO 9100
IF (R.EQ.-1.0) GO TO 9300
GO TO 9000
43 IF (FIXLIT(OPND1).AND.I.EQ.0) GO TO 9200 ! DIV
IF (FIXLIT(OPND2)) THEN
IF (I.EQ.0) GO TO 9900
IF (I.EQ.1) GO TO 9100
IF (I.EQ.-1) GO TO 9300
ENDIF
GO TO 9000
48 IF (FLOATLIT(OPND1).AND.R.EQ.0.0) GO TO 9200
IF (FLOATLIT(OPND2)) THEN
IF (R.EQ.0.0) GO TO 9900
IF (R.EQ.1.0) GO TO 9100
IF (R.EQ.-1.0) GO TO 9300
ENDIF
GO TO 9000
53 GO TO 9000 ! ADWC
58 GO TO 9000
63 GO TO 9000 ! SUBWC
68 GO TO 9000
73 CONTINUE ! NEG
78 CONTINUE
83 CONTINUE ! NOT
88 CONTINUE
CALL BUG ('FC-88')
93 IF (FIXLIT(OPND1).AND.I1.EQ.0) GO TO 9200 ! EXT
IF (FIXLIT(OPND1).AND.I1.EQ.MASK(TYPE1)) THEN
IF (OPNODE_OP(OPND2).EQ.OP_NOT) THEN
FOLD_CONSTANTS=OPNODE_OPND1(OPND2)
RETURN
ELSE
GO TO 9400
ENDIF
ENDIF
IF (FIXLIT(OPND2).AND.I2.EQ.0) GO TO 9100
IF (FIXLIT(OPND2).AND.I2.EQ.MASK(TYPE1)) THEN
I=0
GO TO 8000
ENDIF
GO TO 9000
98 GO TO 8900
103 IF (I.EQ.0) GO TO 9100 ! OR
IF (I.EQ.MASK(TYPE1)) GO TO 9200
GO TO 9000
108 GO TO 8900
113 IF (I.EQ.0) GO TO 9100 ! XOR
IF (I.EQ.MASK(TYPE1)) GO TO 9400
GO TO 9000
118 GO TO 8900
203 IF (FIXLIT(OPND1).AND.I.EQ.0) GO TO 9200 ! MOD
IF (FIXLIT(OPND2)) THEN
IF (I.EQ.0) GO TO 9900
IF (I.EQ.1.OR.I.EQ.-1) THEN
FOLD_CONSTANTS=MAKE_FIXED(0,TYPE)
RETURN
ENDIF
ENDIF
GO TO 9000
208 GO TO 8900
C------------- REDUCE OPERATIONS WITH CONSTANT OPERANDS.
10 I=I1+I2 ! ADD
GO TO 8000
15 R=R1+R2
GO TO 8005
20 I=I1-I2 ! SUB
GO TO 8000
25 R=R1-R2
GO TO 8005
30 I=I1*I2 ! MUL
GO TO 8000
35 R=R1*R2
GO TO 8005
40 IF (I2.EQ.0) GO TO 9900 ! DIV
I=I1/I2
GO TO 8000
45 IF (R2.EQ.0.0) GO TO 9900
R=R1/R2
GO TO 8005
50 GO TO 9000 ! ADWC
55 GO TO 8900
60 GO TO 9000 ! SBWC
65 GO TO 8900
70 I=-I1 ! NEG
GO TO 8000
75 R=-R1
GO TO 8005
80 I=.NOT.I1 ! NOT
GO TO 8000
85 GO TO 8900
90 I=I1.AND..NOT.I2 ! EXT
GO TO 8000
95 GO TO 8900
100 I=I1.OR.I2 ! OR
GO TO 8000
105 GO TO 8900
110 I=I1.XOR.I2 ! XOR
GO TO 8000
115 GO TO 8900
120 I=I1.LT.I2 ! LT
GO TO 8000
125 I=R1.LT.R2
GO TO 8000
130 I=I1.GT.I2 ! GT
GO TO 8000
135 I=R1.GT.R2
GO TO 8000
140 I=I1.EQ.I2 ! EQ
GO TO 8000
145 I=R1.EQ.R2
GO TO 8000
150 I=I1.NE.I2 ! NE
GO TO 8000
155 I=R1.NE.R2
GO TO 8000
160 I=I1.LE.I2 ! LE
GO TO 8000
165 I=R1.LE.R2
GO TO 8000
170 I=I1.GE.I2 ! GE
GO TO 8000
175 R=R1.GE.R2
GO TO 8000
180 CALL BUG('FC-180') ! LOC
185 CALL BUG('FC-185')
190 CALL BUG('FC-190') ! ASSN
195 CALL BUG('FC-195')
200 IF (I2.EQ.0) GO TO 9900 ! MOD
I=MOD(I1,I2)
GO TO 8000
205 GO TO 8900
C----------- CONVERT TYPE OF LITERAL OPERAND.
1010 CONTINUE ! B2W
1020 CONTINUE ! B2I
1030 CONTINUE ! B2L
1050 CONTINUE ! W2B
1060 CONTINUE ! W2L
1070 CONTINUE ! I2B
1090 CONTINUE ! I2L
1120 CONTINUE ! L2W
1140 CONTINUE ! L2B
1180 CONTINUE ! L2Q
1240 CONTINUE ! Q2L
I=I1
GO TO 8000
1040 CONTINUE ! B2R
1080 CONTINUE ! I2R
1130 CONTINUE ! L2R
1170 CONTINUE ! L2D
1250 CONTINUE ! I2D
R=I1
GO TO 8005
1100 CONTINUE ! R2L
1110 CONTINUE ! R2I
1150 CONTINUE ! R2B
1160 CONTINUE ! R2W
1200 CONTINUE ! D2B
1210 CONTINUE ! D2I
1230 CONTINUE ! D2L
I=R1
GO TO 8000
1190 CONTINUE ! R2D
1220 CONTINUE ! D2R
R=R1
GO TO 8005
1260 CONTINUE ! L2P
1270 CONTINUE ! P2L
GO TO 9000
C---------------------------------------------------
8000 FOLD_CONSTANTS=MAKE_FIXED(I.AND.MASK(TYPE),TYPE)
RETURN
8005 FOLD_CONSTANTS=MAKE_FLOAT(R,TYPE)
RETURN
8900 CALL ERROR('FC - ILLEGAL MIXING OF TYPES')
9000 FOLD_CONSTANTS=NOD
RETURN
9100 FOLD_CONSTANTS=OPND
RETURN
9200 FOLD_CONSTANTS=LITOPND
RETURN
9300 FOLD_CONSTANTS=MAKE_NODE(OP_NEG,OPND,NULL,TYPE,0,0)
RETURN
9400 FOLD_CONSTANTS=MAKE_NODE(OP_NOT,OPND,NULL,TYPE,0,0)
RETURN
9900 CALL WARN('FC - ATTEMPTED DIVISION BY ZERO')
GO TO 9000
END
C----------------------------------------------------
INTEGER*2 FUNCTION FOLD_CONSTANTS2(NODX)
IMPLICIT INTEGER*2 (A-Z)
FOLD_CONSTANTS2=FOLD_CONSTANTS(NODX)
RETURN
END
C----------------------------------------------------
INTEGER*2 FUNCTION EXTRACT_DISPLACEMENT(NOD,DISP)
INCLUDE 'PLMCOM.FOR/NOLIST'
INTEGER*2 COMBOP(S_BYTE:S_QUAD,S_BYTE:S_QUAD)
DATA COMBOP/
# 0, 0, 0, 0, 0, 0, 0, 0,
# OP_B2W, 0, 0, 0, 0, 0, 0, 0,
# OP_B2I, 0, 0, 0, 0, 0, 0, 0,
# 0, 0, 0, 0, 0, 0, 0, 0,
# 0, 0, 0, 0, 0, 0, 0, 0,
# OP_B2L,OP_W2L,OP_I2L, 0, 0, 0, 0, 0,
# 0, 0, 0, 0, 0, 0, 0, 0,
# 0, 0, 0, 0, 0, 0, 0, 0/
NOD1=NOD
IF (FIXLIT(NOD1)) THEN
DISP=FIXED_VAL(NOD1)
EXTRACT_DISPLACEMENT=NULL
RETURN
ENDIF
IF (.NOT.NODE(NOD1)) GO TO 900
IF (OPNODE_OP(NOD1).GT.100) NOD1=OPNODE_OPND1(NOD1)
IF (OPNODE_OP(NOD1).EQ.OP_ADD) THEN
IF (FIXLIT(OPNODE_OPND2(NOD1))) THEN
DISP=FIXED_VAL(OPNODE_OPND2(NOD1))
NOD2=OPNODE_OPND1(NOD1)
ELSEIF (FIXLIT(OPNODE_OPND1(NOD1))) THEN
DISP=FIXED_VAL(OPNODE_OPND1(NOD1))
NOD2=OPNODE_OPND2(NOD1)
ELSE
GO TO 900
ENDIF
ELSEIF (OPNODE_OP(NOD1).EQ.OP_SUB) THEN
IF (FIXLIT(OPNODE_OPND2(NOD1))) THEN
DISP=-FIXED_VAL(OPNODE_OPND2(NOD1))
NOD2=OPNODE_OPND1(NOD1)
ELSE
GO TO 900
ENDIF
ELSE
GO TO 900
ENDIF
IF (OPNODE_OP(NOD).LE.100) THEN
EXTRACT_DISPLACEMENT=NOD2
RETURN
ENDIF
IF (.NOT.NODE(NOD2) .OR. OPNODE_OP(NOD2).LE.100 .OR.
# NODE_TYPE(OPNODE_OPND1(NOD2)).GT.NODE_TYPE(NOD2)) THEN
C------- (Note that downward/upward coercions are not transitive!) ---
OPNODE_OPND1(NOD)=NOD2
EXTRACT_DISPLACEMENT=NOD
RETURN
ENDIF
NOD2=OPNODE_OPND1(NOD2)
NEWOP=COMBOP(NODE_TYPE(NOD2),NODE_TYPE(NOD))
IF (NEWOP.EQ.0) CALL BUG('ED-0')
EXTRACT_DISPLACEMENT=MAKE_NODE(NEWOP,NOD2,NULL,NODE_TYPE(NOD),
# 0,0)
RETURN
900 DISP=0
EXTRACT_DISPLACEMENT=NOD
RETURN
END
C----------------------------------------------------
INTEGER*2 FUNCTION FOLD_LOC_REF(NOD,OPND,I)
INCLUDE 'PLMCOM.FOR/NOLIST'
INTEGER*4 I
IF (NODE(OPND).AND.OPNODE_OP(OPND).EQ.OP_LOC) THEN
ATM=OPNODE_OPND1(OPND)
IF (.NOT.ATOM(ATM)) GO TO 900
ATOM_DISP(ATM)=ATOM_DISP(ATM)+I
FOLD_LOC_REF=OPND
RETURN
ENDIF
900 FOLD_LOC_REF=NOD
RETURN
END

245
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/gencode.for Normal file
View File

@@ -0,0 +1,245 @@
C***********************************************************************
C
C GENCODE.FOR
C
C
C D I S C L A I M E R N O T I C E
C ------------------- -----------
C
C This document and/or portions of the material and data furnished
C herewith, was developed under sponsorship of the U. S. Government.
C Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior
C University, nor their employees, nor their respective contractors,
C subcontractors, or their employees, makes any warranty, express or
C implied, or assumes any liability or responsibility for accuracy,
C completeness or usefulness of any information, apparatus, product
C or process disclosed, or represents that its use will not infringe
C privately-owned rights. Mention of any product, its manufacturer,
C or suppliers shall not, nor is it intended to, imply approval, dis-
C approval, or fitness for any particular use. The U. S. and the
C University at all times retain the right to use and disseminate same
C for any purpose whatsoever. Such distribution shall be made by the
C National Energy Software Center at the Argonne National Laboratory
C and only subject to the distributee furnishing satisfactory proof
C that he has a valid license from the Intel Corporation in effect.
C
C
C-----------------------------------------------------------------------
C
C This module of the PL/M-VAX compiler generates actual symbolic
C MACRO assembly code from the abstract operators and operands of
C of a code tree node.
C
C-----------------------------------------------------------------------
C R E V I S I O N H I S T O R Y
C
C 15OCT81 Alex Hunter 1. Added disclaimer notice. (V5.4)
C 23OCT81 Alex Hunter 1. Add peephole optimizations for trivial
C conversions and commutative binary
C operators. (V5.6)
C 09NOV81 Alex Hunter 1. Implement MCO assumption. (V5.9)
C
C-----------------------------------------------------------------------
C!!!!!!!! COMPILE ME WITH /CONT=99 PLEASE!!!!!!!!!!
C
SUBROUTINE EMIT_CODE(OP,OPND1X,OPND2X,OPND3)
INCLUDE 'PLMCOM.FOR/NOLIST'
CHARACTER*80 OPERAND,OPERAND1,OPERAND2,OPERAND3,TEMPOPND
CHARACTER*6 MNEM(S_BYTE:S_QUAD,2:3,1:22)
C BYTE WORD INTEGER POINTER REAL LONG DOUBLE QUAD
DATA MNEM/
#'ADDB2','ADDW2','ADDW2','ADDL2','ADDF2','ADDL2','ADDD2','---- ',
#'ADDB3','ADDW3','ADDW3','ADDL3','ADDF3','ADDL3','ADDD3','---- ',
#'SUBB2','SUBW2','SUBW2','SUBL2','SUBF2','SUBL2','SUBD2','---- ',
#'SUBB3','SUBW3','SUBW3','SUBL3','SUBF3','SUBL3','SUBD3','---- ',
#'MULB2','MULW2','MULW2','MULL2','MULF2','MULL2','MULD2','---- ',
#'MULB3','MULW3','MULW3','MULL3','MULF3','MULL3','MULD3','---- ',
#'DIVB2','DIVW2','DIVW2','DIVL2','DIVF2','DIVL2','DIVD2','---- ',
#'DIVB3','DIVW3','DIVW3','DIVL3','DIVF3','DIVL3','DIVD3','---- ',
#'---- ','---- ','---- ','ADWC ','---- ','ADWC ','---- ','---- ',
#'---- ','---- ','---- ','---- ','---- ','---- ','---- ','---- ',
#'---- ','---- ','---- ','SBWC ','---- ','SBWC ','---- ','---- ',
#'---- ','---- ','---- ','---- ','---- ','----', '---- ','---- ',
#'MNEGB','MNEGW','MNEGW','MNEGL','MNEGF','MNEGL','MNEGD','---- ',
#'---- ','---- ','---- ','---- ','---- ','---- ','---- ','---- ',
#'MCOMB','MCOMW','MCOMW','MCOML','---- ','MCOML','---- ','---- ',
#'---- ','---- ','---- ','---- ','---- ','---- ','---- ','---- ',
#'BICB2','BICW2','BICW2','BICL2','---- ','BICL2','---- ','---- ',
#'BICB3','BICW3','BICW3','BICL3','---- ','BICL3','---- ','---- ',
#'BISB2','BISW2','BISW2','BISL2','---- ','BISL2','---- ','---- ',
#'BISB3','BISW3','BISW3','BISL3','---- ','BISL3','---- ','---- ',
#'XORB2','XORW2','XORW2','XORL2','---- ','XORL2','---- ','---- ',
#'XORB3','XORW3','XORW3','XORL3','---- ','XORL3','---- ','---- ',
#'CMPB ','CMPW ','CMPW ','CMPL ','CMPF ','CMPL ','CMPD ','---- ',
#'BLSSU','BLSSU','BLSS ','BLSSU','BLSS ','BLSS ','BLSS ','---- ',
#'CMPB ','CMPW ','CMPW ','CMPL ','CMPF ','CMPL ','CMPD ','---- ',
#'BGTRU','BGTRU','BGTR ','BGTRU','BGTR ','BGTR ','BGTR ','---- ',
#'CMPB ','CMPW ','CMPW ','CMPL ','CMPF ','CMPL ','CMPD ','---- ',
#'BEQLU','BEQLU','BEQL ','BEQLU','BEQL ','BEQL ','BEQL ','---- ',
#'CMPB ','CMPW ','CMPW ','CMPL ','CMPF ','CMPL ','CMPD ','---- ',
#'BNEQU','BNEQU','BNEQ ','BNEQU','BNEQ ','BNEQ ','BNEQ ','---- ',
#'CMPB ','CMPW ','CMPW ','CMPL ','CMPF ','CMPL ','CMPD ','---- ',
#'BLEQU','BLEQU','BLEQ ','BLEQU','BLEQ ','BLEQ ','BLEQ ','---- ',
#'CMPB ','CMPW ','CMPW ','CMPL ','CMPF ','CMPL ','CMPD ','---- ',
#'BGEQU','BGEQU','BGEQ ','BGEQU','BGEQ ','BGEQ ','BGEQ ','---- ',
#'MOVAB','MOVAW','MOVAW','MOVAL','MOVAF','MOVAL','MOVAD','MOVAQ',
#'---- ','---- ','---- ','---- ','---- ','---- ','---- ','---- ',
#'MOVB ','MOVW ','MOVW ','MOVL ','MOVF ','MOVL ','MOVD ','MOVQ ',
#'---- ','---- ','---- ','---- ','---- ','---- ','---- ','---- ',
#'---- ','---- ','---- ','---- ','---- ','---- ','---- ','---- ',
#'---- ','---- ','---- ','---- ','---- ','EDIV ','---- ','---- ',
#'---- ','---- ','---- ','---- ','---- ','---- ','---- ','---- ',
#'---- ','---- ','---- ','---- ','---- ','---- ','---- ','---- ',
#'BITB ','BITW ','BITW ','BITL ','---- ','BITL ','---- ','---- ',
#'---- ','---- ','---- ','---- ','---- ','---- ','---- ','---- '/
CHARACTER*6 CLROP(8),INCOP(8),DECOP(8),PUSHAOP(8),PUSHLOP(8),
# TSTOP(8)
DATA CLROP,INCOP,DECOP,PUSHAOP,PUSHLOP,TSTOP/
#'CLRB ','CLRW ','CLRW ','CLRL ','CLRF ','CLRL ','CLRD ','CLRQ ',
#'INCB ','INCW ','INCW ','INCL ','---- ','INCL ','---- ','---- ',
#'DECB ','DECW ','DECW ','DECL ','---- ','DECL ','---- ','---- ',
#'PUSHAB','PUSHAW','PUSHAW','PUSHAL','PUSHAF','PUSHAL','PUSHAD',
# 'PUSHAQ',
#'---- ','---- ','---- ','PUSHL','PUSHL','PUSHL','---- ','---- ',
#'TSTB ','TSTW ','TSTW ','TSTL ','TSTF ','TSTL ','TSTD ','---- '/
CHARACTER*6 CNVT(OP_B2W:OP_I2D)
DATA CNVT/
# 'MOVZBW','MOVZBW','MOVZBL','CVTBF ','CVTWB ',
# 'MOVZWL','CVTWB ','CVTWF ','CVTWL ','CVTFL ',
# 'CVTFW ','CVTLW ','CVTLF ','CVTLB ','CVTFB ',
# 'CVTFW ','CVTLD ','---- ','CVTFD ','CVTDB ',
# 'CVTDW ','CVTDF ','CVTDL ','---- ','CVTWD '/
LOGICAL*1 NONTRIVIAL_CONVERSION(OP_B2W:OP_I2D)
DATA NONTRIVIAL_CONVERSION/
# .TRUE., .TRUE., .TRUE., .TRUE.,.FALSE.,
# .TRUE.,.FALSE., .TRUE., .TRUE., .TRUE.,
# .TRUE.,.FALSE., .TRUE.,.FALSE., .TRUE.,
# .TRUE., .TRUE., .TRUE., .TRUE., .TRUE.,
# .TRUE., .TRUE., .TRUE., .TRUE., .TRUE./
LOGICAL*1 COMMUTATIVE(OP_ADD:OP_BIT)
DATA COMMUTATIVE/
# .TRUE.,.FALSE., .TRUE.,.FALSE.,.FALSE.,.FALSE.,
# .FALSE.,.FALSE.,.FALSE., .TRUE., .TRUE.,.FALSE.,
# .FALSE., .TRUE., .TRUE.,.FALSE.,.FALSE.,.FALSE.,
# .FALSE.,.FALSE.,.FALSE.,.FALSE./
IF (OPND1X.EQ.NULL) THEN
OPND1=OPND2X
OPERAND2=' '
ELSEIF (OPND2X.EQ.NULL) THEN
OPND1=OPND1X
OPERAND2=' '
ELSE
OPND1=OPND1X
OPND2=OPND2X
OPERAND2=OPERAND(OPND2,N2)
ENDIF
OPERAND1=OPERAND(OPND1,N1)
IF (OPND3.NE.NULL) OPERAND3=OPERAND(OPND3,N3)
TYPE=NODE_TYPE(OPND1)
IF (TYPE.EQ.0) CALL BUG('EC-0')
IF (OP.GE.101) THEN
IF (OP.EQ.OP_L2Q) THEN
IF (.NOT.REGISTER(OPND3)) CALL BUG('GC-L2Q')
CALL EMIT('EMUL #1,'//OPERAND1(:N1)//',#0,'//
# OPERAND3(:N3))
ELSEIF (OP.EQ.OP_Q2L) THEN
IF (.NOT.REGISTER(OPND1)) CALL BUG('GC-Q2L')
IF (OPERAND1.NE.OPERAND3) THEN
CALL EMIT('MOVL '//OPERAND1(:N1)//','//OPERAND3(:N3))
ENDIF
ELSEIF (OP.EQ.OP_L2P) THEN
IF (OPERAND1.EQ.OPERAND3) THEN
CALL EMIT('ADDL2 '//BASEV//','//OPERAND3(:N3))
ELSE
CALL EMIT('ADDL3 '//BASEV//','//OPERAND1(:N1)//','//
# OPERAND3(:N3))
ENDIF
ELSEIF (OP.EQ.OP_P2L) THEN
IF (OPERAND1.EQ.OPERAND3) THEN
CALL EMIT('SUBL2 '//BASEV//','//OPERAND3(:N3))
ELSE
CALL EMIT('SUBL3 '//BASEV//','//OPERAND1(:N1)//','//
# OPERAND3(:N3))
ENDIF
ELSE
IF (.NOT.ASSUME_MCO.OR.
# NONTRIVIAL_CONVERSION(OP).OR.OPERAND1.NE.OPERAND3.OR.
# OPERAND1(N1:N1).EQ.']') THEN
CALL EMIT(CNVT(OP)//' '//OPERAND1(:N1)//','
# //OPERAND3(:N3))
ENDIF
ENDIF
ELSEIF (OP.GE.OP_LT.AND.OP.LE.OP_GE) THEN
IF (ASSUME_MCO.AND.
# (OPERAND1.EQ.'#0'.OR.OPERAND1.EQ.'#0.0')) THEN
CALL EMIT(TSTOP(TYPE)//' '//OPERAND2(:N2))
ELSE
CALL EMIT(MNEM(TYPE,2,OP)//' '//OPERAND2(:N2)//','//
# OPERAND1(:N1))
ENDIF
IF (OPND3.NE.NULL) THEN
CALL GENERATE_LOCAL_LABEL(LL1)
CALL GENERATE_LOCAL_LABEL(LL2)
CALL EMIT(MNEM(TYPE,3,OP)//' '//
# LOCAL_LABEL(LL1,N0))
CALL EMIT('CLRB '//OPERAND3(:N3))
CALL EMIT('BRB '//LOCAL_LABEL(LL2,N0))
CALL EMIT_LOCAL_LABEL(LL1)
CALL EMIT('MCOMB #0,'//OPERAND3(:N3))
CALL EMIT_LOCAL_LABEL(LL2)
ENDIF
ELSE
IF (ASSUME_MCO.AND.
# COMMUTATIVE(OP).AND.OPERAND1.EQ.OPERAND3) THEN
TEMPOPND=OPERAND1
OPERAND1=OPERAND2
OPERAND2=TEMPOPND
NT=N1
N1=N2
N2=NT
ENDIF
IF (ASSUME_MCO.AND.
# (OPERAND2.EQ.' '.OR.(OPERAND2.EQ.OPERAND3.AND.
# MNEM(TYPE,2,OP).NE.'----'))) THEN
IF (OP.EQ.OP_ASSN.AND.(OPERAND1.EQ.'#0'.OR.
# OPERAND1.EQ.'#0.0')) THEN
CALL EMIT(CLROP(TYPE)//' '//OPERAND3(:N3))
ELSEIF (OP.EQ.OP_ADD.AND.OPERAND1.EQ.'#1') THEN
CALL EMIT(INCOP(TYPE)//' '//OPERAND3(:N3))
ELSEIF (OP.EQ.OP_SUB.AND.OPERAND1.EQ.'#1') THEN
CALL EMIT(DECOP(TYPE)//' '//OPERAND3(:N3))
ELSEIF (OP.EQ.OP_LOC.AND.OPERAND3.EQ.'-(SP)') THEN
CALL EMIT(PUSHAOP(TYPE)//' '//OPERAND1(:N1))
ELSEIF (OP.EQ.OP_ASSN.AND.BYTE_SIZE(TYPE).EQ.4.AND.
# OPERAND3.EQ.'-(SP)') THEN
CALL EMIT(PUSHLOP(TYPE)//' '//OPERAND1(:N1))
ELSE
CALL EMIT(MNEM(TYPE,2,OP)//' '//OPERAND1(:N1)//','//
# OPERAND3(:N3))
ENDIF
ELSEIF (OPERAND2.EQ.' ') THEN
CALL EMIT(MNEM(TYPE,2,OP)//' '//OPERAND1(:N1)//','//
# OPERAND3(:N3))
ELSEIF (OP.EQ.OP_MOD) THEN
CALL EMIT(MNEM(TYPE,3,OP)//' '//OPERAND1(:N1)//','//
# OPERAND2(:N2)//',R0,'//
# OPERAND3(:N3))
ELSE
CALL EMIT(MNEM(TYPE,3,OP)//' '//OPERAND1(:N1)//
# ','//OPERAND2(:N2)//','//OPERAND3(:N3))
ENDIF
ENDIF
RETURN
END

178
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/getc.for Normal file
View File

@@ -0,0 +1,178 @@
C***********************************************************************
C
C GETC.FOR
C
C
C D I S C L A I M E R N O T I C E
C ------------------- -----------
C
C This document and/or portions of the material and data furnished
C herewith, was developed under sponsorship of the U. S. Government.
C Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior
C University, nor their employees, nor their respective contractors,
C subcontractors, or their employees, makes any warranty, express or
C implied, or assumes any liability or responsibility for accuracy,
C completeness or usefulness of any information, apparatus, product
C or process disclosed, or represents that its use will not infringe
C privately-owned rights. Mention of any product, its manufacturer,
C or suppliers shall not, nor is it intended to, imply approval, dis-
C approval, or fitness for any particular use. The U. S. and the
C University at all times retain the right to use and disseminate same
C for any purpose whatsoever. Such distribution shall be made by the
C National Energy Software Center at the Argonne National Laboratory
C and only subject to the distributee furnishing satisfactory proof
C that he has a valid license from the Intel Corporation in effect.
C
C
C-----------------------------------------------------------------------
C
C This module of the PL/M-VAX compiler contains routines which
C are called by the lexical analysis module (GETLEX) to obtain
C the next (maybe non-blank) source character. The source char-
C acter may come from the source input file, an INCLUDE file, or
C a macro body. When a new source line is read, it is (possibly)
C listed, and tested to see if it is a control line.
C
C-----------------------------------------------------------------------
C R E V I S I O N H I S T O R Y
C
C 15OCT81 Alex Hunter 1. Added disclaimer notice. (V5.4)
C 04FEB82 Alex Hunter 1. Delete reference to GET_CNTRL_FLD. (V6.6)
C 2. Change name of LINE_SEQS common block.
C
C-----------------------------------------------------------------------
SUBROUTINE GETC
C
C----- GET NEXT CHARACTER FROM INPUT STREAM.
C
INCLUDE 'PLMCOM.FOR/NOLIST'
INTEGER*2 W_LINE_NUMBER(0:99)
COMMON /XQ_LINE_SEQS/ W_LINE_NUMBER
CHARACTER*1 CR
DATA CR /'0D'X/
PARAMETER FIFO_MAX=10
CHARACTER*133 FIFO_LINE(FIFO_MAX)
INTEGER*2 FIFO_LEN(FIFO_MAX),FIFO_LINE_NO(FIFO_MAX),
# FIFO_IN(FIFO_MAX)
CHARACTER*300 CARD1
10 COL=COL+1
20 CHAR = LITVAL(LITLEV)(COL:COL)
IF (CHAR.EQ.EOL) THEN
IF (LITLEV.EQ.1) THEN
30 IF (TABS.NE.0) THEN
READ(IN,1000,END=100) L,CARD1
J=1
CARD=' '
DO 31 I=1,L
IF (CARD1(I:I).EQ.TAB) THEN
J=J+TABS-MOD(J-1,TABS)
ELSEIF (J.LE.300) THEN
CARD(J:J)=CARD1(I:I)
J=J+1
ENDIF
31 CONTINUE
L=J-1
ELSE
READ(IN,1000,END=100) L,CARD
ENDIF
1000 FORMAT(Q,A)
LINES_READ=LINES_READ+1
IF (W_LINE_NUMBER(IN).GE.0) THEN
LIST_LINE_NO=W_LINE_NUMBER(IN)
ELSE
LIST_LINE_NO = -W_LINE_NUMBER(IN)
W_LINE_NUMBER(IN) = W_LINE_NUMBER(IN)-1
ENDIF
IF (CARD(LEFTMARGIN:LEFTMARGIN).EQ.'$') THEN
IF (.NOT.NON_CONTROL_LINE_READ) THEN
FIFO_DEPTH=FIFO_DEPTH+1
IF (FIFO_DEPTH.GT.FIFO_MAX)
# CALL FATAL('TOO MANY CONTROL LINES BEFORE FIRST '
# //'NON-CONTROL LINE')
FIFO_LINE(FIFO_DEPTH)=CARD
FIFO_LEN(FIFO_DEPTH)=L
FIFO_LINE_NO(FIFO_DEPTH)=LIST_LINE_NO
FIFO_IN(FIFO_DEPTH)=IN
ELSE
CALL LIST_SOURCE_LINE(CARD(:L))
ENDIF
CARD(L+1:L+1)=CR
CALL DQ SWITCH BUFFER(%REF(CARD(LEFTMARGIN+1:)),STATUS)
CALL CONTROL_LINE
GO TO 30
ENDIF
IF (.NOT.NON_CONTROL_LINE_READ) THEN
NON_CONTROL_LINE_READ=.TRUE.
CALL OPEN_OUTPUT_FILES
CALL INIT_SYMTAB
LISTING_TO_TERMINAL=PRINT_FILE_STRING(0).GE.3.AND.
# PRINT_FILE_STRING(1).EQ.'T'.AND.
# PRINT_FILE_STRING(2).EQ.'T'.AND.
# PRINT_FILE_STRING(3).EQ.':'
CALL SUMMARY_HEAD
LINE_NO_SAVE=LIST_LINE_NO
IN_SAVE=IN
SKIP_STATE_SAVE=SKIP_STATE
SKIP_STATE=4
DO 35 I=1,FIFO_DEPTH
LIST_LINE_NO=FIFO_LINE_NO(I)
IN=FIFO_IN(I)
CALL LIST_SOURCE_LINE(FIFO_LINE(I)(:FIFO_LEN(I)))
35 CONTINUE
LIST_LINE_NO=LINE_NO_SAVE
IN=IN_SAVE
SKIP_STATE=SKIP_STATE_SAVE
ENDIF
CALL LIST_SOURCE_LINE(CARD(:L))
GO TO (40,30,30,40), SKIP_STATE
40 CONTINUE
CARD(L+2:L+2) = EOL
COL = LEFTMARGIN
ELSE
LITLEV = LITLEV-1
COL = LITCOL(LITLEV)
ENDIF
GO TO 20
ENDIF
RETURN
100 IF (IN.EQ.8) THEN
CHAR=EOF
ELSE
CLOSE(UNIT=IN)
IN=IN-1
GO TO 30
ENDIF
RETURN
END
C-------------------------------------------------------
SUBROUTINE GETNB
C
C------ GET NEXT NON-BLANK CHARACTER.
C
INCLUDE 'PLMCOM.FOR/NOLIST'
INTEGER*4 I
CHARACTER*1 CH
10 DO 20 I=COL+1,999
CH=LITVAL(LITLEV)(I:I)
IF (CH.NE.' '.AND.CH.NE.TAB) GO TO 30
20 CONTINUE
STOP 'GETNB BUG'
30 IF (CH.EQ.EOL) THEN
COL=I-1
CALL GETC
IF (CHAR.EQ.' '.OR.CHAR.EQ.TAB) GO TO 10
ELSE
CHAR=CH
COL=I
ENDIF
RETURN
END

Some files were not shown because too many files have changed in this diff Show More