GnuCOBOL  2.0
A free COBOL compiler
 All Data Structures Files Functions Variables Typedefs Enumerations Enumerator Macros
Functions | Variables
field.c File Reference
#include "config.h"
#include <stdio.h>
#include <stdlib.h>
#include <stddef.h>
#include <string.h>
#include <ctype.h>
#include <limits.h>
#include "cobc.h"
#include "tree.h"
Include dependency graph for field.c:

Functions

int cb_get_level (cb_tree x)
 
cb_tree cb_build_field_tree (cb_tree level, cb_tree name, struct cb_field *last_field, enum cb_storage storage, struct cb_file *fn, const int expl_level)
 
struct cb_field * cb_resolve_redefines (struct cb_field *field, cb_tree redefines)
 
static void validate_field_clauses (cb_tree x, struct cb_field *f)
 
static unsigned int check_picture_item (cb_tree x, struct cb_field *f)
 
static unsigned int validate_field_1 (struct cb_field *f)
 
static void setup_parameters (struct cb_field *f)
 
static void compute_binary_size (struct cb_field *f, const int size)
 
static int compute_size (struct cb_field *f)
 
static int validate_field_value (struct cb_field *f)
 
void cb_validate_field (struct cb_field *f)
 
void cb_validate_88_item (struct cb_field *f)
 
struct cb_field * cb_validate_78_item (struct cb_field *f, const cob_u32_t no78add)
 
void cb_clear_real_field (void)
 
struct cb_field * cb_get_real_field (void)
 

Variables

cb_tree cb_depend_check = NULL
 
size_t cb_needs_01 = 0
 
static struct cb_field * last_real_field = NULL
 
static int occur_align_size = 0
 
static const int pic_digits [] = { 2, 4, 7, 9, 12, 14, 16, 18 }
 

Function Documentation

cb_tree cb_build_field_tree ( cb_tree  level,
cb_tree  name,
struct cb_field *  last_field,
enum cb_storage  storage,
struct cb_file *  fn,
const int  expl_level 
)

References _, cb_build_field(), cb_build_filler(), CB_CHAIN, cb_error_node, cb_error_x(), CB_FIELD, cb_field_founder(), CB_FIELD_P, cb_get_level(), cb_needs_01, CB_REFERENCE, CB_STORAGE_FILE, CB_TREE, CB_VALUE, cb_warning_x(), cb_field::children, cb_word::count, current_program, cb_field::flag_external, cb_file::flag_external, cb_field::flag_filler, cb_reference::flag_filler_ref, cb_file::flag_global, cb_program::flag_has_external, cb_field::flag_is_global, cb_field::flag_item_78, cb_field::flag_sign_leading, cb_field::flag_sign_separate, cb_field::indexes, cb_word::items, cb_field::level, NULL, p, cb_field::parent, redefinition_warning(), cb_field::sister, cb_field::storage, cb_field::usage, and cb_reference::word.

Referenced by cb_build_debug_item().

93 {
94  struct cb_reference *r;
95  struct cb_field *f;
96  struct cb_field *p;
97  struct cb_field *field_fill;
98  cb_tree dummy_fill;
99  cb_tree l;
100  cb_tree x;
101  int lv;
102 
103  if (!expl_level) {
104  if (level == cb_error_node || name == cb_error_node) {
105  return cb_error_node;
106  }
107  /* Check the level number */
108  lv = cb_get_level (level);
109  if (!lv) {
110  return cb_error_node;
111  }
112  } else {
113  lv = expl_level;
114  }
115 
116  /* Build the field */
117  r = CB_REFERENCE (name);
118  f = CB_FIELD (cb_build_field (name));
119  f->storage = storage;
120  last_real_field = last_field;
121  if (lv == 78) {
122  f->level = 01;
123  f->flag_item_78 = 1;
124  return CB_TREE (f);
125  } else {
126  f->level = lv;
127  }
128  if (f->level == 01 && storage == CB_STORAGE_FILE && fn) {
129  if (fn->flag_external) {
130  f->flag_external = 1;
131  current_program->flag_has_external = 1;
132  } else if (fn->flag_global) {
133  f->flag_is_global = 1;
134  }
135  }
136  if (last_field) {
137  if (last_field->level == 77 && f->level != 01 &&
138  f->level != 77 && f->level != 66 && f->level != 88) {
139  cb_error_x (name, _("Level number must begin with 01 or 77"));
140  return cb_error_node;
141  }
142  }
143 
144  /* Checks for redefinition */
145  if (cb_warn_redefinition && r->word->count > 1 && !r->flag_filler_ref) {
146  if (f->level == 01 || f->level == 77) {
147  redefinition_warning (name, NULL);
148  } else {
149  for (l = r->word->items; l; l = CB_CHAIN (l)) {
150  x = CB_VALUE (l);
151  if (!CB_FIELD_P (x) ||
152  CB_FIELD (x)->level == 01 ||
153  CB_FIELD (x)->level == 77 ||
154  (last_field && f->level == last_field->level &&
155  CB_FIELD (x)->parent == last_field->parent)) {
156  redefinition_warning (name, x);
157  break;
158  }
159  }
160  }
161  }
162 
163  if (last_field && last_field->level == 88) {
164  last_field = last_field->parent;
165  }
166 
167  /* Link the field into the tree */
168  if (f->level == 01 || f->level == 77) {
169  /* Top level */
170  cb_needs_01 = 0;
171  if (last_field) {
172  cb_field_founder (last_field)->sister = f;
173  }
174  } else if (!last_field || cb_needs_01) {
175  /* Invalid top level */
176  cb_error_x (name, _("Level number must begin with 01 or 77"));
177  return cb_error_node;
178  } else if (f->level == 66) {
179  /* Level 66 */
180  f->parent = cb_field_founder (last_field);
181  for (p = f->parent->children; p && p->sister; p = p->sister) ;
182  if (p) {
183  p->sister = f;
184  }
185  } else if (f->level == 88) {
186  /* Level 88 */
187  f->parent = last_field;
188  } else if (f->level > last_field->level) {
189  /* Lower level */
190  last_field->children = f;
191  f->parent = last_field;
192  } else if (f->level == last_field->level) {
193  /* Same level */
194 same_level:
195  last_field->sister = f;
196  f->parent = last_field->parent;
197  } else {
198  /* Upper level */
199  for (p = last_field->parent; p; p = p->parent) {
200  if (p->level == f->level) {
201  last_field = p;
202  goto same_level;
203  }
204  if (cb_relax_level_hierarchy && p->level < f->level) {
205  break;
206  }
207  }
208  if (cb_relax_level_hierarchy) {
209  dummy_fill = cb_build_filler ();
210  field_fill = CB_FIELD (cb_build_field (dummy_fill));
211  cb_warning_x (name,
212  _("No previous data item of level %02d"),
213  f->level);
214  field_fill->level = f->level;
215  field_fill->flag_filler = 1;
216  field_fill->storage = storage;
217  field_fill->children = p->children;
218  field_fill->parent = p;
219  for (p = p->children; p; p = p->sister) {
220  p->parent = field_fill;
221  }
222  field_fill->parent->children = field_fill;
223  field_fill->sister = f;
224  f->parent = field_fill->parent;
225  /* last_field = field_fill; */
226  } else {
227  cb_error_x (name,
228  _("No previous data item of level %02d"),
229  f->level);
230  return cb_error_node;
231  }
232  }
233 
234  /* Inherit parents properties */
235  if (f->parent) {
236  f->usage = f->parent->usage;
237  f->indexes = f->parent->indexes;
238  f->flag_sign_leading = f->parent->flag_sign_leading;
239  f->flag_sign_separate = f->parent->flag_sign_separate;
240  f->flag_is_global = f->parent->flag_is_global;
241  }
242  return CB_TREE (f);
243 }
void cb_clear_real_field ( void  )

