Google
 

Trailing-Edge - PDP-10 Archives - decuslib20-01 - decus/20-0001/block.for
There are 3 other files named block.for in the archive. Click here to see a list.
C
C
C            COPYRIGHT (c) 1977 BY
C    DIGITAL EQUIPMENT CORPORTATION, MAYNARD, MASS.
C   
C  THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND  COPIED
C  ONLY  IN  ACCORDANCE  WITH  THE  TERMS  OF  SUCH  LICENSE AND WITH THE
C  INCLUSION OF THE  ABOVE COPYRIGHT NOTICE.  THIS  SOFTWARE OR ANY OTHER
C  COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE  MADE AVAILABLE TO ANY
C  OTHER PERSON.  NO TITLE TO AND OWNERSHIP OF  THE  SOFTWARE  IS  HEREBY
C  TRANSFERRED.
C 
C  THE INFORMATION IN THIS  SOFTWARE IS SUBJECT TO CHANGE  WITHOUT NOTICE
C  AND  SHOULD  NOT  BE  CONSTRUED AS A COMMITMENT BY  DIGITAL  EQUIPMENT
C  CORPORATION.
C 
C  DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
C  SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.
C 
C 
C 
C
C
C
C
C
C   ++++++++++++++++++++++++++++++++++++++++++++++++++
C   +                                                +
C   +            CALC    VERSION  X01-01             +
C   +                                                +
C   +  PETER BAUM  1-SEP-77                          +
C   +  DIGITAL EQUIPMENT CORPORATION                 +
C   +  146 MAIN STREET                               +
C   +  MAYNARD, MASSACHUSETTS  01754                 +
C   +                                                +
C   ++++++++++++++++++++++++++++++++++++++++++++++++++
C
C
C *******************************************************
C *                                                     *
C *            BLOCK  DATA  MODULE                      *
C *                                                     *
C *******************************************************
C
C
C COMMON AREAS ARE INITIALIZED BY THIS MODULE.
C
C
C
C  MODIFICATION CLASSES: M2,M3,M9,M10
C
C
C
C
C   VARIABLE      USE
C
C  ALPHA(27)    HOLDS LEGAL VARIABLE NAMES: ALPHABETIC CHARACTERS
C               OR THE CHARACTER %.
C  BASED     HOLDS DEFAULT BASE.
C  BLANK        ' '
C  COMMA        ','
C  DIGITS(16,3) HOLDS DECIMAL, OCTAL, AND HEXADECIMAL DIGITS. THE
C               SECOND SUBSCRIPT IS
C                     1 FOR DECIMAL
C                     2 FOR OCTAL
C                     3 FOR HEXADECIMAL
C  DTBL1(9,9,8) CONTROLS THE DECISION PROCESS WHEN EVALUATING A
C               BINARY OPERATION. SEE BELOW FOR DETAILS.
C  EQ           '='
C  ITCNTV(6)    INDEXED BY LEVEL. 0 INDICATES THAT NO ITERATION ON THE
C               INDIRECT COMMAND FILE IS TO TAKE PLACE. IF POSITIVE, IT
C               HOLDS THE INDEX INTO VBLS AND REPRESENTS THE VARIABLE
C               USED TO CONTROL ITERATION.
C  LINE(80)     COMMAND INPUT LINE
C  LPAR         '('
C  RPAR         ')'
C  ST1LIM       HOLDS THE SIZE OF STACK 1 (ALWAYS CONSTANT)
C  ST2LIM       HOLDS THE SIZE OF STACK 2 (ALWAYS CONSTANT)
C  ST1PT        POINTS TO THE TOP OF STACK 1 (CHANGES AS STACK IS USED)
C  ST2PT        POINTS TO THE TOP OF STACK 2 (CHANGES AS STACK IS USED)
C  ST1TYP(40)       DATA TYPE FOR EACH ELEMENT IN STACK 1
C  ST2TYP(40)       DATA TYPE FOR EACH ELEMENT IN STACK 2
C  STACK1(100,40)   UTILITY STACKS USED WHEN EVALUATING EXPRESSIONS. THE FIRST
C  STACK2(100,40)   SUBSCRIPT CONTROLS INDEXING ACROSS THE BYTES OF A SINGLE
C                   VARIABLE. THE SECOND SUBSCRIPT CONTROLS STACK ELEMENTS.
C  TYPE(27)         HOLDS THE DATA TYPES FOR EACH OF THE 27 VARIABLES. SEE
C                   CODES.FTN FOR THE POSSIBLE VALUES.
C  VIEWSW           VIEW SWITCH
C                    0 = OUTPUT ERROR MESSAGES
C                    1 = OUTPUT ERROR MESSAGES AND FILE COMMAND LINES
C                    2 = OUTPUT ERROR MESSAGES AND VALUE OF EXPRESSIONS
C                        EVALUATED.
C                    3 = OUTPUT EVERYTHING
C  VLEN(9)      INDEXED BY DATA TYPE. GIVES THE NUMBER OF BYTES USED
C               BY THAT DATA TYPE.
C  VBLS(100,27)      HOLDS THE VALUES OF THE 27 LEGAL VARIABLES.
C
C
C
C    CONSTANTS ARE STORED IN VBLS ACCORDING TO THEIR TYPE:
C
C
C
C <----------- MULTIPLE PRECISION (M10, M8, M16) ------------------------->
C !                        <------------- DECIMAL AND REAL --------------->
C !                        !                      <-- INTEGER HEX OCTAL -->
C !                                               !             ---> ASCII <---
C !                        !                      !                        !
C
C -------------     -------------------------------------------------------
C !     !     !     !     !     !     !     !     !     !     !     !     !
C ! 100 !  99 ! ... !  9  !  8  !  7  !  6  !  5  !  4  !  3  !  2  !  1  !
C !     !     !     !     !     !     !     !     !     !     !     !     !
C -------------     -------------------------------------------------------
C
C
C NOTE: BYTE 100 HOLDS THE SIGN FOR MULTIPLE PRECISION NUMBERS.
C       0 = POSITIVE, 1 = NEGATIVE
C
C
C
C
C
	BLOCK DATA
	INTEGER*2 LEVEL,NONBLK,LEND
	INTEGER*2 LASTOP
	INTEGER*2 TYPE(27),ST1TYP(40),ST2TYP(40)
	INTEGER*2 VIEWSW,BASED,VLEN(9)
	INTEGER*2 ST1LIM,ST2LIM,ST1PT,ST2PT
	INTEGER*2 ITCNTV(6)
