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