References NULL.

Referenced by cb_build_program().

1437 {
1438  last_real_field = NULL;
1439 }
int cb_get_level ( cb_tree  x)

References _, cb_error_x(), CB_INVALID_TREE, CB_NAME, cb_field::level, cb_field::name, and p.

Referenced by cb_build_field_tree().

47 {
48  const unsigned char *p;
49  const char *name;
50  int level;
51 
52  if (CB_INVALID_TREE (x)) {
53  return 0;
54  }
55  name = CB_NAME (x);
56  level = 0;
57  /* Get level */
58  for (p = (const unsigned char *)name; *p; p++) {
59  if (!isdigit ((int)(*p))) {
60  goto level_error;
61  }
62  level = level * 10 + (*p - '0');
63  if (level > 88) {
64  goto level_error;
65  }
66  }
67 
68  /* Check level */
69  switch (level) {
70  case 66:
71  case 77:
72  case 78:
73  case 88:
74  break;
75  default:
76  if (level < 1 || level > 49) {
77  goto level_error;
78  }
79  break;
80  }
81 
82  return level;
83 
84 level_error:
85  cb_error_x (x, _("Invalid level number '%s'"), name);
86  return 0;
87 }
struct cb_field* cb_get_real_field ( void  )
read

References last_real_field.

1443 {
1444  return last_real_field;
1445 }
struct cb_field* cb_resolve_redefines ( struct cb_field *  field,
cb_tree  redefines 
)
read

References _, CB_CHAIN, cb_error_x(), CB_FIELD_P, CB_FIELD_PTR, CB_NAME, CB_REFERENCE, CB_TREE, CB_VALUE, cb_reference::chain, cb_field::children, cb_word::items, cb_field::level, cb_field::name, NULL, cb_field::parent, cb_field::redefines, cb_field::sister, cb_reference::subs, undefined_error(), and cb_reference::word.

247 {
248  struct cb_field *f;
249  struct cb_reference *r;
250  const char *name;
251  cb_tree x;
252  cb_tree candidate;
253  cb_tree items;
254 
255  r = CB_REFERENCE (redefines);
256  name = CB_NAME (redefines);
257  x = CB_TREE (field);
258 
259  /* Check qualification */
260  if (r->chain) {
261  cb_error_x (x, _("'%s' cannot be qualified here"), name);
262  return NULL;
263  }
264 
265  /* Check subscripts */
266  if (r->subs) {
267  cb_error_x (x, _("'%s' cannot be subscripted here"), name);
268  return NULL;
269  }
270 
271  /* Resolve the name in the current group (if any) */
272  if (field->parent && field->parent->children) {
273  for (f = field->parent->children; f; f = f->sister) {
274  if (strcasecmp (f->name, name) == 0) {
275  break;
276  }
277  }
278  if (f == NULL) {
279  cb_error_x (x, _("'%s' is not defined in '%s'"), name, field->parent->name);
280  return NULL;
281  }
282  } else {
283  /* Get last defined name */
284  candidate = NULL;
285  items = r->word->items;
286  for (; items; items = CB_CHAIN (items)) {
287  if (CB_FIELD_P (CB_VALUE (items))) {
288  candidate = CB_VALUE (items);
289  }
290  }
291  if (!candidate) {
292  undefined_error (redefines);
293  return NULL;
294  }
295  f = CB_FIELD_PTR (candidate);
296  }
297 
298  /* Check level number */
299  if (f->level != field->level) {
300  cb_error_x (x, _("Level number of REDEFINES entries must be identical"));
301  return NULL;
302  }
303  if (f->level == 66 || f->level == 88) {
304  cb_error_x (x, _("Level number of REDEFINES entry cannot be 66 or 88"));
305  return NULL;
306  }
307 
308  if (!cb_indirect_redefines && f->redefines) {
309  cb_error_x (x, _("'%s' not the original definition"), f->name);
310  return NULL;
311  }
312 
313  /* Return the original definition */
314  while (f->redefines) {
315  f = f->redefines;
316  }
317  return f;
318 }
struct cb_field* cb_validate_78_item ( struct cb_field *  f,
const cob_u32_t  no78add 
)
read

References cb_add_78(), CB_INVALID_TREE, CB_TREE, CB_VALUE, cob_u32_t, cb_field::flag_occurs, last_real_field, level_except_error(), level_require_error(), cb_field::pic, and cb_field::values.

Referenced by cb_add_const_var(), and cb_build_symbolic_chars().

1413 {
1414  cb_tree x;
1415  cob_u32_t noadd;
1416 
1417  x = CB_TREE (f);
1418  noadd = no78add;
1419  if (CB_INVALID_TREE(f->values) ||
1420  CB_INVALID_TREE(CB_VALUE(f->values))) {
1421  level_require_error (x, "VALUE");
1422  noadd = 1;
1423  }
1424 
1425  if (f->pic || f->flag_occurs) {
1426  level_except_error (x, "VALUE");
1427  noadd = 1;
1428  }
1429  if (!noadd) {
1430  cb_add_78 (f);
1431  }
1432  return last_real_field;
1433 }
void cb_validate_88_item ( struct cb_field *  f)

References _, CB_CHAIN, CB_CLASS_NUMERIC, cb_error_x(), cb_high, cb_low, cb_quote, cb_space, CB_TREE, CB_TREE_CLASS, CB_VALID_TREE, CB_VALUE, cb_field::flag_occurs, level_except_error(), level_require_error(), cb_field::parent, cb_field::pic, and cb_field::values.

1384 {
1385  cb_tree x;
1386  cb_tree l;
1387  cb_tree t;
1388 
1389  x = CB_TREE (f);
1390  if (!f->values) {
1391  level_require_error (x, "VALUE");
1392  return;
1393  }
1394 
1395  if (f->pic || f->flag_occurs) {
1396  level_except_error (x, "VALUE");
1397  return;
1398  }
1399  if (CB_VALID_TREE(f->parent) &&
1400  CB_TREE_CLASS (f->parent) == CB_CLASS_NUMERIC) {
1401  for (l = f->values; l; l = CB_CHAIN (l)) {
1402  t = CB_VALUE (l);
1403  if (t == cb_space || t == cb_low ||
1404  t == cb_high || t == cb_quote) {
1405  cb_error_x (x, _("Literal type does not match data type"));
1406  }
1407  }
1408  }
1409 }
void cb_validate_field ( struct cb_field *  f)

References CB_STORAGE_LINKAGE, CB_STORAGE_LOCAL, cb_field::children, compute_size(), cb_field::count, cb_field::flag_base, cb_field::flag_invalid, cb_field::flag_is_global, cb_field::flag_is_verified, cb_field::flag_item_78, cb_field::flag_item_based, cb_field::flag_local, cb_field::memory_size, occur_align_size, cb_field::occurs_max, cb_field::redefines, setup_parameters(), cb_field::sister, cb_field::size, cb_field::storage, validate_field_1(), and validate_field_value().

Referenced by cb_build_const_length(), cb_build_debug_item(), cb_build_implicit_field(), cb_build_index(), cb_validate_program_data(), and finalize_file().

