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