mirror of
https://github.com/SEPPDROID/Digital-Research-Source-Code.git
synced 2025-10-22 07:54:25 +00:00
Upload
Digital Research
This commit is contained in:
1
ASSEMBLY & COMPILE TOOLS/Basic-E/readme.md
Normal file
1
ASSEMBLY & COMPILE TOOLS/Basic-E/readme.md
Normal 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
30
ASSEMBLY & COMPILE TOOLS/Basic-E/source/BASCOM.LIT
Normal 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
BIN
ASSEMBLY & COMPILE TOOLS/Basic-E/source/BASIC.COM
Normal file
Binary file not shown.
996
ASSEMBLY & COMPILE TOOLS/Basic-E/source/BASIC.PLM
Normal file
996
ASSEMBLY & COMPILE TOOLS/Basic-E/source/BASIC.PLM
Normal 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
312
ASSEMBLY & COMPILE TOOLS/Basic-E/source/BASPAR.PLM
Normal 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
1639
ASSEMBLY & COMPILE TOOLS/Basic-E/source/BASSYN.PLM
Normal file
File diff suppressed because it is too large
Load Diff
426
ASSEMBLY & COMPILE TOOLS/Basic-E/source/BUILD.PLM
Normal file
426
ASSEMBLY & COMPILE TOOLS/Basic-E/source/BUILD.PLM
Normal 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
304
ASSEMBLY & COMPILE TOOLS/Basic-E/source/FPCONV.SRC
Normal 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
80
ASSEMBLY & COMPILE TOOLS/Basic-E/source/FPDATA.SRC
Normal 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
315
ASSEMBLY & COMPILE TOOLS/Basic-E/source/FPINT.SRC
Normal 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
648
ASSEMBLY & COMPILE TOOLS/Basic-E/source/FPPKG.SRC
Normal 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
BIN
ASSEMBLY & COMPILE TOOLS/Basic-E/source/RUN.COM
Normal file
Binary file not shown.
2292
ASSEMBLY & COMPILE TOOLS/Basic-E/source/RUN.PLM
Normal file
2292
ASSEMBLY & COMPILE TOOLS/Basic-E/source/RUN.PLM
Normal file
File diff suppressed because it is too large
Load Diff
577
ASSEMBLY & COMPILE TOOLS/Basic-E/source/TRAN.SRC
Normal file
577
ASSEMBLY & COMPILE TOOLS/Basic-E/source/TRAN.SRC
Normal 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
2519
ASSEMBLY & COMPILE TOOLS/Basic-E/source/manual.txt
Normal file
File diff suppressed because it is too large
Load Diff
2521
ASSEMBLY & COMPILE TOOLS/Basic-E/source/readme.md
Normal file
2521
ASSEMBLY & COMPILE TOOLS/Basic-E/source/readme.md
Normal file
File diff suppressed because it is too large
Load Diff
3656
ASSEMBLY & COMPILE TOOLS/PLM COMPILER/PLM81.FOR
Normal file
3656
ASSEMBLY & COMPILE TOOLS/PLM COMPILER/PLM81.FOR
Normal file
File diff suppressed because it is too large
Load Diff
6050
ASSEMBLY & COMPILE TOOLS/PLM COMPILER/PLM82.FOR
Normal file
6050
ASSEMBLY & COMPILE TOOLS/PLM COMPILER/PLM82.FOR
Normal file
File diff suppressed because it is too large
Load Diff
93
ASSEMBLY & COMPILE TOOLS/PLM COMPILER/PLMCOMP.DOC
Normal file
93
ASSEMBLY & COMPILE TOOLS/PLM COMPILER/PLMCOMP.DOC
Normal 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
352
ASSEMBLY & COMPILE TOOLS/PLM COMPILER/PLMLANG.DOC
Normal 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
67
ASSEMBLY & COMPILE TOOLS/PLM COMPILER/PLMSAMP.HEX
Normal 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
70
ASSEMBLY & COMPILE TOOLS/PLM COMPILER/PLMSAMP.PLM
Normal 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
147
ASSEMBLY & COMPILE TOOLS/PLM COMPILER/PLMSAMP.PRN
Normal 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
63
ASSEMBLY & COMPILE TOOLS/PLM COMPILER/README.MARKDOWN
Normal 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
56
ASSEMBLY & COMPILE TOOLS/PLM COMPILER/README.PLM
Normal 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
36
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/abs.mar
Normal 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
285
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/argument.plm
Normal 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
38
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/ascii.lit
Normal 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
74
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/change.plm
Normal 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
38
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/close.plm
Normal 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;
|
@@ -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
|
@@ -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
76
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/config.mar
Normal 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
|
@@ -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;
|
@@ -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
138
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/decode.plm
Normal 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;
|
@@ -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
38
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/detach.plm
Normal 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;
|
@@ -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.
|
||||
;
|
||||
;-----------------------------------------------------------------------
|
@@ -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
7
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/dm.com
Normal 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
25
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/dm.mar
Normal 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
58
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/except.for
Normal 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
63
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/except.lit
Normal 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
38
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/exit.plm
Normal 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;
|
@@ -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
90
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/finds.mar
Normal 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
76
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/gettime.plm
Normal 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
53
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/hilo.mar
Normal 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
38
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/iabs.mar
Normal 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
177
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/iodef.for
Normal 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
|
@@ -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.
|
||||
$!
|
@@ -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
39
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/move.mar
Normal 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
106
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/moves.mar
Normal 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
38
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/open.plm
Normal 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
86
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/overlay.plm
Normal 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
11
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/plmmac.bld
Normal 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
55
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/plmrun.bld
Normal 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
44
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/read.me
Normal 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
42
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/read.plm
Normal 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
44
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/readme.md
Normal 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
57
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/rename.mar
Normal 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
194
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/rmsdef.for
Normal 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
40
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/seek.plm
Normal 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
51
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/sets.mar
Normal 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
88
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/shifts.mar
Normal 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
98
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/skips.mar
Normal 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
38
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/special.plm
Normal 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;
|
@@ -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;
|
@@ -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
154
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/udi.def
Normal 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
39
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/udimsgs.msg
Normal 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
42
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/write.plm
Normal 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
42
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/xlat.mar
Normal 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
102
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/xqcommon.for
Normal 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
10
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/xqio.bld
Normal 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
945
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmudi/xqio.for
Normal 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
215
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/basics.for
Normal 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
119
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/block.for
Normal 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
201
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/branches.for
Normal 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
53
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/break.for
Normal 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
218
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/builtins.for
Normal 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
372
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/coerce.for
Normal 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
12
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/comlist.com
Normal 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
148
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/context.for
Normal 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
1093
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/control.plm
Normal file
File diff suppressed because it is too large
Load Diff
2687
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/control.tmp
Normal file
2687
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/control.tmp
Normal file
File diff suppressed because it is too large
Load Diff
150
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/counts.for
Normal file
150
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/counts.for
Normal 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
177
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/data.for
Normal 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
687
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/decls.for
Normal 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
92
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/effects.for
Normal 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
191
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/emit.for
Normal 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
11
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/errfind.com
Normal 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
97
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/error.for
Normal 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
13
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/exlist.com
Normal 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
589
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/exprs.for
Normal 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
578
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/fold.for
Normal 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
245
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/gencode.for
Normal 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
178
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/getc.for
Normal 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
Reference in New Issue
Block a user