1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
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
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
|
/*****************************************/
/* CLE-2000 API */
/* AUTHOR OF FORTRAN VERSION: R. Roy */
/* AUTHOR: A. Hebert ; 31/07/10 */
/*****************************************/
#include <stdlib.h>
#include <string.h>
#include "cle2000.h"
void drviox(lifo *my_iptdat, int_32 minput, int_32 *nusec2)
{
char *nomsub = "drviox";
static char *ctypes[] = {"_I", "_R", "_S", "_D", "_L"};
/* GAN-2000 SYSTEM: R.ROY (01/2000), VERSION 2.1 */
/* *DRVIOX* IS USED TO INPUT/OUTPUT CLE-2000 VALUES */
/* INTO/FROM DATA STRUCTURE. */
/* INPUT: *IPTDAT* IS THE DATA STRUCTURE POINTER (ALLOCATED) */
/* *MINPUT* IS AN INTEGER -1: TO READ DATA INPUT (IN MAIN) */
/* 0: TO GET THIS INPUT (IN PROC, AFTER "::") */
/* +1: TO RETURN VALUES (IN MAIN) */
/* *NUSEC2* IS THE OFFSET OF NEXT DATA VALUE ENTERED AFTER "::" */
int_32 ityp, nitma, ntypc2;
float_32 flott;
double_64 dflot;
char text[73], messag[73];
lifo_node *my_node;
if (minput == -1) {
int_32 nembed = 0;
/* INPUT CLE-2000 VARIABLES FROM MAIN PROGRAM */
L10:
redget_c(&ityp, &nitma, &flott, text, &dflot);
if (ityp == 10) {
xabort_c("DRVIOX: REDGET HITS THE ; (1).");
} else if (ityp == 3 && strcmp(text, ";") == 0 && nembed == 0) {
/* END OF STATEMENT REACHED */
goto L666;
} else {
my_node = (lifo_node *) malloc(sizeof(lifo_node));
clepush(&my_iptdat, my_node);
strcpy(my_node->name, "_dummy");
if (ityp > 0) {
my_node->type = 10 + ityp;
my_node->access = 1;
if (ityp == 3) {
if (strcmp(text, ":::") == 0) {
++nembed;
} else if (strcmp(text, ";") == 0) {
--nembed;
} else if (strcmp(text, "::") == 0) {
xabort_c("DRVIOX: INPUT DATA MISTAKE (ACT).");
}
strcpy(my_node->value.hval, text);
} else if (ityp == 1 || ityp == 5) {
my_node->value.ival = nitma;
} else if (ityp == 2) {
my_node->value.fval = flott;
} else if (ityp == 4) {
my_node->value.dval = dflot;
} else {
xabort_c("DRVIOX: INVALID TYPE (ACT).");
}
} else {
my_node->type = -10 + ityp;
my_node->access = 0;
strcpy(my_node->name, text);
}
}
goto L10;
} else if (minput == 0) {
/* READ/WRITE CLE-2000 VARIABLES IN THE PROCEDURE CALL */
L20:
redget_c(&ityp, &nitma, &flott, text, &dflot);
if (ityp == 10) {
xabort_c("DRVIOX: REDGET HITS THE ; (2).");
} else if (ityp == 3 && strcmp(text, ";") == 0) {
goto L666;
} else {
if (*nusec2 + 1 > my_iptdat->nup) {
printf("%s: INVALID NUMBER OF PARAMETERS (nusec2=%d)\n", nomsub, (int)(*nusec2 + 1));
sprintf(messag, "%s: PROC WAS CALLED WITH ONLY %d PARAMETERS.\n", nomsub, (int)my_iptdat->nup);
xabort_c(messag);
}
if (ityp < 0) {
my_node = clepos(&my_iptdat, *nusec2);
ntypc2 = my_node->type - 10;
if (-ityp != ntypc2) {
if (ityp < 0) {
printf("%s: DUMMY VARIABLE NAME *%.12s* OF TYPE(%s)\n",
nomsub, text, ctypes[-ityp-1]);
} else {
printf("%s: DUMMY VALUE OF TYPE(%s)\n", nomsub, ctypes[ityp-1]);
}
if (my_node->type < 0) {
strcpy(text, my_node->name);
printf("%s: ACTUAL VARIABLE NAME *%.12s* OF TYPE(%s)\n", nomsub, text, ctypes[-ntypc2-1]);
} else {
printf("%s: DUMMY VALUE OF TYPE(%s)\n", nomsub, ctypes[ntypc2-1]);
}
xabort_c("DRVIOX: INVALID TYPE (DUMMY) 5.");
}
if (strcmp(my_node->name, "_dummy") == 0) strcpy(my_node->name, text);
nitma = 0;
flott = 0.f;
dflot = 0.L;
strcpy(text, " ");
if (ityp == -1 || ityp == -5) {
nitma = my_node->value.ival;
} else if (ityp == -2) {
flott = my_node->value.fval;
} else if (ityp == -3) {
strcpy(text, my_node->value.hval);
nitma = strlen(text);
} else if (ityp == -4) {
dflot = my_node->value.dval;
} else {
xabort_c("DRVIOX: INVALID TYPE (DUMMY) 6.");
}
redput_c(&ntypc2, &nitma, &flott, text, &dflot);
} else {
my_node = clepos(&my_iptdat, *nusec2);
ntypc2 = my_node->type + 10;
if (-ityp != ntypc2) {
if (ityp < 0) {
printf("%s: DUMMY VARIABLE NAME *%.12s* OF TYPE(%s)\n", nomsub, text, ctypes[-ityp-1]);
} else {
printf("%s: DUMMY VALUE OF TYPE(%s)\n", nomsub, ctypes[ityp-1]);
}
if (my_node->type < 0) {
strcpy(text, my_node->name);
printf("%s: ACTUAL VARIABLE NAME *%.12s* OF TYPE(%s)\n", nomsub, text, ctypes[-ntypc2-1]);
} else {
printf("%s: DUMMY VALUE OF TYPE(%s)\n", nomsub, ctypes[ntypc2-1]);
}
xabort_c("DRVIOX: INVALID TYPE (DUMMY) 5.");
}
if (ityp == 1 || ityp == 5) {
my_node->value.ival = nitma;
} else if (ityp == 2) {
my_node->value.fval = flott;
} else if (ityp == 3) {
strcpy(my_node->value.hval, text);
} else if (ityp == 4) {
my_node->value.dval = dflot;
} else {
xabort_c("DRVIOX: INVALID TYPE (DUMMY) 7.");
}
my_node->type = -my_node->type;
}
++(*nusec2);
}
goto L20;
} else if (minput == 1) {
int_32 iloop;
/* CONSISTENT RETURN (NOW, *REDPUT* IN THE REVERSE ORDER) */
for (iloop = my_iptdat->nup - 1; iloop >= 0; --iloop) {
my_node = clepos(&my_iptdat, iloop);
if (my_node->type < 10) continue;
ityp = my_node->type - 10;
nitma = 0;
flott = 0.f;
dflot = 0.L;
strcpy(text, " ");
if (my_node->access == 0) {
if (ityp == 1 || ityp == 5) {
nitma = my_node->value.ival;
} else if (ityp == 2) {
flott = my_node->value.fval;
} else if (ityp == 3) {
strcpy(text, my_node->value.hval);
nitma = strlen(text);
} else if (ityp == 4) {
dflot = my_node->value.dval;
} else {
xabort_c("DRVIOX: INVALID TYPE (DUMMY) 4.");
}
redput_c(&ityp, &nitma, &flott, text, &dflot);
my_node->access = 1;
}
}
} else {
xabort_c("DRVIOX: INVALID VALUE FOR *MINPUT* ARG");
}
L666:
return;
} /* drviox */
|
