143219Sbostic /* 243219Sbostic * Copyright (c) 1980 Regents of the University of California. 343219Sbostic * All rights reserved. The Berkeley software License Agreement 443219Sbostic * specifies the terms and conditions for redistribution. 543219Sbostic */ 643219Sbostic 743219Sbostic #ifndef lint 843219Sbostic static char sccsid[] = "@(#)paramset.c 5.1 (Berkeley) 6/7/85"; 943219Sbostic #endif not lint 1043219Sbostic 1143219Sbostic /* 1243219Sbostic * paramset.c 1343219Sbostic * 1443219Sbostic * Routines for handling PARAMETER statements, f77 compiler, 4.2 BSD. 1543219Sbostic * 1643219Sbostic * $Log: paramset.c,v $ 1743219Sbostic * Revision 3.2 84/10/13 03:52:03 donn 1843219Sbostic * Setting a parameter variable to a nonconstant expression is an error; 1943219Sbostic * previously a mere warning was emitted. Also added a comment header. 2043219Sbostic * 2143219Sbostic */ 2243219Sbostic 2343219Sbostic #include "defs.h" 2443219Sbostic #include "data.h" 2543219Sbostic 2643219Sbostic /* process the items in a PARAMETER statement */ 2743219Sbostic paramset( param_item_nm, param_item_vl ) 2843219Sbostic Namep param_item_nm; 2943219Sbostic expptr param_item_vl; 3043219Sbostic { 3143219Sbostic if (param_item_nm->vstg != STGUNKNOWN && param_item_nm->vstg != STGCONST ) 3243219Sbostic dclerr("conflicting declarations", param_item_nm); 3343219Sbostic else if (param_item_nm->vclass == CLUNKNOWN) 3443219Sbostic param_item_nm->vclass = CLPARAM; 3543219Sbostic else if ( param_item_nm->vclass == CLPARAM ) 3643219Sbostic dclerr("redefining PARAMETER value", param_item_nm ); 3743219Sbostic else 3843219Sbostic dclerr("conflicting declarations", param_item_nm); 3943219Sbostic 4043219Sbostic if (param_item_nm->vclass == CLPARAM) 4143219Sbostic { 4243219Sbostic if (!ISCONST(param_item_vl)) 4343219Sbostic param_item_vl = fixtype(param_item_vl); 4443219Sbostic 4543219Sbostic if (param_item_nm->vtype == TYUNKNOWN) 4643219Sbostic { 4743219Sbostic char c; 4843219Sbostic 4943219Sbostic c = param_item_nm->varname[0]; 5043219Sbostic if (c >= 'A' && c <= 'Z') 5143219Sbostic c = c - 'A'; 5243219Sbostic else 5343219Sbostic c = c - 'a'; 5443219Sbostic param_item_nm->vtype = impltype[c]; 5543219Sbostic param_item_nm->vleng = ICON(implleng[c]); 5643219Sbostic } 5743219Sbostic if (param_item_nm->vtype == TYUNKNOWN) 5843219Sbostic { 5943219Sbostic warn1("type undefined for %s", 6043219Sbostic varstr(VL, param_item_nm->varname)); 6143219Sbostic ((struct Paramblock *) (param_item_nm))->paramval = param_item_vl; 6243219Sbostic } 6343219Sbostic else 6443219Sbostic { 6543219Sbostic extern int badvalue; 6643219Sbostic extern expptr constconv(); 6743219Sbostic int type; 6843219Sbostic ftnint len; 6943219Sbostic 7043219Sbostic type = param_item_nm->vtype; 7143219Sbostic if (type == TYCHAR) 7243219Sbostic { 7343219Sbostic if (param_item_nm->vleng != NULL) 74*46305Sbostic len = param_item_nm->vleng->constblock.constant.ci; 7543219Sbostic else if (ISCONST(param_item_vl) && 7643219Sbostic param_item_vl->constblock.vtype == TYCHAR) 7743219Sbostic len = param_item_vl->constblock.vleng-> 78*46305Sbostic constblock.constant.ci; 7943219Sbostic else 8043219Sbostic len = 1; 8143219Sbostic } 8243219Sbostic badvalue = 0; 8343219Sbostic if (ISCONST(param_item_vl)) 8443219Sbostic { 8543219Sbostic ((struct Paramblock *) (param_item_nm))->paramval = 8643219Sbostic convconst(param_item_nm->vtype, len, param_item_vl); 8743219Sbostic if (type == TYLOGICAL) 8843219Sbostic ((struct Paramblock *) (param_item_nm))->paramval-> 8943219Sbostic headblock.vtype = TYLOGICAL; 9043219Sbostic frexpr((tagptr) param_item_vl); 9143219Sbostic } 9243219Sbostic else 9343219Sbostic { 9443219Sbostic erri("%s set to a nonconstant", 9543219Sbostic varstr(VL, param_item_nm->varname)); 9643219Sbostic ((struct Paramblock *) (param_item_nm))->paramval = param_item_vl; 9743219Sbostic } 9843219Sbostic } 9943219Sbostic } 10043219Sbostic } 101