Trailing-Edge
-
PDP-10 Archives
-
decuslib20-01
-
decus/20-0001/cmnd.for
There is 1 other file named cmnd.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 CMND *
C * *
C ***************************************************
C
C
C UPON ENTRANCE, NONBLK POINT TO THE "*" IN LINE
C INDICATING A COMMAND. THIS ROUTINE DETERMINES WHICH COMMAND
C IS DESIRED AND CALLS THE APPROPRIATE SUBROUTINE.
C
C RETCD:
C 1=NORMAL
C 2=BYPASS NEXT READ BECAUSE READ COMMAND HAS BEEN EXECUTED
C TO CHANGE LINE(80)
C 3=ERROR, SO GO TO 1000 TO SET LEVEL=1
C
C
C MODIFY CLASSES: M1
C
C
C CMND CALLS
C
C AT TO PROCESS A FILE OF CALC COMMANDS
C BASCNG TO CHANGE THE DEFAULT BASE FOR CONSTANTS
C CLOSE CLOSE FILE OF CALC COMMANDS
C DECLR DECLARE VAIABLES TO BE A CERTAIN DATA TYPE
C ERRMSG PRINTS ERROR MESSAGES
C EXIT RETURN TO OPERATING SYSTEM
C GETNNB GETS NEXT NON-BLANK FROM LINE(80)
C STRCMP LOOKS FOR A SPECIFIED STRING IN LINE(80)
C ZERO ZEROES ALL VARIABLES
C ZNEG TO SEE IF A VARIABLE HAS POSITIVE VALUE
C
C
C
C CMND IS CALLED BY CALC WHO HAS IDENTIFIED THE '*'
C INDICATING A COMMAND IS DESIRED.
C
C
C
C
C VARIABLE USE
C
C
C CHAR TEMPORARILY HOLDS A SINGLE CHARACTER.
C DIGITS HOLDS ASCII REPRESENTATION OF DIGITS.
C I TEMPORARY INDEX.
C ID ARGUMENT FOR SUBROUTINE DECLR. INDICATES
C A PARTICULAR DATA TYPE.
C IPT POINTER FOR LINE(80).
C ITCNTV 0 IF NO ITERATION. IF POSITIVE, INDEX
C OF VARIABLE USED TO CONTROL ITERATION ON THAT LEVEL.
C KIND(15) HOLDS FIRST LETTER OF ALL LEGAL COMMANDS.
C LEVEL HOLDS LOGICAL I/O UNIT WHERE NEXT COMMAND COMES FROM.
C LINE(80) HOLDS COMMAND LINE.
C NONBLK POINTER FOR LINE(80).
C RETCD HOLDS RETURN CODE.
C RETCD2 HOLDS RETURN CODE.
C VIEWSW VIEW SWITCH:
C 0 = OFF
C 1 = DISPLAY COMMAND LINES
C 2 = DISPLAY VALUE OF EXPRESSIONS
C 3 = DISPLAY ALL
C
C
C
C
C
SUBROUTINE CMND(RETCD)
C
C
INTEGER*2 LEVEL,NONBLK,LEND
INTEGER*2 RETCD,RETCD2,VIEWSW,BASED
INTEGER*2 ZNEG,ITCNTV(6)
C
LOGICAL*1 LINE(80),KIND(15),ASCII(4),DEC(6),HEX(2),INT(6),
; M10(2),M8(1),M16(2),OCTAL(4),REAL(3),CHAR
LOGICAL*1 DIGITS(16,3)
C
COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
COMMON /ITERA/ITCNTV
COMMON /DIGV/ DIGITS
C
DATA KIND
;/'@','A','B','C','D','E','H','I','M','N','O','R','S','V','Z'/
DATA ASCII/'S','C','I','I'/, DEC/'E','C','I','M','A','L'/
DATA HEX/'E','X'/, INT/'N','T','E','G','E','R'/
DATA M10/'1','0'/, M8/'8'/
DATA M16/'1','6'/
DATA OCTAL/'C','T','A','L'/
DATA REAL/'E','A','L'/
C
C
C
C PICK UP NON-BLANK CHARACTER AFTER '*'
RETCD=1
CALL GETNNB(IPT,RETCD2)
GOTO(2,4),RETCD2
STOP 2
2 NONBLK=IPT
C NONBLK POINTS TO 1ST NONBLANK CHARACTER AFTER *
C
DO 3 I=1,15
IF (LINE(NONBLK).EQ.KIND(I)) GOTO 6
3 CONTINUE
C
C
C UNIDENTIFIED COMMAND
4 GOTO 995
C
C
C
C GO TO DIFFERENT SECTIONS ON THE BASIS OF THE FIRST CHARACTER
C OF THE COMMAND.
6 GOTO (10,20,30,1000,40,50,60,70,80,90,100,110,50,130,140),I
STOP 6
C
C
C
C
C **************************************************
C ***** *@ INDIRECT COMMAND PROCESSING ******
C **************************************************
10 CALL AT(RETCD)
GOTO (1000,999),RETCD
STOP 10
C
C
C
C
C **************************************************
C ****** *A DECLARE TYPE ASCII ******
C **************************************************
20 CALL STRCMP (ASCII,4,RETCD2)
ID=1
GOTO (200,995),RETCD2
STOP 20
C
C
C
C
C **************************************************
C ****** *B BASE DEFAULT *******
C **************************************************
30 CONTINUE
CALL BASCNG(RETCD2)
IF(VIEWSW.NE.0)WRITE(1,34) BASED
34 FORMAT(' DEFAULT BASE IS ',I2)
GO TO (1000,999),RETCD2
STOP 30
C
C
C
C
C ********************************************************
C ** *C COMMENT, JUST RETURN (VIA STATEMENT 1000) **
C ********************************************************
C
C
C
C **************************************************
C ******* *D DECLARE TYPE DECIMAL *******
C **************************************************
40 CALL STRCMP(DEC,6,RETCD2)
ID=2
GOTO (200,995),RETCD2
STOP 40
C
C
C **************************************************
C ********** *E EXIT ********
C **************************************************
50 IF (LEVEL.EQ.1) CALL EXIT
IF(ITCNTV(LEVEL).EQ.0)GOTO 55
IF(ZNEG(ITCNTV(LEVEL)).EQ.1)GOTO 55
C ITERATION VARIABLE IS POSITIVE SO EXECUTE FILE AGAIN
REWIND LEVEL
GO TO 1000
C
C NOTE THAT WHEN EXITING A LEVEL THAT WAS ITERATED, ITCNTV
C IS NOT SET TO ZERO. THIS REQUIRES THAT WHEN ENTERED AT
C SUBROUTINE 'AT' AND ITERATION IS NOT DESIRED, THAT ITCNTV
C MUST BE SET TO ZERO THERE
55 CALL CLOSE(LEVEL)
LEVEL=LEVEL-1
59 GOTO 1000
C
C
C
C
C
C **************************************************
C * *H DECLARE VARIABLES TO BE OF TYPE HEXADECIMAL *
C **************************************************
60 CALL STRCMP (HEX,2,RETCD2)
ID=3
GOTO (200,995),RETCD2
STOP 60
C
C
C
C
C **************************************************
C * *I DECLARE VARIABLE TO BE OF TYPE INTEGER (*4) *
C **************************************************
70 CALL STRCMP (INT,6,RETCD2)
ID=4
GOTO (200,995),RETCD2
STOP 70
C
C
C **************************************************
C * *M DECLARE VARIABLE TO BE MULTIPLE PRECISION *
C **************************************************
80 CALL STRCMP (M10,2,RETCD2)
ID=5
GOTO (200,84),RETCD2
STOP '80'
C
C
C SEE IF MULTIPLE PRECISION IS OCTAL
84 CALL STRCMP (M8,1,RETCD2)
ID=6
GOTO (200,88),RETCD2
STOP '84'
C
C
C SEE IF MULTIPLE PRECISION HEXADECIMAL
88 CALL STRCMP (M16,2,RETCD2)
ID=7
GOTO (200,995),RETCD2
STOP '88'
C
C
C
C
C ************************************************************
C ** *N SUPPRESS PRINTING OF VARIABLES WHEN VALUES CHANGE **
C ************************************************************
90 VIEWSW=1
GOTO 1000
C
C
C
C
C **************************************************
C *** *O DECLARE VARIABLE TO BE OF TYPE OCTAL ***
C **************************************************
100 CALL STRCMP (OCTAL,4,RETCD2)
ID=8
GOTO (200,995),RETCD2
STOP 100
C
C
C
C
C
C **************************************************
C *********** *R ENCOUNTERED *************
C **************************************************
C
C *R SEE IF A REAL DECLARATION
110 CALL STRCMP (REAL,3,RETCD2)
ID=9
GOTO (200,114),RETCD2
STOP 110
C
C
C OTHERWISE ASSUME A READ IS REQUIRED
114 IF (LEVEL.NE.1) GOTO 117
WRITE(1,116)
GOTO 118
116 FORMAT(' CALC>',$)
117 WRITE (1,119) LEVEL
119 FORMAT (' CALC<',I1,'>',$)
118 READ (1,115,END=1000,ERR=990) LINE
115 FORMAT (80A1)
C
C NOTE THAT IF <CR> IS HIT AS THE ONLY INPUT, RETURN IS NORMAL
C AND PROCESSING CONTINUES ON LEVEL (RETCD=2)
RETCD=2
GOTO 1000
C
C
C
C
C
C ************************************************************
C *** *V ACTIVATE PRINTING OF VARIABLE WHEN VALUES CHANGE ***
C ************************************************************
129 NONBLK=IPT
130 CALL GETNNB(IPT,RETCD2)
GO TO (129,132),RETCD2
STOP 130
132 CHAR=LINE(NONBLK)
IF(CHAR.NE.DIGITS(10,1))GO TO 134
C
C *VIEW 0 ENCOUNTERED
VIEWSW=0
GO TO 1000
134 IF(CHAR.NE.DIGITS(1,1))GO TO 136
C
C *VIEW 1 ENCOUNTERED
VIEWSW=1
GO TO 1000
136 IF(CHAR.NE.DIGITS(2,1))GO TO 138
VIEWSW=2
GO TO 1000
138 VIEWSW=3
GOTO 1000
C
C
C
C
C **************************************************
C ********** *Z ZERO OUT ALL VARIABLES ********
C **************************************************
140 CALL ZERO
GOTO 1000
C
C
C
C
C
C MAKE DECLARATIONS
200 CALL DECLR(ID,RETCD2)
GO TO(1000,999),RETCD2
STOP 200
C
C
C
C
C
C **** ERROR PROCESSING ****
C
990 I=27
GO TO 998
995 I=3
998 CALL ERRMSG(I)
999 RETCD=3
1000 CONTINUE
RETURN
END