1336 {
1337  struct cb_field *c;
1338 
1339  if (f->flag_is_verified) {
1340  return;
1341  }
1342  if (validate_field_1 (f) != 0) {
1343  f->flag_invalid = 1;
1344  return;
1345  }
1346  if (f->flag_item_78) {
1347  f->flag_is_verified = 1;
1348  return;
1349  }
1350 
1351  /* Set up parameters */
1352  if (f->storage == CB_STORAGE_LOCAL ||
1353  f->storage == CB_STORAGE_LINKAGE ||
1354  f->flag_item_based) {
1355  f->flag_local = 1;
1356  }
1357  if (f->storage == CB_STORAGE_LINKAGE || f->flag_item_based) {
1358  f->flag_base = 1;
1359  }
1360  setup_parameters (f);
1361 
1362  /* Compute size */
1363  occur_align_size = 1;
1364  compute_size (f);
1365  if (!f->redefines) {
1366  f->memory_size = f->size * f->occurs_max;
1367  } else if (f->redefines->memory_size < f->size * f->occurs_max) {
1368  f->redefines->memory_size = f->size * f->occurs_max;
1369  }
1370 
1371  validate_field_value (f);
1372  if (f->flag_is_global) {
1373  f->count++;
1374  for (c = f->children; c; c = c->sister) {
1375  c->flag_is_global = 1;
1376  c->count++;
1377  }
1378  }
1379  f->flag_is_verified = 1;
1380 }
static unsigned int check_picture_item ( cb_tree  x,
struct cb_field *  f 
)
static

References _, cb_picture::category, cb_build_picture(), CB_CATEGORY_ALPHANUMERIC, CB_CATEGORY_NUMERIC, cb_error_node, cb_error_x(), CB_FIELD_PTR, CB_LITERAL, cb_name(), CB_NUMERIC_LITERAL_P, CB_PICTURE, CB_STORAGE_SCREEN, CB_USAGE_COMP_5, CB_USAGE_DISPLAY, CB_VALUE, cb_warning_x(), cb_field::count, cb_field::flag_item_78, cb_field::flag_no_field, if(), cb_field::level, level_require_error(), cb_field::pic, cb_literal::scale, cb_field::screen_from, cb_field::screen_to, cb_literal::sign, cb_literal::size, cb_field::storage, cb_field::usage, cb_field::values, and warningopt.

Referenced by validate_field_1().

333 {
334  char *pp;
335  struct cb_literal *lp;
336  int vorint;
337  char pic[24];
338 
339  if (f->storage == CB_STORAGE_SCREEN) {
340  /* RXWRXW Fixme - Corner cases */
341  if (f->values) {
342  sprintf (pic, "X(%d)", (int)CB_LITERAL(CB_VALUE(f->values))->size);
343  } else if (f->screen_from) {
344  sprintf (pic, "X(%d)", (int)CB_FIELD_PTR (f->screen_from)->size);
345  } else if (f->screen_to) {
346  sprintf (pic, "X(%d)", (int)CB_FIELD_PTR (f->screen_to)->size);
347  } else {
348  f->flag_no_field = 1;
349  strcpy (pic, "X(1)");
350  }
351  f->pic = CB_PICTURE (cb_build_picture (pic));
352  return 0;
353  }
354  if (f->flag_item_78) {
355  if (!f->values || CB_VALUE(f->values) == cb_error_node) {
356  level_require_error (x, "VALUE");
357  return 1;
358  }
359  f->count++;
360  lp = CB_LITERAL(CB_VALUE(f->values));
361  if (CB_NUMERIC_LITERAL_P(CB_VALUE(f->values))) {
362  memset (pic, 0, sizeof (pic));
363  pp = pic;
364  if (lp->sign) {
365  *pp++ = 'S';
366  }
367  vorint = (int)lp->size - lp->scale;
368  if (vorint) {
369  pp += sprintf (pp, "9(%d)", vorint);
370  }
371  if (lp->scale) {
372  sprintf (pp, "V9(%d)", lp->scale);
373  }
374  if (lp->size < 10) {
375  f->usage = CB_USAGE_COMP_5;
376  } else {
377  f->usage = CB_USAGE_DISPLAY;
378  }
379  f->pic = CB_PICTURE (cb_build_picture (pic));
380  f->pic->category = CB_CATEGORY_NUMERIC;
381  } else {
382  sprintf (pic, "X(%d)", (int)lp->size);
383  f->pic = CB_PICTURE (cb_build_picture (pic));
384  f->pic->category = CB_CATEGORY_ALPHANUMERIC;
385  f->usage = CB_USAGE_DISPLAY;
386  }
387  return 0;
388  }
389  if (f->level == 1) {
390  cb_error_x (x, _("PICTURE clause required for '%s'"),
391  cb_name (x));
392  return 1;
393  }
394  if (!f->values || CB_VALUE(f->values) == cb_error_node) {
395  cb_error_x (x, _("PICTURE clause required for '%s'"),
396  cb_name (x));
397  return 1;
398  }
399  if (CB_NUMERIC_LITERAL_P(CB_VALUE(f->values))) {
400  cb_error_x (x, _("A non-numeric literal is expected for '%s'"),
401  cb_name (x));
402  return 1;
403  }
404  vorint = (int)CB_LITERAL(CB_VALUE(f->values))->size;
405  if (warningopt) {
406  cb_warning_x (x, _("Defining implicit picture size %d for '%s'"),
407  vorint, cb_name (x));
408  }
409  sprintf (pic, "X(%d)", vorint);
410  f->pic = CB_PICTURE (cb_build_picture (pic));
411  f->pic->category = CB_CATEGORY_ALPHANUMERIC;
412  f->usage = CB_USAGE_DISPLAY;
413  return 0;
414 }
static void compute_binary_size ( struct cb_field *  f,
const int  size 
)
static

References CB_BINARY_SIZE_1_2_4_8, CB_BINARY_SIZE_1__8, CB_BINARY_SIZE_2_4_8, cb_field::flag_real_binary, cb_picture::have_sign, cb_field::pic, and cb_field::size.

Referenced by compute_size().