C
	LOGICAL*1 ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ,LINE(80)
	LOGICAL*1 STACK1(100,40),STACK2(100,40)
	LOGICAL*1 VBLS(100,27)
	LOGICAL*1 DTBL1(9,9,8)
	LOGICAL*1 DIGITS(16,3)
C
	COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
	COMMON /CONS/ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
	COMMON /STACK/ STACK1,STACK2,ST1PT,ST2PT,ST1TYP,ST2TYP,
     ;         ST1LIM,ST2LIM
	COMMON /V/ TYPE,VBLS,VLEN
	COMMON /DECIDE/ DTBL1
	COMMON /DIGV/ DIGITS
	COMMON /ERROR/ LASTOP
	COMMON/ITERA/ ITCNTV
C
	DATA VIEWSW/3/
	DATA LEVEL/1/
	DATA LASTOP/0/
	DATA ITCNTV/6*0/
	DATA ALPHA/'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','%'/
	DATA DIGITS/'1','2','3','4','5','6','7','8','9',7*'0',
     ;       '1','2','3','4','5','6','7',9*'0',
     ;  '1','2','3','4','5','6','7','8','9','A','B','C','D','E','F','0'/
	DATA COMMA/','/, BLANK/' '/,RPAR/')'/,LPAR/'('/,EQ/'='/
C
C
C DEFAULT BASE IS 10
	DATA BASED/10/
C
C
C STACKS ARE CURRENTLY SET AT 40 ELEMENTS DEEP
	DATA ST1LIM/40/, ST2LIM/40/
C
C
C
C	DEFAULT TYPES
C	A,B,C,D,E,F,G,H  =  DECIMAL
C	I,J,K,L,M,N      =  INTEGER (BASE10)
C	O,P,Q,R,S,T,U,V,W,X,Y,Z  =  DECIMAL
C
C  % AS INTEGER TO HOLD CALC VERSION NUMBER
C
	DATA TYPE/8*-2,6*-4,12*-2,4/
C
C
C GIVE VERSION # BY VALUE IN %
C
	DATA VBLS(1,27)/3/
	DATA VBLS(2,27)/0/,VBLS(3,27)/0/,VBLS(4,27)/0/
C
C
C
C
C SPECIFY THE LENGTH USED BY EACH DATA TYPE
	DATA VLEN/1,8,4,4,100,100,100,4,8/
