Google
 

Trailing-Edge - PDP-10 Archives - decus_20tap1_198111 - decus/20-0001/declr.for
There is 1 other file named declr.for in the archive. Click here to see a list.
C
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 *       SUBROUTINE  DECLR (ITYP,RETCD)           *
C *                                                *
C **************************************************
C
C
C ANALYZES VECTOR LINE TO DETERMINE WHAT VARIABLES GET THEIR
C TYPES CHANGED. THE NEW TYPE IS SPECIFIED AS AN ARGUMENT IN
C THE CALL:
C
C
C  TYPE CODE
C	1  ASCII
C	2  DECIMAL (REAL BUT DECIMAL POINT FOR OUTPUT)
C	3  HEXADECIMAL
C	4  INTEGER
C	5  MULTIPLE PRECISION (BASE 10)
C	6  MULTIPLE PRECISION (BASE 8)
C	7  MULTIPLE PRECISION (BASE 16)
C	8  OCTAL
C	9  REAL
C
C  IF NEGATIVE, TYPE IS DEFINED BUT VARIABLE HAS
C  NOT BEEN ASSIGNED A VALUE
C
C
C  RETCD     MEANING
C  1    =    O.K.
C  2    =    ERROR
C
C  NOTE:  AS IN FORTRAN, VARIABLES IN DECLARATIONS MUST BE SEPARATED
C         BY COMMAS
C
C
C  MODIFICATION CLASSES: M1, M2
C
C
C
C
C DECLR CALLS:
C
C  ERRMSG   PRINTS ERROR MESSAGES
C
C
C
C DECLR IS CALLED BY CMND, THE ROUTINE THAT DECODES COMMANDS.
C
C
C
C
C       VARIABLE        USE
C
C    ALPHA           LIST OF LEGAL VARIABLE NAMES. THE FIRST 26 ARE
C                    ALPHABETIC, THE 27TH IS THE CHARACTER '%'.
C    BLANK           ' '
C    I,I2,I3         TEMPORARY VALUES.
C    ITYP            CODE THAT GIVES THE TYPE OF VARIABLE FOR A
C                    PARTICULAR CALL TO THIS ROUTINE. VARIABLES ARE
C                    EITHER DECLARED TO BE OF THIS TYPE OR, IF NO
C                    VARIABLES ARE SPECIFIED, A LIST OF ALL THE
C                    VARIABLES OF THAT TYPE ARE GIVEN.
C    LEND            LAST NON-BLANK IN VECTOR LINE(80).
C    LINE(80)        HOLDS INPUT COMMAND LINE. IF DECLARATION HAS
C                    NO ARGUMENT, THIS VECTOR IS THEN USED TO OUTPUT
C                    A LIST OF VARIABLES OF THE TYPE SPECIFIED.
C    NONBLK          START SCAN OF VARIABLE LIST.
C    TYPE            HOLDS THE TYPE CODE FOR EACH VARIABLE.
C
C
C
C
C
C
C 
	SUBROUTINE DECLR(ITYP,RETCD)
	INTEGER*2 LEVEL,NONBLK,LEND
	INTEGER*2  TYPE(27),RETCD,VIEWSW,BASED,VLEN(9)
	INTEGER*2 I,I2,I3,ITYP
C
	LOGICAL*1  LINE(80),VBLS(100,27)
	LOGICAL*1 ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ
C
	COMMON  /V/TYPE,VBLS,VLEN
	COMMON  /CONS/ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
	COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
C
C
C
	IF(NONBLK.EQ.LEND)GO TO 500
C
C
C **************************************************
C ****** DECLARE VARIABLES TO BE OF TYPE ITYP ******
C **************************************************
	I2=NONBLK+1
10	IF (LINE(I2).EQ.BLANK) GOTO 60
	DO 20 I3=1,26
	IF (LINE(I2).EQ.ALPHA(I3)) GOTO 30
20	CONTINUE
C
C  ILLEGAL CHARACTER IN DECLARATION'S VARIABLE LIST
22	I=4
C
C
C
C ******* ERROR RETURN *******
25	RETCD=2
	CALL ERRMSG(I)
	RETURN
C
C
C
C
30	CONTINUE
C IF OLD VARIABLE WAS UNDEFINED, MAKE NEW TYPE LESS THAN 0 ALSO.
C THIS ALLOWS ONE TO EXAMINE INTERNAL VALUES FOR DIFFERENT DATA
C TYPES. IF THIS IS NOT NEEDED, IT WOULD BE CLEANER TO ALWAYS MAKE
C VARIABLES UNDEFINED WHEN THEIR DATA TYPE IS CHANGED. TO DO THIS
C JUST USE THE STATEMENT
C	I=-ITYP
	I=ITYP
	IF(TYPE(I3).LE.0)I=-I
	TYPE(I3)=I
	I3=I2+1
	IF (I3.GT.LEND) GOTO 1000
	DO 40 I2=I3,LEND
	IF (LINE(I2).EQ.BLANK) GOTO 40
	IF (LINE(I2).EQ.COMMA) GOTO 45
C
C VARIABLES NOT SEPARATED BY COMMAS
	I=5
	GO TO 25
40	CONTINUE
	GOTO 1000
45	IF (I2.EQ.LEND) GOTO 22
60	I2=I2+1
	IF (I2.LE.LEND) GOTO 10
	GO TO 1000
C
C
C
C
C
C
C **********************************************************************
C ** NO ARGUMENTS SO SHOW WHAT VARIABLES HAVE BEEN DECLARED THAT TYPE **
C **********************************************************************
500	CONTINUE
	IF(VIEWSW.EQ.0) GO TO 1000
C PERHAPS THE ABOVE LINE SHOULD BE REMOVED (???)
C
C
C BLANK OUT OUTPUT LINE.
	DO 510 I=1,80
510	LINE(I)=BLANK
C
C
C SEARCH FOR VARIABLES OF TYPE ITYP. PUT THEM IN LINE(I2) WHEN FOUND FOR
C LATER PRINTING.
	I2=0
	DO 550 I=1,27
	IF(IABS(TYPE(I)).NE.ITYP)GO TO 550
	I2=I2+1
	LINE(I2)=ALPHA(I)
550	CONTINUE
C
C
C GO TO SECTION APPROPRIATE FOR PRINTING EITHER THE LIST OF VARIABLES OR
C A MESSAGE INDICATING THAT NO VARIABLES ARE OF THAT TYPE.
	IF(I2.EQ.0) GO TO 600
C
C
C OUTPUT A LIST OF VARIABLES OF TYPE ITYP
	WRITE(1,560) (LINE(I),I=1,I2)
560	FORMAT(' VARIABLES SO DECLARED = ',30A1)
	GO TO 1000
C
C
C
C
C NO VARIABLES OF THAT TYPE
600	WRITE(1,610)
610	FORMAT(' NO VARIABLES OF THAT TYPE')
C
C
C
C **** NORMAL RETURN ****
1000	RETCD=1
	RETURN
	END