919 {
920  if (cb_binary_size == CB_BINARY_SIZE_1_2_4_8) {
921  f->size = ((size <= 2) ? 1 :
922  (size <= 4) ? 2 :
923  (size <= 9) ? 4 : (size <= 18) ? 8 : 16);
924  return;
925  }
926  if (cb_binary_size == CB_BINARY_SIZE_2_4_8) {
927  if (f->flag_real_binary && size <= 2) {
928  f->size = 1;
929  } else {
930  f->size = ((size <= 4) ? 2 :
931  (size <= 9) ? 4 : (size <= 18) ? 8 : 16);
932  }
933  return;
934  }
935  if (cb_binary_size != CB_BINARY_SIZE_1__8) {
936  f->size = size;
937  return;
938  }
939  if (f->pic->have_sign) {
940  switch (size) {
941  case 0:
942  case 1:
943  case 2:
944  f->size = 1;
945  return;
946  case 3:
947  case 4:
948  f->size = 2;
949  return;
950  case 5:
951  case 6:
952  f->size = 3;
953  return;
954  case 7:
955  case 8:
956  case 9:
957  f->size = 4;
958  return;
959  case 10:
960  case 11:
961  f->size = 5;
962  return;
963  case 12:
964  case 13:
965  case 14:
966  f->size = 6;
967  return;
968  case 15:
969  case 16:
970  f->size = 7;
971  return;
972  case 17:
973  case 18:
974  f->size = 8;
975  return;
976  case 19:
977  case 20:
978  case 21:
979  f->size = 9;
980  return;
981  case 22:
982  case 23:
983  f->size = 10;
984  return;
985  case 24:
986  case 25:
987  case 26:
988  f->size = 11;
989  return;
990  case 27:
991  case 28:
992  f->size = 12;
993  return;
994  case 29:
995  case 30:
996  case 31:
997  f->size = 13;
998  return;
999  case 32:
1000  case 33:
1001  f->size = 14;
1002  return;
1003  case 34:
1004  case 35:
1005  f->size = 15;
1006  return;
1007  default:
1008  f->size = 16;
1009  return;
1010  }
1011  }
1012  switch (size) {
1013  case 0:
1014  case 1:
1015  case 2:
1016  f->size = 1;
1017  return;
1018  case 3:
1019  case 4:
1020  f->size = 2;
1021  return;
1022  case 5:
1023  case 6:
1024  case 7:
1025  f->size = 3;
1026  return;
1027  case 8:
1028  case 9:
1029  f->size = 4;
1030  return;
1031  case 10:
1032  case 11:
1033  case 12:
1034  f->size = 5;
1035  return;
1036  case 13:
1037  case 14:
1038  f->size = 6;
1039  return;
1040  case 15:
1041  case 16:
1042  f->size = 7;
1043  return;
1044  case 17:
1045  case 18:
1046  case 19:
1047  f->size = 8;
1048  return;
1049  case 20:
1050  case 21:
1051  f->size = 9;
1052  return;
1053  case 22:
1054  case 23:
1055  case 24:
1056  f->size = 10;
1057  return;
1058  case 25:
1059  case 26:
1060  f->size = 11;
1061  return;
1062  case 27:
1063  case 28:
1064  f->size = 12;
1065  return;
1066  case 29:
1067  case 30:
1068  case 31:
1069  f->size = 13;
1070  return;
1071  case 32:
1072  case 33:
1073  f->size = 14;
1074  return;
1075  case 34:
1076  case 35:
1077  case 36:
1078  f->size = 15;
1079  return;
1080  default:
1081  f->size = 16;
1082  return;
1083  }
1084 }
static int compute_size ( struct cb_field *  f)
static

References _, cb_picture::category, CB_CATEGORY_ALPHANUMERIC, cb_error_x(), cb_name(), CB_TREE, CB_USAGE_BINARY, CB_USAGE_COMP_5, CB_USAGE_COMP_6, CB_USAGE_COMP_X, CB_USAGE_DISPLAY, CB_USAGE_DOUBLE, CB_USAGE_FLOAT, CB_USAGE_FP_BIN128, CB_USAGE_FP_BIN32, CB_USAGE_FP_BIN64, CB_USAGE_FP_DEC128, CB_USAGE_FP_DEC64, CB_USAGE_INDEX, CB_USAGE_LENGTH, CB_USAGE_LONG_DOUBLE, CB_USAGE_OBJECT, CB_USAGE_PACKED, CB_USAGE_POINTER, CB_USAGE_PROGRAM, CB_USAGE_PROGRAM_POINTER, cb_verify(), cb_warning_x(), cb_field::children, COB_MAX_BINARY, COB_MAX_FIELD_SIZE, cob_u64_t, COBC_ABORT, cobc_abort_pr(), compute_binary_size(), cb_field::flag_binary_swap, cb_field::flag_external, cb_field::flag_sign_separate, cb_field::flag_synchronized, cb_picture::have_sign, cb_field::level, cb_field::name, occur_align_size, cb_field::occurs_max, cb_field::offset, cb_field::pic, cb_field::redefines, cb_field::rename_thru, cb_field::sister, cb_picture::size, cb_field::size, cb_field::usage, and warningopt.

Referenced by cb_validate_field().

