OpenCOBOL 1.1pre-rel
field.c
Go to the documentation of this file.
00001 /*
00002  * Copyright (C) 2001-2009 Keisuke Nishida
00003  * Copyright (C) 2007-2009 Roger While
00004  *
00005  * This program is free software; you can redistribute it and/or modify
00006  * it under the terms of the GNU General Public License as published by
00007  * the Free Software Foundation; either version 2, or (at your option)
00008  * any later version.
00009  *
00010  * This program is distributed in the hope that it will be useful,
00011  * but WITHOUT ANY WARRANTY; without even the implied warranty of
00012  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
00013  * GNU General Public License for more details.
00014  *
00015  * You should have received a copy of the GNU General Public License
00016  * along with this software; see the file COPYING.  If not, write to
00017  * the Free Software Foundation, 51 Franklin Street, Fifth Floor
00018  * Boston, MA 02110-1301 USA
00019  */
00020 
00021 #include "config.h"
00022 
00023 #include <stdio.h>
00024 #include <stdlib.h>
00025 #include <string.h>
00026 #include <ctype.h>
00027 
00028 #include "cobc.h"
00029 #include "tree.h"
00030 
00031 /* Global variables */
00032 
00033 size_t                  cb_needs_01 = 0;
00034 
00035 /* Local variables */
00036 
00037 static struct cb_field  *last_real_field = NULL;
00038 static const int        pic_digits[] = { 2, 4, 7, 9, 12, 14, 16, 18 };
00039 
00040 int
00041 cb_get_level (cb_tree x)
00042 {
00043         const char      *p;
00044         const char      *name;
00045         int             level = 0;
00046 
00047         name = CB_NAME (x);
00048         /* get level */
00049         for (p = name; *p; p++) {
00050                 if (!isdigit (*p)) {
00051                         goto level_error;
00052                 }
00053                 level = level * 10 + (*p - '0');
00054         }
00055 
00056         /* check level */
00057         switch (level) {
00058         case 66:
00059         case 77:
00060         case 78:
00061         case 88:
00062                 break;
00063         default:
00064                 if (level < 1 || level > 49) {
00065                         goto level_error;
00066                 }
00067                 break;
00068         }
00069 
00070         return level;
00071 
00072 level_error:
00073         cb_error_x (x, _("Invalid level number '%s'"), name);
00074         return 0;
00075 }
00076 
00077 cb_tree
00078 cb_build_field_tree (cb_tree level, cb_tree name,
00079                      struct cb_field *last_field,
00080                      enum cb_storage storage, struct cb_file *fn)
00081 {
00082         struct cb_reference     *r;
00083         struct cb_field         *f;
00084         struct cb_field         *p;
00085         struct cb_field         *field_fill;
00086         cb_tree                 dummy_fill;
00087         cb_tree                 l;
00088         cb_tree                 x;
00089         int                     lv;
00090 
00091         if (level == cb_error_node || name == cb_error_node) {
00092                 return cb_error_node;
00093         }
00094 
00095         /* check the level number */
00096         lv = cb_get_level (level);
00097         if (!lv) {
00098                 return cb_error_node;
00099         }
00100 
00101         /* build the field */
00102         r = CB_REFERENCE (name);
00103         f = CB_FIELD (cb_build_field (name));
00104         f->storage = storage;
00105         last_real_field = last_field;
00106         if (lv == 78) {
00107                 f->level = 01;
00108                 f->flag_item_78 = 1;
00109                 return CB_TREE (f);
00110         } else {
00111                 f->level = lv;
00112         }
00113         if (f->level == 01 && storage == CB_STORAGE_FILE) {
00114                 if (fn->external) {
00115                         f->flag_external = 1;
00116                         has_external = 1;
00117                 } else if (fn->global) {
00118                         f->flag_is_global = 1;
00119                 }
00120         }
00121         if (last_field) {
00122                 if (last_field->level == 77 && f->level != 01 &&
00123                     f->level != 77 && f->level != 66 && f->level != 88) {
00124                         cb_error_x (name, _("Level number must begin with 01 or 77"));
00125                         return cb_error_node;
00126                 }
00127         }
00128 
00129         /* checks for redefinition */
00130         if (cb_warn_redefinition) {
00131                 if (r->word->count > 1) {
00132                         if (f->level == 01 || f->level == 77) {
00133                                 redefinition_warning (name, NULL);
00134                         } else {
00135                                 for (l = r->word->items; l; l = CB_CHAIN (l)) {
00136                                         x = CB_VALUE (l);
00137                                         if (!CB_FIELD_P (x)
00138                                             || CB_FIELD (x)->level == 01
00139                                             || CB_FIELD (x)->level == 77
00140                                             || (f->level == last_field->level
00141                                                 && CB_FIELD (x)->parent == last_field->parent)) {
00142                                                 redefinition_warning (name, x);
00143                                                 break;
00144                                         }
00145                                 }
00146                         }
00147                 }
00148         }
00149 
00150         if (last_field && last_field->level == 88) {
00151                 last_field = last_field->parent;
00152         }
00153 
00154         /* link the field into the tree */
00155         if (f->level == 01 || f->level == 77) {
00156                 /* top level */
00157                 cb_needs_01 = 0;
00158                 if (last_field) {
00159 /*
00160                         cb_field_add (cb_field_founder (last_field), f);
00161 */
00162                         cb_field_founder (last_field)->sister = f;
00163                 }
00164         } else if (!last_field || cb_needs_01) {
00165                 /* invalid top level */
00166                 cb_error_x (name, _("Level number must begin with 01 or 77"));
00167                 return cb_error_node;
00168         } else if (f->level == 66) {
00169                 /* level 66 */
00170                 f->parent = cb_field_founder (last_field);
00171                 for (p = f->parent->children; p && p->sister; p = p->sister) ;
00172                 if (p) {
00173                         p->sister = f;
00174                 }
00175         } else if (f->level == 88) {
00176                 /* level 88 */
00177                 f->parent = last_field;
00178         } else if (f->level > last_field->level) {
00179                 /* lower level */
00180                 last_field->children = f;
00181                 f->parent = last_field;
00182         } else if (f->level == last_field->level) {
00183                 /* same level */
00184 same_level:
00185                 last_field->sister = f;
00186                 f->parent = last_field->parent;
00187         } else {
00188                 /* upper level */
00189                 for (p = last_field->parent; p; p = p->parent) {
00190                         if (p->level == f->level) {
00191                                 last_field = p;
00192                                 goto same_level;
00193                         }
00194                         if (cb_relax_level_hierarchy && p->level < f->level) {
00195                                 break;
00196                         }
00197                 }
00198                 if (cb_relax_level_hierarchy) {
00199                         dummy_fill = cb_build_filler ();
00200                         field_fill = CB_FIELD (cb_build_field (dummy_fill));
00201                         cb_warning_x (name, _("No previous data item of level %02d"), f->level);
00202                         field_fill->level = f->level;
00203                         field_fill->storage = storage;
00204                         field_fill->children = p->children;
00205                         field_fill->parent = p;
00206                         for (p = p->children; p != NULL; p = p->sister) {
00207                                 p->parent = field_fill;
00208                         }
00209                         field_fill->parent->children = field_fill;
00210                         field_fill->sister = f;
00211                         f->parent = field_fill->parent;
00212                         last_field = field_fill;
00213                 } else {
00214                         cb_error_x (name, _("No previous data item of level %02d"), f->level);
00215                         return cb_error_node;
00216                 }
00217         }
00218 
00219         /* inherit parent's properties */
00220         if (f->parent) {
00221                 f->usage = f->parent->usage;
00222                 f->indexes = f->parent->indexes;
00223                 f->flag_sign_leading = f->parent->flag_sign_leading;
00224                 f->flag_sign_separate = f->parent->flag_sign_separate;
00225                 f->flag_is_global = f->parent->flag_is_global;
00226         }
00227         return CB_TREE (f);
00228 }
00229 
00230 struct cb_field *
00231 cb_resolve_redefines (struct cb_field *field, cb_tree redefines)
00232 {
00233         struct cb_field         *f;
00234         struct cb_reference     *r;
00235         const char              *name;
00236         cb_tree                 x;
00237 
00238         r = CB_REFERENCE (redefines);
00239         name = CB_NAME (redefines);
00240         x = CB_TREE (field);
00241 
00242         /* check qualification */
00243         if (r->chain) {
00244                 cb_error_x (x, _("'%s' cannot be qualified here"), name);
00245                 return NULL;
00246         }
00247 
00248         /* check subscripts */
00249         if (r->subs) {
00250                 cb_error_x (x, _("'%s' cannot be subscripted here"), name);
00251                 return NULL;
00252         }
00253 
00254         /* resolve the name in the current group (if any) */
00255         if (field->parent && field->parent->children) {
00256                 for (f = field->parent->children; f; f = f->sister) {
00257                         if (strcasecmp (f->name, name) == 0) {
00258                                 break;
00259                         }
00260                 }
00261                 if (f == NULL) {
00262                         cb_error_x (x, _("'%s' undefined in '%s'"), name, field->parent->name);
00263                         return NULL;
00264                 }
00265         } else {
00266                 if (cb_ref (redefines) == cb_error_node) {
00267                         return NULL;
00268                 }
00269                 f = cb_field (redefines);
00270         }
00271 
00272         /* check level number */
00273         if (f->level != field->level) {
00274                 cb_error_x (x, _("Level number of REDEFINES entries must be identical"));
00275                 return NULL;
00276         }
00277         if (f->level == 66 || f->level == 88) {
00278                 cb_error_x (x, _("Level number of REDEFINES entry cannot be 66 or 88"));
00279                 return NULL;
00280         }
00281 
00282         if (!cb_indirect_redefines && f->redefines) {
00283                 cb_error_x (x, _("'%s' not the original definition"), f->name);
00284                 return NULL;
00285         }
00286 
00287         /* return the original definition */
00288         while (f->redefines) {
00289                 f = f->redefines;
00290         }
00291         return f;
00292 }
00293 
00294 static int
00295 validate_field_1 (struct cb_field *f)
00296 {
00297         cb_tree         x;
00298         cb_tree         l;
00299         char            *name;
00300         struct cb_field *p;
00301         char            *pp;
00302         unsigned char   *pstr;
00303         int             vorint;
00304         int             need_picture;
00305         char            pic[16];
00306 
00307         x = CB_TREE (f);
00308         name = cb_name (x);
00309         if (f->flag_any_length) {
00310                 if (f->storage != CB_STORAGE_LINKAGE) {
00311                         cb_error_x (x, _("'%s' ANY LENGTH only allowed in LINKAGE"), name);
00312                         return -1;
00313                 }
00314                 if (f->level != 01) {
00315                         cb_error_x (x, _("'%s' ANY LENGTH must be 01 level"), name);
00316                         return -1;
00317                 }
00318                 if (f->flag_item_based || f->flag_external) {
00319                         cb_error_x (x, _("'%s' ANY LENGTH can not be BASED/EXTERNAL"), name);
00320                         return -1;
00321                 }
00322                 if (f->flag_occurs || f->occurs_depending ||
00323                     f->children || f->values || f->flag_blank_zero) {
00324                         cb_error_x (x, _("'%s' ANY LENGTH has invalid definition"), name);
00325                         return -1;
00326                 }
00327                 if (!f->pic) {
00328                         cb_error_x (x, _("'%s' ANY LENGTH must have a PICTURE"), name);
00329                         return -1;
00330                 }
00331                 if (f->pic->size != 1 || f->usage != CB_USAGE_DISPLAY) {
00332                         cb_error_x (x, _("'%s' ANY LENGTH has invalid definition"), name);
00333                         return -1;
00334                 }
00335                 f->count++;
00336                 return 0;
00337         }
00338 
00339         if (f->level == 77) {
00340                 if (f->storage != CB_STORAGE_WORKING &&
00341                     f->storage != CB_STORAGE_LOCAL &&
00342                     f->storage != CB_STORAGE_LINKAGE) {
00343                         cb_error_x (x, _("'%s' 77 level not allowed here"), name);
00344                 }
00345         }
00346         if (f->flag_external) {
00347                 if (f->level != 01 && f->level != 77) {
00348                         cb_error_x (x, _("'%s' EXTERNAL must be specified at 01/77 level"), name);
00349                 }
00350                 if (f->storage != CB_STORAGE_WORKING &&
00351                     f->storage != CB_STORAGE_FILE) {
00352                         cb_error_x (x, _("'%s' EXTERNAL can only be specified in WORKING-STORAGE section"),
00353                                     name);
00354                 }
00355                 if (f->flag_item_based) {
00356                         cb_error_x (x, _("'%s' EXTERNAL and BASED are mutually exclusive"), name);
00357                 }
00358                 if (f->redefines) {
00359                         cb_error_x (x, _("'%s' EXTERNAL not allowed with REDEFINES"), name);
00360                 }
00361         }
00362         if (f->flag_item_based) {
00363                 if (f->storage != CB_STORAGE_WORKING &&
00364                     f->storage != CB_STORAGE_LOCAL &&
00365                     f->storage != CB_STORAGE_LINKAGE) {
00366                         cb_error_x (x, _("'%s' BASED not allowed here"), name);
00367                 }
00368                 if (f->redefines) {
00369                         cb_error_x (x, _("'%s' BASED not allowed with REDEFINES"), name);
00370                 }
00371                 if (f->level != 01 && f->level != 77) {
00372                         cb_error_x (x, _("'%s' BASED only allowed at the 01 and 77 levels"), name);
00373                 }
00374         }
00375         if (f->level == 66) {
00376                 if (!f->redefines) {
00377                         level_require_error (x, "RENAMES");
00378                         return -1;
00379                 }
00380                 if (f->flag_occurs) {
00381                         level_except_error (x, "RENAMES");
00382                 }
00383                 return 0;
00384         }
00385 
00386         /* validate OCCURS */
00387         if (f->flag_occurs) {
00388                 if ((!cb_verify (cb_top_level_occurs_clause, "01/77 OCCURS")
00389                      && (f->level == 01 || f->level == 77))
00390                     || (f->level == 66 || f->level == 88)) {
00391                         level_redundant_error (x, "OCCURS");
00392                 }
00393                 for (l = f->index_list; l; l = CB_CHAIN (l)) {
00394                         cb_field (CB_VALUE (l))->flag_is_global = f->flag_is_global;
00395                 }
00396         }
00397 
00398         /* validate OCCURS DEPENDING */
00399         if (f->occurs_depending) {
00400                 /* the data item that contains a OCCURS DEPENDING clause shall not
00401                    be subordinate to a data item that has the OCCURS clause */
00402                 for (p = f->parent; p; p = p->parent) {
00403                         if (p->flag_occurs) {
00404                                 cb_error_x (CB_TREE (p),
00405                                             _("'%s' cannot have the OCCURS clause due to '%s'"),
00406                                             check_filler_name ((char *)p->name),
00407                                             check_filler_name (name));
00408                                 break;
00409                         }
00410                 }
00411 
00412                 /* the data item that contains a OCCURS DEPENDING clause must be
00413                    the last data item in the group */
00414                 for (p = f; p->parent; p = p->parent) {
00415                         for (; p->sister; p = p->sister) {
00416                                 if (p->sister == cb_field (f->occurs_depending)) {
00417                                                 cb_error_x (x,
00418                                                             _("'%s' ODO field item invalid here"),
00419                                                             p->sister->name);
00420                                 }
00421                                 if (!p->sister->redefines) {
00422                                         if (!cb_complex_odo) {
00423                                                 cb_error_x (x,
00424                                                             _("'%s' cannot have OCCURS DEPENDING"),
00425                                                             check_filler_name (name));
00426                                                 break;
00427                                         }
00428                                 }
00429                         }
00430                 }
00431                 /* If the field is GLOBAL, then the ODO must also be GLOBAL */
00432                 if (f->flag_is_global) {
00433                         if (!cb_field (f->occurs_depending)->flag_is_global) {
00434                                 cb_error_x (x, _("'%s' ODO item must have GLOBAL attribute"),
00435                                         cb_field (f->occurs_depending)->name);
00436                         }
00437                         if (f->storage != cb_field (f->occurs_depending)->storage) {
00438                                 cb_error_x (x, _("GLOBAL '%s' ODO item is not in the same section as OCCURS"),
00439                                         cb_field (f->occurs_depending)->name);
00440                         }
00441                 }
00442         }
00443 
00444         /* validate REDEFINES */
00445         if (f->redefines) {
00446                 /* check OCCURS */
00447                 if (f->redefines->flag_occurs) {
00448                         cb_warning_x (x, _("The original definition '%s' should not have OCCURS"),
00449                                       f->redefines->name);
00450                 }
00451 
00452                 /* check definition */
00453                 for (p = f->redefines->sister; p && p != f; p = p->sister) {
00454                         if (!p->redefines) {
00455                                 cb_error_x (x, _("REDEFINES must follow the original definition"));
00456                                 break;
00457                         }
00458                 }
00459 
00460                 /* check variable occurrence */
00461                 if (f->occurs_depending || cb_field_variable_size (f)) {
00462                         cb_error_x (x, _("'%s' cannot be variable length"), f->name);
00463                 }
00464                 if (cb_field_variable_size (f->redefines)) {
00465                         cb_error_x (x,
00466                                     _("The original definition '%s' cannot be variable length"),
00467                                     f->redefines->name);
00468                 }
00469         }
00470 
00471         if (f->children) {
00472                 /* group item */
00473 
00474                 if (f->pic) {
00475                         group_error (x, "PICTURE");
00476                 }
00477                 if (f->flag_justified) {
00478                         group_error (x, "JUSTIFIED RIGHT");
00479                 }
00480                 if (f->flag_blank_zero) {
00481                         group_error (x, "BLANK WHEN ZERO");
00482                 }
00483 
00484                 for (f = f->children; f; f = f->sister) {
00485                         if (validate_field_1 (f) != 0) {
00486                                 return -1;
00487                         }
00488                 }
00489         } else {
00490                 /* elementary item */
00491 
00492                 /* validate PICTURE */
00493                 need_picture = 1;
00494                 if (f->usage == CB_USAGE_INDEX
00495                     || f->usage == CB_USAGE_LENGTH
00496                     || f->usage == CB_USAGE_OBJECT
00497                     || f->usage == CB_USAGE_POINTER
00498                     || f->usage == CB_USAGE_PROGRAM_POINTER
00499                     || f->usage == CB_USAGE_FLOAT
00500                     || f->usage == CB_USAGE_DOUBLE
00501                     || f->usage == CB_USAGE_SIGNED_CHAR
00502                     || f->usage == CB_USAGE_SIGNED_SHORT
00503                     || f->usage == CB_USAGE_SIGNED_INT
00504                     || f->usage == CB_USAGE_SIGNED_LONG
00505                     || f->usage == CB_USAGE_UNSIGNED_CHAR
00506                     || f->usage == CB_USAGE_UNSIGNED_SHORT
00507                     || f->usage == CB_USAGE_UNSIGNED_INT
00508                     || f->usage == CB_USAGE_UNSIGNED_LONG
00509                     || f->usage == CB_USAGE_PROGRAM) {
00510                         need_picture = 0;
00511                 }
00512                 if (f->pic == NULL && need_picture != 0) {
00513                         if (f->storage == CB_STORAGE_SCREEN) {
00514 /* RXW
00515                                 if (f->values &&
00516                                     CB_LITERAL(CB_VALUE(f->values))->size) {
00517 */
00518                                 if (f->values) {
00519                                         sprintf (pic, "X(%d)", (int)CB_LITERAL(CB_VALUE(f->values))->size);
00520                                 } else {
00521                                         sprintf (pic, "X(1)");
00522                                 }
00523                                 f->pic = CB_PICTURE (cb_build_picture (pic));
00524                         } else if (f->flag_item_78 && f->values &&
00525                                    CB_VALUE(f->values) != cb_error_node) {
00526                                 f->count++;
00527                                 if (CB_NUMERIC_LITERAL_P(CB_VALUE(f->values))) {
00528                                         memset (pic, 0, sizeof (pic));
00529                                         pp = pic;
00530                                         if (CB_LITERAL(CB_VALUE(f->values))->sign) {
00531                                                 *pp++ = 'S';
00532                                         }
00533                                         vorint = CB_LITERAL(CB_VALUE(f->values))->size -
00534                                                  CB_LITERAL(CB_VALUE(f->values))->scale;
00535                                         if (vorint) {
00536                                                 pp += sprintf (pp, "9(%d)", vorint);
00537                                         }
00538                                         if (CB_LITERAL(CB_VALUE(f->values))->scale) {
00539                                                 sprintf (pp, "V9(%d)",
00540                                                  CB_LITERAL(CB_VALUE(f->values))->scale);
00541                                         }
00542                                         if (CB_LITERAL(CB_VALUE(f->values))->size < 10) {
00543                                                 f->usage = CB_USAGE_COMP_5;
00544                                         } else {
00545                                                 f->usage = CB_USAGE_DISPLAY;
00546                                         }
00547                                         f->pic = CB_PICTURE (cb_build_picture (pic));
00548                                         f->pic->category = CB_CATEGORY_NUMERIC;
00549                                 } else {
00550                                         sprintf (pic, "X(%d)", (int)CB_LITERAL(CB_VALUE(f->values))->size);
00551                                         f->pic = CB_PICTURE (cb_build_picture (pic));
00552                                         f->pic->category = CB_CATEGORY_ALPHANUMERIC;
00553                                         f->usage = CB_USAGE_DISPLAY;
00554                                 }
00555                         } else {
00556                                 if (f->flag_item_78) {
00557                                         cb_error_x (x, _("Value required for constant item '%s'"), name);
00558                                 } else {
00559                                         cb_error_x (x, _("PICTURE clause required for '%s'"), name);
00560                                 }
00561                                 return -1;
00562                         }
00563                 }
00564                 if (f->pic != NULL && need_picture == 0) {
00565                         cb_error_x (x, _("'%s' cannot have PICTURE clause"), name);
00566                 }
00567 
00568                 /* validate USAGE */
00569                 switch (f->usage) {
00570                 case CB_USAGE_SIGNED_CHAR:
00571                         f->usage = CB_USAGE_COMP_5;
00572                         f->pic = CB_PICTURE (cb_build_picture ("S99"));
00573                         f->flag_real_binary = 1;
00574                         break;
00575                 case CB_USAGE_SIGNED_SHORT:
00576                         f->usage = CB_USAGE_COMP_5;
00577                         f->pic = CB_PICTURE (cb_build_picture ("S9(4)"));
00578                         f->flag_real_binary = 1;
00579                         break;
00580                 case CB_USAGE_SIGNED_INT:
00581                         f->usage = CB_USAGE_COMP_5;
00582                         f->pic = CB_PICTURE (cb_build_picture ("S9(9)"));
00583                         f->flag_real_binary = 1;
00584                         break;
00585                 case CB_USAGE_SIGNED_LONG:
00586                         f->usage = CB_USAGE_COMP_5;
00587                         f->pic = CB_PICTURE (cb_build_picture ("S9(18)"));
00588                         f->flag_real_binary = 1;
00589                         break;
00590                 case CB_USAGE_UNSIGNED_CHAR:
00591                         f->usage = CB_USAGE_COMP_5;
00592                         f->pic = CB_PICTURE (cb_build_picture ("99"));
00593                         f->flag_real_binary = 1;
00594                         break;
00595                 case CB_USAGE_UNSIGNED_SHORT:
00596                         f->usage = CB_USAGE_COMP_5;
00597                         f->pic = CB_PICTURE (cb_build_picture ("9(4)"));
00598                         f->flag_real_binary = 1;
00599                         break;
00600                 case CB_USAGE_UNSIGNED_INT:
00601                         f->usage = CB_USAGE_COMP_5;
00602                         f->pic = CB_PICTURE (cb_build_picture ("9(9)"));
00603                         f->flag_real_binary = 1;
00604                         break;
00605                 case CB_USAGE_UNSIGNED_LONG:
00606                         f->usage = CB_USAGE_COMP_5;
00607                         f->pic = CB_PICTURE (cb_build_picture ("9(18)"));
00608                         f->flag_real_binary = 1;
00609                         break;
00610                 case CB_USAGE_BINARY:
00611                 case CB_USAGE_PACKED:
00612                         if (f->pic->category != CB_CATEGORY_NUMERIC) {
00613                                 cb_error_x (x, _("'%s' PICTURE clause not compatible with USAGE"), name);
00614                         }
00615                         break;
00616                 case CB_USAGE_COMP_5:
00617                 case CB_USAGE_COMP_X:
00618                         if (f->pic) {
00619                                 if (f->pic->category != CB_CATEGORY_NUMERIC &&
00620                                     f->pic->category != CB_CATEGORY_ALPHANUMERIC) {
00621                                         cb_error_x (x, _("'%s' PICTURE clause not compatible with USAGE"), name);
00622                                 }
00623                         }
00624                         break;
00625                 default:
00626                         break;
00627                 }
00628 
00629                 /* validate SIGN */
00630 
00631                 /* validate JUSTIFIED RIGHT */
00632                 if (f->flag_justified) {
00633                         switch (f->pic->category) {
00634                         case CB_CATEGORY_ALPHABETIC:
00635                         case CB_CATEGORY_ALPHANUMERIC:
00636                                 break;
00637                         default:
00638                                 cb_error_x (x, _("'%s' cannot have JUSTIFIED RIGHT"), name);
00639                                 break;
00640                         }
00641                 }
00642 
00643                 /* validate SYNCHRONIZED */
00644 
00645                 /* validate BLANK ZERO */
00646                 if (f->flag_blank_zero) {
00647                         switch (f->pic->category) {
00648                         case CB_CATEGORY_NUMERIC:
00649                                 /* reconstruct the picture string */
00650                                 if (f->pic->scale > 0) {
00651                                         f->pic->str = cobc_malloc (20);
00652                                         pstr = (unsigned char *)(f->pic->str);
00653                                         *pstr++ = '9';
00654                                         vorint = f->pic->digits - f->pic->scale;
00655                                         memcpy (pstr, (unsigned char *)&vorint, sizeof(int));
00656                                         pstr += sizeof(int);
00657                                         *pstr++ = 'V';
00658                                         vorint = 1;
00659                                         memcpy (pstr, (unsigned char *)&vorint, sizeof(int));
00660                                         pstr += sizeof(int);
00661                                         *pstr++ = '9';
00662                                         vorint = f->pic->scale;
00663                                         memcpy (pstr, (unsigned char *)&vorint, sizeof(int));
00664                                         f->pic->size++;
00665                                 } else {
00666                                         f->pic->str = cobc_malloc (8);
00667                                         pstr = (unsigned char *)(f->pic->str);
00668                                         *pstr++ = '9';
00669                                         vorint = f->pic->digits;
00670                                         memcpy (pstr, (unsigned char *)&vorint, sizeof(int));
00671                                 }
00672                                 f->pic->category = CB_CATEGORY_NUMERIC_EDITED;
00673                                 break;
00674                         case CB_CATEGORY_NUMERIC_EDITED:
00675                                 break;
00676                         default:
00677                                 cb_error_x (x, _("'%s' cannot have BLANK WHEN ZERO"), name);
00678                                 break;
00679                         }
00680                 }
00681 
00682                 /* validate VALUE */
00683                 if (f->values) {
00684                         if (CB_PAIR_P (CB_VALUE (f->values)) || CB_CHAIN (f->values)) {
00685                                 cb_error_x (x, _("Only level 88 item may have multiple values"));
00686                         }
00687 
00688                         /* ISO+IEC+1989-2002: 13.16.42.2-10 */
00689                         for (p = f; p; p = p->parent) {
00690                                 if (p->redefines) {
00691                                         cb_error_x (x, _("Entries under REDEFINES cannot have VALUE clause"));
00692                                 }
00693                                 if (p->flag_external) {
00694                                         cb_warning_x (x, _("VALUE clause ignored for EXTERNAL items"));
00695                                 }
00696                         }
00697                 }
00698         }
00699 
00700         return 0;
00701 }
00702 
00703 static void
00704 setup_parameters (struct cb_field *f)
00705 {
00706         int     flag_local;
00707         char    pic[8];
00708 
00709         /* determine the class */
00710         if (f->children) {
00711                 /* group field */
00712                 flag_local = f->flag_local;
00713                 for (f = f->children; f; f = f->sister) {
00714                         f->flag_local = flag_local;
00715                         setup_parameters (f);
00716                 }
00717         } else {
00718                 /* regular field */
00719                 switch (f->usage) {
00720                 case CB_USAGE_BINARY:
00721 #ifndef WORDS_BIGENDIAN
00722                         if (cb_binary_byteorder == CB_BYTEORDER_BIG_ENDIAN) {
00723                                 f->flag_binary_swap = 1;
00724                         }
00725 #endif
00726                         break;
00727 
00728                 case CB_USAGE_INDEX:
00729                         f->pic = CB_PICTURE (cb_build_picture ("S9(9)"));
00730                         break;
00731 
00732                 case CB_USAGE_LENGTH:
00733                         f->pic = CB_PICTURE (cb_build_picture ("9(9)"));
00734                         break;
00735 
00736                 case CB_USAGE_POINTER:
00737                 case CB_USAGE_PROGRAM_POINTER:
00738                         f->pic = CB_PICTURE (cb_build_picture ("9(10)"));
00739                         break;
00740                 case CB_USAGE_FLOAT:
00741                         f->pic = CB_PICTURE (cb_build_picture ("S9(7)V9(7)"));
00742                         break;
00743                 case CB_USAGE_DOUBLE:
00744                         f->pic = CB_PICTURE (cb_build_picture ("S9(9)V9(9)"));
00745                         break;
00746 
00747                 case CB_USAGE_COMP_5:
00748                 case CB_USAGE_COMP_X:
00749                         if (f->pic->category == CB_CATEGORY_ALPHANUMERIC) {
00750                                 if (f->pic->size > 8) {
00751                                         sprintf (pic, "9(36)");
00752                                 } else {
00753                                         sprintf (pic, "9(%d)", pic_digits[f->pic->size - 1]);
00754                                 }
00755                                 f->pic = CB_PICTURE (cb_build_picture (pic));
00756                         }
00757 #ifndef WORDS_BIGENDIAN
00758                         if (f->usage == CB_USAGE_COMP_X) {
00759                                 if (cb_binary_byteorder == CB_BYTEORDER_BIG_ENDIAN) {
00760                                         f->flag_binary_swap = 1;
00761                                 }
00762                         }
00763 #endif
00764                         break;
00765 
00766                 default:
00767                         break;
00768                 }
00769         }
00770 }
00771 
00772 static int
00773 compute_size (struct cb_field *f)
00774 {
00775         struct cb_field *c;
00776         int             size;
00777         int             align_size;
00778         int             pad;
00779 
00780         if (f->level == 66) {
00781                 /* rename */
00782                 if (f->rename_thru) {
00783                         f->size = f->rename_thru->offset + f->rename_thru->size -
00784                                   f->redefines->offset;
00785                 } else {
00786                         f->size = f->redefines->size;
00787                 }
00788                 return f->size;
00789         }
00790 
00791         if (f->children) {
00792                 /* groups */
00793                 size = 0;
00794                 for (c = f->children; c; c = c->sister) {
00795                         if (c->redefines) {
00796                                 c->offset = c->redefines->offset;
00797                                 compute_size (c);
00798                                 /* increase the size if redefinition is larger */
00799                                 if (c->level != 66 &&
00800                                     c->size * c->occurs_max >
00801                                     c->redefines->size * c->redefines->occurs_max) {
00802                                         if (cb_larger_redefines_ok) {
00803                                                 cb_warning_x (CB_TREE (c),
00804                                                               _("Size of '%s' larger than size of '%s'"),
00805                                                               c->name, c->redefines->name);
00806                                                 size +=
00807                                                     (c->size * c->occurs_max) -
00808                                                     (c->redefines->size *
00809                                                      c->redefines->occurs_max);
00810                                         } else {
00811                                                 cb_error_x (CB_TREE (c),
00812                                                             _("Size of '%s' larger than size of '%s'"),
00813                                                             c->name, c->redefines->name);
00814                                         }
00815                                 }
00816                         } else {
00817                                 c->offset = f->offset + size;
00818                                 size += compute_size (c) * c->occurs_max;
00819 
00820                                 /* word alignment */
00821                                 if (c->flag_synchronized
00822                                     && cb_verify (cb_synchronized_clause, "SYNC")) {
00823                                         align_size = 1;
00824                                         switch (c->usage) {
00825                                         case CB_USAGE_BINARY:
00826                                         case CB_USAGE_COMP_5:
00827                                         case CB_USAGE_COMP_X:
00828                                         case CB_USAGE_FLOAT:
00829                                         case CB_USAGE_DOUBLE:
00830                                                 if (c->size == 2 || c->size == 4
00831                                                     || c->size == 8) {
00832                                                         align_size = c->size;
00833                                                 }
00834                                                 break;
00835                                         case CB_USAGE_INDEX:
00836                                         case CB_USAGE_LENGTH:
00837                                                 align_size = sizeof (int);
00838                                                 break;
00839                                         case CB_USAGE_OBJECT:
00840                                         case CB_USAGE_POINTER:
00841                                         case CB_USAGE_PROGRAM_POINTER:
00842                                         case CB_USAGE_PROGRAM:
00843                                                 align_size = sizeof (void *);
00844                                                 break;
00845                                         default:
00846                                                 break;
00847                                         }
00848                                         if (c->offset % align_size != 0) {
00849                                                 pad = align_size - (c->offset % align_size);
00850                                                 c->offset += pad;
00851                                                 size += pad;
00852                                         }
00853                                 }
00854                         }
00855                 }
00856                 f->size = size;
00857         } else {
00858                 /* elementary item */
00859                 switch (f->usage) {
00860                 case CB_USAGE_COMP_X:
00861                         if (f->pic->category == CB_CATEGORY_ALPHANUMERIC) {
00862                                 break;
00863                         }
00864                         size = f->pic->size;
00865                         f->size = ((size <= 2) ? 1 : (size <= 4) ? 2 :
00866                                    (size <= 7) ? 3 : (size <= 9) ? 4 :
00867                                    (size <= 12) ? 5 : (size <= 14) ? 6 :
00868                                    (size <= 16) ? 7 : (size <= 18) ? 8 : 16);
00869                         break;
00870                 case CB_USAGE_BINARY:
00871                 case CB_USAGE_COMP_5:
00872                         size = f->pic->size;
00873                         if (size > 18) {
00874                                 f->flag_binary_swap = 0;
00875                                 cb_error_x (CB_TREE (f),
00876                                             _("'%s' binary field cannot be larger than 18 digits"),
00877                                             f->name);
00878                         }
00879                         switch (cb_binary_size) {
00880                         case CB_BINARY_SIZE_2_4_8:
00881                                 if (f->flag_real_binary && size <= 2) {
00882                                         f->size = 1;
00883                                 } else {
00884                                         f->size = ((size <= 4) ? 2 :
00885                                                    (size <= 9) ? 4 : (size <= 18) ? 8 : 16);
00886                                 }
00887                                 break;
00888                         case CB_BINARY_SIZE_1_2_4_8:
00889                                 f->size = ((size <= 2) ? 1 :
00890                                            (size <= 4) ? 2 :
00891                                            (size <= 9) ? 4 : (size <= 18) ? 8 : 16);
00892                                 break;
00893                         case CB_BINARY_SIZE_1__8:
00894                                 if (f->pic->have_sign) {
00895                                         f->size = ((size <= 2) ? 1 : (size <= 4) ? 2 :
00896                                                    (size <= 6) ? 3 : (size <= 9) ? 4 :
00897                                                    (size <= 11) ? 5 : (size <= 14) ? 6 :
00898                                                    (size <= 16) ? 7 : (size <= 18) ? 8 : 16);
00899                                 } else {
00900                                         f->size = ((size <= 2) ? 1 : (size <= 4) ? 2 :
00901                                                    (size <= 7) ? 3 : (size <= 9) ? 4 :
00902                                                    (size <= 12) ? 5 : (size <= 14) ? 6 :
00903                                                    (size <= 16) ? 7 : (size <= 18) ? 8 : 16);
00904                                 }
00905                                 break;
00906                         }
00907                         break;
00908                 case CB_USAGE_DISPLAY:
00909                         f->size = f->pic->size;
00910                         if (f->pic->category == CB_CATEGORY_NUMERIC
00911                             && f->pic->have_sign && f->flag_sign_separate) {
00912                                 f->size++;
00913                         }
00914                         break;
00915                 case CB_USAGE_PACKED:
00916                         f->size = f->pic->size / 2 + 1;
00917                         break;
00918                 case CB_USAGE_INDEX:
00919                 case CB_USAGE_LENGTH:
00920                         f->size = sizeof (int);
00921                         break;
00922                 case CB_USAGE_FLOAT:
00923                         f->size = sizeof (float);
00924                         break;
00925                 case CB_USAGE_DOUBLE:
00926                         f->size = sizeof (double);
00927                         break;
00928                 case CB_USAGE_OBJECT:
00929                 case CB_USAGE_POINTER:
00930                 case CB_USAGE_PROGRAM_POINTER:
00931                 case CB_USAGE_PROGRAM:
00932                         f->size = sizeof (void *);
00933                         break;
00934                 default:
00935                         ABORT ();
00936                 }
00937         }
00938 
00939         /* the size of redefining field should not be larger than
00940            the size of redefined field unless the redefined field
00941            is level 01 and non-external */
00942         if (f->redefines && f->redefines->flag_external
00943             && (f->size * f->occurs_max > f->redefines->size * f->redefines->occurs_max)) {
00944                 if (cb_larger_redefines_ok) {
00945                         cb_warning_x (CB_TREE (f), _("Size of '%s' larger than size of '%s'"),
00946                                       f->name, f->redefines->name);
00947                 } else {
00948                         cb_error_x (CB_TREE (f), _("Size of '%s' larger than size of '%s'"),
00949                                     f->name, f->redefines->name);
00950                 }
00951         }
00952 
00953         return f->size;
00954 }
00955 
00956 static int
00957 validate_field_value (struct cb_field *f)
00958 {
00959         if (f->values) {
00960                 validate_move (CB_VALUE (f->values), CB_TREE (f), 1);
00961         }
00962 
00963         if (f->children) {
00964                 for (f = f->children; f; f = f->sister) {
00965                         validate_field_value (f);
00966                 }
00967         }
00968 
00969         return 0;
00970 }
00971 
00972 void
00973 cb_validate_field (struct cb_field *f)
00974 {
00975         struct cb_field         *c;
00976 
00977         if (validate_field_1 (f) != 0) {
00978                 f->flag_invalid = 1;
00979                 return;
00980         }
00981         /* RXW - Remove */
00982         if (f->flag_item_78) {
00983                 f->flag_is_verified = 1;
00984                 return;
00985         }
00986 
00987         /* setup parameters */
00988         if (f->storage == CB_STORAGE_LOCAL ||
00989             f->storage == CB_STORAGE_LINKAGE ||
00990             f->flag_item_based) {
00991                 f->flag_local = 1;
00992         }
00993         if (f->storage == CB_STORAGE_LINKAGE || f->flag_item_based) {
00994                 f->flag_base = 1;
00995         }
00996         setup_parameters (f);
00997 
00998         /* compute size */
00999         compute_size (f);
01000         if (!f->redefines) {
01001                 f->memory_size = f->size * f->occurs_max;
01002         } else if (f->redefines->memory_size < f->size * f->occurs_max) {
01003                 f->redefines->memory_size = f->size * f->occurs_max;
01004         }
01005 
01006         validate_field_value (f);
01007         if (f->flag_is_global) {
01008                 f->count++;
01009                 for (c = f->children; c; c = c->sister) {
01010                         c->flag_is_global = 1;
01011                         c->count++;
01012                 }
01013         }
01014         f->flag_is_verified = 1;
01015 }
01016 
01017 void
01018 cb_validate_88_item (struct cb_field *f)
01019 {
01020         cb_tree x;
01021 
01022         x = CB_TREE (f);
01023         if (!f->values) {
01024                 level_require_error (x, "VALUE");
01025         }
01026 
01027         if (f->pic || f->flag_occurs) {
01028                 level_except_error (x, "VALUE");
01029         }
01030 }
01031 
01032 struct cb_field *
01033 cb_validate_78_item (struct cb_field *f)
01034 {
01035         cb_tree x;
01036 
01037         x = CB_TREE (f);
01038         if (!f->values) {
01039                 level_require_error (x, "VALUE");
01040         }
01041 
01042         if (f->pic || f->flag_occurs) {
01043                 level_except_error (x, "VALUE");
01044         }
01045         cb_add_78 (f);
01046         return last_real_field;
01047 }
01048 
01049 void
01050 cb_clear_real_field (void)
01051 {
01052         last_real_field = NULL;
01053 }
 All Data Structures Files Functions Variables Typedefs Enumerations Enumerator Defines