1*22857Smckusick /* 2*22857Smckusick * Copyright (c) 1980 Regents of the University of California. 3*22857Smckusick * All rights reserved. The Berkeley software License Agreement 4*22857Smckusick * specifies the terms and conditions for redistribution. 5*22857Smckusick */ 6*22857Smckusick 7*22857Smckusick #ifndef lint 8*22857Smckusick static char sccsid[] = "@(#)paramset.c 5.1 (Berkeley) 06/07/85"; 9*22857Smckusick #endif not lint 10*22857Smckusick 11*22857Smckusick /* 12*22857Smckusick * paramset.c 13*22857Smckusick * 14*22857Smckusick * Routines for handling PARAMETER statements, f77 compiler, 4.2 BSD. 15*22857Smckusick * 16*22857Smckusick * $Log: paramset.c,v $ 17*22857Smckusick * Revision 3.2 84/10/13 03:52:03 donn 18*22857Smckusick * Setting a parameter variable to a nonconstant expression is an error; 19*22857Smckusick * previously a mere warning was emitted. Also added a comment header. 20*22857Smckusick * 21*22857Smckusick */ 22*22857Smckusick 23*22857Smckusick #include "defs.h" 24*22857Smckusick #include "data.h" 25*22857Smckusick 26*22857Smckusick /* process the items in a PARAMETER statement */ 27*22857Smckusick paramset( param_item_nm, param_item_vl ) 28*22857Smckusick Namep param_item_nm; 29*22857Smckusick expptr param_item_vl; 30*22857Smckusick { 31*22857Smckusick if (param_item_nm->vstg != STGUNKNOWN && param_item_nm->vstg != STGCONST ) 32*22857Smckusick dclerr("conflicting declarations", param_item_nm); 33*22857Smckusick else if (param_item_nm->vclass == CLUNKNOWN) 34*22857Smckusick param_item_nm->vclass = CLPARAM; 35*22857Smckusick else if ( param_item_nm->vclass == CLPARAM ) 36*22857Smckusick dclerr("redefining PARAMETER value", param_item_nm ); 37*22857Smckusick else 38*22857Smckusick dclerr("conflicting declarations", param_item_nm); 39*22857Smckusick 40*22857Smckusick if (param_item_nm->vclass == CLPARAM) 41*22857Smckusick { 42*22857Smckusick if (!ISCONST(param_item_vl)) 43*22857Smckusick param_item_vl = fixtype(param_item_vl); 44*22857Smckusick 45*22857Smckusick if (param_item_nm->vtype == TYUNKNOWN) 46*22857Smckusick { 47*22857Smckusick char c; 48*22857Smckusick 49*22857Smckusick c = param_item_nm->varname[0]; 50*22857Smckusick if (c >= 'A' && c <= 'Z') 51*22857Smckusick c = c - 'A'; 52*22857Smckusick else 53*22857Smckusick c = c - 'a'; 54*22857Smckusick param_item_nm->vtype = impltype[c]; 55*22857Smckusick param_item_nm->vleng = ICON(implleng[c]); 56*22857Smckusick } 57*22857Smckusick if (param_item_nm->vtype == TYUNKNOWN) 58*22857Smckusick { 59*22857Smckusick warn1("type undefined for %s", 60*22857Smckusick varstr(VL, param_item_nm->varname)); 61*22857Smckusick ((struct Paramblock *) (param_item_nm))->paramval = param_item_vl; 62*22857Smckusick } 63*22857Smckusick else 64*22857Smckusick { 65*22857Smckusick extern int badvalue; 66*22857Smckusick extern expptr constconv(); 67*22857Smckusick int type; 68*22857Smckusick ftnint len; 69*22857Smckusick 70*22857Smckusick type = param_item_nm->vtype; 71*22857Smckusick if (type == TYCHAR) 72*22857Smckusick { 73*22857Smckusick if (param_item_nm->vleng != NULL) 74*22857Smckusick len = param_item_nm->vleng->constblock.const.ci; 75*22857Smckusick else if (ISCONST(param_item_vl) && 76*22857Smckusick param_item_vl->constblock.vtype == TYCHAR) 77*22857Smckusick len = param_item_vl->constblock.vleng-> 78*22857Smckusick constblock.const.ci; 79*22857Smckusick else 80*22857Smckusick len = 1; 81*22857Smckusick } 82*22857Smckusick badvalue = 0; 83*22857Smckusick if (ISCONST(param_item_vl)) 84*22857Smckusick { 85*22857Smckusick ((struct Paramblock *) (param_item_nm))->paramval = 86*22857Smckusick convconst(param_item_nm->vtype, len, param_item_vl); 87*22857Smckusick if (type == TYLOGICAL) 88*22857Smckusick ((struct Paramblock *) (param_item_nm))->paramval-> 89*22857Smckusick headblock.vtype = TYLOGICAL; 90*22857Smckusick frexpr((tagptr) param_item_vl); 91*22857Smckusick } 92*22857Smckusick else 93*22857Smckusick { 94*22857Smckusick erri("%s set to a nonconstant", 95*22857Smckusick varstr(VL, param_item_nm->varname)); 96*22857Smckusick ((struct Paramblock *) (param_item_nm))->paramval = param_item_vl; 97*22857Smckusick } 98*22857Smckusick } 99*22857Smckusick } 100*22857Smckusick } 101