1088 {
1089  struct cb_field *c;
1090  int size;
1091  cob_u64_t size_check;
1092  int align_size;
1093  int pad;
1094 
1095  int maxsz;
1096  struct cb_field *c0;
1097 
1098  if (f->level == 66) {
1099  /* Rename */
1100  if (f->rename_thru) {
1101  f->size = f->rename_thru->offset + f->rename_thru->size -
1102  f->redefines->offset;
1103  } else {
1104  f->size = f->redefines->size;
1105  }
1106  return f->size;
1107  }
1108 
1109  if (f->children) {
1110  /* Groups */
1111  if (f->flag_synchronized && warningopt) {
1112  cb_warning_x (CB_TREE(f), _("Ignoring SYNCHRONIZED for group item '%s'"),
1113  cb_name (CB_TREE (f)));
1114  }
1115  size_check = 0;
1116  occur_align_size = 1;
1117  for (c = f->children; c; c = c->sister) {
1118  if (c->redefines) {
1119  c->offset = c->redefines->offset;
1120  compute_size (c);
1121  /* Increase the size if redefinition is larger */
1122  if (c->level != 66 &&
1123  c->size * c->occurs_max >
1124  c->redefines->size * c->redefines->occurs_max) {
1125  if (cb_larger_redefines_ok) {
1126  cb_warning_x (CB_TREE (c),
1127  _("Size of '%s' larger than size of '%s'"),
1128  c->name, c->redefines->name);
1129  maxsz = c->redefines->size * c->redefines->occurs_max;
1130  for (c0 = c->redefines->sister; c0 != c; c0 = c0->sister) {
1131  if (c0->size * c0->occurs_max > maxsz) {
1132  maxsz = c0->size * c0->occurs_max;
1133  }
1134  }
1135  if (c->size * c->occurs_max > maxsz) {
1136  size_check += (c->size * c->occurs_max) - maxsz;
1137  }
1138  } else {
1139  cb_error_x (CB_TREE (c),
1140  _("Size of '%s' larger than size of '%s'"),
1141  c->name, c->redefines->name);
1142  }
1143  }
1144  } else {
1145  c->offset = f->offset + (int) size_check;
1146  size_check += compute_size (c) * c->occurs_max;
1147 
1148  /* Word alignment */
1149  if (c->flag_synchronized &&
1150  cb_verify (cb_synchronized_clause, "SYNC")) {
1151  align_size = 1;
1152  switch (c->usage) {
1153  case CB_USAGE_BINARY:
1154  case CB_USAGE_COMP_5:
1155  case CB_USAGE_COMP_X:
1156  case CB_USAGE_FLOAT:
1157  case CB_USAGE_DOUBLE:
1158  case CB_USAGE_LONG_DOUBLE:
1159  case CB_USAGE_FP_BIN32:
1160  case CB_USAGE_FP_BIN64:
1161  case CB_USAGE_FP_BIN128:
1162  case CB_USAGE_FP_DEC64:
1163  case CB_USAGE_FP_DEC128:
1164  if (c->size == 2 ||
1165  c->size == 4 ||
1166  c->size == 8 ||
1167  c->size == 16) {
1168  align_size = c->size;
1169  }
1170  break;
1171  case CB_USAGE_INDEX:
1172  case CB_USAGE_LENGTH:
1173  align_size = sizeof (int);
1174  break;
1175  case CB_USAGE_OBJECT:
1176  case CB_USAGE_POINTER:
1177  case CB_USAGE_PROGRAM_POINTER:
1178  case CB_USAGE_PROGRAM:
1179  align_size = sizeof (void *);
1180  break;
1181  default:
1182  break;
1183  }
1184  if (c->offset % align_size != 0) {
1185  pad = align_size - (c->offset % align_size);
1186  c->offset += pad;
1187  size_check += pad;
1188  }
1189  if (align_size > occur_align_size) {
1190  occur_align_size = align_size;
1191  }
1192  }
1193  }
1194  }
1195  if (f->occurs_max > 1 && (size_check % occur_align_size) != 0) {
1196  pad = occur_align_size - (size_check % occur_align_size);
1197  size_check += pad;
1198  f->offset += pad;
1199  }
1200  /* size check for group items */
1201  if (size_check > COB_MAX_FIELD_SIZE) {
1202  cb_error_x (CB_TREE (f),
1203  _("'%s' cannot be larger than %d bytes"),
1204  f->name, COB_MAX_FIELD_SIZE);
1205  }
1206  f->size = (int) size_check;
1207  } else {
1208  /* Elementary item */
1209  switch (f->usage) {
1210  case CB_USAGE_COMP_X:
1211  if (f->pic->category == CB_CATEGORY_ALPHANUMERIC) {
1212  break;
1213  }
1214  size = f->pic->size;
1215  f->size = ((size <= 2) ? 1 : (size <= 4) ? 2 :
1216  (size <= 7) ? 3 : (size <= 9) ? 4 :
1217  (size <= 12) ? 5 : (size <= 14) ? 6 :
1218  (size <= 16) ? 7 : (size <= 19) ? 8 :
1219  (size <= 21) ? 9 : (size <= 24) ? 10 :
1220  (size <= 26) ? 11 : (size <= 28) ? 12 :
1221  (size <= 31) ? 13 : (size <= 33) ? 14 :
1222  (size <= 36) ? 15 : 16);
1223  break;
1224  case CB_USAGE_BINARY:
1225  case CB_USAGE_COMP_5:
1226  size = f->pic->size;
1227 #if 0 /* RXWRXW - Max binary */
1228  if (size > COB_MAX_BINARY) {
1229  f->flag_binary_swap = 0;
1230  size = 38;
1231  cb_error_x (CB_TREE (f),
1232  _("'%s' binary field cannot be larger than %d digits"),
1233  f->name, COB_MAX_BINARY);
1234  }
1235 #else
1236  if (size > 18) {
1237  f->flag_binary_swap = 0;
1238  size = 18;
1239  cb_error_x (CB_TREE (f),
1240  _("'%s' binary field cannot be larger than %d digits"),
1241  f->name, 18);
1242  }
1243 #endif
1244  compute_binary_size (f, size);
1245  break;
1246  case CB_USAGE_DISPLAY:
1247  f->size = f->pic->size;
1248  /* size check for single items */
1249  if (f->size > COB_MAX_FIELD_SIZE) {
1250  cb_error_x (CB_TREE (f),
1251  _("'%s' cannot be larger than %d bytes"),
1252  f->name, COB_MAX_FIELD_SIZE);
1253  }
1254  if (f->pic->have_sign && f->flag_sign_separate) {
1255  f->size++;
1256  }
1257  break;
1258  case CB_USAGE_PACKED:
1259  f->size = f->pic->size / 2 + 1;
1260  break;
1261  case CB_USAGE_COMP_6:
1262  f->size = (f->pic->size + 1) / 2;
1263  break;
1264  case CB_USAGE_INDEX:
1265  case CB_USAGE_LENGTH:
1266  f->size = sizeof (int);
1267  break;
1268  case CB_USAGE_FLOAT:
1269  f->size = sizeof (float);
1270  break;
1271  case CB_USAGE_DOUBLE:
1272  f->size = sizeof (double);
1273  break;
1274  case CB_USAGE_LONG_DOUBLE:
1275  f->size = 16;
1276  break;
1277  case CB_USAGE_FP_BIN32:
1278  f->size = 4;
1279  break;
1280  case CB_USAGE_FP_BIN64:
1281  case CB_USAGE_FP_DEC64:
1282  f->size = 8;
1283  break;
1284  case CB_USAGE_FP_BIN128:
1285  case CB_USAGE_FP_DEC128:
1286  f->size = 16;
1287  break;
1288  case CB_USAGE_OBJECT:
1289  case CB_USAGE_POINTER:
1290  case CB_USAGE_PROGRAM_POINTER:
1291  case CB_USAGE_PROGRAM:
1292  f->size = sizeof (void *);
1293  break;
1294  default:
1295  cobc_abort_pr (_("Unexpected usage - %d"),
1296  (int)f->usage);
1297  COBC_ABORT ();
1298  }
1299  }
1300 
1301  /* The size of redefining field should not be larger than
1302  the size of redefined field unless the redefined field
1303  is level 01 and non-external */
1304  if (f->redefines && f->redefines->flag_external &&
1305  (f->size * f->occurs_max > f->redefines->size * f->redefines->occurs_max)) {
1306  if (cb_larger_redefines_ok) {
1307  cb_warning_x (CB_TREE (f), _("Size of '%s' larger than size of '%s'"),
1308  f->name, f->redefines->name);
1309  } else {
1310  cb_error_x (CB_TREE (f), _("Size of '%s' larger than size of '%s'"),
1311  f->name, f->redefines->name);
1312  }
1313  }
1314 
1315  return f->size;
1316 }
static void setup_parameters ( struct cb_field *  f)
static

References cb_picture::category, cb_build_picture(), CB_BYTEORDER_BIG_ENDIAN, CB_CATEGORY_ALPHANUMERIC, CB_PICTURE, CB_USAGE_BINARY, CB_USAGE_COMP_5, CB_USAGE_COMP_X, CB_USAGE_DOUBLE, CB_USAGE_FLOAT, CB_USAGE_FP_DEC128, CB_USAGE_FP_DEC64, CB_USAGE_INDEX, CB_USAGE_LENGTH, CB_USAGE_POINTER, CB_USAGE_PROGRAM_POINTER, cb_field::children, cb_field::flag_binary_swap, cb_field::flag_local, cb_field::pic, pic_digits, cb_field::sister, cb_picture::size, and cb_field::usage.

Referenced by cb_validate_field().

843 {
844  unsigned int flag_local;
845  char pic[8];
846 
847  /* Determine the class */
848  if (f->children) {
849  /* Group field */
850  flag_local = f->flag_local;
851  for (f = f->children; f; f = f->sister) {
852  f->flag_local = !!flag_local;
853  setup_parameters (f);
854  }
855  } else {
856  /* Regular field */
857  switch (f->usage) {
858  case CB_USAGE_BINARY:
859 #ifndef WORDS_BIGENDIAN
860  if (cb_binary_byteorder == CB_BYTEORDER_BIG_ENDIAN) {
861  f->flag_binary_swap = 1;
862  }
863 #endif
864  break;
865 
866  case CB_USAGE_INDEX:
867  f->pic = CB_PICTURE (cb_build_picture ("S9(9)"));
868  break;
869 
870  case CB_USAGE_LENGTH:
871  f->pic = CB_PICTURE (cb_build_picture ("9(9)"));
872  break;
873 
874  case CB_USAGE_POINTER:
875  case CB_USAGE_PROGRAM_POINTER:
876  f->pic = CB_PICTURE (cb_build_picture ("9(10)"));
877  break;
878  case CB_USAGE_FLOAT:
879  f->pic = CB_PICTURE (cb_build_picture ("S9(7)V9(8)"));
880  break;
881  case CB_USAGE_DOUBLE:
882  f->pic = CB_PICTURE (cb_build_picture ("S9(17)V9(17)"));
883  break;
884  case CB_USAGE_FP_DEC64:
885  /* RXWRXW - Scale Fix me */
886  f->pic = CB_PICTURE (cb_build_picture ("S9(17)V9(16)"));
887  break;
888  case CB_USAGE_FP_DEC128:
889  /* RXWRXW - Scale Fix me */
890  f->pic = CB_PICTURE (cb_build_picture ("S999V9(34)"));
891  break;
892 
893  case CB_USAGE_COMP_5:
894  case CB_USAGE_COMP_X:
895  if (f->pic->category == CB_CATEGORY_ALPHANUMERIC) {
896  if (f->pic->size > 8) {
897  strcpy (pic, "9(36)");
898  } else {
899  sprintf (pic, "9(%d)", pic_digits[f->pic->size - 1]);
900  }
901  f->pic = CB_PICTURE (cb_build_picture (pic));
902  }
903 #ifndef WORDS_BIGENDIAN
904  if (f->usage == CB_USAGE_COMP_X &&
905  cb_binary_byteorder == CB_BYTEORDER_BIG_ENDIAN) {
906  f->flag_binary_swap = 1;
907  }
908 #endif
909  break;
910 
911  default:
912  break;
913  }
914  }
915 }
static unsigned int validate_field_1 ( struct cb_field *  f)
static

