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