seppdroid/Digital-Research-Source-Code
1
0
Fork 0
mirror of https://github.com/SEPPDROID/Digital-Research-Source-Code.git synced 2025-12-09 23:03:02 +00:00
Code Issues Actions Packages Projects Releases Wiki Activity

Upload

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

File diff suppressed because it is too large Load Diff

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

File diff suppressed because it is too large Load Diff

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

288
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/getlex.for Normal file
View File

@@ -0,0 +1,288 @@
C***********************************************************************
C
C GETLEX.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 is the lexical analysis module of the PL/M-VAX compiler.
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. Increase max string size. (V5.3)
C 2. Replace null strings with ' '.
C 28OCT81 Alex Hunter 1. Add new keywords. (V5.7)
C
C***********************************************************************
C --- Compile me with /NOCHECK please ! ---
SUBROUTINE GETLEX
C
C----- GET A LEXICAL ELEMENT.
C
INCLUDE 'PLMCOM.FOR/NOLIST'
CHARACTER*100 NUMBER
INTEGER*2 I,J,LAST,DIG,RADIX
CHARACTER*1 UPPER(97:122)
DATA UPPER /'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'/
CHARACTER*10 KEYWORD(101:154)
DATA KEYWORD
//'ADDRESS ','AND ','AT ','BASED ','BY '
,,'BYTE ','CALL ','CASE ','DATA ','DECLARE '
,,'DISABLE ','DO ','ELSE ','ENABLE ','END '
,,'EOF ','EXTERNAL ','GO ','GOTO ','HALT '
,,'IF ','INITIAL ','INTEGER ','INTERRUPT ','LABEL '
,,'LITERALLY ','MINUS ','MOD ','NOT ','OR '
,,'PLUS ','POINTER ','PROCEDURE ','PUBLIC ','REAL '
,,'REENTRANT ','RETURN ','STRUCTURE ','THEN ','TO '
,,'WHILE ','WORD ','XOR ','COMMON ','LONG '
,,'DOUBLE ','OTHERWISE ','QUAD ','FORWARD ','SELECTOR '
,,'DWORD ','SHORT ','BOOLEAN ','REGISTER '
//
CHARACTER*2 DD(201:218)
DATA DD
//'+ ','- ','* ','/ ','< ','> ','= ','<>','<=','>='
,,':=',': ','; ','. ',', ','( ',') ','@ '
//
COMMON /ANALYZE/ KEYWORD,DD
C
100 IF (CHAR.EQ.' '.OR.CHAR.EQ.TAB) CALL GETNB
C
C /* COMMENT */ OR '/' DELIMITER.
C
IF (CHAR.EQ.'/') THEN
NEXT_DELIMITER = CHAR
CALL GETC
IF (CHAR.NE.'*') GO TO 695
110 CALL GETC
120 IF (CHAR.EQ.EOF) CALL FATAL('EOF BEFORE END OF COMMENT')
IF (CHAR.NE.'*') GO TO 110
CALL GETC
IF (CHAR.NE.'/') GO TO 120
CALL GETC
GO TO 100
C
C IDENTIFIER.
C
ELSEIF (CHAR.GE.'A'.AND.CHAR.LE.'Z' .OR. CHAR.EQ.'%' .OR.
# CHAR.GE.'a'.AND.CHAR.LE.'z' .OR. CHAR.EQ.'_') THEN
I=1
NEXT_IDENTIFIER=' '
200 IF (I.LE.32) THEN
IF (CHAR.EQ.'%') THEN
CHAR='$'
ELSEIF (CHAR.GE.'a'.AND.CHAR.LE.'z') THEN
CHAR=UPPER(ICHAR(CHAR))
ENDIF
NEXT_IDENTIFIER(I:I)=CHAR
I=I+1
ENDIF
210 CALL GETC
IF (CHAR.GE.'A' .AND. CHAR.LE.'Z' .OR. CHAR.EQ.'_' .OR.
# CHAR.GE.'0' .AND. CHAR.LE.'9') GO TO 200
IF (CHAR.EQ.'%' .OR. CHAR.GE.'a'.AND.CHAR.LE.'z') GO TO 200
IF (CHAR.EQ.'$') GO TO 210
I=HASH_BUCKET(HASH(NEXT_IDENTIFIER))
225 IF (I.GT.0) THEN
IF (SYMBOL_PLM_ID(I).EQ.NEXT_IDENTIFIER) THEN
IF (SYMBOL_KIND(I).EQ.S_KEYWORD) GO TO 230
IF (SYMBOL_KIND(I).EQ.S_MACRO) GO TO 240
GO TO 226
ENDIF
I=SYMBOL_CHAIN(I)
GO TO 225
ENDIF
226 NEXT_TOKENTYPE=ID
RETURN
C
C KEYWORD.
C
230 I=SYMBOL_LINK(I) ! TOKEN_VALUE OF KEYWORD.
NEXT_TOKENTYPE=I
IF (I.EQ.K_THEN) THEN
LIST_STNO=LIST_STNO+1
ELSEIF (I.EQ.K_DO.OR.I.EQ.K_PROCEDURE) THEN
LIST_BLOCK_LEVEL=LIST_BLOCK_LEVEL+1
ELSEIF (I.EQ.K_END) THEN
LIST_BLOCK_LEVEL=LIST_BLOCK_LEVEL-1
ENDIF
RETURN
C
C PARAMETERLESS MACRO.
C
240 IF (LITLEV.EQ.LITMAX) CALL FATAL('MACRO STACK OVERFLOW')
LITCOL(LITLEV)=COL
LITLEV=LITLEV+1
COL=0
LITVAL(LITLEV)=STRINGS(SYMBOL_LINK(I):SYMBOL_LINK(I)+
# SYMBOL_ELEMENT_SIZE(I)-1)//EOL
CALL GETC
GO TO 100
C
C NUMERIC CONSTANT.
C
ELSEIF (CHAR.GE.'0' .AND. CHAR.LE.'9') THEN
NUMBER=' '
I=1
300 IF (I.LE.100) NUMBER(I:I)=CHAR
I=I+1
310 CALL GETC
IF (CHAR.GE.'0'.AND.CHAR.LE.'9' .OR.
# CHAR.GE.'A'.AND.CHAR.LE.'Z') GO TO 300
IF (CHAR.GE.'a'.AND.CHAR.LE.'z') THEN
CHAR=UPPER(ICHAR(CHAR))
GO TO 300
ENDIF
IF (CHAR.EQ.'$') GO TO 310
IF (CHAR.EQ.'.') GO TO 350
C
C FIXED POINT CONSTANT.
C
LAST=I-1
IF (NUMBER(LAST:LAST).EQ.'B') THEN
RADIX=2
LAST=LAST-1
ELSEIF (NUMBER(LAST:LAST).EQ.'O' .OR.
# NUMBER(LAST:LAST).EQ.'Q') THEN
RADIX=8
LAST=LAST-1
ELSEIF (NUMBER(LAST:LAST).EQ.'D') THEN
RADIX=10
LAST=LAST-1
ELSEIF (NUMBER(LAST:LAST).EQ.'H') THEN
RADIX=16
LAST=LAST-1
ELSE
RADIX=10
ENDIF
NEXT_FIXVAL=0
DO 320 J=1,LAST
IF (NUMBER(J:J).GE.'A') THEN
DIG=ICHAR(NUMBER(J:J))-ICHAR('A')+10
ELSE
DIG=ICHAR(NUMBER(J:J))-ICHAR('0')
ENDIF
IF (DIG.GE.RADIX)
# CALL ERROR('Illegal digit in numeric constant')
NEXT_FIXVAL=NEXT_FIXVAL*RADIX+DIG
320 CONTINUE
NEXT_TOKENTYPE=FIXCON
GO TO 400
C
C FLOATING POINT CONSTANT.
C
350 IF (I.LE.100) NUMBER(I:I)=CHAR
I=I+1
360 CALL GETC
IF (CHAR.GE.'0'.AND.CHAR.LE.'9') GO TO 350
IF (CHAR.EQ.'$') GO TO 360
IF (CHAR.NE.'E'.AND.CHAR.NE.'e') GO TO 390
IF (I.LE.100) NUMBER(I:I)=CHAR
I=I+1
CALL GETC
IF (CHAR.NE.'+'.AND.CHAR.NE.'-') GO TO 380
370 IF (I.LE.100) NUMBER(I:I)=CHAR
I=I+1
375 CALL GETC
380 IF (CHAR.GE.'0'.AND.CHAR.LE.'9') GO TO 370
IF (CHAR.EQ.'$') GO TO 375
390 NEXT_TOKENTYPE=FLOATCON
DECODE(I-1,9999,NUMBER,ERR=410) NEXT_FLOATVAL
9999 FORMAT(G)
400 IF (I.GT.101) CALL ERROR('Numeric constant too long')
RETURN
410 CALL ERROR('Invalid floating point constant')
RETURN
C
C STRING.
C
ELSEIF (CHAR.EQ.'''') THEN
NEXT_STRING=' '
I=1
500 CALL GETC
IF (CHAR.EQ.EOF) THEN
CALL ERROR('String is missing final quote')
NEXT_TOKENTYPE=EOFTOK
RETURN
ELSEIF (CHAR.EQ.'''') THEN
CALL GETC
IF (CHAR.NE.'''') GO TO 510
ENDIF
IF (I.LE.STRING_SIZE_MAX) THEN
NEXT_STRING(I:I)=CHAR
I=I+1
ELSE
CALL ERROR('String constant is too long')
GO TO 510
ENDIF
GO TO 500
510 NEXT_TOKENTYPE=STRCON
NEXT_STRLEN=I-1
IF (NEXT_STRLEN.EQ.0) THEN
CALL WARN('NULL STRING REPLACED BY '' ''')
NEXT_STRLEN=1
ENDIF
RETURN
C
C END OF FILE.
C
ELSEIF (CHAR.EQ.EOF) THEN
NEXT_TOKENTYPE=EOFTOK
RETURN
C
C DELIMITER.
C
ELSE
NEXT_DELIMITER=CHAR
IF (CHAR.EQ.';') THEN
LIST_STNO=LIST_STNO+1
GO TO 690
ENDIF
IF (CHAR.EQ.'+'.OR.CHAR.EQ.'-'.OR.CHAR.EQ.'*'.OR.
# CHAR.EQ.'='.OR.CHAR.EQ.'.'.OR.
# CHAR.EQ.','.OR.CHAR.EQ.'('.OR.CHAR.EQ.')'.OR.
# CHAR.EQ.'@') GO TO 690
IF (CHAR.EQ.'<') THEN
CALL GETC
IF (CHAR.EQ.'>'.OR.CHAR.EQ.'=') GO TO 680
GO TO 695
ELSEIF (CHAR.EQ.'>'.OR.CHAR.EQ.':') THEN
CALL GETC
IF (CHAR.EQ.'=') GO TO 680
GO TO 695
ENDIF
NEXT_TOKENTYPE=INVALID
CALL GETC
RETURN
680 NEXT_DELIMITER(2:2)=CHAR
690 CALL GETC
695 DO 697 NEXT_TOKENTYPE=201,218
IF (NEXT_DELIMITER.EQ.DD(NEXT_TOKENTYPE)) RETURN
697 CONTINUE
CALL BUG('DELIMITER NOT FOUND IN DD TABLE')
ENDIF
END

73
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/gettok.for Normal file
View File

@@ -0,0 +1,73 @@
C***********************************************************************
C
C GETTOK.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 the token analysis
C routine which is called to obtain the next token from the input
C stream. The token analyzer looks ahead one lexical element to
C determine if the next token is a label, and if so stores the
C label in the current label list. This list must be emptied
C before the next token is obtained, or an error will be diagnosed.
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 14JAN82 Alex Hunter 1. Treat <keyword>: as <identifier>:. (V6.5)
C
C-----------------------------------------------------------------------
SUBROUTINE GETTOK
INCLUDE 'PLMCOM.FOR/NOLIST'
C
DO 5 I=1,NLABELS
CALL ERROR('MISPLACED LABEL -- '//LABELS(I))
5 CONTINUE
NLABELS=0
10 TOKENTYPE=NEXT_TOKENTYPE
DELIMITER=NEXT_DELIMITER
IDENTIFIER=NEXT_IDENTIFIER
STRING=NEXT_STRING
STRLEN=NEXT_STRLEN
FIXVAL=NEXT_FIXVAL
FLOATVAL=NEXT_FLOATVAL
CALL GETLEX
IF (NEXT_TOKENTYPE.EQ.D_COLON .AND.
# (TOKENTYPE.EQ.ID.OR.(TOKENTYPE.GE.101.AND.TOKENTYPE.LE.199)))
#THEN
IF (NLABELS.GE.MAX_LABELS) THEN
CALL ERROR('TOO MANY LABELS -- '//IDENTIFIER)
ELSE
NLABELS=NLABELS+1
LABELS(NLABELS) = IDENTIFIER
ENDIF
CALL GETLEX
GO TO 10
ENDIF
RETURN
END

50
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/hash.for Normal file
View File

@@ -0,0 +1,50 @@
C***********************************************************************
C
C HASH.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 the symbol table
C hash code routine, which maps a 32 character identifier into
C an integer in the range [0..210].
C
C-----------------------------------------------------------------------
C R E V I S I O N H I S T O R Y
C
C 18OCT81 Alex Hunter 1. Added disclaimer notice. (V5.4)
C
C-----------------------------------------------------------------------
INTEGER*4 FUNCTION HASH (ID)
IMPLICIT INTEGER*4 (A-Z)
CHARACTER*32 ID
HASH= ((
# (ICHAR(ID(1:1))+ICHAR(ID(5:5))+ICHAR(ID(9:9)))*256
# + (ICHAR(ID(2:2))+ICHAR(ID(6:6))+ICHAR(ID(10:10))))*256
# + (ICHAR(ID(3:3))+ICHAR(ID(7:7))+ICHAR(ID(11:11))))*256
# + (ICHAR(ID(4:4))+ICHAR(ID(8:8))+ICHAR(ID(12:12)))
HASH=MOD(IABS(HASH),211)
RETURN
END

360
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/init.for Normal file
View File

@@ -0,0 +1,360 @@
C***********************************************************************
C
C INIT.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 initialization
C routines which are called just before the first non-control line
C is processed (i.e., after all primary controls have been processed
C but before the first program text is processed).
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. LENGTH,FIRST,LAST, and SIZE are now LONG
C procedures.
C 24OCT81 Alex Hunter 1. Change BI_NBR_ELEMENTS and BI_ELEMENT_SIZE
C to INTEGER*4 per changes to corresponding
C SYMBOL arrays. (V5.6)
C 28OCT81 Alex Hunter 1. Add new keywords and delete '%' from
C existing keywords, since keywords may
C now be re-declared. (V5.7)
C 10NOV81 Alex Hunter 1. Add S_NO_SIDE_EFFECTS attribute. (V6.0)
C 12NOV81 Alex Hunter 1. Implement LAST(MEMORY), etc. (V6.1)
C 2. Add BI_PSECT.
C 3. Change the way psect names are fixed up.
C 14NOV81 Alex Hunter 1. Append overlay name to P_CODE psect name.
C (V6.2)
C 21NOV81 Alex Hunter 1. Temporarily change LOW back to an external.
C (V6.3)
C 10JAN81 Alex Hunter 1. Change DOUBLE keyword to DOUBLE$PRECISION
C to avoid conflict with DOUBLE builtin.
C (V6.4).
C
C***********************************************************************
SUBROUTINE INIT_SYMTAB
INCLUDE 'PLMCOM.FOR/NOLIST'
CHARACTER*32 SYMBOL
CHARACTER*1 MODL
DATA SYMBOL_VAX_ID(SYM_MLAST),SYMBOL_REF(SYM_MLAST)
// 'MEMORY.LAST', S_VALUE /
DATA SYMBOL_VAX_ID(SYM_MLEN),SYMBOL_REF(SYM_MLEN)
// 'MEMORY.LEN', S_VALUE /
DATA SYMBOL_VAX_ID(SYM_MSIZ),SYMBOL_REF(SYM_MSIZ)
// 'MEMORY.SIZ', S_VALUE /
DATA SYMBOL_VAX_ID(SYM_SLAST),SYMBOL_REF(SYM_SLAST)
// 'STACK.LAST', S_VALUE /
DATA SYMBOL_VAX_ID(SYM_SLEN),SYMBOL_REF(SYM_SLEN)
// 'STACK.LEN', S_VALUE /
DATA SYMBOL_VAX_ID(SYM_SSIZ),SYMBOL_REF(SYM_SSIZ)
// 'STACK.SIZ', S_VALUE /
PARAMETER M = FIRST_AVAILABLE_SYMBOL_INDEX
PARAMETER N=54 ! # OF BUILTINS.
CHARACTER*32 BI_PLM_ID(N),BI_VAX_ID(N)
INTEGER*2 BI_KIND(N),BI_TYPE(N),
# BI_LINK(N),
# BI_LIST_SIZE(N),BI_REF(N),BI_BASE(N),
# BI_BASE_MEMBER(N),BI_FLAGS(N),
# BI_SERIAL_NO(N),BI_PSECT(N)
INTEGER*4 BI_NBR_ELEMENTS(N),BI_ELEMENT_SIZE(N),
# BI_LOWER_BOUND(N),BI_DISP(N)
EQUIVALENCE (BI_PLM_ID,SYMBOL_PLM_ID(M))
,, (BI_VAX_ID,SYMBOL_VAX_ID(M))
,, (BI_KIND,SYMBOL_KIND(M))
,, (BI_TYPE,SYMBOL_TYPE(M))
,, (BI_NBR_ELEMENTS,SYMBOL_NBR_ELEMENTS(M))
,, (BI_ELEMENT_SIZE,SYMBOL_ELEMENT_SIZE(M))
,, (BI_LOWER_BOUND,SYMBOL_LOWER_BOUND(M))
,, (BI_LINK,SYMBOL_LINK(M))
,, (BI_LIST_SIZE,SYMBOL_LIST_SIZE(M))
,, (BI_REF,SYMBOL_REF(M))
,, (BI_BASE,SYMBOL_BASE(M))
,, (BI_BASE_MEMBER,SYMBOL_BASE_MEMBER(M))
,, (BI_FLAGS,SYMBOL_FLAGS(M))
,, (BI_DISP,SYMBOL_DISP(M))
,, (BI_SERIAL_NO,SYMBOL_SERIAL_NO(M))
,, (BI_PSECT,SYMBOL_PSECT(M))
DATA BI_PLM_ID
// 'LENGTH','LAST','FIRST','SIZE','MEMORY','MEMORYTOP'
,, 'STACK','STACKTOP','STACKPTR','FRAMEPTR'
,, 'ABS','CMPB','CMPW','DOUBLE','FINDB','FINDRB','FINDRW'
,, 'FINDW','FIX','FLOAT','HIGH','IABS','INT','LOW'
,, 'MOVB','MOVE','MOVRB','MOVRW','MOVW','ROL'
,, 'ROR','SAL','SAR','SETB','SETW','SHL'
,, 'SHR','SIGNED','SKIPB','SKIPRB','SKIPRW','SKIPW'
,, 'UNSIGN','XLAT'
,, '$_BYTE','$_WORD','$_INTEGER','$_POINTER','$_REAL'
,, '$_LONG','$_DOUBLE','$_QUAD','$_SIGNED','$_UNSIGNED'
//
DATA BI_VAX_ID
// '...','...','...','...','MEMORY.','MEMORY.TOP'
,, 'S.BOT','S.','...','...'
,, 'ABS.','CMPB.','CMPW.','...','FINDB.','FINDRB.'
,, 'FINDRW.'
,, 'FINDW.','...','...','HIGH.','IABS.','...','LOW.'
,, 'MOVB.','MOVE.','MOVRB.','MOVRW.','MOVW.','ROL.'
,, 'ROR.','SAL.','SAR.','SETB.','SETW.','SHL.'
,, 'SHR.','...','SKIPB.','SKIPRB.','SKIPRW.','SKIPW.'
,, '...','XLAT.'
,, '...','...','...','...','...'
,, '...','...','...','...','...'
//
DATA BI_KIND
// 4*S_PROC,S_ARRAY,S_SCALAR
,, S_ARRAY,S_SCALAR,S_PROC,S_PROC
,, 7*S_PROC
,, 7*S_PROC
,, 6*S_PROC
,, 6*S_PROC
,, 6*S_PROC
,, 2*S_PROC
,, 5*S_PROC
,, 5*S_PROC
//
DATA BI_TYPE
// 4*S_LONG,S_BYTE,S_BYTE
,, S_BYTE,S_BYTE,S_PTR,S_PTR
,, S_REAL,S_WORD,S_WORD,S_WORD,S_WORD,S_WORD,S_WORD
,, S_WORD,S_INTEGER,S_REAL,S_BYTE,S_INTEGER,S_LONG,S_BYTE
,, 0,0,0,0,0,S_BYTE
,, S_BYTE,S_INTEGER,S_INTEGER,0,0,S_WORD
,, S_WORD,S_INTEGER,S_WORD,S_WORD,S_WORD,S_WORD
,, S_WORD,0
,, S_BYTE,S_WORD,S_INTEGER,S_PTR,S_REAL
,, S_LONG,S_DOUBLE,S_QUAD,-1,-1
//
DATA BI_NBR_ELEMENTS
// 4*0, 0, 0
,, 0, 0, 0, 0
,, 7*0
,, 7*0
,, 6*0
,, 6*0
,, 6*0
,, 2*0
,, 5*0
,, 5*0
//
DATA BI_ELEMENT_SIZE
// 4*4, 1, 1
,, 1,1,4,4
,, 4,2,2,2,2,2,2
,, 2,2,4,1,2,4,1
,, 0,0,0,0,0,1
,, 1,2,2,0,0,2
,, 2,2,2,2,2,2
,, 2,0
,, 1,2,2,4,4
,, 4,8,8,-1,-1
//
DATA BI_LOWER_BOUND
// N*0
//
DATA BI_LINK
// N*0
//
DATA BI_LIST_SIZE
// 4*1, 0, 0
,, 0,0,0,0
,, 1,3,3,1,3,3,3
,, 3,1,1,1,1,1,1
,, 3,3,3,3,3,2
,, 2,2,2,3,3,2
,, 2,1,3,3,3,3
,, 1,4
,, 1,1,1,1,1
,, 1,1,1,1,1
//
DATA BI_REF
// 4*S_BUILTIN, S_STATIC, S_EXT
,, S_EXT,S_EXT,S_BUILTIN,S_BUILTIN
,, 3*S_EXT,S_BUILTIN,3*S_EXT
,, S_EXT,S_BUILTIN,S_BUILTIN,S_EXT,S_EXT,S_BUILTIN,S_EXT
,, 6*S_EXT
,, 6*S_EXT
,, S_EXT,S_BUILTIN,4*S_EXT
,, S_BUILTIN,S_EXT
,, 5*S_BUILTIN
,, 5*S_BUILTIN
//
DATA BI_BASE
// N*0
//
DATA BI_BASE_MEMBER
// N*0
//
DATA BI_FLAGS
// 4*S_NO_SIDE_EFFECTS,S_SPECIAL,0
,, S_SPECIAL,0,2*S_NO_SIDE_EFFECTS
,, 7*S_NO_SIDE_EFFECTS
,, 7*S_NO_SIDE_EFFECTS
,, 5*0,S_NO_SIDE_EFFECTS
,, 3*S_NO_SIDE_EFFECTS,2*0,S_NO_SIDE_EFFECTS
,, 6*S_NO_SIDE_EFFECTS
,, 2*S_NO_SIDE_EFFECTS
,, 5*S_NO_SIDE_EFFECTS
,, 5*S_NO_SIDE_EFFECTS
//
DATA BI_DISP
// N*0
//
DATA BI_SERIAL_NO
// N*0
//
DATA BI_PSECT
// 4*0,2*P_MEMORY
,, 2*P_STACK,2*0
,, 7*0
,, 7*0
,, 6*0
,, 6*0
,, 6*0
,, 2*0
,, 5*0
,, 5*0
//
PARAMETER K=54 ! # OF KEYWORDS.
CHARACTER*32 KW_PLM_ID(K)
INTEGER*2 KW_KIND(K),KW_LINK(K)
EQUIVALENCE (KW_PLM_ID,SYMBOL_PLM_ID(M+N))
,, (KW_KIND,SYMBOL_KIND(M+N))
,, (KW_LINK,SYMBOL_LINK(M+N))
DATA KW_PLM_ID
//'ADDRESS ','AND ','AT ','BASED ','BY '
,,'BYTE ','CALL ','CASE ','DATA ','DECLARE '
,,'DISABLE ','DO ','ELSE ','ENABLE ','END '
,,'EOF ','EXTERNAL ','GO ','GOTO ','HALT '
,,'IF ','INITIAL ','INTEGER ','INTERRUPT ','LABEL '
,,'LITERALLY ','MINUS ','MOD ','NOT ','OR '
,,'PLUS ','POINTER ','PROCEDURE ','PUBLIC ','REAL '
,,'REENTRANT ','RETURN ','STRUCTURE ','THEN ','TO '
,,'WHILE ','WORD ','XOR ','COMMON ','LONG '
,,'DOUBLEPRECISION'
,, 'OTHERWISE ','QUAD ','FORWARD ','SELECTOR '
,,'DWORD ','SHORT ','BOOLEAN ','REGISTER '
//
DATA KW_KIND
// K*S_KEYWORD
//
DATA KW_LINK
// 101,102,103,104,105,106,107,108,109,110
,, 111,112,113,114,115,116,117,118,119,120
,, 121,122,123,124,125,126,127,128,129,130
,, 131,132,133,134,135,136,137,138,139,140
,, 141,142,143,144,145,146,147,148,149,150
,, 151,152,153,154
//
SYMBOL_TOP(0)=M+N+K-1
FIRST_KEYWORD=M+N
C-------- IF PLM80, DISGUISE NON-PLM80 KEYWORDS.
C
C IF (PLM80_FLAG) THEN
C KW_PLM_ID(K_INTEGER-100)='$INTEGER'
C KW_PLM_ID(K_POINTER-100)='$POINTER'
C KW_PLM_ID(K_REAL-100)='$REAL'
C KW_PLM_ID(K_WORD-100)='$WORD'
C ENDIF
C-------- FIXUP VAX_ID'S OF BUILTINS WHICH DEPEND ON MODEL SIZE.
! IF (LARGE) THEN
! MODL='L'
! ELSE
! MODL='S'
! ENDIF
!
! DO I=1,N
! DO J=1,32
! IF (BI_VAX_ID(I)(J:J).EQ.'#') BI_VAX_ID(I)(J:J)=MODL
! ENDDO
! ENDDO
C-------- CHAIN BUILTINS AND KEYWORDS INTO HASH BUCKETS.
DO 10 I=M,SYMBOL_TOP(0)
H=HASH(SYMBOL_PLM_ID(I))
SYMBOL_CHAIN(I)=HASH_BUCKET(H)
HASH_BUCKET(H)=I
10 CONTINUE
C-------- READ IN GLOBAL SYMBOLS IF REQUIRED.
LAST_GLOBAL=0
IF (GLOBALS_FLAG) THEN
20 READ(GBL,1001,END=30) SYMBOL
1001 FORMAT(X,A)
IF (SYMBOL(1:1).NE.'*') THEN
IF (LAST_GLOBAL.GE.GBL_MAX)
# CALL FATAL('TOO MANY GLOBALS')
LAST_GLOBAL=LAST_GLOBAL+1
GLOBAL_SYMBOL(LAST_GLOBAL)=SYMBOL
ENDIF
GO TO 20
30 CLOSE (UNIT=GBL)
ENDIF
C-------- FIX UP PSECT NAMES AND COMPILE TIME BASES.
IF (MODEL.EQ.4) THEN
PSECT_NAME(P_DATA)='$PLM_DATA'
ENDIF
IF (OVERLAY_FLAG) THEN
NC=LNB(PSECT_NAME(P_DATA))
PSECT_NAME(P_DATA)(NC+1:)='_'
CALL MAKE_CHARS(PSECT_NAME(P_DATA)(NC+2:),OVERLAY_PREFIX)
NC=LNB(PSECT_NAME(P_CODE))
PSECT_NAME(P_CODE)(NC+1:)='_'
CALL MAKE_CHARS(PSECT_NAME(P_CODE)(NC+2:),OVERLAY_PREFIX)
BASEC='D.'
CALL MAKE_CHARS(BASEC(3:),OVERLAY_PREFIX)
NC=LNB(BASEC)
ENDIF
IF (.NOT.ROM_FLAG .AND. MODEL.NE.4) THEN
PSECT_NAME(P_CONSTANTS)=PSECT_NAME(P_DATA)
ENDIF
IF (OVERLAY_FLAG) THEN
BASEV='R11'
ELSE
BASEV='#D.'
ENDIF
RETURN
END

51
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/jpi.for Normal file
View File

@@ -0,0 +1,51 @@
C***********************************************************************
C
C JPI.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 is used to obtain job
C statistics for compiler performance measurement and reporting.
C
C-----------------------------------------------------------------------
C R E V I S I O N H I S T O R Y
C
C 18OCT81 Alex Hunter 1. Added disclaimer notice. (V5.4)
C
C-----------------------------------------------------------------------
SUBROUTINE JPI(NTICKS,NFAULTS)
IMPLICIT INTEGER*4 (A-Z)
INCLUDE 'SYS$LIBRARY:JPIDEF.FOR/NOLIST'
INTEGER*4 IL(7)
INTEGER*2 IW(14)
EQUIVALENCE (IL,IW)
DATA IW/4,JPI$_CPUTIM,0,0,0,0,4,JPI$_PAGEFLTS,0,0,0,0,0,0/
IL(2)=%LOC(NTICKS)
IL(5)=%LOC(NFAULTS)
ISS=SYS$GETJPI(,,,IL,,,)
RETURN
END

154
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/list.for Normal file
View File

@@ -0,0 +1,154 @@
C***********************************************************************
C
C LIST.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 listing
C lines to the print file.
C
C-----------------------------------------------------------------------
C R E V I S I O N H I S T O R Y
C
C 18OCT81 Alex Hunter 1. Added disclaimer notice. (V5.4)
C
C-----------------------------------------------------------------------
SUBROUTINE LIST_SOURCE_LINE(LINE)
INCLUDE 'PLMCOM.FOR/NOLIST'
CHARACTER*(*) LINE
CHARACTER*10 STRING10,S1,S2,S3
INTEGER*4 IVAL,IFSD
LAST_LINE_EXISTS=.TRUE.
IVAL=LIST_LINE_NO+100000
S1=STRING10(IVAL,IFSD)
IF (IN.EQ.8) THEN
S2=' '
ELSE
IVAL=(IN-9)*10
S2=STRING10(IVAL,IFSD)
S2(8:8)='='
ENDIF
IF (OBJECT_FLAG.AND.OPRINT_FLAG.AND.LIST_FLAG) THEN
WRITE(OUT,1001) S1(6:10),S2(8:9),LINE
1001 FORMAT(' ;',A5,A2,X,A)
ENDIF
IF (.NOT.PRINT_FLAG .OR. .NOT.LIST_FLAG) RETURN
GO TO (20,10,10,20), SKIP_STATE
10 IF (.NOT.COND_FLAG) RETURN
20 CONTINUE
CALL ADVANCE_ONE_LINE
IF (LIST_STNO.NE.PREVIOUS_STNO.AND.LINE.NE.' '.AND.
# LINE(LEFTMARGIN:LEFTMARGIN).NE.'$'.AND.
# SKIP_STATE.NE.2.AND.SKIP_STATE.NE.3) THEN
IVAL=LIST_BLOCK_LEVEL*10
S3=STRING10(IVAL,IFSD)
WRITE(LST,1002) S1(6:10),LIST_STNO,S3(8:9),S2(8:9),LINE
1002 FORMAT(X,A5,X,I4,X,A2,X,A2,X,A)
PREVIOUS_STNO=LIST_STNO
ELSE
WRITE(LST,1003) S1(6:10),S2(8:9),LINE
1003 FORMAT(X,A5,9X,A2,X,A)
ENDIF
RETURN
C-------------------------
ENTRY FORCE_LIST_SOURCE
C------------------------
IF (.NOT.PRINT_FLAG .OR. .NOT.LIST_FLAG .OR. COND_FLAG) RETURN
IF (.NOT.LAST_LINE_EXISTS) RETURN
CALL ADVANCE_ONE_LINE
WRITE(LST,1003) S1(6:10),S2(8:9),CARD(:LNB(CARD))
RETURN
C----------------------------------------
ENTRY TYPE_LAST_SOURCE_LINE
C----------------------------------------
IF (.NOT.LAST_LINE_EXISTS) RETURN
WRITE(7,1003) S1(6:10),S2(8:9),CARD(:LNB(CARD))
RETURN
C-------------------------------------
ENTRY LIST_LINE(LINE)
C-------------------------------------
IF (.NOT.PRINT_FLAG) RETURN
CALL ADVANCE_ONE_LINE
WRITE(LST,1004) LINE(:LNB(LINE))
1004 FORMAT(X,A)
RETURN
END
C-----------------------------------------------------------------
SUBROUTINE ADVANCE_ONE_LINE
INCLUDE 'PLMCOM.FOR/NOLIST'
CHARACTER*80 TITLE,SUBTITLE,DATE
CHARACTER*45 SOURCE_FILE
LINE_OF_PAGE=LINE_OF_PAGE+1
IF (PAGING_FLAG.AND.(EJECT_FLAG.OR.LINE_OF_PAGE.GT.PAGELENGTH))
# THEN
PAGE_NO=PAGE_NO+1
N1=MAKE_CHARS(TITLE,TITLE_STRING)
N2=MAKE_CHARS(SUBTITLE,SUBTITLE_STRING)
N3=MAKE_CHARS(DATE,DATE_STRING)
N4=MAKE_CHARS(SOURCE_FILE,IN_FILE_STRING(0,8))
T1=55-N1/2
T2=55-N2/2
T3=110-N3
WRITE(LST,1001) TITLE(:N1),DATE(:N3),PAGE_NO,SOURCE_FILE(:N4),
# SUBTITLE(:N2)
1001 FORMAT('1PL/M-VAX COMPILER',T<T1>,A,T<T3>,A,T112,'Page ',I4/
# X,A,T<T2>,A/)
EJECT_FLAG=.FALSE.
LINE_OF_PAGE=4
ENDIF
RETURN
END
C--------------------------------------------------------
SUBROUTINE ROOM_FOR(NBR_OF_LINES)
INCLUDE 'PLMCOM.FOR/NOLIST'
IF (LINE_OF_PAGE+NBR_OF_LINES.GT.PAGELENGTH) EJECT_FLAG=.TRUE.
RETURN
END

59
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/locals.for Normal file
View File

@@ -0,0 +1,59 @@
C***********************************************************************
C
C LOCALS.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 to
C generate and name local labels.
C
C-----------------------------------------------------------------------
C R E V I S I O N H I S T O R Y
C
C 18OCT81 Alex Hunter 1. Added disclaimer notice. (V5.4)
C
C-----------------------------------------------------------------------
CHARACTER*32 FUNCTION LOCAL_LABEL(LL,N1)
IMPLICIT INTEGER*2 (A-Z)
CHARACTER*10 STRING10
INTEGER*4 N,IFSD
N=LL
LOCAL_LABEL=STRING10(N,IFSD)
LOCAL_LABEL=LOCAL_LABEL(IFSD:10)
N1=12-IFSD
LOCAL_LABEL(N1:N1)='$'
RETURN
END
C-----------------------------------------------------------------------
SUBROUTINE GENERATE_LOCAL_LABEL(LL)
IMPLICIT INTEGER*2 (A-Z)
DATA LLN/0/
IF (LLN.GE.29999) CALL FATAL('LOCAL LABELS EXHAUSTED')
LLN=LLN+1
LL=LLN
RETURN
END

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

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

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

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

52
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/massage.for Normal file
View File

@@ -0,0 +1,52 @@
C***********************************************************************
C
C MASSAGE.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 'massages' a code tree by
C (1) resolving signed/unsigned context of nodes, (2) coercing
C context if needed, (3) folding constant operations, (4) merging
C common subnodes, and (5) computing reference counts for the nodes.
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. Compute reference counts. (V5.1)
C
C***********************************************************************
INTEGER*2 FUNCTION MASSAGE(CODE,DEFAULT_CONTEXT)
INCLUDE 'PLMCOM.FOR/NOLIST'
CALL RESOLVE_CONTEXT(CODE)
IF (NODE_CONTEXT(CODE).EQ.0)
# CALL SET_CONTEXT(CODE,DEFAULT_CONTEXT)
CALL COERCE_TYPES(CODE)
MASSAGE=FOLD_CONSTANTS(CODE)
MASSAGE=MERGE(MASSAGE)
CALL COMPUTE_REFERENCE_COUNTS(MASSAGE)
RETURN
END

155
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/match.for Normal file
View File

@@ -0,0 +1,155 @@
C***********************************************************************
C
C MATCH.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 to test the
C next token for a match. Syntax errors are detected and analyzed
C by this module.
C
C-----------------------------------------------------------------------
C R E V I S I O N H I S T O R Y
C
C 18OCT81 Alex Hunter 1. Added disclaimer notice. (V5.4)
C 28OCT81 Alex Hunter 1. Add new keywords. (V5.7)
C
C-----------------------------------------------------------------------
SUBROUTINE MATCH(TOKEN)
INCLUDE 'PLMCOM.FOR/NOLIST'
CHARACTER*32 ACTUAL1,ACTUAL2,ACTUAL3,TOKEN1,TOKEN2,TOKEN3
IF (TOKEN.EQ.TT) THEN
CALL GETTOK
RETURN
ENDIF
GO TO 10
C----------------------------
ENTRY MUSTBE(TOKEN)
C----------------------------
IF (TOKEN.EQ.TT) RETURN
C
C
C SYNTAX ERROR......
C
10 CALL ANALYZE_TOKEN(TOKEN1,ACTUAL1,TOKENTYPE,FIXVAL,FLOATVAL,
# STRLEN,DELIMITER,IDENTIFIER,STRING)
CALL ANALYZE_TOKEN(TOKEN2,ACTUAL2,NEXT_TOKENTYPE,NEXT_FIXVAL,
# NEXT_FLOATVAL,NEXT_STRLEN,NEXT_DELIMITER,
# NEXT_IDENTIFIER,NEXT_STRING)
CALL ANALYZE_TOKEN(TOKEN3,ACTUAL3,TOKEN,0,0.0,1,' ',' ',' ')
IF (PRINT_FLAG) THEN
WRITE(LST,1001) ACTUAL1(:LNB(ACTUAL1)),ACTUAL2(:LNB(ACTUAL2)),
# TOKEN3(:LNB(TOKEN3)),ACTUAL3(:LNB(ACTUAL3)),
# TOKEN1(:LNB(TOKEN1)),ACTUAL1(:LNB(ACTUAL1))
ENDIF
IF (.NOT.LISTING_TO_TERMINAL) THEN
CALL TYPE_LAST_SOURCE_LINE
WRITE(7,1001) ACTUAL1(:LNB(ACTUAL1)),ACTUAL2(:LNB(ACTUAL2)),
# TOKEN3(:LNB(TOKEN3)),ACTUAL3(:LNB(ACTUAL3)),
# TOKEN1(:LNB(TOKEN1)),ACTUAL1(:LNB(ACTUAL1))
ENDIF
1001 FORMAT(/' ***** Syntax Error Near ',A,X,A,' ****'//
# ' ***** Expected: ',A,X,A/
# ' ***** Actually Found: ',A,X,A/)
STOP '**** Compilation Aborted (Syntax Error) ****'
END
C------------------------------------------------------------
SUBROUTINE ANALYZE_TOKEN(TOKEN_STRING,ACTUAL_STRING,TOKEN,
# FIXV,FLOATV,STRL,D_STRING,ID_STRING,
# S_STRING)
INCLUDE 'PLMCOM.FOR/NOLIST'
CHARACTER TOKEN_STRING*32,ACTUAL_STRING*32,D_STRING*(*),
# ID_STRING*(*),S_STRING*(*)
INTEGER*4 FIXV
REAL*8 FLOATV
CHARACTER*10 KEYWORD(101:154)
CHARACTER*2 DD(201:218)
COMMON /ANALYZE/ KEYWORD,DD
CHARACTER*16 NON_TERMINAL(301:303)
DATA NON_TERMINAL /
# '<statement>','<expression>','<type>'/
IF (TOKEN.EQ.INVALID) THEN
TOKEN_STRING='<illegal character>'
ENCODE(32,1000,ACTUAL_STRING) ICHAR(D_STRING),D_STRING(1:1)
1000 FORMAT('X''',Z2,''' (',A1,')')
RETURN
ELSEIF (TOKEN.EQ.ID) THEN
TOKEN_STRING='<identifier>'
ACTUAL_STRING=ID_STRING
RETURN
ELSEIF (TOKEN.EQ.FIXCON) THEN
TOKEN_STRING='<fixed point constant>'
ENCODE(32,1001,ACTUAL_STRING) FIXV
1001 FORMAT(I10)
RETURN
ELSEIF (TOKEN.EQ.FLOATCON) THEN
TOKEN_STRING='<floating point constant>'
ENCODE(32,1002,ACTUAL_STRING) FLOATV
1002 FORMAT(G14.7)
RETURN
ELSEIF (TOKEN.EQ.STRCON) THEN
TOKEN_STRING='<string constant>'
ACTUAL_STRING=''''//S_STRING
IF (STRL.LE.30) THEN
ACTUAL_STRING(STRL+2:STRL+2)=''''
ELSE
ACTUAL_STRING(30:32)='...'
ENDIF
RETURN
ELSEIF (TOKEN.EQ.EOFTOK) THEN
TOKEN_STRING='<eof>'
ACTUAL_STRING=' '
RETURN
ELSEIF (TOKEN.GE.101.AND.TOKEN.LE.199) THEN
TOKEN_STRING='<keyword>'
ACTUAL_STRING=KEYWORD(TOKEN)
RETURN
ELSEIF (TOKEN.GE.201.AND.TOKEN.LE.299) THEN
TOKEN_STRING='<delimiter>'
ACTUAL_STRING=DD(TOKEN)
RETURN
ELSE ! MUST BE NON_TERMINAL PSEUDO_TOKEN.
TOKEN_STRING=NON_TERMINAL(TOKEN)
ACTUAL_STRING=' '
RETURN
ENDIF
END

137
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/merge.for Normal file
View File

@@ -0,0 +1,137 @@
C***********************************************************************
C
C MERGE.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 is used to merge identical
C nodes of a code tree, which effectively eliminates common sub-
C expressions. Note that after 'merging' a code tree, the code
C 'tree' is no longer necessarily a tree, but rather a directed
C acyclic graph. This means that the code 'tree' may no longer be
C traversed without some form of 'node marking' to detect already-
C visited nodes.
C
C-----------------------------------------------------------------------
C R E V I S I O N H I S T O R Y
C
C 18OCT81 Alex Hunter 1. Added disclaimer notice. (V5.4)
C 21OCT81 Alex Hunter 1. Basic block analysis. (V5.5)
C 09NOV81 Alex Hunter 1. Implement CSE assumption. (V5.9)
C 14NOV81 Alex Hunter 1. Don't merge certain opnode ops. (V6.2)
C 08FEB82 Alex Hunter 1. Do want to merge ARG opnodes. (V6.7)
C
C-----------------------------------------------------------------------
INTEGER*2 FUNCTION MERGE(NODX)
INCLUDE 'PLMCOM.FOR/NOLIST'
NOD=NODX
IF (.NOT.ASSUME_CSE.OR.NOD.EQ.NULL.OR.CONSTANT(NOD).OR.
# REGISTER(NOD)) THEN
MERGE=NOD
RETURN
ENDIF
IF (FIXLIT(NOD)) THEN
DO 100 MERGE=FIX_MIN,NEXT_FIXED-1
IF (FIXED_VAL(MERGE).EQ.FIXED_VAL(NOD).AND.
# NODE_TYPE(MERGE).EQ.NODE_TYPE(NOD)) RETURN
100 CONTINUE
CALL BUG('MERGE-100')
ELSEIF (FLOATLIT(NOD)) THEN
DO 200 MERGE=FLT_MIN,NEXT_FLOAT-1
IF (FLOAT_VAL(MERGE).EQ.FLOAT_VAL(NOD).AND.
# NODE_TYPE(MERGE).EQ.NODE_TYPE(NOD)) RETURN
200 CONTINUE
CALL BUG('MERGE-200')
ELSEIF (ATOM(NOD)) THEN
IF (NOD.LT.FIRST_FREE_ATOM) THEN
MERGE=NOD
RETURN
ENDIF
CALL PUSH(NOD,1)
BASE=MERGE2(ATOM_BASE(NOD))
CALL POP(NOD,1)
CALL PUSH(NOD,1)
CALL PUSH(BASE,1)
SUB=MERGE2(ATOM_SUB(NOD))
CALL POP(BASE,1)
CALL POP(NOD,1)
DO 300 MERGE=FIRST_FREE_ATOM,NEXT_ATOM-1
IF (ATOM_SYM(MERGE).EQ.ATOM_SYM(NOD).AND.
# ATOM_MEM(MERGE).EQ.ATOM_MEM(NOD).AND.
# ATOM_BASE(MERGE).EQ.BASE.AND.
# ATOM_SUB(MERGE).EQ.SUB.AND.
# ATOM_FLAGS(MERGE).EQ.ATOM_FLAGS(NOD).AND.
# ATOM_SERIAL_NO(MERGE).EQ.ATOM_SERIAL_NO(NOD).AND.
# ATOM_DISP(MERGE).EQ.ATOM_DISP(NOD)) RETURN
CCCC # NODE_TYPE(MERGE).EQ.NODE_TYPE(NOD)) RETURN
300 CONTINUE
ATOM_BASE(NOD)=BASE
ATOM_SUB(NOD)=SUB
MERGE=NOD
RETURN
ENDIF
C--------- NODE MUST BE AN OPNODE.
CALL PUSH(NOD,1)
OPND1=MERGE2(OPNODE_OPND1(NOD))
CALL POP(NOD,1)
CALL PUSH(NOD,1)
CALL PUSH(OPND1,1)
OPND2=MERGE2(OPNODE_OPND2(NOD))
CALL POP(OPND1,1)
CALL POP(NOD,1)
IF (OPNODE_OP(NOD).NE.OP_MOV.AND.
# OPNODE_OP(NOD).NE.OP_ASSN.AND.
# OPNODE_OP(NOD).NE.OP_THEN.AND.
# OPNODE_OP(NOD).NE.OP_ALSO)
#THEN
DO MERGE=NODE_MIN,NEXT_NODE-1
IF (OPNODE_OP(MERGE).EQ.OPNODE_OP(NOD).AND.
# OPNODE_OPND1(MERGE).EQ.OPND1.AND.
# OPNODE_OPND2(MERGE).EQ.OPND2.AND.
# NODE_TYPE(MERGE).EQ.NODE_TYPE(NOD)) RETURN
ENDDO
ENDIF
OPNODE_OPND1(NOD)=OPND1
OPNODE_OPND2(NOD)=OPND2
MERGE=NOD
RETURN
END
C-----------------------------------------------------------------------
INTEGER*2 FUNCTION MERGE2(NODX)
IMPLICIT INTEGER*2 (A-Z)
MERGE2=MERGE(NODX)
RETURN
END

199
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/modules.for Normal file
View File

@@ -0,0 +1,199 @@
C***********************************************************************
C
C MODULES.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 a (series of) PL/M
C program modules.
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. Add LONG attribute to P_DATA psect. (V5.2)
C 21OCT81 Alex Hunter 1. Basic block analysis. (V5.5)
C 12NOV81 Alex Hunter 1. Define APD and MEMORY psects. (V6.1)
C 14NOV81 Alex Hunter 1. Change addressing modes and psect usage.
C (V6.2)
C
C***********************************************************************
SUBROUTINE COMPILATION
INCLUDE 'PLMCOM.FOR/NOLIST'
CALL MODULE
IF (TT.EQ.EOFTOK.OR.TT.EQ.K_EOF) RETURN
CALL ERROR('MULTIPLE COMPILATIONS NOT CURRENTLY SUPPORTED')
RETURN
END
C--------------------------------------------------------------
SUBROUTINE MODULE
INCLUDE 'PLMCOM.FOR/NOLIST'
CHARACTER*80 TITLE
CHARACTER*32 MODULE_NAME,START_NAME,ID_LINE,PUBLIQUE
INTEGER*4 NTICKS,NTICKS1,NFAULTS,NFAULTS1
REAL*4 TIME,TIME1,CPUTIM
INTEGER*4 HANDLE
CHARACTER*40 REGISTER_MASK
C
HANDLE=0
CALL LIB$INIT_TIMER(HANDLE)
TIME1=SECNDS(0.0)
CALL JPI(NTICKS1,NFAULTS1)
IF (NLABELS.EQ.0) THEN
CALL ERROR('MODULE NAME MISSING: MAIN. ASSUMED')
NLABELS=1
LABELS(NLABELS) = 'MAIN.'
ENDIF
PROC_ENTRY_MASK(PROC_LEVEL)=0
DO I=1,NLABELS-1
CALL ERROR('EXTRANEOUS LABEL IGNORED -- '//LABELS(I))
ENDDO
MODULE_NAME=PUBLIQUE(LABELS(NLABELS))
CALL PUSHC(LABELS(NLABELS))
CALL EMIT('.TITLE '//MODULE_NAME(:LNB(MODULE_NAME))//' '//
# TITLE(:MAKE_CHARS(TITLE,TITLE_STRING)))
ENCODE(32,1001,ID_LINE) VERSION
1001 FORMAT('.IDENT "PL/M-VAX V',F3.1,'"')
CALL EMIT(ID_LINE)
CALL EMIT('.ENABLE GLOBAL')
CALL EMIT('.ENABLE LOCAL_BLOCK')
IF (DEBUG_FLAG) CALL EMIT('.ENABLE DEBUG')
IF (PSECT_NAME(P_CONSTANTS).NE.PSECT_NAME(P_DATA)) THEN
CALL EMIT('.PSECT '//
# PSECT_NAME(P_CONSTANTS)(:LNB(PSECT_NAME(P_CONSTANTS)))//
# ',RD,NOWRT,EXE,GBL,CON')
ENDIF
CALL EMIT('.PSECT '//
# PSECT_NAME(P_STACK)(:LNB(PSECT_NAME(P_STACK)))//
# ',RD,WRT,EXE,GBL,CON')
IF (VECTOR_FLAG) THEN
CALL EMIT('.PSECT '//
# PSECT_NAME(P_VECTOR)(:LNB(PSECT_NAME(P_VECTOR)))//
# ',RD,NOWRT,EXE,GBL,CON')
ENDIF
CALL EMIT('.PSECT '//
# PSECT_NAME(P_APD)(:LNB(PSECT_NAME(P_APD)))//
# ',RD,WRT,NOEXE,GBL,CON,LONG')
IF (FREQ_FLAG) THEN
CALL EMIT('.PSECT '//
# PSECT_NAME(P_FREQ)(:LNB(PSECT_NAME(P_FREQ)))//
# ',RD,WRT,NOEXE,GBL,CON')
ENDIF
CALL EMIT('.PSECT '//
# PSECT_NAME(P_MEMORY)(:LNB(PSECT_NAME(P_MEMORY)))//
# ',PIC,OVR,GBL,SHR,NOEXE,RD,WRT,LONG')
CALL EMIT1('MEMORY.:')
CALL EMIT('.PSECT '//
# PSECT_NAME(P_DATA)(:LNB(PSECT_NAME(P_DATA)))//
# ',RD,WRT,NOEXE,GBL,CON,LONG')
IF (MODEL.NE.4) THEN
CALL EMIT1('K. = ^X8000')
ENDIF
IF (MODEL.EQ.4.AND..NOT.OVERLAY_FLAG) THEN
CALL EMIT1('M. = .+128')
ENDIF
CALL EMIT('.PSECT '//
# PSECT_NAME(P_CODE)(:LNB(PSECT_NAME(P_CODE)))//
# ',RD,NOWRT,EXE,GBL,CON')
NLABELS=0
CALL MATCH(K_DO)
CALL MATCH(D_SEMI)
CALL BLOCK_BEGIN
CALL DECLARATIONS
IF (TT.NE.K_END) THEN
CALL PSECT(P_APD)
CALL EMIT1('FPSP. = .')
CALL EMIT('.BLKQ 1')
CALL PSECT(P_CODE)
PATH=.TRUE.
IF (OVERLAY_FLAG) THEN
CALL EMIT1(MODULE_NAME(:LNB(MODULE_NAME))//'::')
CALL EMIT('.WORD MSK.')
START_NAME=' '
ELSE
CALL EMIT1('START.: .WORD MSK.')
START_NAME='START.'
ENDIF
IF (MODEL.NE.4) THEN
CALL EMIT('MOVL #K.,R11')
CALL PRESERVE_REG(11)
ELSEIF (.NOT.OVERLAY) THEN
CALL EMIT('MOVAB M.,R11')
CALL PRESERVE_REG(11)
ENDIF
IF (MODEL.EQ.1 .OR. MODEL.EQ.3) THEN
CALL EMIT('MOVAB S.,R10')
CALL PRESERVE_REG(10)
ENDIF
CALL EMIT('MOVQ FP,FPSP.')
CALL UNITS
CALL BREAK
IF (PATH) THEN
CALL EMIT('MOVL #1,R0')
CALL EMIT('RET')
ENDIF
CALL EMIT1('MSK. = '//
# REGISTER_MASK(PROC_ENTRY_MASK(PROC_LEVEL)))
ELSE
START_NAME=' '
ENDIF
CALL OUTPUT_PUBLICS(MODULE_NAME)
CALL BLOCK_END
CALL END_STATEMENT
IF (SKIP_STATE.NE.4) THEN
CALL ERROR('$ENDIF MISSING AT END OF COMPILATION')
ENDIF
CALL EMIT('.END '//START_NAME)
IF (PRINT_FLAG) THEN
CALL SUMMARY_TAIL
CALL ROOM_FOR(8)
CALL ADVANCE_ONE_LINE
TIME=SECNDS(TIME1)
CALL JPI(NTICKS,NFAULTS)
CPUTIM=(NTICKS-NTICKS1)*.01
WRITE(LST,1000) CPUTIM,TIME,NFAULTS-NFAULTS1
1000 FORMAT(//' PL/M-VAX COMPILATION STATISTICS'//
# ' CPU Time:',T21,F8.2' seconds'/
# ' Elapsed Time:'T21,F8.2' seconds'/
# ' Page Faults:'T21,I8)
ENDIF
CALL LIB$SHOW_TIMER(HANDLE)
RETURN
END

192
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/nodes.for Normal file
View File

@@ -0,0 +1,192 @@
C***********************************************************************
C
C NODES.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 to create
C nodes of a code tree, and to determine the type of a node.
C
C-----------------------------------------------------------------------
C R E V I S I O N H I S T O R Y
C
C 20OCT81 Alex Hunter 1. Added disclaimer notice. (V5.4)
C 21OCT81 Alex Hunter 1. Basic block analysis. (V5.5)
C 10NOV81 Alex Hunter 1. Add serial no. deltas. (6.0)
C
C-----------------------------------------------------------------------
INTEGER*2 FUNCTION MAKE_NODE(OP,OPND1,OPND2,TYPE,REG,REFCT)
INCLUDE 'PLMCOM.FOR/NOLIST'
REAL*8 RVAL
INTEGER*4 IVAL,IVAL1
IF (NEXT_NODE.GT.NODE_MAX) CALL FATAL('NODE TABLE OVERFLOW')
OPNODE_OP(NEXT_NODE)=OP
OPNODE_OPND1(NEXT_NODE)=OPND1
OPNODE_OPND2(NEXT_NODE)=OPND2
NODE_TYPE(NEXT_NODE)=TYPE
NODE_REG(NEXT_NODE)=REG
NODE_REFCT(NEXT_NODE)=0
NODE_CONTEXT(NEXT_NODE)=0
MAKE_NODE=NEXT_NODE
NEXT_NODE=NEXT_NODE+1
RETURN
C---------------------------------------
ENTRY MAKE_ATOM(SYM,MEM,BASE,SUBSCRIPT,TYPE,REG,REFCT)
C---------------------------------------
IF (NEXT_ATOM.GT.ATOM_MAX) CALL FATAL('ATOM TABLE OVERFLOW')
ATOM_SYM(NEXT_ATOM)=SYM
ATOM_MEM(NEXT_ATOM)=MEM
ATOM_BASE(NEXT_ATOM)=BASE
ATOM_SUB(NEXT_ATOM)=SUBSCRIPT
ATOM_DISP(NEXT_ATOM)=0
ATOM_FLAGS(NEXT_ATOM)=0
NODE_TYPE(NEXT_ATOM)=TYPE
NODE_REG(NEXT_ATOM)=REG
NODE_REFCT(NEXT_ATOM)=0
NODE_CONTEXT(NEXT_ATOM)=CONTEXT(TYPE)
IF (MEM.NE.0) THEN
ATOM_SERIAL_NO(NEXT_ATOM)=MEMBER_SERIAL_NO(MEM)
ELSEIF (SYM.NE.0) THEN
ATOM_SERIAL_NO(NEXT_ATOM)=SYMBOL_SERIAL_NO(SYM)
ELSE
ATOM_SERIAL_NO(NEXT_ATOM)=-1
ENDIF
IF (SYM.NE.0.AND.SYMBOL_REF(SYM).EQ.S_EXT) THEN
ATOM_SERIAL_NO(NEXT_ATOM) =
# ATOM_SERIAL_NO(NEXT_ATOM) + EXTERNAL_SERIAL_DELTA
ENDIF
IF (BASE.NE.NULL) THEN
ATOM_SERIAL_NO(NEXT_ATOM) =
# ATOM_SERIAL_NO(NEXT_ATOM) + BASED_SERIAL_DELTA
ENDIF
IF (SUBSCRIPT.NE.NULL) THEN
ATOM_SERIAL_NO(NEXT_ATOM) =
# ATOM_SERIAL_NO(NEXT_ATOM) + SUBSCRIPTED_SERIAL_DELTA
ENDIF
IF ((SYMBOL_FLAGS(SYM).AND.S_OVERLAID).NE.0) THEN
ATOM_SERIAL_NO(NEXT_ATOM) =
# ATOM_SERIAL_NO(NEXT_ATOM) + OVERLAID_SERIAL_DELTA
ENDIF
MAKE_ATOM=NEXT_ATOM
NEXT_ATOM=NEXT_ATOM+1
RETURN
C---------------------------------------
ENTRY MAKE_FIXED(IVAL,TYPE)
C---------------------------------------
IVAL1=IVAL
GO TO 10
C---------------------------------------
ENTRY MAKE_FIXED2(I2VAL,TYPE)
C---------------------------------------
IVAL1=I2VAL
10 IF (NEXT_FIXED.GT.FIX_MAX)
# CALL FATAL('FIXED POINT LITERAL TABLE OVERFLOW')
FIXED_VAL(NEXT_FIXED)=IVAL1
NODE_TYPE(NEXT_FIXED)=TYPE
NODE_REG(NEXT_FIXED)=0
NODE_REFCT(NEXT_FIXED)=0
IF (TYPE.EQ.0) THEN
NODE_CONTEXT(NEXT_FIXED)=0
ELSEIF (TYPE.EQ.S_INTEGER) THEN
NODE_CONTEXT(NEXT_FIXED)=CX_SIGNED
ELSE
NODE_CONTEXT(NEXT_FIXED)=CX_UNSIGNED
ENDIF
MAKE_FIXED=NEXT_FIXED
NEXT_FIXED=NEXT_FIXED+1
RETURN
C---------------------------------------
ENTRY MAKE_FLOAT(RVAL,TYPE)
C---------------------------------------
IF (NEXT_FLOAT.GT.FLT_MAX)
# CALL FATAL('FLOATING POINT LITERAL TABLE OVERFLOW')
FLOAT_VAL(NEXT_FLOAT)=RVAL
NODE_TYPE(NEXT_FLOAT)=TYPE
NODE_REG(NEXT_FLOAT)=0
NODE_REFCT(NEXT_FLOAT)=0
NODE_CONTEXT(NEXT_FLOAT)=CX_SIGNED
MAKE_FLOAT=NEXT_FLOAT
NEXT_FLOAT=NEXT_FLOAT+1
RETURN
C---------------------------------------
ENTRY MAKE_CONSTANT(LL,TYPE)
C---------------------------------------
IF (NEXT_CONSTANT.GT.CON_MAX)
# CALL FATAL('CONSTANT TABLE OVERFLOW')
CONSTANT_LABEL(NEXT_CONSTANT)=LL
NODE_TYPE(NEXT_CONSTANT)=TYPE
NODE_REG(NEXT_CONSTANT)=0
NODE_REFCT(NEXT_CONSTANT)=0
NODE_CONTEXT(NEXT_CONSTANT)=CONTEXT(TYPE)
MAKE_CONSTANT=NEXT_CONSTANT
NEXT_CONSTANT=NEXT_CONSTANT+1
RETURN
C---------------------------------------
ENTRY MAKE_REGISTER(REG,TYPE)
C---------------------------------------
NODE_TYPE(REG)=TYPE
NODE_REG(REG)=REG
NODE_REFCT(REG)=0
NODE_CONTEXT(REG)=CONTEXT(TYPE)
MAKE_REGISTER=REG
RETURN
END
C--------------------------------------------------------------
FUNCTION NODE(LINK)
INCLUDE 'PLMCOM.FOR/NOLIST'
NODE=LINK.GE.NODE_MIN.AND.LINK.LE.NODE_MAX
RETURN
C---------------------------------------
ENTRY ATOM(LINK)
C---------------------------------------
ATOM=LINK.GE.ATOM_MIN.AND.LINK.LE.ATOM_MAX
RETURN
C---------------------------------------
ENTRY LITERAL(LINK)
C---------------------------------------
LITERAL=LINK.GE.FIX_MIN.AND.LINK.LE.FIX_MAX.OR.
# LINK.GE.FLT_MIN.AND.LINK.LE.FLT_MAX
RETURN
C---------------------------------------
ENTRY FIXLIT(LINK)
C---------------------------------------
FIXLIT=LINK.GE.FIX_MIN.AND.LINK.LE.FIX_MAX
RETURN
C---------------------------------------
ENTRY FLOATLIT(LINK)
C---------------------------------------
FLOATLIT=LINK.GE.FLT_MIN.AND.LINK.LE.FLT_MAX
RETURN
C---------------------------------------
ENTRY CONSTANT(LINK)
C---------------------------------------
CONSTANT=LINK.GE.CON_MIN.AND.LINK.LE.CON_MAX
RETURN
C---------------------------------------
ENTRY REGISTER(LINK)
C---------------------------------------
REGISTER=LINK.GE.REG_MIN.AND.LINK.LE.REG_MAX
RETURN
END

79
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/open.for Normal file
View File

@@ -0,0 +1,79 @@
C***********************************************************************
C
C OPEN.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 used to
C open input and output files. A 'USEROPEN' procedure is invoked
C when an input file is opened to allow access to the VFC line
C numbers created by text editors.
C
C-----------------------------------------------------------------------
C R E V I S I O N H I S T O R Y
C
C 20OCT81 Alex Hunter 1. Added disclaimer notice. (V5.4)
C 04FEB82 Alex Hunter 1. Change name of useropen procedure
C and its common block. (V6.6)
C
C-----------------------------------------------------------------------
SUBROUTINE OPEN_SOS_FILE(UNIT,FILE_STRING)
INCLUDE 'PLMCOM.FOR/NOLIST'
EXTERNAL XQ_GET_CNTRL_FLD
BYTE FILE_STRING(0:45)
INTEGER*2 W_LINE_NUMBER(0:99)
COMMON /XQ_LINE_SEQS/ W_LINE_NUMBER
FILE_STRING(FILE_STRING(0)+1)=0
W_LINE_NUMBER(UNIT)=-1
I=1
IF (FILE_STRING(1).EQ.':') I=2
OPEN(UNIT=UNIT,FILE=FILE_STRING(I),STATUS='OLD',READONLY,
# USEROPEN=XQ_GET_CNTRL_FLD,ERR=99)
RETURN
99 IF (PRINT_FLAG) THEN
CALL ADVANCE_ONE_LINE
WRITE(LST,1000) (FILE_STRING(I),I=1,FILE_STRING(0))
ENDIF
IF (.NOT.LISTING_TO_TERMINAL) THEN
CALL TYPE_LAST_SOURCE_LINE
WRITE(7,1000) (FILE_STRING(I),I=1,FILE_STRING(0))
ENDIF
1000 FORMAT(' **** Input File Not Found: ',99A1)
STOP 'COMPILATION ABORTED'
C----------------------------------
ENTRY OPEN_OUTPUT_FILE(UNIT,FILE_STRING)
C----------------------------------
FILE_STRING(FILE_STRING(0)+1)=0
I=1
IF (FILE_STRING(1).EQ.':') I=2
OPEN(UNIT=UNIT,FILE=FILE_STRING(I),STATUS='NEW')
RETURN
END

248
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/operand.for Normal file
View File

@@ -0,0 +1,248 @@
C***********************************************************************
C
C OPERAND.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 is used to translate a
C code tree operand into a symbolic assembly-language character
C string.
C
C-----------------------------------------------------------------------
C R E V I S I O N H I S T O R Y
C
C 20OCT81 Alex Hunter 1. Added disclaimer notice. (V5.4)
C 2. Generate long-displacement addressing
C for constants in ROM.
C 12NOV81 Alex Hunter 1. Qualify S_STATIC with P_DATA. (V6.1)
C 14NOV81 Alex Hunter 1. Major rewrite to change addressing modes.
C (V6.2)
C 03FEB82 Alex Hunter 1. Fix bug for immediate operands in LARGE
C model. (V6.6)
C
C-----------------------------------------------------------------------
CHARACTER*80 FUNCTION OPERAND(OPND,N)
INCLUDE 'PLMCOM.FOR/NOLIST'
INTEGER*4 IVAL,IFSD,ILSD
CHARACTER*32 VECNIQUE
CHARACTER*14 STRINGG,LITG
CHARACTER*10 LIT,STRING10
CHARACTER*2 DISPL
CHARACTER*3 REGNAME(REG_MIN:REG_MAX)
DATA REGNAME /'R1','R2','R3','R4','R5','R6','R7','R8','R9',
# 'R10','R11','AP','FP','SP','PC','R0'/
INTEGER*2 REGNAME_LENGTH(REG_MIN:REG_MAX)
DATA REGNAME_LENGTH /2,2,2,2,2,2,2,2,2,3,3,2,2,2,2,2/
IF (OPND.GE.REG_MIN.AND.OPND.LE.REG_MAX) THEN
OPERAND=REGNAME(OPND)
N=REGNAME_LENGTH(OPND)
RETURN
ELSEIF (OPND.EQ.ON_STACK) THEN
IF (MODEL.EQ.2 .OR. MODEL.EQ.4) THEN
OPERAND='-(SP)'
N=5
ELSE
OPERAND='-(R10)'
N=6
ENDIF
RETURN
ELSEIF (FIXLIT(OPND)) THEN
IVAL=FIXED_VAL(OPND)
LIT=STRING10(IVAL,IFSD)
OPERAND='#'//LIT(IFSD:10)
N=12-IFSD
RETURN
ELSEIF (FLOATLIT(OPND)) THEN
LITG=STRINGG(FLOAT_VAL(OPND),IFSD,ILSD)
OPERAND='#'//LITG(IFSD:ILSD)
N=ILSD-IFSD+2
RETURN
ENDIF
C -- OPERAND MUST BE A CONSTANT OR AN ATOM.
C
C --- COMPUTE WHICH ADDRESSING SCHEMA TO USE.
C
SCHEMA=1 ! Default schema.
ATMSYM=0 ! In case opnd is a constant.
IF (CONSTANT(OPND)) THEN
IF (ROM_FLAG.OR.MODEL.EQ.4) THEN
SCHEMA=3
ELSEIF (OVERLAY_FLAG) THEN
SCHEMA=7
ELSE
SCHEMA=5
ENDIF
ELSEIF (ATOM(OPND)) THEN
ATMSYM=ATOM_SYM(OPND) ! We'll need this a lot.
IF ((ATOM_FLAGS(OPND).AND.A_VECTOR).NE.0) THEN
SCHEMA=4
ELSEIF (ATOM_BASE(OPND).NE.0) THEN
SCHEMA=2
BASEREG=NODE_REG(ATOM_BASE(OPND))
ELSEIF (ATMSYM.NE.0) THEN
IF (SYMBOL_REF(ATMSYM).EQ.S_STATIC) THEN
IF (SYMBOL_PSECT(ATMSYM).EQ.P_DATA) THEN
IF (OVERLAY_FLAG) THEN
SCHEMA=7
ELSE
SCHEMA=5
ENDIF
ELSEIF (SYMBOL_PSECT(ATMSYM).EQ.P_CONSTANT) THEN
SCHEMA=3
ELSEIF (SYMBOL_PSECT(ATMSYM).EQ.P_MEMORY) THEN
SCHEMA=8
ELSEIF (SYMBOL_PSECT(ATMSYM).GT.P_MEMORY) THEN
SCHEMA=3 ! User common.
ENDIF
ELSEIF (SYMBOL_REF(ATMSYM).EQ.S_EXT) THEN
IF (SYMBOL_PSECT(ATMSYM).EQ.P_DATA) THEN
IF ((SYMBOL_FLAGS(ATMSYM).AND.S_SAME_OVERLAY).NE.0)
# THEN
SCHEMA=7
ELSE
SCHEMA=6
ENDIF
ELSEIF (SYMBOL_PSECT(ATMSYM).EQ.P_CONSTANT) THEN
SCHEMA=3
ELSEIF (SYMBOL_PSECT(ATMSYM).EQ.P_MEMORY) THEN
SCHEMA=8
ELSEIF (SYMBOL_PSECT(ATMSYM).GT.P_MEMORY) THEN
SCHEMA=3 ! User common.
ENDIF
ELSEIF (SYMBOL_REF(ATMSYM).EQ.S_ARG) THEN
SCHEMA=2
BASEREG=PROC_AP(SYMBOL_LINK(ATMSYM))
ELSEIF (SYMBOL_REF(ATMSYM).EQ.S_DYNAMIC) THEN
SCHEMA=2
BASEREG=12
ENDIF
ENDIF
ENDIF
C
C --- COMPUTE THE DISPLACEMENT MODE FIELD.
C
IF (ATOM(OPND).AND.(ATOM_FLAGS(OPND).AND.A_IMMEDIATE).NE.0 .OR.
# ATMSYM.NE.0.AND.SYMBOL_REF(ATMSYM).EQ.S_VALUE) THEN
OPERAND='#'
N=1
ELSEIF (SCHEMA.GE.5.AND.MODEL.NE.4.AND.
# .NOT.(MODEL.EQ.2.AND.SCHEMA.EQ.8)) THEN
OPERAND='W^'
N=2
ELSE
OPERAND=' '
N=0
ENDIF
C
C --- COMPUTE THE SYMBOLIC VALUE FIELD.
C
IF (CONSTANT(OPND)) THEN
OPERAND(N+1:)=LOCAL_LABEL(CONSTANT_LABEL(OPND),N1)
N=N+N1
ELSEIF (SCHEMA.EQ.4) THEN
OPERAND(N+1:)=VECNIQUE(SYMBOL_VAX_ID(ATMSYM))
N=LNB(OPERAND)
ELSE
IF (ATMSYM.NE.0) THEN
OPERAND(N+1:)=SYMBOL_VAX_ID(ATMSYM)
N=LNB(OPERAND)
ENDIF
IF (ATOM_MEM(OPND).NE.0) THEN
OPERAND(N+1:)='+'//MEMBER_VAX_ID(ATOM_MEM(OPND))
N=LNB(OPERAND)
ENDIF
IVAL=ATOM_DISP(OPND)
IF (ATMSYM.NE.0) THEN
IVAL=IVAL+SYMBOL_DISP(ATMSYM)
ENDIF
IF (IVAL.NE.0) THEN
LIT=STRING10(IVAL,IFSD)
IF (IVAL.GE.0) THEN
OPERAND(N+1:)='+'//LIT(IFSD:10)
N=N+12-IFSD
ELSE
OPERAND(N+1:)=LIT(IFSD:10)
N=N+11-IFSD
ENDIF
ENDIF
ENDIF
C
C --- COMPUTE RUNTIME RELOCATION FIELD.
C
IF (SCHEMA.EQ.7.AND.
# (.NOT.ATOM(OPND).OR.(ATOM_FLAGS(OPND).AND.A_CTIM).EQ.0)) THEN
OPERAND(N+1:)='-'//BASEC
N=N+NC+1
ENDIF
C
C --- COMPUTE THE BASE FIELD.
C
IF (SCHEMA.EQ.2) THEN
OPERAND(N+1:)='('//REGNAME(BASEREG)(:REGNAME_LENGTH(BASEREG))
# //')'
N=N+REGNAME_LENGTH(BASEREG)+2
ELSEIF (SCHEMA.EQ.4) THEN
OPERAND(N+1:)='-V.'
N=N+3
ELSEIF (SCHEMA.GE.5.AND.MODEL.NE.4.AND.
# .NOT.(MODEL.EQ.2.AND.SCHEMA.EQ.8)) THEN
IF (.NOT.ATOM(OPND).OR.(ATOM_FLAGS(OPND).AND.A_IMMEDIATE).EQ.0)
# THEN
OPERAND(N+1:)='-K.(R11)'
N=N+8
ENDIF
ELSEIF (SCHEMA.EQ.5.AND.MODEL.EQ.4) THEN
IF (.NOT.ATOM(OPND).OR.(ATOM_FLAGS(OPND).AND.A_IMMEDIATE).EQ.0)
# THEN
OPERAND(N+1:)='(R11)'
N=N+5
ELSE
OPERAND(N+1:)='+M.'
N=N+3
ENDIF
ENDIF
C
C --- COMPUTE THE INDEX FIELD.
C
IF (ATOM(OPND).AND.ATOM_SUB(OPND).NE.NULL) THEN
XREG=NODE_REG(ATOM_SUB(OPND))
OPERAND(N+1:)='['//REGNAME(XREG)(:REGNAME_LENGTH(XREG))//']'
N=N+REGNAME_LENGTH(XREG)+2
ENDIF
RETURN
END

17
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/plm.bld Normal file
View File

@@ -0,0 +1,17 @@
$SET VERIFY
$!
$! PLM.BLD
$!
$! Command file to build the PL/M-VAX compiler.
$!
$! 02FEB82 Alex Hunter 1. Original version.
$!
$!
$! 1. Compile all source modules.
$!
$@PLM.CMP
$!
$! 2. Link everything together.
$!
$@PLM.LNK
$SET NOVERIFY

75
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/plm.cmp Normal file
View File

@@ -0,0 +1,75 @@
$SET VERIFY
$!
$! PLM.CMP
$!
$!
$! Command file to compile all the modules of the PL/M-VAX compiler.
$!
$! 02FEB82 Alex Hunter 1. Original version.
$! 05FEB82 Alex Hunter 1. Add call to LOGNAMES.COM.
$!
$@LOGNAMES
$!
$FOR/DEB/NOCHECK/CONT=99 BASICS.FOR
$FOR/DEB/NOCHECK/CONT=99 BLOCK.FOR
$FOR/DEB/NOCHECK/CONT=99 BRANCHES.FOR
$FOR/DEB/NOCHECK/CONT=99 BREAK.FOR
$FOR/DEB/NOCHECK/CONT=99 BUILTINS.FOR
$FOR/DEB/NOCHECK/CONT=99 COERCE.FOR
$FOR/DEB/NOCHECK/CONT=99 CONTEXT.FOR
$PLM CONTROL.PLM DEBUG OPTIMIZE(3) ALIGN
$FOR/DEB/NOCHECK/CONT=99 COUNTS.FOR
$FOR/DEB/NOCHECK/CONT=99 DATA.FOR
$FOR/DEB/NOCHECK/CONT=99 DECLS.FOR
$FOR/DEB/NOCHECK/CONT=99 EFFECTS.FOR
$FOR/DEB/NOCHECK/CONT=99 EMIT.FOR
$FOR/DEB/NOCHECK/CONT=99 ERROR.FOR
$FOR/DEB/NOCHECK/CONT=99 EXPRS.FOR
$FOR/DEB/NOCHECK/CONT=99 FOLD.FOR
$FOR/DEB/NOCHECK/CONT=99 GENCODE.FOR
$FOR/DEB/NOCHECK/CONT=99 GETC.FOR
$FOR/DEB/NOCHECK/CONT=99 GETLEX.FOR
$FOR/DEB/NOCHECK/CONT=99 GETTOK.FOR
$FOR/DEB/NOCHECK/CONT=99 HASH.FOR
$FOR/DEB/NOCHECK/CONT=99 INIT.FOR
$FOR/DEB/NOCHECK/CONT=99 JPI.FOR
$FOR/DEB/NOCHECK/CONT=99 LIST.FOR
$FOR/DEB/NOCHECK/CONT=99 LOCALS.FOR
$FOR/DEB/NOCHECK/CONT=99 MASSAGE.FOR
$FOR/DEB/NOCHECK/CONT=99 MATCH.FOR
$FOR/DEB/NOCHECK/CONT=99 MERGE.FOR
$FOR/DEB/NOCHECK/CONT=99 MODULES.FOR
$FOR/DEB/NOCHECK/CONT=99 NODES.FOR
$FOR/DEB/NOCHECK/CONT=99 OPEN.FOR
$FOR/DEB/NOCHECK/CONT=99 OPERAND.FOR
$FOR/DEB/NOCHECK/CONT=99 PLM.FOR
$FOR/DEB/NOCHECK/CONT=99 PROCS.FOR
$FOR/DEB/NOCHECK/CONT=99 PSECTS.FOR
$FOR/DEB/NOCHECK/CONT=99 PUBLICS.FOR
$FOR/DEB/NOCHECK/CONT=99 PUSH.FOR
$FOR/DEB/NOCHECK/CONT=99 REGS.FOR
$FOR/DEB/NOCHECK/CONT=99 REPLICA.FOR
$FOR/DEB/NOCHECK/CONT=99 SAVETREE.FOR
$FOR/DEB/NOCHECK/CONT=99 SCOPES.FOR
$FOR/DEB/NOCHECK/CONT=99 SOMEWHERE.FOR
$FOR/DEB/NOCHECK/CONT=99 STRINGS.FOR
$FOR/DEB/NOCHECK/CONT=99 SUMMARY.FOR
$FOR/DEB/NOCHECK/CONT=99 SYMTAB.FOR
$FOR/DEB/NOCHECK/CONT=99 UNIQUE.FOR
$FOR/DEB/NOCHECK/CONT=99 UNITS.FOR
$!
$LIB/CRE PLMCOM
$LIB PLMCOM BASICS,BLOCK,BRANCHES,BREAK,BUILTINS
$LIB PLMCOM COERCE,CONTEXT,CONTROL,COUNTS
$LIB PLMCOM DATA,DECLS
$LIB PLMCOM EFFECTS,EMIT,ERROR,EXPRS,FOLD
$LIB PLMCOM GENCODE,GETC,GETLEX,GETTOK
$LIB PLMCOM HASH,INIT,JPI
$LIB PLMCOM LIST,LOCALS
$LIB PLMCOM MASSAGE,MATCH,MERGE,MODULES
$LIB PLMCOM NODES,OPEN,OPERAND
$LIB PLMCOM PLM,PROCS,PSECTS,PUBLICS,PUSH
$LIB PLMCOM REGS,REPLICA
$LIB PLMCOM SAVETREE,SCOPES,SOMEWHERE
$LIB PLMCOM STRINGS,SUMMARY,SYMTAB
$LIB PLMCOM UNIQUE,UNITS

356
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/plm.for Normal file
View File

@@ -0,0 +1,356 @@
C***********************************************************************
C
C PLM.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 is the main module for the PL/M-VAX compiler. Default values
C for controls are established, the invocation line is processed, a
C compilation is performed, and the MACRO assembler is chained to
C (if required).
C
C-----------------------------------------------------------------------
C
C R E V I S I O N H I S T O R Y
C
C VERSION 3.5 29APR81 AFH FOR MODEL=1 (SMALL) ASSUME D.=0,
C AND MAKE APPROPRIATE SIMPLIFICATIONS.
C
C VERSION 3.6 30APR81 AFH IMPLEMENT PROCEDURE EXECUTION FREQUENCY
C COUNTS
C
C VERSION 3.7 08MAY81 AFH FIXED BUG IN CONTROL_LINE PROCEDURE
C WHICH COULD SOMETIMES CAUSE A CONTROL
C LINE TO BE IGNORED. ALSO, CHECK
C SKIP_STATE AT END OF COMPILATION TO
C DETECT UNCLOSED CONDITIONAL COMPILATION
C BLOCKS.
C
C VERSION 3.8 14MAY81 AFH 1. Special handling for DO WHILE <const>
C (eliminates some spurious PATH warnings).
C 2. Fix invocation line bug introduced in
C version 3.7.
C 3. Allow spurious trailing comma in
C initialization list (for compatibility
C with PLM86).
C 4. Put runtime statistics at end of listing.
C 5. Fix node_type(reg) bug in SOMEWHERE.
C 6. Set attributes of all symbols in a
C factored declaration before processing
C the initialization list (in case list
C contains restricted location refs to
C any elements in the current declaration).
C
C VERSION 3.9 AFH 15MAY81 1. Add STACK,STACKTOP,STACKPTR builtins.
C 2. Change default extent for PUBLICS to PBL.
C 3. Fix line #'s for unsequenced INCLUDE
C files.
C
C VERSION 4.0 AFH 28MAY81 (FIRST RELEASE TO INTEL.)
C 1. No traceback on FATAL error or BUG.
C 2. Fix 'input file not found' message
C to come out on terminal.
C 3. Try to type offending source line
C along with error message to terminal.
C
C VERSION 4.1 AFH 14JUN81 1. Increase string space to 32K bytes.
C 2. Don't allow procedure as LHS of
C assignment statement.
C
C VERSION 4.2 AFH 22JUN81 1. Temporary fix to allow dimensions>32K.
C
C VERSION 4.3 AFH 23JUN81 (SECOND RELEASE TO INTEL.)
C 1. Fix LAST,LENGTH,SIZE for dimension>32K.
C 2. Generate in-line code for the following
C built-ins:
C DOUBLE,LOW,FLOAT,FIX,INT,SIGNED,
C UNSIGN.
C
C VERSION 4.4 AFH 23JUN81 (THIRD RELEASE TO INTEL.)
C 1. Allow AT(@external+offset).
C
C VERSION 4.5 AFH 05JUL81 1. Implement ACALLS control.
C 2. Only two models (LARGE & SMALL),
C so make some simplifications.
C 3. Change FIND* library routine names
C to the unified versions.
C 4. Change most D.'s to 0's.
C 5. Generate 'MCOMB #0' instead of
C 'MNEGB #1' for aesthetic reasons.
C 6. Generate word-displacement addressing
C for SMALL-model constants.
C (Modules affected: PLMCOM, PLM, CONTROL,
C PROCS, BASICS, LOCALS, MODULES, INIT,
C EMIT, FOLD, GENCODE, OPERAND.)
C
C VERSION 4.6 AFH 05JUL81 1. Allow %forward references in restricted
C location references.
C 2. Add ALIGN, FREQUENCIES, ACALLS to
C summary tail.
C
C VERSION 4.7 AFH 16JUL81 1. Correct bug introduced by 4.5(6.).
C (addressing was wrong for SMALL model
C non-overlay module constants).
C (Modules affected: PLM, OPERAND.)
C
C VERSION 4.8 AFH 29JUL81 1. Add FRAME$PTR builtin.
C (Modules affected: PLM, INIT, BUILTINS.)
C
C VERSION 4.9 AFH 18AUG81 (FIFTH RELEASE TO INTEL.)
C 1. Fold the special case of
C symbol(const).member(const) where
C element_size(symbol).ne.0
C (modulo element_size(member)).
C 2. Increase max number of globals to 800.
C 3. Fix bug in EXTRACT_DISPLACEMENT
C (downward/upward coercions are not
C transitive).
C 4. Change names of all out-of-line builtins
C to the unified versions.
C (Modules affected: PLM,PLMCOM,FOLD,INIT.)
C
C VERSION 5.0 AFH 19AUG81 1. Support COMPACT and MEDIUM models as
C well as SMALL and LARGE.
C 2. Implement VECTOR control in place of
C ACALLS control.
C (Modules affected: PLM,PLMCOM,SOMEWHERE,
C CONTROL,OPERAND,SUMMARY,UNIQUE,PROCS,
C BASICS,REGS,MODULES,EXPRS,INIT,EMIT,UNITS.)
C
C VERSION 5.1 AFH 08SEP81 1. Compute reference counts (resolves
C semantic ambiguity of multiple assign-
C ment statements in favor of PL/M-86
C interpretation.
C (Modules affected: PLM,SOMEWHERE,BASICS,
C MASSAGE,COUNTS.)
C
C VERSION 5.2 AFH 13SEP81 1. Implement the ALIGN control.
C (Modules affected: PLM,MODULES,DECLS.)
C
C VERSION 5.3 AFH 29SEP81 1. Fix CRC-0 bug on reference to STACK$PTR.
C 2. Correct choice of SP for STACK$PTR.
C 3. Increase symbol table to 2000 entries.
C 4. Allow DATA attribute with EXTERNAL.
C 5. Allow dimensions >64K.
C 6. Allow structure member arrays to have
C explicit lower bounds.
C 7. Implement the builtin function FIRST.
C 8. Support the AT(@external.member)
C construct.
C 9. Increase max string size to 290 chars
C (for larger LITERALLY's).
C (Modules changed: PLMCOM,PLM,COUNTS,
C BUILTINS,SYMTAB,DATA,DECLS,EMIT,REPLICA,
C INIT,GETLEX. All modules were recompiled
C because of changes to PLMCOM.)
C
C VERSION 5.4 AFH 15OCT81 1. Experimental version to try out
C reference count stuff.
C (Modules changed: PLM,COUNTS,SOMEWHERE,
C REGS.)
C
C VERSION 5.5 AFH 21OCT81 1. Add basic block analysis.
C 2. Implement %_signed and %_unsigned
C builtins.
C
C VERSION 5.6 AFH 23OCT81 1. More peephole optimizations.
C 2. Add OP_BB operator.
C 3. No reference counts for OP_LOC
C and OP_ASSN.
C
C VERSION 5.7 AFH 28OCT81 1. Add definitions for SELECTOR, DWORD,
C SHORT, and BOOLEAN data types.
C 2. Allow keywords to be re-declared.
C
C VERSION 5.8 AFH 06NOV81 1. Add ASSUME control.
C
C VERSION 5.9 AFH 09NOV81 1. Implement CSE,CTE,BBA,MCO assumptions.
C
C VERSION 6.0 AFH 10NOV81 1. Add EFFECTS module.
C 2. Add DBG assumption.
C 3. Fix DRC bug in SCOPES.
C 4. Implement EEQ,BRO,SWB assumptions.
C
C VERSION 6.1 AFH 12NOV81 1. Restore argument pointer display in
C transfer vector prologue.
C 2. Change psect names, and add the
C symbol_psect field to the symbol
C table.
C 3. Make ATOM_DISP be I*4. (All modules
C must be recompiled.)
C 4. Implement LAST(MEMORY), etc.
C 5. Allow structure arrays to be implicitly
C dimensioned.
C 6. Implement AT(arg) and AT(dynamic).
C
C VERSION 6.2 AFH 14NOV81 1. Change addressing modes to reflect
C new psect usage.
C
C VERSION 6.3 AFH 21NOV81 1. Temporarily change LOW back to an
C external to correct a bug with
C extract_displacement.
C
C VERSION 6.4 AFH 10JAN82 1. Change DOUBLE keyword to DOUBLE$-
C PRECISION to avoid conflict with
C the DOUBLE builtin.
C 2. Set VMS delimiter set in CONTROL.
C
C VERSION 6.5 AFH 14JAN82 1. Change ASSUME_S32 to ASSUME_S64.
C 2. Ignore $-signs in switch names.
C 3. Make <keyword>: and GOTO <keyword>
C work correctly.
C
C VERSION 6.6 AFH 03FEB82 1. Fix bug for immediate operands
C under LARGE model (OPERAND).
C 2. Change name of GET_CNTRL_FLD.
C
C VERSION 6.7 AFH 08FEB82 1. Merge ARG opnodes.
C 2. Change opcode column in emitted code
C to allow longer emitted code lines.
C
C***********************************************************************
PROGRAM PLM
INCLUDE 'PLMCOM.FOR/NOLIST'
CHARACTER*45 FILE1_CHARS,FILE2_CHARS,FILE3_CHARS
VERSION=6.7
IN=8
OUT=4
LST=6
IXI=3
FIFO_DEPTH=0
LIST_LINE_NO=0
LIST_STNO=1
LIST_BLOCK_LEVEL=0
LINE_OF_PAGE=1
PAGE_NO=0
LINES_READ=0
ERRORS=0
WARNINGS=0
PREVIOUS_STNO=0
EXTERNAL_SERIAL_DELTA=0
BASED_SERIAL_DELTA=0
SUBSCRIPTED_SERIAL_DELTA=0
OVERLAID_SERIAL_DELTA=0
PATH=.FALSE.
BASIC_BLOCK=NULL
CALL BREAK
C------- SET DEFAULT VALUES OF PRIMARY CONTROLS.
LARGE=.FALSE.
PAGELENGTH=LIB$LP_LINES()-5
PAGEWIDTH=120
OPTIMIZE=1
MODEL=1
PRINT_FLAG=.TRUE.
XREF_FLAG=.FALSE.
IXREF_FLAG=.FALSE.
SYMBOLS_FLAG=.FALSE.
PAGING_FLAG=.TRUE.
INTVECTOR_FLAG=.TRUE.
OBJECT_FLAG=.TRUE.
OPRINT_FLAG=.FALSE.
DEBUG_FLAG=.FALSE.
TYPE_FLAG=.TRUE.
ROM_FLAG=.FALSE.
TITLE_STRING(0)=0
TABS=8
WARN_FLAG=.TRUE.
PLM80_FLAG=.FALSE.
GLOBALS_FLAG=.FALSE.
PUBLICS_FLAG=.FALSE.
OVERLAY_FLAG=.FALSE.
ROOT_FLAG=.FALSE.
ALIGN_FLAG=.FALSE.
FREQ_FLAG=.FALSE.
VECTOR_FLAG=.FALSE.
CALL DATE(DATE_STRING(1))
DATE_STRING(10)=' '
CALL TIME(DATE_STRING(11))
DATE_STRING(0)=18
C------- SET DEFAULT VALUES OF GENERAL CONTROLS.
LEFTMARGIN=1
RIGHTMARGIN=200
LIST_FLAG=.TRUE.
NON_CONTROL_LINE_READ=.FALSE.
SKIP_STATE=0 ! READING INVOCATION LINE.
CODE_FLAG=.FALSE.
EJECT_FLAG=.TRUE.
OVERFLOW_FLAG=.FALSE.
COND_FLAG=.TRUE.
SUBTITLE_STRING(0)=0
C-------- SET DEFAULT VALUES OF ASSUMPTION FLAGS.
ASSUME_SCE=.TRUE.
ASSUME_CSE=.TRUE.
ASSUME_EEQ=.TRUE.
ASSUME_PSE=.TRUE.
ASSUME_BRO=.TRUE.
ASSUME_BBA=.TRUE.
ASSUME_CTE=.TRUE.
ASSUME_MCO=.TRUE.
ASSUME_CFA=.TRUE.
ASSUME_SWB=.TRUE.
ASSUME_OSR=.TRUE.
ASSUME_SVE=.TRUE.
ASSUME_S64=.TRUE.
ASSUME_C7F=.TRUE.
ASSUME_DBG=.FALSE.
C-------- PERFORM A COMPILATION.
CALL INVOCATION_LINE
SKIP_STATE=4 ! READING AT LEVEL 0.
CALL GETC
CALL GETLEX
CALL GETTOK
CALL COMPILATION
C-------- CHAIN TO MACRO IF OBJECT WANTED.
IF (OBJECT_FLAG) THEN
IF (OPRINT_FLAG) THEN
CALL LIB$DO_COMMAND(
# 'MAC/OBJ=' //
# FILE1_CHARS(:MAKE_CHARS(FILE1_CHARS,OBJECT_FILE_STRING))
# // '/LIS=' //
# FILE2_CHARS(:MAKE_CHARS(FILE2_CHARS,OPRINT_FILE_STRING))
# // ' ' //
# FILE3_CHARS(:MAKE_CHARS(FILE3_CHARS,WORK_FILE_STRING)))
ELSE
CALL LIB$DO_COMMAND(
# 'MAC/OBJ=' //
# FILE1_CHARS(:MAKE_CHARS(FILE1_CHARS,OBJECT_FILE_STRING))
# // '/NOLIS ' //
# FILE3_CHARS(:MAKE_CHARS(FILE3_CHARS,WORK_FILE_STRING)))
ENDIF
ENDIF
END

13
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/plm.lnk Normal file
View File

@@ -0,0 +1,13 @@
$SET VERIFY
$!
$! PLM.LNK
$!
$! Command file to link the PL/M-VAX compiler.
$!
$! 02FEB82 Alex Hunter 1. Original version.
$! 04FEB82 Alex Hunter 1. Use LOGNAMES.COM to set logical names.
$!
$@LOGNAMES
$LINK/NODEB/EXE=PLM/NOMAP -
PLMCOM/INCLUDE=PLM/LIB,-
PLM$UDI:PLMRUN/LIB

539
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/plmcom.for Normal file
View File

@@ -0,0 +1,539 @@
C***********************************************************************
C
C PLMCOM.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 include-file supplies all global definitions for the
C PL/M-VAX compiler.
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. Increase SYMBOL_MAX. (V5.3)
C 2. Increase max string size to 290.
C 3. Change relevant SYMBOL and MEMBER arrays
C to INTEGER*4.
C 4. Add MEMBER_LOWER_BOUND array to support
C lower bounds for structure member arrays.
C 5. Add MEMBER_OFFSET array to support the
C AT(@external.member) construct.
C 21OCT81 Alex Hunter 1. Add stuff for basic block analysis. (V5.5)
C 2. Add OP_SIGNED and OP_UNSIGNED operators.
C 28OCT81 Alex Hunter 1. Add new keywords (SELECTOR-REGISTER). (V5.7)
C 2. Add new symbol type attributes.
C 09NOV81 Alex Hunter 1. Add assumption flags. (V5.8)
C 10NOV81 Alex Hunter 1. Add S_NO_SIDE_EFFECTS, ASSUME_DBG, and
C serial no. deltas. (V6.0)
C 12NOV81 Alex Hunter 1. Add S_REGISTER,S_SPECIAL,SYMBOL_PSECT,
C SYM_MLAST, et al. (V6.1)
C 2. Change ATOM_DISP to I*4.
C 3. Delete predefined atoms.
C 4. Add new PSECTS and change names.
C 14JAN82 Alex Hunter 1. Change ASSUME_S32 to ASSUME_S64. (V6.5)
C
C-----------------------------------------------------------------------
C
IMPLICIT INTEGER*2 (A-Z)
C-----------------------------------------------------------------------
C
C Reserved word token values.
C
C-----------------------------------------------------------------------
PARAMETER K_ADDRESS=101, K_AND=102, K_AT=103, K_BASED=104,
# K_BY=105, K_BYTE=106, K_CALL=107, K_CASE=108,
# K_DATA=109, K_DECLARE=110, K_DISABLE=111, K_DO=112,
# K_ELSE=113, K_ENABLE=114, K_END=115, K_EOF=116,
# K_EXTERNAL=117, K_GO=118, K_GOTO=119, K_HALT=120,
# K_IF=121, K_INITIAL=122, K_INTEGER=123,
# K_INTERRUPT=124, K_LABEL=125, K_LITERALLY=126,
# K_MINUS=127, K_MOD=128, K_NOT=129, K_OR=130,
# K_PLUS=131, K_POINTER=132, K_PROCEDURE=133,
# K_PUBLIC=134, K_REAL=135, K_REENTRANT=136,
# K_RETURN=137, K_STRUCTURE=138, K_THEN=139, K_TO=140,
# K_WHILE=141, K_WORD=142, K_XOR=143,
# K_COMMON=144, K_LONG=145, K_DOUBLE=146, K_OTHERWISE=147,
# K_QUAD=148,K_FORWARD=149,K_SELECTOR=150,K_DWORD=151,
# K_SHORT=152,K_BOOLEAN=153,K_REGISTER=154
C-----------------------------------------------------------------------
C
C Delimiter token values.
C
C-----------------------------------------------------------------------
PARAMETER D_PLUS=201, D_MINUS=202, D_STAR=203, D_SLASH=204,
# D_LT=205, D_GT=206, D_EQ=207, D_NE=208, D_LE=209,
# D_GE=210, D_ASSN=211, D_COLON=212, D_SEMI=213,
# D_DOT=214, D_COMMA=215, D_LP=216, D_RP=217, D_AT=218
C-----------------------------------------------------------------------
C
C Non-terminal token values.
C
C-----------------------------------------------------------------------
PARAMETER NT_STATEMENT=301,NT_EXPRESSION=302,NT_TYPE=303
C-----------------------------------------------------------------------
C
C Controls.
C
C-----------------------------------------------------------------------
INTEGER*2 LEFTMARGIN,RIGHTMARGIN,SKIP_STATE,PAGELENGTH,
# PAGEWIDTH,OPTIMIZE,MODEL,TABS
LOGICAL*1 LIST_FLAG,LARGE,NON_CONTROL_LINE_READ
LOGICAL*1 PRINT_FLAG,CODE_FLAG,XREF_FLAG,IXREF_FLAG,SYMBOLS_FLAG,
# PAGING_FLAG,EJECT_FLAG,INTVECTOR_FLAG,OBJECT_FLAG,
# OVERFLOW_FLAG,DEBUG_FLAG,TYPE_FLAG,ROM_FLAG,COND_FLAG,
# OPRINT_FLAG,WARN_FLAG,PLM80_FLAG,GLOBALS_FLAG,
# PUBLICS_FLAG,OVERLAY_FLAG,ROOT_FLAG,ALIGN_FLAG,
# FREQ_FLAG,VECTOR_FLAG
PARAMETER MAX_IN=20
BYTE PRINT_FILE_STRING(0:45),IXREF_FILE_STRING(0:45),
# WORK_FILE_STRING(0:45),OBJECT_FILE_STRING(0:45),
# DATE_STRING(0:80),TITLE_STRING(0:80),SUBTITLE_STRING(0:80),
# IN_FILE_STRING(0:45,8:MAX_IN+1),OPRINT_FILE_STRING(0:45),
# GLOBALS_FILE_STRING(0:45),PUBLICS_FILE_STRING(0:45),
# OVERLAY_PREFIX(0:80)
COMMON/CONTROLS/ LEFTMARGIN,RIGHTMARGIN,LIST_FLAG,LARGE,
# NON_CONTROL_LINE_READ,SKIP_STATE,PAGELENGTH,PAGEWIDTH,
# OPTIMIZE,MODEL,PRINT_FLAG,CODE_FLAG,XREF_FLAG,IXREF_FLAG,
# SYMBOLS_FLAG,PAGING_FLAG,EJECT_FLAG,INTVECTOR_FLAG,
# OBJECT_FLAG,OVERFLOW_FLAG,DEBUG_FLAG,TYPE_FLAG,ROM_FLAG,
# COND_FLAG,
# PRINT_FILE_STRING,IXREF_FILE_STRING,WORK_FILE_STRING,
# OBJECT_FILE_STRING,DATE_STRING,TITLE_STRING,
# SUBTITLE_STRING,IN_FILE_STRING,OPRINT_FILE_STRING,
# OPRINT_FLAG,TABS,WARN_FLAG,PLM80_FLAG,GLOBALS_FLAG,
# PUBLICS_FLAG,OVERLAY_FLAG,ROOT_FLAG,GLOBALS_FILE_STRING,
# PUBLICS_FILE_STRING,OVERLAY_PREFIX,ALIGN_FLAG,FREQ_FLAG,
# VECTOR_FLAG
C-----------------------------------------------------------------------
C
C Character stream input and macro expansion stuff.
C
C-----------------------------------------------------------------------
PARAMETER LITMAX=16
PARAMETER EOLCHAR='01'X, EOFCHAR='02'X
INTEGER*2 COL, LITLEV, LITCOL(LITMAX)
CHARACTER*1 CHAR, EOL, EOF, TAB
CHARACTER*300 LITVAL(LITMAX), CARD
EQUIVALENCE (CARD,LITVAL(1))
COMMON /LEXICAL/ COL,LITLEV,LITCOL
COMMON /LEXCHAR/ LITVAL,CHAR,EOL,EOF,TAB
DATA COL/72/, CARD(73:73)/EOLCHAR/, LITLEV/1/
DATA EOL/EOLCHAR/, EOF/EOFCHAR/, TAB/'09'X/
C-----------------------------------------------------------------------
C
C Lexical token analysis stuff.
C
C-----------------------------------------------------------------------
PARAMETER STRING_SIZE_MAX=290 ! (V5.3)
CHARACTER DELIMITER*2, IDENTIFIER*32, STRING*(STRING_SIZE_MAX)
CHARACTER NEXT_DELIMITER*2, NEXT_IDENTIFIER*32,
# NEXT_STRING*(STRING_SIZE_MAX)
REAL*8 FLOATVAL, NEXT_FLOATVAL
INTEGER*4 FIXVAL, NEXT_FIXVAL
INTEGER*2 TOKENTYPE, TT, STRLEN
INTEGER*2 NEXT_TOKENTYPE, NEXT_STRLEN
PARAMETER INVALID=0, DELIM=1, ID=2, FIXCON=3, FLOATCON=4,
# STRCON=5, EOFTOK=6
COMMON /TOKEN/ TOKENTYPE,FIXVAL,FLOATVAL,STRLEN,
# NEXT_TOKENTYPE,NEXT_FIXVAL,NEXT_FLOATVAL,
# NEXT_STRLEN
COMMON /TOKENCHAR/ DELIMITER,IDENTIFIER,STRING,
# NEXT_DELIMITER,NEXT_IDENTIFIER,NEXT_STRING
EQUIVALENCE (TT,TOKENTYPE)
C-----------------------------------------------------------------------
C
C I/O unit definitions.
C
C-----------------------------------------------------------------------
COMMON /IO/ IN,OUT,LST,IXI,GBL,PUB
DATA IN/8/, OUT/4/, LST/6/, IXI/3/, GBL/1/, PUB/2/
C-----------------------------------------------------------------------
C
C Label structures.
C
C-----------------------------------------------------------------------
PARAMETER MAX_LABELS=10
CHARACTER*32 LABELS(MAX_LABELS), LAST_LABEL
INTEGER*2 NLABELS
COMMON /LABEL/ NLABELS
COMMON /LABELC/ LABELS, LAST_LABEL
DATA NLABELS /0/
C-----------------------------------------------------------------------
C
C Symbol attribute values.
C
C-----------------------------------------------------------------------
PARAMETER S_MACRO=1,S_SCALAR=2,S_ARRAY=3,S_PROC=4,S_LABEL=5,
# S_KEYWORD=6
PARAMETER S_BYTE=1,S_WORD=2,S_INTEGER=3,S_PTR=4,S_REAL=5,
# S_LONG=6,S_DOUBLE=7,S_QUAD=8,S_SHORT=9,S_DWORD=10,
# S_SELECTOR=11,S_BOOLEAN=12,
# S_STRUC=100
PARAMETER S_EXT=1,S_STATIC=2,S_BASED=3,S_ARG=4,S_FORWARD=5,
# S_DYNAMIC=6, S_VALUE=8,S_UNRESOLVED=9,
# S_BUILTIN=10,S_LOCAL=11,S_REGISTER=12
PARAMETER S_PUBLIC=1,S_UNDEF=2,S_INTERRUPT=4,S_REENT=8,
# S_FORCE_STATIC=16,S_DATA=32,S_OVERLAID=64,
# S_SAME_OVERLAY=128,S_NOTPUBLIC=256,
# S_NO_SIDE_EFFECTS=512,S_SPECIAL=1024
C-----------------------------------------------------------------------
C
C Symbol table structures.
C
C-----------------------------------------------------------------------
PARAMETER SYMBOL_MAX=2000, MEMBER_MAX=500, PARAM_MAX=100
PARAMETER SYM_MLAST=1,SYM_MLEN=2,SYM_MSIZ=3,
# SYM_SLAST=4,SYM_SLEN=5,SYM_SSIZ=6,
# FIRST_AVAILABLE_SYMBOL_INDEX=7
CHARACTER*32 SYMBOL_PLM_ID(SYMBOL_MAX), SYMBOL_VAX_ID(SYMBOL_MAX)
INTEGER*2 SYMBOL_KIND(SYMBOL_MAX), SYMBOL_TYPE(SYMBOL_MAX),
# SYMBOL_LINK(SYMBOL_MAX), SYMBOL_LIST_SIZE(SYMBOL_MAX),
# SYMBOL_REF(SYMBOL_MAX), SYMBOL_BASE(SYMBOL_MAX),
# SYMBOL_BASE_MEMBER(SYMBOL_MAX),
# SYMBOL_FLAGS(SYMBOL_MAX), SYMBOL_INDEX,
# SYMBOL_CHAIN(SYMBOL_MAX),
# SYMBOL_SERIAL_NO(SYMBOL_MAX),
# SYMBOL_PSECT(SYMBOL_MAX)
INTEGER*4 SYMBOL_DISP(SYMBOL_MAX),SYMBOL_NBR_ELEMENTS(SYMBOL_MAX),
# SYMBOL_LOWER_BOUND(SYMBOL_MAX),
# SYMBOL_ELEMENT_SIZE(SYMBOL_MAX)
LOGICAL*4 SAME_OVERLAY
COMMON/SYMBOLC/SYMBOL_PLM_ID,SYMBOL_VAX_ID
COMMON/SYMBOL/SYMBOL_KIND,SYMBOL_TYPE,
# SYMBOL_LINK,SYMBOL_LIST_SIZE,
# SYMBOL_REF,SYMBOL_BASE,SYMBOL_BASE_MEMBER,
# SYMBOL_FLAGS,SYMBOL_INDEX,SYMBOL_CHAIN,SAME_OVERLAY,
# SYMBOL_SERIAL_NO,SYMBOL_PSECT
COMMON/SYMBOL4/SYMBOL_DISP,SYMBOL_NBR_ELEMENTS,
# SYMBOL_LOWER_BOUND,SYMBOL_ELEMENT_SIZE
C-----------------------------------------------------------------------
C
C Member-symbol table structures.
C
C-----------------------------------------------------------------------
CHARACTER*32 MEMBER_PLM_ID(MEMBER_MAX), MEMBER_VAX_ID(MEMBER_MAX)
INTEGER*2 MEMBER_KIND(MEMBER_MAX), MEMBER_TYPE(MEMBER_MAX),
# MEMBER_INDEX,MEMBER_SERIAL_NO(MEMBER_MAX)
INTEGER*4 MEMBER_NBR_ELEMENTS(MEMBER_MAX),
# MEMBER_LOWER_BOUND(MEMBER_MAX),
# MEMBER_ELEMENT_SIZE(MEMBER_MAX),
# MEMBER_OFFSET(MEMBER_MAX)
COMMON/MEMBERC/MEMBER_PLM_ID,MEMBER_VAX_ID
COMMON/MEMBER/MEMBER_KIND,MEMBER_TYPE,MEMBER_INDEX,
# MEMBER_SERIAL_NO
COMMON/MEMBER4/MEMBER_NBR_ELEMENTS,MEMBER_LOWER_BOUND,
# MEMBER_ELEMENT_SIZE,MEMBER_OFFSET
C-----------------------------------------------------------------------
C
C Parameter list structures.
C
C-----------------------------------------------------------------------
INTEGER*2 PARAM_TYPE(PARAM_MAX)
COMMON/PARAM/PARAM_TYPE
C-----------------------------------------------------------------------
C
C Block scope structures.
C
C-----------------------------------------------------------------------
PARAMETER BLOCK_MAX=20
INTEGER*2 BLOCK_LEVEL,SYMBOL_TOP(0:BLOCK_MAX),
# MEMBER_TOP(0:BLOCK_MAX),PARAM_TOP(0:BLOCK_MAX),
# STRINGS_TOP(0:BLOCK_MAX)
COMMON/BLOCK/BLOCK_LEVEL,SYMBOL_TOP,MEMBER_TOP,PARAM_TOP,
# STRINGS_TOP
DATA BLOCK_LEVEL/0/
DATA MEMBER_TOP(0)/0/,PARAM_TOP(0)/0/,
# STRINGS_TOP(0)/0/
C-----------------------------------------------------------------------
C
C String space structures.
C
C-----------------------------------------------------------------------
PARAMETER STRINGS_MAX=32000
CHARACTER*(STRINGS_MAX) STRINGS
COMMON/STRINGS/STRINGS
C-----------------------------------------------------------------------
C
C Miscellaneous stuff.
C
C-----------------------------------------------------------------------
INTEGER*2 BYTE_SIZE(S_BYTE:S_QUAD)
COMMON/TABLES/BYTE_SIZE
DATA BYTE_SIZE/1,2,2,4,4,4,8,8/
PARAMETER NULL=0, DUMMY=0
PARAMETER R0=16
C-----------------------------------------------------------------------
C
C Node space definitions.
C
C-----------------------------------------------------------------------
PARAMETER NODE_MIN=20,NODE_MAX=200,
# REG_MIN=1,REG_MAX=16,
# ANY_WHERE=-3,ANY_REG=-1,ON_STACK=-2,
# CON_MIN=-9,CON_MAX=-4,
# ATOM_MIN=-200,ATOM_MAX=-10,
# FIRST_FREE_ATOM=ATOM_MIN,
# FIX_MIN=-300,FIX_MAX=-201,
# FLT_MIN=-400,FLT_MAX=-301
C-----------------------------------------------------------------------
C
C Operator node structures.
C
C-----------------------------------------------------------------------
INTEGER*2 OPNODE_OP(NODE_MIN:NODE_MAX),
# OPNODE_OPND1(NODE_MIN:NODE_MAX),
# OPNODE_OPND2(NODE_MIN:NODE_MAX),
# NEXT_NODE
C-----------------------------------------------------------------------
C
C Atom node structures.
C
C-----------------------------------------------------------------------
INTEGER*2 ATOM_SYM(ATOM_MIN:ATOM_MAX),
# ATOM_MEM(ATOM_MIN:ATOM_MAX),
# ATOM_BASE(ATOM_MIN:ATOM_MAX),
# ATOM_SUB(ATOM_MIN:ATOM_MAX),
# ATOM_FLAGS(ATOM_MIN:ATOM_MAX),
# ATOM_SERIAL_NO(ATOM_MIN:ATOM_MAX),
# NEXT_ATOM
INTEGER*4 ATOM_DISP(ATOM_MIN:ATOM_MAX)
PARAMETER A_L2P=1,A_P2L=2,A_IMMEDIATE=4,A_CTIM=8,A_VECTOR=16
C-----------------------------------------------------------------------
C
C Literal and constant node structures.
C
C-----------------------------------------------------------------------
INTEGER*4 FIXED_VAL(FIX_MIN:FIX_MAX),
# NEXT_FIXED
REAL*8 FLOAT_VAL(FLT_MIN:FLT_MAX)
INTEGER*2 NEXT_FLOAT
INTEGER*2 CONSTANT_LABEL(CON_MIN:CON_MAX),
# NEXT_CONSTANT
C-----------------------------------------------------------------------
C
C Structures common to all nodes.
C
C-----------------------------------------------------------------------
INTEGER*2 NODE_REG(FLT_MIN:NODE_MAX),
# NODE_REFCT(FLT_MIN:NODE_MAX),
# NODE_TYPE(FLT_MIN:NODE_MAX),
# NODE_CONTEXT(FLT_MIN:NODE_MAX)
C-----------------------------------------------------------------------
C
C Code tree common block.
C
C-----------------------------------------------------------------------
COMMON/TREE/OPNODE_OP,OPNODE_OPND1,OPNODE_OPND2,
# ATOM_SYM,ATOM_MEM,ATOM_BASE,
# ATOM_SUB,ATOM_DISP,
# FIXED_VAL,FLOAT_VAL,
# NODE_REG,NODE_REFCT,NODE_CONTEXT,NODE_TYPE,
# NEXT_NODE,NEXT_ATOM,NEXT_FIXED,NEXT_FLOAT,
# CONSTANT_LABEL,NEXT_CONSTANT,ATOM_FLAGS,
# ATOM_SERIAL_NO
C-----------------------------------------------------------------------
C
C Context resolution stuff.
C
C-----------------------------------------------------------------------
PARAMETER CX_UNSIGNED=1, CX_SIGNED=2
INTEGER*2 CONTEXT(S_BYTE:S_QUAD)
COMMON /CX/ CONTEXT
DATA CONTEXT
# /CX_UNSIGNED,CX_UNSIGNED,CX_SIGNED,CX_UNSIGNED,CX_SIGNED,
# CX_SIGNED,CX_SIGNED,CX_SIGNED/
C-----------------------------------------------------------------------
C
C Miscellaneous declarations.
C
C-----------------------------------------------------------------------
LOGICAL*4 ATOM,NODE,LITERAL,FIXLIT,FLOATLIT,CONSTANT,REGISTER
CHARACTER*32 LOCAL_LABEL
C-----------------------------------------------------------------------
C
C Operator value definitions.
C
C-----------------------------------------------------------------------
PARAMETER OP_NOP=0,
# OP_ADD=1,OP_SUB=2,OP_MUL=3,OP_DIV=4,OP_ADWC=5,OP_SBWC=6,
# OP_NEG=7,OP_NOT=8,OP_EXT=9,OP_OR=10,OP_XOR=11,OP_LT=12,
# OP_GT=13,OP_EQ=14,OP_NE=15,OP_LE=16,OP_GE=17,OP_LOC=18,
# OP_ASSN=19,OP_MOD=20,OP_THEN=21,OP_BIT=22,OP_ALSO=23,
# OP_CALL=24,OP_ARG=25,OP_AND=26,OP_MOV=27,
# OP_SIGNED=71,OP_UNSIGNED=72,
# OP_BYTE=81,OP_WORD=82,OP_INTEGER=83,OP_PTR=84,
# OP_REAL=85,OP_LONG=86,OP_DOUBLE=87,OP_QUAD=88,
# OP_B2W=101,OP_B2I=102,OP_B2L=103,OP_B2R=104,OP_W2B=105,
# OP_W2L=106,OP_I2B=107,OP_I2R=108,OP_I2L=109,OP_R2L=110,
# OP_R2I=111,OP_L2W=112,OP_L2R=113,OP_L2B=114,OP_R2B=115,
# OP_R2W=116,OP_L2D=117,OP_L2Q=118,OP_R2D=119,OP_D2B=120,
# OP_D2I=121,OP_D2R=122,OP_D2L=123,OP_Q2L=124,OP_I2D=125,
# OP_L2P=126,OP_P2L=127,
# OP_BNE=201,OP_BLB=202,OP_BB=203
C-----------------------------------------------------------------------
C
C Program section definitions.
C
C-----------------------------------------------------------------------
PARAMETER P_MAX=100
PARAMETER P_CONSTANTS=1,P_STACK=2,P_DATA=3,P_CODE=4,P_FREQ=5,
# P_VECTOR=6,P_APD=7,P_MEMORY=8
CHARACTER*32 PSECT_NAME(P_CONSTANTS:P_MAX),BASEC
CHARACTER*3 BASEV
COMMON /PSECTC/ BASEC,BASEV,PSECT_NAME
DATA PSECT_NAME
// '$PLM_ROM','$DGROUP_STACK','$DGROUP_DATA'
,, '$PLM_CODE','$PLM_FREQ','$CGROUP_VECTOR'
,, '$PLM_APD','MEMORY'
,, 92*' '
//
INTEGER*2 NC
COMMON /PSECTS/ NC
C-----------------------------------------------------------------------
C
C Compiler listing stuff.
C
C-----------------------------------------------------------------------
REAL*4 VERSION
LOGICAL*1 LISTING_TO_TERMINAL,LAST_LINE_EXISTS
COMMON /LIST/ LIST_LINE_NO,LIST_STNO,LIST_BLOCK_LEVEL,
# PREVIOUS_STNO,LINE_OF_PAGE,PAGE_NO,VERSION,
# LINES_READ,ERRORS,WARNINGS,LISTING_TO_TERMINAL,
# FIFO_DEPTH,LAST_LINE_EXISTS
C-----------------------------------------------------------------------
C
C Symbol table hash buckets.
C
C-----------------------------------------------------------------------
INTEGER*2 HASH_BUCKET(0:210)
COMMON /HASH/ HASH_BUCKET,FIRST_KEYWORD
C-----------------------------------------------------------------------
C
C Procedure scope structures.
C
C-----------------------------------------------------------------------
PARAMETER PROC_MAX=16 ! MAX STATIC NESTING DEPTH OF PROCS.
PARAMETER PROC_MAIN=1,PROC_EXT=2,PROC_FORWARD=4,PROC_REENT=8
INTEGER*2 PROC_FLAGS(PROC_MAX),PROC_DYN_OFF(PROC_MAX),
# PROC_INDEX(PROC_MAX),PROC_DYN_INDEX(PROC_MAX),
# PROC_ENTRY_MASK(PROC_MAX),PROC_ENTRY_INDEX(PROC_MAX),
# PROC_AP(0:PROC_MAX)
COMMON /PROCS/ PROC_LEVEL,PROC_FLAGS,PROC_DYN_OFF,PROC_INDEX,
# PROC_DYN_INDEX,PROC_ENTRY_MASK,PROC_ENTRY_INDEX,
# PROC_AP
DATA PROC_LEVEL/1/, PROC_FLAGS(1)/PROC_MAIN/,
# PROC_AP(0)/1/, PROC_AP(1)/1/
C-----------------------------------------------------------------------
C
C Path analysis stuff.
C
C-----------------------------------------------------------------------
LOGICAL*4 PATH
COMMON /PATH_ANALYSIS/ PATH
C-----------------------------------------------------------------------
C
C GLOBALS symbol table stuff.
C
C-----------------------------------------------------------------------
PARAMETER GBL_MAX=800 ! MAX # OF GLOBALLY INPUT SYMBOLS.
CHARACTER*32 GLOBAL_SYMBOL(GBL_MAX)
INTEGER*2 LAST_GLOBAL
COMMON /GLOBALS/ LAST_GLOBAL
COMMON /GLOBALC/ GLOBAL_SYMBOL
C-----------------------------------------------------------------------
C
C Basic block analysis stuff.
C
C-----------------------------------------------------------------------
LOGICAL*4 END_OF_BASIC_BLOCK
INTEGER*2 BASIC_BLOCK
INTEGER*2 EXTERNAL_SERIAL_DELTA,BASED_SERIAL_DELTA,
# SUBSCRIPTED_SERIAL_DELTA,OVERLAID_SERIAL_DELTA
COMMON /BASIC_BLOCKS/ END_OF_BASIC_BLOCK,BASIC_BLOCK,
# EXTERNAL_SERIAL_DELTA,BASED_SERIAL_DELTA,
# SUBSCRIPTED_SERIAL_DELTA,OVERLAID_SERIAL_DELTA
C-----------------------------------------------------------------------
C
C Assumption flags.
C
C-----------------------------------------------------------------------
LOGICAL*1 ASSUME_SCE,ASSUME_CSE,ASSUME_EEQ,ASSUME_PSE,
# ASSUME_BRO,ASSUME_BBA,ASSUME_CTE,ASSUME_MCO,
# ASSUME_CFA,ASSUME_SWB,ASSUME_OSR,ASSUME_SVE,
# ASSUME_S64,ASSUME_C7F,ASSUME_DBG
COMMON /ASSUMPTIONS/
# ASSUME_SCE,ASSUME_CSE,ASSUME_EEQ,ASSUME_PSE,
# ASSUME_BRO,ASSUME_BBA,ASSUME_CTE,ASSUME_MCO,
# ASSUME_CFA,ASSUME_SWB,ASSUME_OSR,ASSUME_SVE,
# ASSUME_S64,ASSUME_C7F,ASSUME_DBG

378
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/procs.for Normal file
View File

@@ -0,0 +1,378 @@
C***********************************************************************
C
C PROCS.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 procedure
C declarations.
C
C-----------------------------------------------------------------------
C R E V I S I O N H I S T O R Y
C
C 20OCT81 Alex Hunter 1. Added disclaimer notice. (V5.4)
C 21OCT81 Alex Hunter 1. Basic block analysis. (V5.5)
C 12NOV81 Alex Hunter 1. Save and restore argument pointer displays
C for indirect procedure calls. (V6.1)
C 14NOV81 Alex Hunter 1. Change addressing modes and psect usage.
C (V6.2)
C 2. Use full 31-character external names.
C 3. Increase max nesting of procs with args.
C 4. Allow keyword as formal parameter.
C 14JAN82 Alex Hunter 1. Fix minor bug from V6.2. (V6.5)
C
C-----------------------------------------------------------------------
SUBROUTINE PROCEDURE_DEFINITION
INCLUDE 'PLMCOM.FOR/NOLIST'
CHARACTER*32 PROC_NAME,FREQ_NAME,VECNIQUE,VEC_NAME,APD_NAME
CHARACTER*40 REGISTER_MASK
CHARACTER*41 APD_MASK
CHARACTER*80 OPERAND,OPERAND1
LOGICAL*4 PROC_IS_PUBLIC
PROC_LEVEL=PROC_LEVEL+1
IF (PROC_LEVEL.GT.PROC_MAX)
# CALL FATAL('PROCEDURES NESTED TOO DEEPLY')
CALL PROCEDURE_STATEMENT
PROC_ENTRY_MASK(PROC_LEVEL)=0
CALL PUSHC(IDENTIFIER)
IDENTIFIER='MSK.'//SYMBOL_PLM_ID(PROC_INDEX(PROC_LEVEL))
CALL ENTER_SYMBOL
PROC_ENTRY_INDEX(PROC_LEVEL)=SYMBOL_INDEX
SYMBOL_KIND(SYMBOL_INDEX)=S_SCALAR
SYMBOL_TYPE(SYMBOL_INDEX)=S_WORD
SYMBOL_NBR_ELEMENTS(SYMBOL_INDEX)=1
SYMBOL_ELEMENT_SIZE(SYMBOL_INDEX)=BYTE_SIZE(S_WORD)
SYMBOL_REF(SYMBOL_INDEX)=S_VALUE
CALL POPC(IDENTIFIER)
PROC_FLAGS(PROC_LEVEL)=0
IF (SYMBOL_REF(PROC_INDEX(PROC_LEVEL)).EQ.S_EXT)
# PROC_FLAGS(PROC_LEVEL)=PROC_EXT
IF (SYMBOL_REF(PROC_INDEX(PROC_LEVEL)).EQ.S_FORWARD)
# PROC_FLAGS(PROC_LEVEL)=PROC_FORWARD
IF ((SYMBOL_FLAGS(PROC_INDEX(PROC_LEVEL)).AND.S_REENT).NE.0)
# PROC_FLAGS(PROC_LEVEL)=PROC_FLAGS(PROC_LEVEL).OR.PROC_REENT
PROC_DYN_OFF(PROC_LEVEL)=0 ! INITIAL DYNAMIC_OFFSET.
CALL DECLARATIONS
DO 10 I=SYMBOL_TOP(BLOCK_LEVEL-1)+1,SYMBOL_TOP(BLOCK_LEVEL)
IF (SYMBOL_REF(I).EQ.S_ARG.AND.SYMBOL_FLAGS(I).EQ.S_UNDEF)
# THEN
CALL ERROR('NO DECLARATION FOR FORMAL PARAMETER '//
# SYMBOL_PLM_ID(I))
ENDIF
10 CONTINUE
IF (SYMBOL_REF(PROC_INDEX(PROC_LEVEL)).EQ.S_EXT.OR.
# SYMBOL_REF(PROC_INDEX(PROC_LEVEL)).EQ.S_FORWARD) GO TO 20
CALL PSECT(P_CODE)
CALL BREAK
IF (PATH) THEN
CALL GENERATE_LOCAL_LABEL(LL)
CALL EMIT('BRW '//LOCAL_LABEL(LL,N0))
ELSE
LL=0
ENDIF
PATH=.TRUE.
PROC_NAME=SYMBOL_VAX_ID(PROC_INDEX(PROC_LEVEL))
PROC_IS_PUBLIC = (SYMBOL_FLAGS(PROC_INDEX(PROC_LEVEL)).AND.
# S_PUBLIC).NE.0
IF (PROC_IS_PUBLIC) THEN
CALL EMIT1(PROC_NAME(:LNB(PROC_NAME))//'::')
ELSE
CALL EMIT1(PROC_NAME(:LNB(PROC_NAME))//':')
ENDIF
CALL EMIT('.WORD '//
# SYMBOL_VAX_ID(PROC_ENTRY_INDEX(PROC_LEVEL)))
IF (VECTOR_FLAG) THEN
CALL PSECT(P_VECTOR)
VEC_NAME=VECNIQUE(PROC_NAME)
IF (PROC_AP(PROC_LEVEL-1).LE.1) THEN
APD_MASK=' '
ELSE
MASK=0
DO I=2,PROC_LEVEL-1
MASK=MASK .OR. ISHFT(1,I)
ENDDO
APD_MASK='!'//REGISTER_MASK(MASK)
ENDIF
N1=LNB(SYMBOL_VAX_ID(PROC_ENTRY_INDEX(PROC_LEVEL)))
IF (PROC_IS_PUBLIC) THEN
CALL EMIT1(VEC_NAME(:LNB(VEC_NAME))//'::')
CALL EMIT('.WORD '//
# SYMBOL_VAX_ID(PROC_ENTRY_INDEX(PROC_LEVEL))(:N1)
# //APD_MASK)
ELSE
CALL EMIT1(VEC_NAME(:LNB(VEC_NAME))//':')
IF (MODEL.NE.4.OR.OVERLAY_FLAG) THEN
CALL EMIT('.WORD '//
# SYMBOL_VAX_ID(PROC_ENTRY_INDEX(PROC_LEVEL))(:N1)
# //APD_MASK)
ELSE
CALL EMIT('.WORD ^M<R11>!'//
# SYMBOL_VAX_ID(PROC_ENTRY_INDEX(PROC_LEVEL))(:N1)
# //APD_MASK)
CALL EMIT('MOVAB M.,R11')
ENDIF
ENDIF
DO I=2,PROC_LEVEL-1
IF (PROC_AP(I).NE.PROC_AP(I-1)) THEN
OPERAND1=OPERAND(PROC_AP(I),N1)
APD_NAME=SYMBOL_VAX_ID(PROC_ENTRY_INDEX(I))
APD_NAME(1:3)='APD'
CALL EMIT('MOVL '//APD_NAME(:LNB(APD_NAME))//','//
# OPERAND1(:N1))
ENDIF
ENDDO
CALL GENERATE_LOCAL_LABEL(LL1)
CALL EMIT('JMP '//LOCAL_LABEL(LL1,N0))
CALL PSECT(P_CODE)
CALL EMIT_LOCAL_LABEL(LL1)
ENDIF
IF (PROC_IS_PUBLIC.AND.MODEL.EQ.4.AND..NOT.OVERLAY_FLAG) THEN
CALL EMIT('MOVAB M.,R11')
CALL PRESERVE_REG(11)
ENDIF
IF (FREQ_FLAG) THEN
FREQ_NAME='FRQ.'//PROC_NAME
FREQ_NAME(32:)=' '
CALL EMIT('INCL '//FREQ_NAME)
CALL PSECT(P_FREQ)
CALL EMIT1(FREQ_NAME(:LNB(FREQ_NAME))//'::')
CALL EMIT('.LONG 0')
CALL PSECT(P_CODE)
ENDIF
IF (PROC_AP(PROC_LEVEL).NE.PROC_AP(PROC_LEVEL-1)) THEN
CALL PRESERVE_REG(PROC_AP(PROC_LEVEL))
OPERAND1=OPERAND(PROC_AP(PROC_LEVEL),N1)
CALL EMIT('MOVL AP,'//OPERAND1(:N1))
IF (VECTOR_FLAG) THEN
APD_NAME=SYMBOL_VAX_ID(PROC_ENTRY_INDEX(PROC_LEVEL))
APD_NAME(1:3)='APD'
CALL EMIT('MOVL AP,'//APD_NAME)
CALL PSECT(P_APD)
CALL EMIT1(APD_NAME(:LNB(APD_NAME))//':')
CALL EMIT('.LONG 0')
CALL PSECT(P_CODE)
ENDIF
ENDIF
IF ((PROC_FLAGS(PROC_LEVEL).AND.PROC_REENT).NE.0) THEN
CALL PUSHC(IDENTIFIER)
IDENTIFIER='DYN.'//SYMBOL_PLM_ID(PROC_INDEX(PROC_LEVEL))
CALL ENTER_SYMBOL
PROC_DYN_INDEX(PROC_LEVEL)=SYMBOL_INDEX
CALL POPC(IDENTIFIER)
SYMBOL_KIND(PROC_DYN_INDEX(PROC_LEVEL))=S_SCALAR
SYMBOL_TYPE(PROC_DYN_INDEX(PROC_LEVEL))=S_LONG
SYMBOL_NBR_ELEMENTS(PROC_DYN_INDEX(PROC_LEVEL))=1
SYMBOL_ELEMENT_SIZE(PROC_DYN_INDEX(PROC_LEVEL))=
# BYTE_SIZE(S_LONG)
SYMBOL_REF(PROC_DYN_INDEX(PROC_LEVEL))=S_VALUE
DYN_SIZE=MAKE_ATOM(PROC_DYN_INDEX(PROC_LEVEL),0,NULL,NULL,
# S_LONG,0,0)
SF=12
CCCC CALL PRESERVE_REG(SF) ! AP ALREADY PRESERVED BY CALL.
IF (MODEL.EQ.2 .OR. MODEL.EQ.4) THEN
SP=14
ELSE
SP=10
CALL PRESERVE_REG(SP)
ENDIF
CALL EMIT_CODE(OP_SUB,DYN_SIZE,NULL,SP)
NODE_TYPE(SP)=S_PTR
CALL EMIT_CODE(OP_ASSN,SP,NULL,SF)
ENDIF
CALL PUSH(LL,1)
CALL UNITS
CALL BREAK
CALL POP(LL,1)
IF (PATH) THEN
IF (SYMBOL_TYPE(PROC_INDEX(PROC_LEVEL)).NE.0) THEN
CALL WARN('RETURN MISSING AT END OF TYPED PROCEDURE')
CALL EMIT('CLRL R0')
ENDIF
CALL EMIT('RET')
ENDIF
PATH=.FALSE.
CALL EMIT_LOCAL_LABEL(LL)
CALL EMIT1(SYMBOL_VAX_ID(PROC_ENTRY_INDEX(PROC_LEVEL))
# (:LNB(SYMBOL_VAX_ID(PROC_ENTRY_INDEX(PROC_LEVEL))))
# //' = '//REGISTER_MASK(PROC_ENTRY_MASK(PROC_LEVEL)))
SYMBOL_FLAGS(PROC_ENTRY_INDEX(PROC_LEVEL))=0 ! RESET S_UNDEF.
IF ((PROC_FLAGS(PROC_LEVEL).AND.PROC_REENT).NE.0) THEN
CALL EMIT_ABSDEF(SYMBOL_VAX_ID(PROC_DYN_INDEX(PROC_LEVEL)),
# PROC_DYN_OFF(PROC_LEVEL))
SYMBOL_FLAGS(PROC_DYN_INDEX(PROC_LEVEL))=0
ENDIF
20 CALL BLOCK_END
PROC_LEVEL=PROC_LEVEL-1
CALL END_STATEMENT
RETURN
END
C-------------------------------------------------------
SUBROUTINE PROCEDURE_STATEMENT
INCLUDE 'PLMCOM.FOR/NOLIST'
CHARACTER*32 PROC_NAME,PUBLIQUE
IF (NLABELS.EQ.0) THEN
CALL ERROR('PROCEDURE NAME MISSING: XXX ASSUMED')
NLABELS=1
LABELS(NLABELS) = 'XXX'
ENDIF
DO 10 I=1,NLABELS-1
CALL ERROR('EXTRANEOUS LABEL IGNORED -- '//LABELS(I))
10 CONTINUE
PROC_NAME=LABELS(NLABELS)
CALL PUSHC(PROC_NAME) ! TO MATCH LABEL ON END.
NLABELS=0
CALL MUSTBE(K_PROCEDURE)
IDENTIFIER=PROC_NAME
CALL ENTER_SYMBOL
PROC_INDEX(PROC_LEVEL)=SYMBOL_INDEX
PROC_IX=SYMBOL_INDEX
CALL GETTOK
CALL BLOCK_BEGIN
IF (TT.EQ.D_LP) THEN
CALL FORMAL_PARAMETER_LIST(NARGS)
ELSE
NARGS=0
ENDIF
IF (TT.EQ.K_INTEGER.OR.TT.EQ.K_REAL.OR.TT.EQ.K_POINTER
# .OR.TT.EQ.K_BYTE.OR.TT.EQ.K_WORD.OR.TT.EQ.K_ADDRESS
# .OR.TT.EQ.K_LONG.OR.TT.EQ.K_DOUBLE.OR.TT.EQ.K_QUAD) THEN
CALL BASIC_TYPE(PTYPE)
ELSE
PTYPE=0
ENDIF
CALL PROCEDURE_ATTRIBUTES(FLAGS,REF)
IF (SYMBOL_REF(PROC_IX).EQ.S_FORWARD) THEN
IF (SYMBOL_TYPE(PROC_IX).NE.PTYPE.OR.
# SYMBOL_LIST_SIZE(PROC_IX).NE.NARGS.OR.
# SYMBOL_FLAGS(PROC_IX).NE.FLAGS) THEN
CALL ERROR('FORWARD DECLARATION DOESN''T MATCH THIS '//
# 'DECLARATION OF '//SYMBOL_PLM_ID(PROC_IX))
ENDIF
ENDIF
IF ((FLAGS.AND.S_PUBLIC).NE.0.OR.REF.EQ.S_EXT) THEN
SYMBOL_VAX_ID(PROC_IX)=PUBLIQUE(SYMBOL_PLM_ID(PROC_IX))
ENDIF
SYMBOL_KIND(PROC_IX)=S_PROC
SYMBOL_TYPE(PROC_IX)=PTYPE
SYMBOL_NBR_ELEMENTS(PROC_IX)=0
SYMBOL_ELEMENT_SIZE(PROC_IX)=0
SYMBOL_LINK(PROC_IX)=0
SYMBOL_LIST_SIZE(PROC_IX)=NARGS
SYMBOL_REF(PROC_IX)=REF
SYMBOL_BASE(PROC_IX)=0
SYMBOL_BASE_MEMBER(PROC_IX)=0
SYMBOL_FLAGS(PROC_IX)=FLAGS
IF (NARGS.EQ.0) THEN
PROC_AP(PROC_LEVEL)=PROC_AP(PROC_LEVEL-1)
ELSE
PROC_AP(PROC_LEVEL)=PROC_AP(PROC_LEVEL-1)+1
IF (PROC_AP(PROC_LEVEL).GT.9)
# CALL FATAL('PROCEDURES WITH ARGUMENTS NESTED TOO DEEPLY')
ENDIF
CALL MATCH(D_SEMI)
RETURN
END
C-------------------------------------------------------
SUBROUTINE FORMAL_PARAMETER_LIST(NARGS)
INCLUDE 'PLMCOM.FOR/NOLIST'
NARGS=0
10 CALL GETTOK
IF (TT.LT.101.OR.TT.GT.199) CALL MUSTBE(ID)
NARGS=NARGS+1
CALL ENTER_SYMBOL
IF (SYMBOL_REF(SYMBOL_INDEX).EQ.S_ARG) THEN
CALL ERROR('DUPLICATE ARG NAME: '//IDENTIFIER)
GO TO 20
ENDIF
SYMBOL_REF(SYMBOL_INDEX)=S_ARG
SYMBOL_LINK(SYMBOL_INDEX)=PROC_LEVEL ! REMEMBER PROC_LEVEL.
IF (SYMBOL_REF(PROC_INDEX(PROC_LEVEL)).NE.S_EXT) THEN
C ----- OOPS - DON'T KNOW YET IF PROC IS EXTERNAL ------
CALL EMIT_ABSDEF(SYMBOL_VAX_ID(SYMBOL_INDEX),NARGS*4)
ENDIF
20 CALL GETTOK
IF (TT.EQ.D_COMMA) GO TO 10
CALL MATCH(D_RP)
RETURN
END
C-------------------------------------------------------
SUBROUTINE PROCEDURE_ATTRIBUTES(FLAGS,REF)
INCLUDE 'PLMCOM.FOR/NOLIST'
FLAGS=0
REF=S_LOCAL
10 IF (TT.EQ.K_INTERRUPT) THEN
CALL GETTOK
FLAGS=FLAGS.OR.S_INTERRUPT
CALL MATCH(FIXCON)
ELSEIF (TT.EQ.K_REENTRANT) THEN
CALL GETTOK
FLAGS=FLAGS.OR.S_REENT
ELSEIF (TT.EQ.K_PUBLIC.AND.REF.NE.S_EXT) THEN
CALL GETTOK
FLAGS=FLAGS.OR.S_PUBLIC
ELSEIF (TT.EQ.K_EXTERNAL.AND.REF.EQ.S_LOCAL.AND.
# (FLAGS.AND.S_PUBLIC).EQ.0) THEN
CALL GETTOK
REF=S_EXT
ELSEIF (TT.EQ.K_FORWARD.AND.REF.EQ.S_LOCAL) THEN
CALL GETTOK
REF=S_FORWARD
ELSE
RETURN
ENDIF
GO TO 10
END

67
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/psects.for Normal file
View File

@@ -0,0 +1,67 @@
C***********************************************************************
C
C PSECTS.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 changes in object
C code program sections (PSECTs).
C
C-----------------------------------------------------------------------
C R E V I S I O N H I S T O R Y
C
C 20OCT81 Alex Hunter 1. Added disclaimer notice. (V5.4)
C 12NOV81 Alex Hunter 1. Add SETUP_COMMON_PSECT routine. (V6.1)
C
C-----------------------------------------------------------------------
INTEGER*2 FUNCTION PSECT(P)
INCLUDE 'PLMCOM.FOR/NOLIST'
CHARACTER*32 NAME
DATA CURRENT_PSECT/P_CODE/
PSECT=CURRENT_PSECT
IF (P.NE.CURRENT_PSECT.AND.P.NE.0) THEN
CALL EMIT('.PSECT '//PSECT_NAME(P))
ENDIF
CURRENT_PSECT=P
RETURN
C-------------------------------------------------------
ENTRY SETUP_COMMON_PSECT(NAME)
C------------------------------------
DO I=P_MEMORY,P_MAX
IF (PSECT_NAME(I).EQ.NAME) THEN
SETUP_COMMON_PSECT=I
RETURN
ELSEIF (PSECT_NAME(I).EQ.' ') THEN
PSECT_NAME(I)=NAME
CALL EMIT('.PSECT '//NAME(:LNB(NAME))//
# ',PIC,OVR,GBL,SHR,NOEXE,RD,WRT,LONG')
CURRENT_PSECT=I
SETUP_COMMON_PSECT=I
RETURN
ENDIF
ENDDO
CALL FATAL('TOO MANY DIFFERENT COMMON BLOCKS')
END

94
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/publics.for Normal file
View File

@@ -0,0 +1,94 @@
C***********************************************************************
C
C PUBLICS.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 the PUBLICS file
C at the end of a compilation.
C
C-----------------------------------------------------------------------
C R E V I S I O N H I S T O R Y
C
C 20OCT81 Alex Hunter 1. Added disclaimer notice. (V5.4)
C
C-----------------------------------------------------------------------
SUBROUTINE OUTPUT_PUBLICS(MODULE_NAME)
INCLUDE 'PLMCOM.FOR/NOLIST'
CHARACTER*32 MODULE_NAME,PUBLIQUE
CHARACTER*1 REF_MNEM(11)
DATA REF_MNEM
//'X','S','B','A','F','D','C','V','U','I','L'/
CHARACTER*1 KIND_MNEM(6)
DATA KIND_MNEM
//'M','V','A','P','L','K'/
CHARACTER*1 TYPE_MNEM(-1:S_QUAD)
DATA TYPE_MNEM
//'S',' ','B','W','I','P','R','L','D','Q'/
CHARACTER*1 MREF,MKIND,MTYPE
IF (.NOT.PUBLICS_FLAG) RETURN
WRITE(PUB,1001) MODULE_NAME
1001 FORMAT(' *M* ',A)
DO 100 I=SYMBOL_TOP(0)+1,SYMBOL_TOP(1)
IF (((SYMBOL_REF(I).EQ.S_EXT.OR.
# (SYMBOL_FLAGS(I).AND.S_PUBLIC).NE.0)) .AND.
# (SYMBOL_FLAGS(I).AND.S_NOTPUBLIC).EQ.0) THEN
TYPE=SYMBOL_TYPE(I)
IF (TYPE.EQ.S_STRUC) TYPE=-1
MTYPE=TYPE_MNEM(TYPE)
KIND=SYMBOL_KIND(I)
MKIND=KIND_MNEM(KIND)
MREF=REF_MNEM(SYMBOL_REF(I))
IF (KIND.EQ.S_PROC) THEN
WRITE(PUB,1002) PUBLIQUE(SYMBOL_PLM_ID(I)),MREF,MTYPE,
# MKIND,SYMBOL_LIST_SIZE(I)
1002 FORMAT(X,A,X,3A1:'(',I5,')')
ELSEIF (KIND.EQ.S_ARRAY) THEN
WRITE(PUB,1002) PUBLIQUE(SYMBOL_PLM_ID(I)),MREF,MTYPE,
# MKIND,SYMBOL_NBR_ELEMENTS(I)
ELSE
WRITE(PUB,1002) PUBLIQUE(SYMBOL_PLM_ID(I)),MREF,MTYPE,
# MKIND
ENDIF
ENDIF
100 CONTINUE
CLOSE (UNIT=PUB)
RETURN
END

74
ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/push.for Normal file
View File

@@ -0,0 +1,74 @@
C***********************************************************************
C
C PUSH.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 implements the pushdown
C stacks used by recursive FORTRAN subroutines and functions.
C
C-----------------------------------------------------------------------
C R E V I S I O N H I S T O R Y
C
C 20OCT81 Alex Hunter 1. Added disclaimer notice. (V5.4)
C
C-----------------------------------------------------------------------
SUBROUTINE PUSH(DATA,NWORDS)
IMPLICIT INTEGER*2 (A-Z)
INTEGER*2 DATA(*), SP, STACK(1000)
DATA SP/0/
C
IF (SP+NWORDS.GT.1000) CALL FATAL('SYNTAX STACK OVERFLOW')
DO 10 I=1,NWORDS
STACK(SP+I) = DATA(I)
10 CONTINUE
SP = SP+NWORDS
RETURN
C------------------------------------------
ENTRY POP(DATA,NWORDS)
SP = SP-NWORDS
IF (SP.LT.0) CALL BUG('SYNTAX STACK UNDERFLOW')
DO 20 I=1,NWORDS
DATA(I) = STACK(SP+I)
20 CONTINUE
RETURN
END
C------------------------------------------
SUBROUTINE PUSHC(CHARS)
IMPLICIT INTEGER*2 (A-Z)
CHARACTER CHARS*(*), CSTACK(100)*32
DATA SP/0/
C
IF (SP.GE.100) CALL FATAL('CHAR STACK OVERFLOW')
SP=SP+1
CSTACK(SP)=CHARS
RETURN
C------------------------------------------
ENTRY POPC(CHARS)
IF (SP.LE.0) CALL BUG('CHAR STACK UNDERFLOW')
CHARS=CSTACK(SP)
SP=SP-1
RETURN
END

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