References _, cb_picture::category, cb_build_binary_picture(), cb_build_picture(), CB_CATEGORY_ALPHABETIC, CB_CATEGORY_ALPHANUMERIC, CB_CATEGORY_NUMERIC, CB_CATEGORY_NUMERIC_EDITED, CB_CHAIN, cb_error_x(), CB_FIELD_PTR, cb_field_variable_size(), cb_list_add(), cb_name(), CB_PAIR_P, CB_PICTURE, CB_STORAGE_FILE, CB_STORAGE_LINKAGE, CB_STORAGE_LOCAL, CB_STORAGE_SCREEN, CB_STORAGE_WORKING, CB_TREE, CB_USAGE_BINARY, CB_USAGE_BIT, CB_USAGE_COMP_5, CB_USAGE_COMP_6, CB_USAGE_COMP_X, CB_USAGE_DISPLAY, CB_USAGE_DOUBLE, CB_USAGE_FLOAT, CB_USAGE_FP_BIN128, CB_USAGE_FP_BIN32, CB_USAGE_FP_BIN64, CB_USAGE_FP_DEC128, CB_USAGE_FP_DEC64, CB_USAGE_INDEX, CB_USAGE_LENGTH, CB_USAGE_LONG_DOUBLE, CB_USAGE_OBJECT, CB_USAGE_PACKED, CB_USAGE_POINTER, CB_USAGE_PROGRAM, CB_USAGE_PROGRAM_POINTER, CB_USAGE_SIGNED_CHAR, CB_USAGE_SIGNED_INT, CB_USAGE_SIGNED_LONG, CB_USAGE_SIGNED_SHORT, CB_USAGE_UNSIGNED_CHAR, CB_USAGE_UNSIGNED_INT, CB_USAGE_UNSIGNED_LONG, CB_USAGE_UNSIGNED_SHORT, CB_VALUE, cb_verify(), cb_warning_x(), check_picture_item(), cb_field::children, cobc_parse_malloc(), cb_field::count, current_program, cb_field::depending, cb_picture::digits, cb_field::flag_any_length, cb_field::flag_any_numeric, cb_field::flag_blank_zero, cb_field::flag_external, cb_field::flag_invalid, cb_field::flag_is_global, cb_field::flag_item_based, cb_field::flag_justified, cb_field::flag_occurs, cb_field::flag_real_binary, cb_field::flag_sign_leading, cb_field::flag_sign_separate, cb_program::flag_trailing_separate, group_error(), cb_picture::have_sign, cb_field::index_list, cb_picture::lenstr, cb_field::level, level_except_error(), level_redundant_error(), level_require_error(), cb_field::name, NULL, p, cb_field::parent, cb_field::pic, cb_field::redefines, cb_picture::scale, cb_field::screen_from, cb_field::screen_to, cb_field::sister, cb_picture::size, cb_field::storage, cb_picture::str, cb_field::usage, validate_field_clauses(), and cb_field::values.

Referenced by cb_validate_field().