C
C
C
C
C
C
C
C
C  DECISION TABLE FOR PERFORMING BINARY OPERATIONS
C
C  DTBL1(OPERAND2,OPERAND1,INDEX)
C
C  WHERE:					OPERATOR:
C  INDEX=1	MODIFY CODE FOR OPERAND 1	*/+-
C	 2	MODIFY CODE FOR OPERAND 2	*/+-
C	 3	FUNCTION VALUE TYPE		*/+-
C	 4	OPERATOR CLASS			*/+-
C
C	 5	MODIFY CODE FOR OPERAND 1	**
C	 6	MODIFY CODE FOR OPERAND 2	**
C	 7	FUNCTION VALUE TYPE		**
C	 8	OPERATOR CLASS			**
C
C
C  WHERE TYPE CODES (MODIFY CODES) ARE:
C	0	NO CHANGE
C	1	CONVERT TO ASCII
C	2	CONVERT TO DECIMAL
C	3	CONVERT TO HEXADECIMAL
C	4	CONVERT TO INTEGER
C	5	CONVERT TO M10
C	6	CONVERT TO M8
C	7	CONVERT TO M16
C	8	CONVERT TO OCTAL
C	9	CONVERT TO REAL
C
C  FOR */+- FUNCTION VALUE TYPES AND OPERATOR CLASS ARE PRESENTLY
C  IDENTICAL
C
C  FOR **  OPERATOR CLASSES FOLLOW:
C
C 	CODE	OPERATOR CLASS
C	1	REAL**REAL
C	2	REAL**INTEGER
C	3	INTEGER**REAL
C	4	INTEGER**REAL
C	5	M8**INTEGER
C	6	M10**INTEGER
C	7	M16**INTEGER
C
C
C
C
C
C
	DATA DTBL1 /4,2,3,4,5,6,7,8,9,
     ;  9*0,
     ;  0,2,0,0,3*7,0,9,
     ;  0,2,0,0,5,5,7,0,9,
     ;  0,2,7,0,0,0,7,0,9,
     ;  0,2,7,5,5,0,7,0,9,
     ;  0,2,6*0,9,
     ;  0,2,3,0,5,6,7,0,9,
     ;  0,2,7*0,
     ;  4,8*0,
     ;  2,0,6*2,0,
     ;  3,3*0,7,7,3*0,
     ;  4,4*0,5,3*0,
     ;  5,0,7,5,0,5,0,5,0,
     ;  6,0,7,5,3*0,6,0,
     ;  7,2,4*7,0,7,0,
     ;  8,8*0,
     ;  9,0,6*9,0,
     ;  4,2,3,4,5,6,7,8,9,
     ;  9*2,
     ;  3,2,3,3,3*7,3,9,
     ;  4,2,3,4,5,5,7,4,9,
     ;  5,2,7,3*5,7,5,9,
     ;  6,2,7,5,5,6,7,6,9,
     ;  7,2,6*7,9,
     ;  8,2,3,4,5,6,7,8,9,
     ;  9,2,7*9,
     ;  4,2,3,4,5,6,7,8,9,
     ;  9*2,
     ;  3,2,3,3,3*7,3,9,
     ;  4,2,3,4,5,5,7,4,9,
     ;  5,2,7,5,5,5,7,5,9,
     ;  6,2,7,5,5,6,7,6,9,
     ;  7,2,6*7,9,
     ;  8,2,3,4,5,6,7,8,9,
     ;  9,2,7*9,
     ;  4,2,3,6*4,
     ;  9*0,
     ;  9*0,
     ;  9*0,
     ;  0,9,6*0,9,
     ;  0,9,6*0,9,
     ;  0,9,6*0,9,
     ;  9*0,
     ;  9*0,
     ;  4,3*0,3*9,4,0,
     ;  4,3*0,3*9,0,0,
     ;  4,3*0,3*9,2*0,
     ;  4,3*0,3*9,2*0,
     ;  4,3*0,3*4,2*0,
     ;  4,3*0,3*4,2*0,
     ;  4,3*0,3*4,2*0,
     ;  4,3*0,3*9,2*0,
     ;  4,3*0,3*9,2*0,
     ;  4,2,3,6*4,
     ;  9*2,
     ;  9*3,
     ;  9*4,
     ;  5,9,6*5,9,
     ;  6,9,6,6,5,6,7,6,9,
     ;  7,9,6*7,9,
     ;  9*8,
     ;  9*9,
     ;  4,1,4,4,3,3,3,4,3,
     ;  2,1,2,2,3*1,2,1,
     ;  4,3,4,4,3*3,4,3,
     ;  4,3,4,4,3*3,4,3,
     ;  6,1,6*6,1,
     ;  5,1,6*5,1,
     ;  7,1,6*7,1,
     ;  4,3,4,4,3*3,4,3,
     ;  2,1,2,2,3*1,2,1/
	END