418 {
419  cb_tree x;
420  cb_tree l;
421  struct cb_field *p;
422  unsigned char *pstr;
423  int vorint;
424  int n;
425  int need_picture;
426  unsigned int ret;
427 
428  if (f->flag_invalid) {
429  return 1;
430  }
431  x = CB_TREE (f);
432  if (f->flag_any_length) {
433  if (f->storage != CB_STORAGE_LINKAGE) {
434  cb_error_x (x, _("'%s' ANY LENGTH only allowed in LINKAGE"), cb_name (x));
435  return 1;
436  }
437  if (f->level != 01) {
438  cb_error_x (x, _("'%s' ANY LENGTH must be 01 level"), cb_name (x));
439  return 1;
440  }
441  if (f->flag_item_based || f->flag_external) {
442  cb_error_x (x, _("'%s' ANY LENGTH can not be BASED/EXTERNAL"), cb_name (x));
443  return 1;
444  }
445  if (f->flag_occurs || f->depending ||
446  f->children || f->values || f->flag_blank_zero) {
447  cb_error_x (x, _("'%s' ANY LENGTH has invalid definition"), cb_name (x));
448  return 1;
449  }
450  if (!f->pic) {
451  if (f->flag_any_numeric) {
452  f->pic = CB_PICTURE (cb_build_picture ("9"));
453  } else {
454  f->pic = CB_PICTURE (cb_build_picture ("X"));
455  }
456 #if 0 /* RXWRXW - ANY length */
457  cb_error_x (x, _("'%s' ANY LENGTH must have a PICTURE"), cb_name (x));
458  return 1;
459 #endif
460  }
461  if (f->pic->size != 1 || f->usage != CB_USAGE_DISPLAY) {
462  cb_error_x (x, _("'%s' ANY LENGTH has invalid definition"), cb_name (x));
463  return 1;
464  }
465  f->count++;
466  return 0;
467  }
468 
469  if (f->level == 77) {
470  if (f->storage != CB_STORAGE_WORKING &&
471  f->storage != CB_STORAGE_LOCAL &&
472  f->storage != CB_STORAGE_LINKAGE) {
473  cb_error_x (x, _("'%s' 77 level not allowed here"), cb_name (x));
474  }
475  }
476  if (f->flag_external) {
477  if (f->level != 01 && f->level != 77) {
478  cb_error_x (x, _("'%s' EXTERNAL must be specified at 01/77 level"), cb_name (x));
479  }
480  if (f->storage != CB_STORAGE_WORKING &&
481  f->storage != CB_STORAGE_FILE) {
482  cb_error_x (x, _("'%s' EXTERNAL can only be specified in WORKING-STORAGE section"),
483  cb_name (x));
484  }
485  if (f->flag_item_based) {
486  cb_error_x (x, _("'%s' EXTERNAL and BASED are mutually exclusive"), cb_name (x));
487  }
488  if (f->redefines) {
489  cb_error_x (x, _("'%s' EXTERNAL not allowed with REDEFINES"), cb_name (x));
490  }
491  }
492  if (f->flag_item_based) {
493  if (f->storage != CB_STORAGE_WORKING &&
494  f->storage != CB_STORAGE_LOCAL &&
495  f->storage != CB_STORAGE_LINKAGE) {
496  cb_error_x (x, _("'%s' BASED not allowed here"), cb_name (x));
497  }
498  if (f->redefines) {
499  cb_error_x (x, _("'%s' BASED not allowed with REDEFINES"), cb_name (x));
500  }
501  if (f->level != 01 && f->level != 77) {
502  cb_error_x (x, _("'%s' BASED only allowed at the 01 and 77 levels"), cb_name (x));
503  }
504  }
505  if (f->level == 66) {
506  if (!f->redefines) {
507  level_require_error (x, "RENAMES");
508  return 1;
509  }
510  if (f->flag_occurs) {
511  level_except_error (x, "RENAMES");
512  }
513  return 0;
514  }
515 
516  /* Validate OCCURS */
517  if (f->flag_occurs) {
518  if ((!cb_verify (cb_top_level_occurs_clause, "01/77 OCCURS") &&
519  (f->level == 01 || f->level == 77)) ||
520  (f->level == 66 || f->level == 88)) {
521  level_redundant_error (x, "OCCURS");
522  }
523  for (l = f->index_list; l; l = CB_CHAIN (l)) {
524  CB_FIELD_PTR (CB_VALUE (l))->flag_is_global = f->flag_is_global;
525  }
526  }
527 
528  /* Validate OCCURS DEPENDING */
529  if (f->depending) {
530  /* The data item that contains a OCCURS DEPENDING clause shall not
531  be subordinate to a data item that has an OCCURS clause */
532  for (p = f->parent; p; p = p->parent) {
533  if (p->flag_occurs) {
534  cb_error_x (CB_TREE (p),
535  _("'%s' cannot have the OCCURS clause due to '%s'"),
536  cb_name (CB_TREE (p)),
537  cb_name (x));
538  break;
539  }
540  }
541 
542  /* Cache field for later checking */
543  cb_depend_check = cb_list_add (cb_depend_check, x);
544  }
545 
546  /* Validate REDEFINES */
547  if (f->redefines) {
548  /* Check OCCURS */
549  if (f->redefines->flag_occurs) {
550  cb_warning_x (x, _("The original definition '%s' should not have OCCURS"),
551  f->redefines->name);
552  }
553 
554  /* Check definition */
555  for (p = f->redefines->sister; p && p != f; p = p->sister) {
556  if (!p->redefines) {
557  cb_error_x (x, _("REDEFINES must follow the original definition"));
558  break;
559  }
560  }
561 
562  /* Check variable occurrence */
563  if (f->depending || cb_field_variable_size (f)) {
564  cb_error_x (x, _("'%s' cannot be variable length"), f->name);
565  }
566  if (cb_field_variable_size (f->redefines)) {
567  cb_error_x (x,
568  _("The original definition '%s' cannot be variable length"),
569  f->redefines->name);
570  }
571  }
572 
573  if (f->children) {
574  /* Group item */
575 
576  if (f->pic) {
577  group_error (x, "PICTURE");
578  }
579  if (f->flag_justified) {
580  group_error (x, "JUSTIFIED RIGHT");
581  }
582  if (f->flag_blank_zero) {
583  group_error (x, "BLANK WHEN ZERO");
584  }
585 
586  ret = 0;
587  if (f->storage == CB_STORAGE_SCREEN &&
588  (f->screen_from || f->screen_to || f->values || f->pic)) {
589  cb_error_x (x, _("SCREEN group item '%s' has invalid clause"),
590  cb_name (x));
591  ret = 1;
592  }
593  for (f = f->children; f; f = f->sister) {
594  ret |= validate_field_1 (f);
595  }
596  if (ret) {
597  return 1;
598  }
599  } else {
600  /* Elementary item */
601 
602  /* Validate PICTURE */
603  switch (f->usage) {
604  case CB_USAGE_INDEX:
605  case CB_USAGE_LENGTH:
606  case CB_USAGE_OBJECT:
607  case CB_USAGE_POINTER:
608  case CB_USAGE_PROGRAM_POINTER:
609  case CB_USAGE_FLOAT:
610  case CB_USAGE_DOUBLE:
611  case CB_USAGE_LONG_DOUBLE:
612  case CB_USAGE_FP_BIN32:
613  case CB_USAGE_FP_BIN64:
614  case CB_USAGE_FP_BIN128:
615  case CB_USAGE_FP_DEC64:
616  case CB_USAGE_FP_DEC128:
617  case CB_USAGE_SIGNED_CHAR:
618  case CB_USAGE_SIGNED_SHORT:
619  case CB_USAGE_SIGNED_INT:
620  case CB_USAGE_SIGNED_LONG:
621  case CB_USAGE_UNSIGNED_CHAR:
622  case CB_USAGE_UNSIGNED_SHORT:
623  case CB_USAGE_UNSIGNED_INT:
624  case CB_USAGE_UNSIGNED_LONG:
625  case CB_USAGE_PROGRAM:
626  need_picture = 0;
627  break;
628  default:
629  need_picture = 1;
630  break;
631  }
632 
633  if (f->pic == NULL && need_picture != 0) {
634  if (check_picture_item (x, f)) {
635  return 1;
636  }
637  }
638  if (f->pic != NULL && need_picture == 0) {
639  cb_error_x (x, _("'%s' cannot have PICTURE clause"),
640  cb_name (x));
641  }
642 
643  /* Validate USAGE */
644  switch (f->usage) {
645  case CB_USAGE_DISPLAY:
646  if (current_program->flag_trailing_separate &&
647  f->pic &&
648  f->pic->category == CB_CATEGORY_NUMERIC &&
649  !f->flag_sign_leading) {
650  f->flag_sign_separate = 1;
651  }
652  break;
653  case CB_USAGE_SIGNED_CHAR:
654  f->usage = CB_USAGE_COMP_5;
655  f->pic = cb_build_binary_picture ("BINARY-CHAR", 2, 1);
656  f->flag_real_binary = 1;
657  validate_field_clauses (x, f);
658  break;
659  case CB_USAGE_SIGNED_SHORT:
660  f->usage = CB_USAGE_COMP_5;
661  f->pic = cb_build_binary_picture ("BINARY-SHORT", 4, 1);
662  f->flag_real_binary = 1;
663  validate_field_clauses (x, f);
664  break;
665  case CB_USAGE_SIGNED_INT:
666  f->usage = CB_USAGE_COMP_5;
667  f->pic = cb_build_binary_picture ("BINARY-LONG", 9, 1);
668  f->flag_real_binary = 1;
669  validate_field_clauses (x, f);
670  break;
671  case CB_USAGE_SIGNED_LONG:
672  f->usage = CB_USAGE_COMP_5;
673  f->pic = cb_build_binary_picture ("BINARY-DOUBLE", 18, 1);
674  f->flag_real_binary = 1;
675  validate_field_clauses (x, f);
676  break;
677  case CB_USAGE_UNSIGNED_CHAR:
678  f->usage = CB_USAGE_COMP_5;
679  f->pic = cb_build_binary_picture ("BINARY-CHAR", 2, 0);
680  f->flag_real_binary = 1;
681  validate_field_clauses (x, f);
682  break;
683  case CB_USAGE_UNSIGNED_SHORT:
684  f->usage = CB_USAGE_COMP_5;
685  f->pic = cb_build_binary_picture ("BINARY-SHORT", 4, 0);
686  f->flag_real_binary = 1;
687  validate_field_clauses (x, f);
688  break;
689  case CB_USAGE_UNSIGNED_INT:
690  f->usage = CB_USAGE_COMP_5;
691  f->pic = cb_build_binary_picture ("BINARY-LONG", 9, 0);
692  f->flag_real_binary = 1;
693  validate_field_clauses (x, f);
694  break;
695  case CB_USAGE_UNSIGNED_LONG:
696  f->usage = CB_USAGE_COMP_5;
697  f->pic = cb_build_binary_picture ("BINARY-DOUBLE", 18, 0);
698  f->flag_real_binary = 1;
699  validate_field_clauses (x, f);
700  break;
701  case CB_USAGE_BINARY:
702  case CB_USAGE_PACKED:
703  case CB_USAGE_BIT:
704  if (f->pic->category != CB_CATEGORY_NUMERIC) {
705  cb_error_x (x, _("'%s' PICTURE clause not compatible with USAGE"), cb_name (x));
706  }
707  validate_field_clauses (x, f);
708  break;
709  case CB_USAGE_COMP_6:
710  if (f->pic->category != CB_CATEGORY_NUMERIC) {
711  cb_error_x (x, _("'%s' PICTURE clause not compatible with USAGE"), cb_name (x));
712  }
713  if (f->pic->have_sign) {
714  cb_warning_x (x, _("'%s' COMP-6 with sign - Changing to COMP-3"), cb_name (x));
715  f->usage = CB_USAGE_PACKED;
716  }
717  validate_field_clauses (x, f);
718  break;
719  case CB_USAGE_COMP_5:
720  case CB_USAGE_COMP_X:
721  if (f->pic) {
722  if (f->pic->category != CB_CATEGORY_NUMERIC &&
723  f->pic->category != CB_CATEGORY_ALPHANUMERIC) {
724  cb_error_x (x, _("'%s' PICTURE clause not compatible with USAGE"), cb_name (x));
725  }
726  }
727  validate_field_clauses (x, f);
728  break;
729  case CB_USAGE_POINTER:
730  case CB_USAGE_PROGRAM_POINTER:
731  case CB_USAGE_PROGRAM:
732  case CB_USAGE_FLOAT:
733  case CB_USAGE_DOUBLE:
734  case CB_USAGE_LONG_DOUBLE:
735  case CB_USAGE_FP_BIN32:
736  case CB_USAGE_FP_BIN64:
737  case CB_USAGE_FP_BIN128:
738  case CB_USAGE_FP_DEC64:
739  case CB_USAGE_FP_DEC128:
740  case CB_USAGE_INDEX:
741  validate_field_clauses (x, f);
742  break;
743  default:
744  break;
745  }
746 
747  /* Validate SIGN */
748 
749  /* Validate JUSTIFIED RIGHT */
750  if (f->flag_justified) {
751  switch (f->pic->category) {
752  case CB_CATEGORY_ALPHABETIC:
753  case CB_CATEGORY_ALPHANUMERIC:
754  break;
755  default:
756  cb_error_x (x, _("'%s' cannot have JUSTIFIED RIGHT"), cb_name (x));
757  break;
758  }
759  }
760 
761  /* Validate SYNCHRONIZED */
762 
763  /* Validate BLANK ZERO */
764  if (f->flag_blank_zero) {
765  switch (f->pic->category) {
766  case CB_CATEGORY_NUMERIC:
767  /* Reconstruct the picture string */
768  n = 0;
769  if (f->pic->scale > 0) {
770  /* Enough for genned string */
771  f->pic->str = cobc_parse_malloc ((size_t)32);
772  pstr = (unsigned char *)(f->pic->str);
773  if (f->pic->have_sign) {
774  *pstr++ = '+';
775  vorint = 1;
776  memcpy (pstr, (void *)&vorint, sizeof(int));
777  pstr += sizeof(int);
778  n = 5;
779  }
780  *pstr++ = '9';
781  vorint = (int)f->pic->digits - f->pic->scale;
782  memcpy (pstr, (void *)&vorint, sizeof(int));
783  pstr += sizeof(int);
784  *pstr++ = 'V';
785  vorint = 1;
786  memcpy (pstr, (void *)&vorint, sizeof(int));
787  pstr += sizeof(int);
788  *pstr++ = '9';
789  vorint = f->pic->scale;
790  memcpy (pstr, (void *)&vorint, sizeof(int));
791  f->pic->size++;
792  n += 15;
793  } else {
794  /* Enough for genned string */
795  f->pic->str = cobc_parse_malloc ((size_t)16);
796  pstr = (unsigned char *)(f->pic->str);
797  if (f->pic->have_sign) {
798  *pstr++ = '+';
799  vorint = 1;
800  memcpy (pstr, (void *)&vorint, sizeof(int));
801  pstr += sizeof(int);
802  n = 5;
803  }
804  *pstr++ = '9';
805  vorint = f->pic->digits;
806  memcpy (pstr, (void *)&vorint, sizeof(int));
807  n += 5;
808  }
809  f->pic->lenstr = n;
810  f->pic->category = CB_CATEGORY_NUMERIC_EDITED;
811  break;
812  case CB_CATEGORY_NUMERIC_EDITED:
813  break;
814  default:
815  cb_error_x (x, _("'%s' cannot have BLANK WHEN ZERO"), cb_name (x));
816  break;
817  }
818  }
819 
820  /* Validate VALUE */
821  if (f->values) {
822  if (CB_PAIR_P (CB_VALUE (f->values)) || CB_CHAIN (f->values)) {
823  cb_error_x (x, _("Only level 88 item may have multiple values"));
824  }
825 
826  /* ISO+IEC+1989-2002: 13.16.42.2-10 */
827  for (p = f; p; p = p->parent) {
828  if (p->redefines) {
829  cb_error_x (x, _("Entries under REDEFINES cannot have a VALUE clause"));
830  }
831  if (p->flag_external && cb_warn_external_val) {
832  cb_warning_x (x, _("Initial VALUE clause ignored for EXTERNAL item"));
833  }
834  }
835  }
836  }
837 
838  return 0;
839 }
static void validate_field_clauses ( cb_tree  x,
struct cb_field *  f 
)
static

References _, cb_error_x(), cb_field::flag_blank_zero, cb_field::flag_sign_leading, and cb_field::flag_sign_separate.

Referenced by validate_field_1().

322 {
323  if (f->flag_blank_zero) {
324  cb_error_x (x, _("BLANK ZERO not compatible with USAGE"));
325  }
326  if (f->flag_sign_leading || f->flag_sign_separate) {
327  cb_error_x (x, _("SIGN clause not compatible with USAGE"));
328  }
329 }
static int validate_field_value ( struct cb_field *  f)
static

References CB_TREE, CB_VALUE, cb_field::children, cb_field::sister, validate_move(), and cb_field::values.

Referenced by cb_validate_field().

1320 {
1321  if (f->values) {
1322  validate_move (CB_VALUE (f->values), CB_TREE (f), 1);
1323  }
1324 
1325  if (f->children) {
1326  for (f = f->children; f; f = f->sister) {
1327  validate_field_value (f);
1328  }
1329  }
1330 
1331  return 0;
1332 }

Variable Documentation

cb_tree cb_depend_check = NULL

Referenced by cb_validate_program_data().

size_t cb_needs_01 = 0

Referenced by cb_build_field_tree(), and cb_validate_program_data().

struct cb_field* last_real_field = NULL
static

Referenced by cb_get_real_field(), and cb_validate_78_item().

int occur_align_size = 0
static

Referenced by cb_validate_field(), and compute_size().

const int pic_digits[] = { 2, 4, 7, 9, 12, 14, 16, 18 }
static

Referenced by setup_parameters().