chk_expr.c 29 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350
  1. /* E X P R E S S I O N C H E C K I N G */
  2. /* Check expressions, and try to evaluate them as far as possible.
  3. */
  4. #include "debug.h"
  5. #include <alloc.h>
  6. #include <assert.h>
  7. #include <em_arith.h>
  8. #include <em_label.h>
  9. #include <system.h>
  10. #include <print.h>
  11. #include "LLlex.h"
  12. #include "Lpars.h"
  13. #include "chk_expr.h"
  14. #include "const.h"
  15. #include "def.h"
  16. #include "idf.h"
  17. #include "main.h"
  18. #include "misc.h"
  19. #include "node.h"
  20. #include "required.h"
  21. #include "scope.h"
  22. #include "type.h"
  23. extern char *symbol2str();
  24. STATIC int ChkUnOper();
  25. STATIC
  26. Xerror(nd, mess)
  27. register struct node *nd;
  28. char *mess;
  29. {
  30. if( nd->nd_class == Def && nd->nd_def ) {
  31. if( nd->nd_def->df_kind != D_ERROR )
  32. node_error(nd,"\"%s\": %s",
  33. nd->nd_def->df_idf->id_text, mess);
  34. }
  35. else node_error(nd, "%s", mess);
  36. }
  37. struct node *
  38. ZeroParam()
  39. {
  40. register struct node *nd;
  41. nd = MkLeaf(Value, &dot);
  42. nd->nd_type = int_type;
  43. nd->nd_symb = INTEGER;
  44. nd->nd_INT = (arith) 0;
  45. nd = MkNode(Link, nd, NULLNODE, &dot);
  46. nd->nd_symb = ',';
  47. return nd;
  48. }
  49. MarkUsed(nd)
  50. register struct node *nd;
  51. {
  52. while( nd && nd->nd_class != Def ) {
  53. if( (nd->nd_class == Arrsel) || (nd->nd_class == LinkDef) )
  54. nd = nd->nd_left;
  55. else if( nd->nd_class == Arrow)
  56. nd = nd->nd_right;
  57. else break;
  58. }
  59. if( nd && nd->nd_class == Def ) {
  60. register struct def *df = nd->nd_def;
  61. if( df->df_kind != D_FIELD ) {
  62. if( !(df->df_flags & (D_SET|D_VARPAR)) &&
  63. (df->df_scope == CurrentScope) )
  64. if( !is_anon_idf(df->df_idf) ) {
  65. warning("\"%s\" used before set",
  66. df->df_idf->id_text);
  67. }
  68. df->df_flags |= (D_USED | D_SET);
  69. }
  70. }
  71. }
  72. int
  73. ChkConstant(expp)
  74. register struct node *expp;
  75. {
  76. register struct node *nd;
  77. if( !(nd = expp->nd_right) ) nd = expp;
  78. if( nd->nd_class == Name && !ChkLinkOrName(nd) ) return 0;
  79. if( nd->nd_class != Value || expp->nd_left ) {
  80. Xerror(nd, "constant expected");
  81. return 0;
  82. }
  83. if( expp->nd_class == Uoper )
  84. return ChkUnOper(expp);
  85. else if( nd != expp ) {
  86. Xerror(expp, "constant expected");
  87. return 0;
  88. }
  89. return 1;
  90. }
  91. int
  92. ChkVariable(expp)
  93. register struct node *expp;
  94. {
  95. /* Check that "expp" indicates an item that can be accessed */
  96. if( !ChkLhs(expp) ) return 0;
  97. if( expp->nd_class == Def && expp->nd_def->df_kind == D_FUNCTION ) {
  98. Xerror(expp, "illegal use of function name");
  99. return 0;
  100. }
  101. return 1;
  102. }
  103. int
  104. ChkLhs(expp)
  105. register struct node *expp;
  106. {
  107. int class;
  108. /* Check that "expp" indicates an item that can be the lhs
  109. of an assignment.
  110. */
  111. if( !ChkVarAccess(expp) ) return 0;
  112. class = expp->nd_class;
  113. /* a constant is replaced by it's value in ChkLinkOrName, check here !,
  114. * the remaining classes are checked by ChkVarAccess
  115. */
  116. if( class == Value ) {
  117. node_error(expp, "can't access a value");
  118. return 0;
  119. }
  120. if( class == Def &&
  121. !(expp->nd_def->df_kind & (D_FIELD | D_FUNCTION | D_VARIABLE)) ) {
  122. Xerror(expp, "variable expected");
  123. return 0;
  124. }
  125. /* assignment to function name */
  126. if( class == Def && expp->nd_def->df_kind == D_FUNCTION )
  127. if( expp->nd_def->prc_res )
  128. expp->nd_type = ResultType(expp->nd_def->df_type);
  129. else {
  130. Xerror(expp, "illegal assignment to function-name");
  131. return 0;
  132. }
  133. return 1;
  134. }
  135. #ifdef DEBUG
  136. STATIC int
  137. ChkValue(expp)
  138. register struct node *expp;
  139. {
  140. switch( expp->nd_symb ) {
  141. case INTEGER:
  142. case REAL:
  143. case STRING:
  144. case NIL:
  145. return 1;
  146. default:
  147. crash("(ChkValue)");
  148. }
  149. /*NOTREACHED*/
  150. }
  151. #endif
  152. int
  153. ChkLinkOrName(expp)
  154. register struct node *expp;
  155. {
  156. register struct def *df;
  157. expp->nd_type = error_type;
  158. if( expp->nd_class == Name ) {
  159. expp->nd_def = lookfor(expp, CurrVis, 1);
  160. expp->nd_class = Def;
  161. expp->nd_type = expp->nd_def->df_type;
  162. }
  163. else if( expp->nd_class == Link ) {
  164. /* a selection from a record */
  165. register struct node *left = expp->nd_left;
  166. assert(expp->nd_symb == '.');
  167. if( !ChkVariable(left) ) return 0;
  168. if( left->nd_type->tp_fund != T_RECORD ) {
  169. Xerror(left, "illegal selection");
  170. return 0;
  171. }
  172. if( !(df = lookup(expp->nd_IDF, left->nd_type->rec_scope, D_INUSE)) ) {
  173. id_not_declared(expp);
  174. return 0;
  175. }
  176. else {
  177. expp->nd_def = df;
  178. expp->nd_type = df->df_type;
  179. expp->nd_class = LinkDef;
  180. }
  181. return 1;
  182. }
  183. assert(expp->nd_class == Def);
  184. df = expp->nd_def;
  185. if( df->df_kind & (D_ENUM | D_CONST) ) {
  186. MarkUsed(expp);
  187. /* Replace an enum-literal or a CONST identifier by its value.
  188. */
  189. if( df->df_kind == D_ENUM ) {
  190. expp->nd_class = Value;
  191. expp->nd_INT = df->enm_val;
  192. expp->nd_symb = INTEGER;
  193. }
  194. else {
  195. unsigned int ln = expp->nd_lineno;
  196. assert(df->df_kind == D_CONST);
  197. *expp = *(df->con_const);
  198. expp->nd_lineno = ln;
  199. }
  200. }
  201. return df->df_kind != D_ERROR;
  202. }
  203. STATIC int
  204. ChkExLinkOrName(expp)
  205. register struct node *expp;
  206. {
  207. if( !ChkLinkOrName(expp) ) return 0;
  208. if( expp->nd_class != Def ) return 1;
  209. if( !(expp->nd_def->df_kind & D_VALUE) ) {
  210. Xerror(expp, "value expected");
  211. }
  212. return 1;
  213. }
  214. STATIC int
  215. ChkUnOper(expp)
  216. register struct node *expp;
  217. {
  218. /* Check an unary operation.
  219. */
  220. register struct node *right = expp->nd_right;
  221. register struct type *tpr;
  222. if( !ChkExpression(right) ) return 0;
  223. MarkUsed(right);
  224. expp->nd_type = tpr = BaseType(right->nd_type);
  225. switch( expp->nd_symb ) {
  226. case '+':
  227. if( tpr->tp_fund & T_NUMERIC ) {
  228. *expp = *right;
  229. free_node(right);
  230. return 1;
  231. }
  232. break;
  233. case '-':
  234. if( tpr->tp_fund == T_INTEGER || tpr->tp_fund == T_LONG ) {
  235. if( right->nd_class == Value )
  236. cstunary(expp);
  237. return 1;
  238. }
  239. if( tpr->tp_fund == T_REAL ) {
  240. if( right->nd_class == Value ) {
  241. expp->nd_token.tk_data.tk_real = right->nd_RIV;
  242. expp->nd_class = Value;
  243. expp->nd_symb = REAL;
  244. FreeNode(right);
  245. expp->nd_right = NULLNODE;
  246. }
  247. return 1;
  248. }
  249. break;
  250. case NOT:
  251. if( tpr == bool_type ) {
  252. if( right->nd_class == Value )
  253. cstunary(expp);
  254. return 1;
  255. }
  256. break;
  257. case '(':
  258. /* Delete the brackets */
  259. *expp = *right;
  260. free_node(right);
  261. return 1;
  262. default:
  263. crash("(ChkUnOper)");
  264. }
  265. node_error(expp, "\"%s\": illegal operand", symbol2str(expp->nd_symb));
  266. return 0;
  267. }
  268. STATIC struct type *
  269. ResultOfOperation(operator, tpl, tpr)
  270. struct type *tpl, *tpr;
  271. {
  272. /* Return the result type of the binary operation "operator",
  273. with operand types "tpl" and "tpr".
  274. */
  275. switch( operator ) {
  276. case '=' :
  277. case NOTEQUAL :
  278. case '<' :
  279. case '>' :
  280. case LESSEQUAL :
  281. case GREATEREQUAL:
  282. case IN :
  283. return bool_type;
  284. case '+' :
  285. case '-' :
  286. case '*' :
  287. if( tpl == real_type || tpr == real_type )
  288. return real_type;
  289. if( tpl == long_type || tpr == long_type)
  290. return long_type;
  291. return tpl;
  292. case '/' :
  293. return real_type;
  294. }
  295. if (tpr == long_type && tpl == int_type) return tpr;
  296. return tpl;
  297. }
  298. STATIC int
  299. AllowedTypes(operator)
  300. {
  301. /* Return a bit mask indicating the allowed operand types for
  302. binary operator "operator".
  303. */
  304. switch( operator ) {
  305. case '+' :
  306. case '-' :
  307. case '*' :
  308. return T_NUMERIC | T_SET;
  309. case '/' :
  310. return T_NUMERIC;
  311. case DIV :
  312. case MOD :
  313. return T_INTEGER | T_LONG;
  314. case OR :
  315. case AND :
  316. return T_ENUMERATION;
  317. case '=' :
  318. case NOTEQUAL :
  319. return T_ENUMERATION | T_CHAR | T_NUMERIC |
  320. T_SET | T_POINTER | T_STRINGCONST |
  321. T_STRING;
  322. case LESSEQUAL :
  323. case GREATEREQUAL:
  324. return T_ENUMERATION | T_CHAR | T_NUMERIC |
  325. T_SET | T_STRINGCONST;
  326. case '<' :
  327. case '>' :
  328. return T_ENUMERATION | T_CHAR | T_NUMERIC |
  329. T_STRINGCONST;
  330. default :
  331. crash("(AllowedTypes)");
  332. }
  333. /*NOTREACHED*/
  334. }
  335. STATIC int
  336. Boolean(operator)
  337. {
  338. return operator == OR || operator == AND;
  339. }
  340. STATIC int
  341. ChkBinOper(expp)
  342. register struct node *expp;
  343. {
  344. /* Check a binary operation.
  345. */
  346. register struct node *left, *right;
  347. struct type *tpl, *tpr;
  348. int retval, allowed;
  349. left = expp->nd_left;
  350. right = expp->nd_right;
  351. retval = ChkExpression(left);
  352. retval &= ChkExpression(right);
  353. MarkUsed(left);
  354. MarkUsed(right);
  355. tpl = BaseType(left->nd_type);
  356. tpr = BaseType(right->nd_type);
  357. expp->nd_type = ResultOfOperation(expp->nd_symb, tpl ,tpr);
  358. /* Check that the application of the operator is allowed on the type
  359. of the operands.
  360. There are some needles and pins:
  361. - Boolean operators are only allowed on boolean operands, but the
  362. "allowed-mask" of "AllowedTypes" can only indicate an enumeration
  363. type.
  364. - The IN-operator has as right-hand-side operand a set.
  365. - Strings and packed arrays can be equivalent.
  366. - In some cases, integers must be converted to reals.
  367. - If one of the operands is the empty set then the result doesn't
  368. have to be the empty set.
  369. */
  370. if( expp->nd_symb == IN ) {
  371. if( tpr->tp_fund != T_SET ) {
  372. node_error(expp, "\"IN\": right operand must be a set");
  373. return 0;
  374. }
  375. if( !TstAssCompat(tpl, ElementType(tpr)) ) {
  376. node_error(expp, "\"IN\": incompatible types");
  377. return 0;
  378. }
  379. if( left->nd_class == Value && right->nd_class == Set )
  380. cstset(expp);
  381. return retval;
  382. }
  383. if( !retval ) return 0;
  384. allowed = AllowedTypes(expp->nd_symb);
  385. if( !(tpr->tp_fund & allowed) || !(tpl->tp_fund & allowed) ) {
  386. arith ub;
  387. extern arith IsString();
  388. if( allowed & T_STRINGCONST && (ub = IsString(tpl)) ) {
  389. if( ub == IsString(tpr) )
  390. return 1;
  391. else {
  392. node_error(expp, "\"%s\": incompatible types",
  393. symbol2str(expp->nd_symb));
  394. return 0;
  395. }
  396. }
  397. else if( allowed & T_STRING && tpl->tp_fund == T_STRING )
  398. return 1;
  399. node_error(expp, "\"%s\": illegal operand type(s)",
  400. symbol2str(expp->nd_symb));
  401. return 0;
  402. }
  403. if( Boolean(expp->nd_symb) && tpl != bool_type ) {
  404. node_error(expp, "\"%s\": illegal operand type(s)",
  405. symbol2str(expp->nd_symb));
  406. return 0;
  407. }
  408. if( allowed & T_NUMERIC ) {
  409. if( (tpl == int_type || tpl == long_type) &&
  410. (tpr == real_type || expp->nd_symb == '/') ) {
  411. expp->nd_left =
  412. MkNode(Cast, NULLNODE, expp->nd_left, &dot);
  413. expp->nd_left->nd_type = tpl = real_type;
  414. }
  415. if( tpl == real_type &&
  416. (tpr == int_type || tpr == long_type)) {
  417. expp->nd_right =
  418. MkNode(Cast, NULLNODE, expp->nd_right, &dot);
  419. expp->nd_right->nd_type = tpr = real_type;
  420. }
  421. if( tpl == int_type && tpr == long_type) {
  422. expp->nd_left =
  423. MkNode(IntCoerc, NULLNODE, expp->nd_left, &dot);
  424. expp->nd_left->nd_type = long_type;
  425. }
  426. else if( tpl == long_type && tpr == int_type) {
  427. expp->nd_right =
  428. MkNode(IntCoerc, NULLNODE, expp->nd_right, &dot);
  429. expp->nd_right->nd_type = long_type;
  430. }
  431. }
  432. /* Operands must be compatible */
  433. if( !TstCompat(tpl, tpr) ) {
  434. node_error(expp, "\"%s\": incompatible types",
  435. symbol2str(expp->nd_symb));
  436. return 0;
  437. }
  438. if( tpl->tp_fund & T_SET ) {
  439. if( tpl == emptyset_type )
  440. left->nd_type = tpr;
  441. else if( tpr == emptyset_type )
  442. right->nd_type = tpl;
  443. if( expp->nd_type == emptyset_type )
  444. expp->nd_type = tpr;
  445. if( left->nd_class == Set && right->nd_class == Set )
  446. cstset(expp);
  447. }
  448. else if( tpl->tp_fund != T_REAL &&
  449. left->nd_class == Value && right->nd_class == Value )
  450. cstbin(expp);
  451. return 1;
  452. }
  453. STATIC int
  454. ChkElement(expp, tp, set, cnt)
  455. register struct node *expp;
  456. register struct type **tp;
  457. arith **set;
  458. unsigned *cnt;
  459. {
  460. /* Check elements of a set. This routine may call itself
  461. recursively. Also try to compute the set!
  462. */
  463. register struct node *left = expp->nd_left;
  464. register struct node *right = expp->nd_right;
  465. register int i;
  466. extern char *Malloc();
  467. if( expp->nd_class == Link && expp->nd_symb == UPTO ) {
  468. /* [ ... , expr1 .. expr2, ... ]
  469. First check expr1 and expr2, and try to compute them.
  470. */
  471. if( !ChkElement(left, tp, set, cnt) ||
  472. !ChkElement(right, tp, set, cnt) )
  473. return 0;
  474. if( left->nd_class == Value &&
  475. right->nd_class == Value && *set ) {
  476. if( left->nd_INT > right->nd_INT ) {
  477. /* Remove lower and upper bound of the range.
  478. */
  479. *cnt -= 2;
  480. (*set)[left->nd_INT/wrd_bits] &=
  481. ~(1 << (left->nd_INT%wrd_bits));
  482. (*set)[right->nd_INT/wrd_bits] &=
  483. ~(1 << (right->nd_INT%wrd_bits));
  484. }
  485. else
  486. /* We have a constant range. Put all elements
  487. in the set.
  488. */
  489. for( i = left->nd_INT + 1; i < right->nd_INT; i++ )
  490. (*set)[i/wrd_bits] |= ( 1 << (i%wrd_bits) );
  491. }
  492. return 1;
  493. }
  494. /* Here, a single element is checked
  495. */
  496. if( !ChkExpression(expp) ) return 0;
  497. MarkUsed(expp);
  498. if( *tp == emptyset_type ) {
  499. /* first element in set determines the type of the set */
  500. unsigned size;
  501. *tp = set_type(expp->nd_type, 0);
  502. size = (*tp)->tp_size * (sizeof(arith) / word_size);
  503. *set = (arith *) Malloc(size);
  504. clear((char *) *set, size);
  505. }
  506. else if( !TstCompat(ElementType(*tp), expp->nd_type) ) {
  507. node_error(expp, "set element has incompatible type");
  508. return 0;
  509. }
  510. if( expp->nd_class == Value ) {
  511. /* a constant element
  512. */
  513. i = expp->nd_INT;
  514. if( expp->nd_type == int_type ) {
  515. /* Check only integer base-types because they are not
  516. equal to the integer host-type. The other base-types
  517. are equal to their host-types.
  518. */
  519. if( i < 0 || i > max_intset ) {
  520. node_error(expp, "set element out of range");
  521. return 0;
  522. }
  523. }
  524. if( *set ) (*set)[i/wrd_bits] |= ( 1 << (i%wrd_bits));
  525. (*cnt)++;
  526. }
  527. else if( *set ) {
  528. free((char *) *set);
  529. *set = (arith *) 0;
  530. }
  531. return 1;
  532. }
  533. STATIC int
  534. ChkSet(expp)
  535. register struct node *expp;
  536. {
  537. /* Check the legality of a SET aggregate, and try to evaluate it
  538. compile time. Unfortunately this is all rather complicated.
  539. */
  540. register struct node *nd = expp->nd_right;
  541. arith *set = (arith *) 0;
  542. unsigned cnt = 0;
  543. assert(expp->nd_symb == SET);
  544. expp->nd_type = emptyset_type;
  545. /* Now check the elements given, and try to compute a constant set.
  546. First allocate room for the set, but only if it isn't empty.
  547. */
  548. if( !nd ) {
  549. /* The resulting set IS empty, so we just return
  550. */
  551. expp->nd_class = Set;
  552. expp->nd_set = (arith *) 0;
  553. return 1;
  554. }
  555. /* Now check the elements, one by one
  556. */
  557. while( nd ) {
  558. assert(nd->nd_class == Link && nd->nd_symb == ',');
  559. if( !ChkElement(nd->nd_left, &(expp->nd_type), &set, &cnt) )
  560. return 0;
  561. nd = nd->nd_right;
  562. }
  563. if( set ) {
  564. /* Yes, it was a constant set, and we managed to compute it!
  565. Notice that at the moment there is no such thing as
  566. partial evaluation. Either we evaluate the set, or we
  567. don't (at all). Improvement not neccesary (???)
  568. ??? sets have a contant part and a variable part ???
  569. */
  570. expp->nd_class = Set;
  571. if( !cnt ) {
  572. /* after all the work we've done, the set turned out
  573. out to be empty!
  574. */
  575. free((char *) set);
  576. set = (arith *) 0;
  577. }
  578. expp->nd_set = set;
  579. FreeNode(expp->nd_right);
  580. expp->nd_right = NULLNODE;
  581. }
  582. return 1;
  583. }
  584. char *
  585. ChkAllowedVar(nd, reading) /* reading indicates read or readln */
  586. register struct node *nd;
  587. {
  588. char *message = 0;
  589. switch( nd->nd_class ) {
  590. case Def:
  591. if( nd->nd_def->df_flags & D_INLOOP ) {
  592. message = "control variable";
  593. break;
  594. }
  595. if( nd->nd_def->df_kind != D_FIELD ) break;
  596. /* FALL THROUGH */
  597. case LinkDef:
  598. assert(nd->nd_def->df_kind == D_FIELD);
  599. if( nd->nd_def->fld_flags & F_PACKED )
  600. message = "field of packed record";
  601. else if( nd->nd_def->fld_flags & F_SELECTOR )
  602. message = "variant selector";
  603. break;
  604. case Arrsel:
  605. if( IsPacked(nd->nd_left->nd_type) )
  606. if( !reading ) message = "component of packed array";
  607. break;
  608. case Arrow:
  609. if( nd->nd_right->nd_type->tp_fund == T_FILE )
  610. message = "filebuffer variable";
  611. break;
  612. default:
  613. crash("(ChkAllowedVar)");
  614. /*NOTREACHED*/
  615. }
  616. MarkDef(nd, D_SET, 1);
  617. return message;
  618. }
  619. int
  620. ChkVarPar(nd, name)
  621. register struct node *nd, *name;
  622. {
  623. /* ISO 6.6.3.3 :
  624. An actual variable parameter shall not denote a field
  625. that is the selector of a variant-part or a component
  626. of a variable where that variable possesses a type
  627. that is designated packed.
  628. */
  629. static char err_mes[80];
  630. char *message = (char *) 0;
  631. if( !ChkVariable(nd) ) return 0;
  632. message = ChkAllowedVar(nd, 0);
  633. if( message ) {
  634. sprint(err_mes, "%s can't be a variable parameter", message);
  635. Xerror(name, err_mes);
  636. return 0;
  637. }
  638. return 1;
  639. }
  640. STATIC struct node *
  641. getarg(argp, bases, varaccess, name, paramtp)
  642. struct node **argp, *name;
  643. struct type *paramtp;
  644. {
  645. /* This routine is used to fetch the next argument from an
  646. argument list. The argument list is indicated by "argp".
  647. The parameter "bases" is a bitset indicating which types are
  648. allowed at this point, and "varaccess" is a flag indicating
  649. that the address from this argument is taken, so that it
  650. must be a varaccess and may not be a register variable.
  651. */
  652. register struct node *arg = (*argp)->nd_right;
  653. register struct node *left;
  654. if( !arg ) {
  655. Xerror(name, "too few arguments supplied");
  656. return 0;
  657. }
  658. left = arg->nd_left;
  659. *argp = arg;
  660. if( paramtp && paramtp->tp_fund & T_ROUTINE ) {
  661. /* From the context it appears that the occurrence of the
  662. procedure/function-identifier is not a call.
  663. */
  664. if( left->nd_class != NameOrCall ) {
  665. Xerror(name, "illegal proc/func parameter");
  666. return 0;
  667. }
  668. else if( ChkLinkOrName(left->nd_left) ) {
  669. left->nd_type = left->nd_left->nd_type;
  670. MarkUsed(left->nd_left);
  671. }
  672. else return 0;
  673. }
  674. else if( varaccess ) {
  675. if( !ChkVarPar(left, name) ) {
  676. MarkUsed(left);
  677. return 0;
  678. }
  679. }
  680. else if( !ChkExpression(left) ) {
  681. MarkUsed(left);
  682. return 0;
  683. }
  684. MarkUsed(left);
  685. if( !varaccess && bases == T_INTEGER &&
  686. BaseType(left->nd_type)->tp_fund == T_LONG) {
  687. arg->nd_left = MkNode(IntReduc, NULLNODE, left, &dot);
  688. arg->nd_left->nd_type = int_type;
  689. left = arg->nd_left;
  690. }
  691. if( bases && !(BaseType(left->nd_type)->tp_fund & bases) ) {
  692. Xerror(name, "unexpected parameter type");
  693. return 0;
  694. }
  695. return left;
  696. }
  697. STATIC int
  698. ChkProcCall(expp)
  699. struct node *expp;
  700. {
  701. /* Check a procedure call
  702. */
  703. register struct node *left;
  704. struct node *name;
  705. register struct paramlist *param;
  706. char ebuf[80];
  707. int retval = 1;
  708. int cnt = 0;
  709. int new_par_section;
  710. struct type *lasttp = NULLTYPE;
  711. name = left = expp->nd_left;
  712. if( left->nd_type == error_type ) {
  713. /* Just check parameters as if they were value parameters
  714. */
  715. expp->nd_type = error_type;
  716. while( expp->nd_right )
  717. (void) getarg(&expp, 0, 0, name, NULLTYPE);
  718. return 0;
  719. }
  720. expp->nd_type = ResultType(left->nd_type);
  721. /* Check parameter list
  722. */
  723. for( param = ParamList(left->nd_type); param; param = param->next ) {
  724. if( !(left = getarg(&expp, 0, (int) IsVarParam(param), name,
  725. TypeOfParam(param))) )
  726. return 0;
  727. cnt++;
  728. new_par_section = lasttp != TypeOfParam(param);
  729. if( !TstParCompat(TypeOfParam(param), left->nd_type,
  730. (int) IsVarParam(param), left, new_par_section) ) {
  731. sprint(ebuf, "type incompatibility in parameter %d",
  732. cnt);
  733. Xerror(name, ebuf);
  734. retval = 0;
  735. }
  736. /* Convert between integers and longs.
  737. */
  738. if( !IsVarParam(param) && options['d'] ) {
  739. if( left->nd_type->tp_fund == T_INTEGER &&
  740. TypeOfParam(param)->tp_fund == T_LONG) {
  741. expp->nd_left =
  742. MkNode(IntCoerc, NULLNODE, left, &dot);
  743. expp->nd_left->nd_type = long_type;
  744. left = expp->nd_left;
  745. }
  746. else if( left->nd_type->tp_fund == T_LONG &&
  747. TypeOfParam(param)->tp_fund == T_INTEGER) {
  748. expp->nd_left =
  749. MkNode(IntReduc, NULLNODE, left, &dot);
  750. expp->nd_left->nd_type = int_type;
  751. left = expp->nd_left;
  752. }
  753. }
  754. if( left->nd_type == emptyset_type )
  755. /* type of emptyset determined by the context */
  756. left->nd_type = TypeOfParam(param);
  757. lasttp = TypeOfParam(param);
  758. }
  759. if( expp->nd_right ) {
  760. Xerror(name, "too many arguments supplied");
  761. while( expp->nd_right )
  762. (void) getarg(&expp, 0, 0, name, NULLTYPE);
  763. return 0;
  764. }
  765. return retval;
  766. }
  767. STATIC int ChkStandard();
  768. int
  769. ChkCall(expp)
  770. register struct node *expp;
  771. {
  772. /* Check something that looks like a procedure or function call.
  773. Of course this does not have to be a call at all,
  774. it may also be a standard procedure call.
  775. */
  776. /* First, get the name of the function or procedure
  777. */
  778. register struct node *left = expp->nd_left;
  779. expp->nd_type = error_type;
  780. if( ChkLinkOrName(left) ) {
  781. MarkUsed(left);
  782. if( IsProcCall(left) || left->nd_type == error_type ) {
  783. /* A call.
  784. It may also be a call to a standard procedure
  785. */
  786. if( left->nd_type == std_type )
  787. /* A standard procedure
  788. */
  789. return ChkStandard(expp, left);
  790. /* Here, we have found a real procedure call.
  791. */
  792. }
  793. else {
  794. node_error(left, "procedure or function expected");
  795. return 0;
  796. }
  797. }
  798. return ChkProcCall(expp);
  799. }
  800. STATIC int
  801. ChkExCall(expp)
  802. register struct node *expp;
  803. {
  804. if( !ChkCall(expp) ) return 0;
  805. if( !expp->nd_type ) {
  806. node_error(expp, "function call expected");
  807. return 0;
  808. }
  809. return 1;
  810. }
  811. STATIC int
  812. ChkNameOrCall(expp)
  813. register struct node *expp;
  814. {
  815. /* From the context it appears that the occurrence of the function-
  816. identifier is a call to that function
  817. */
  818. assert(expp->nd_class == NameOrCall);
  819. expp->nd_class = Call;
  820. return ChkExCall(expp);
  821. }
  822. STATIC int
  823. ChkStandard(expp,left)
  824. register struct node *expp, *left;
  825. {
  826. /* Check a call of a standard procedure or function
  827. */
  828. struct node *arg = expp;
  829. struct node *name = left;
  830. int req;
  831. assert(left->nd_class == Def);
  832. req = left->nd_def->df_value.df_reqname;
  833. switch( req ) {
  834. case R_ABS:
  835. case R_SQR:
  836. if( !(left = getarg(&arg, T_NUMERIC, 0, name, NULLTYPE)) )
  837. return 0;
  838. expp->nd_type = left->nd_type;
  839. if( left->nd_class == Value &&
  840. expp->nd_type->tp_fund != T_REAL )
  841. cstcall(expp, req);
  842. break;
  843. case R_SIN:
  844. case R_COS:
  845. case R_EXP:
  846. case R_LN:
  847. case R_SQRT:
  848. case R_ARCTAN:
  849. if( !(left = getarg(&arg, T_NUMERIC, 0, name, NULLTYPE)) )
  850. return 0;
  851. expp->nd_type = real_type;
  852. if( BaseType(left->nd_type)->tp_fund == T_INTEGER ||
  853. BaseType(left->nd_type)->tp_fund == T_LONG) {
  854. arg->nd_left = MkNode(Cast,NULLNODE, arg->nd_left,&dot);
  855. arg->nd_left->nd_type = real_type;
  856. }
  857. break;
  858. case R_TRUNC:
  859. case R_ROUND:
  860. if( !(left = getarg(&arg, T_REAL, 0, name, NULLTYPE)) )
  861. return 0;
  862. expp->nd_type = int_type;
  863. break;
  864. case R_ORD:
  865. if( !(left = getarg(&arg, T_ORDINAL, 0, name, NULLTYPE)) )
  866. return 0;
  867. if( BaseType(left->nd_type)->tp_fund == T_LONG ) {
  868. arg->nd_left = MkNode(IntReduc, NULLNODE, arg->nd_left, &dot);
  869. arg->nd_left->nd_type = int_type;
  870. }
  871. expp->nd_type = int_type;
  872. if( left->nd_class == Value )
  873. cstcall(expp, R_ORD);
  874. break;
  875. case R_CHR:
  876. if( !(left = getarg(&arg, T_INTEGER, 0, name, NULLTYPE)) )
  877. return 0;
  878. expp->nd_type = char_type;
  879. if( left->nd_class == Value )
  880. cstcall(expp, R_CHR);
  881. break;
  882. case R_SUCC:
  883. case R_PRED:
  884. if( !(left = getarg(&arg, T_ORDINAL, 0, name, NULLTYPE)) )
  885. return 0;
  886. expp->nd_type = left->nd_type;
  887. if( left->nd_class == Value && options['R'] )
  888. cstcall(expp, req);
  889. break;
  890. case R_ODD:
  891. if( !(left = getarg(&arg, T_INTEGER | T_LONG , 0, name, NULLTYPE)) )
  892. return 0;
  893. expp->nd_type = bool_type;
  894. if( left->nd_class == Value )
  895. cstcall(expp, R_ODD);
  896. break;
  897. case R_EOF:
  898. case R_EOLN:
  899. case R_GET:
  900. case R_PAGE: {
  901. int st_out;
  902. if( req == R_PAGE ) {
  903. expp->nd_type = NULLTYPE;
  904. st_out = 1;
  905. }
  906. else {
  907. st_out = 0;
  908. if (req == R_GET) {
  909. expp->nd_type = NULLTYPE;
  910. }
  911. else expp->nd_type = bool_type;
  912. }
  913. if( !arg->nd_right ) {
  914. struct node *nd;
  915. if( !(nd = ChkStdInOut(name->nd_IDF->id_text, st_out)) )
  916. return 0;
  917. expp->nd_right = MkNode(Link, nd, NULLNODE, &dot);
  918. expp->nd_right->nd_symb = ',';
  919. arg = arg->nd_right;
  920. }
  921. else {
  922. if( !(left = getarg(&arg, T_FILE, 1, name, NULLTYPE)) )
  923. return 0;
  924. if( (req == R_PAGE || req == R_EOLN)
  925. && left->nd_type != text_type ) {
  926. Xerror(name, "textfile expected");
  927. return 0;
  928. }
  929. }
  930. break;
  931. }
  932. case R_REWRITE:
  933. case R_PUT:
  934. case R_RESET:
  935. if( !(left = getarg(&arg, T_FILE, 1, name, NULLTYPE)) )
  936. return 0;
  937. expp->nd_type = NULLTYPE;
  938. break;
  939. case R_PACK:
  940. case R_UNPACK: {
  941. struct type *tp1, *tp2, *tp3;
  942. if( req == R_PACK ) {
  943. /* pack(a, i, z) */
  944. if( !(left = getarg(&arg, T_ARRAY, 1, name, NULLTYPE)) )
  945. return 0;
  946. tp1 = left->nd_type; /* (a) */
  947. if( !(left = getarg(&arg, 0, 0, name, NULLTYPE)) )
  948. return 0;
  949. tp2 = left->nd_type; /* (i) */
  950. if( !(left = getarg(&arg, T_ARRAY, 1, name, NULLTYPE)) )
  951. return 0;
  952. tp3 = left->nd_type; /* (z) */
  953. }
  954. else {
  955. /* unpack(z, a, i) */
  956. if( !(left = getarg(&arg, T_ARRAY, 1, name, NULLTYPE)) )
  957. return 0;
  958. tp3 = left->nd_type; /* (z) */
  959. if( !(left = getarg(&arg, T_ARRAY, 1, name, NULLTYPE)) )
  960. return 0;
  961. tp1 = left->nd_type; /* (a) */
  962. if( !(left = getarg(&arg, 0, 0, name, NULLTYPE)) )
  963. return 0;
  964. tp2 = left->nd_type; /* (i) */
  965. }
  966. if( IsConformantArray(tp1) || IsPacked(tp1) ) {
  967. Xerror(name, "unpacked array expected");
  968. return 0;
  969. }
  970. if( !TstAssCompat(IndexType(tp1), tp2) ) {
  971. Xerror(name, "ordinal constant expected");
  972. return 0;
  973. }
  974. if( IsConformantArray(tp3) || !IsPacked(tp3) ) {
  975. Xerror(name, "packed array expected");
  976. return 0;
  977. }
  978. if( !TstTypeEquiv(tp1->arr_elem, tp3->arr_elem) ) {
  979. Xerror(name, "component types of arrays not equal");
  980. return 0;
  981. }
  982. expp->nd_type = NULLTYPE;
  983. break;
  984. }
  985. case R_NEW:
  986. case R_DISPOSE:
  987. if( !(left = getarg(&arg, T_POINTER, 1, name, NULLTYPE)) )
  988. return 0;
  989. if( arg->nd_right ) {
  990. /* varargs new/dispose(p,c1,.....) */
  991. register struct selector *sel;
  992. register arith i;
  993. if( PointedtoType(left->nd_type)->tp_fund != T_RECORD )
  994. break;
  995. sel = PointedtoType(left->nd_type)->rec_sel;
  996. do {
  997. if( !sel ) break;
  998. arg = arg->nd_right;
  999. left = arg->nd_left;
  1000. /* ISO : COMPILETIME CONSTANTS NOT PERMITTED */
  1001. if( !ChkConstant(left) ) return 0;
  1002. if( !TstCompat(left->nd_type, sel->sel_type) ) {
  1003. node_error(left,
  1004. "type incompatibility in caselabel");
  1005. return 0;
  1006. }
  1007. i = left->nd_INT - sel->sel_lb;
  1008. if( i < 0 || i >= sel->sel_ncst ) {
  1009. node_error(left,
  1010. "case constant: out of bounds");
  1011. return 0;
  1012. }
  1013. sel = sel->sel_ptrs[i];
  1014. } while( arg->nd_right );
  1015. FreeNode(expp->nd_right->nd_right);
  1016. expp->nd_right->nd_right = NULLNODE;
  1017. }
  1018. expp->nd_type = NULLTYPE;
  1019. break;
  1020. case R_MARK:
  1021. case R_RELEASE:
  1022. if( !(left = getarg(&arg, T_POINTER, 1, name, NULLTYPE)) )
  1023. return 0;
  1024. expp->nd_type = NULLTYPE;
  1025. break;
  1026. case R_HALT:
  1027. if( !arg->nd_right ) /* insert 0 parameter */
  1028. arg->nd_right = ZeroParam();
  1029. if( !(left = getarg(&arg, T_INTEGER, 0, name, NULLTYPE)) )
  1030. return 0;
  1031. expp->nd_type = NULLTYPE;
  1032. break;
  1033. default:
  1034. crash("(ChkStandard)");
  1035. }
  1036. if( arg->nd_right ) {
  1037. Xerror(name, "too many arguments supplied");
  1038. return 0;
  1039. }
  1040. return 1;
  1041. }
  1042. STATIC int
  1043. ChkArrow(expp)
  1044. register struct node *expp;
  1045. {
  1046. /* Check an application of the '^' operator.
  1047. The operand must be a variable of a pointer-type or a
  1048. variable of a file-type.
  1049. */
  1050. register struct type *tp;
  1051. assert(expp->nd_class == Arrow);
  1052. assert(expp->nd_symb == '^');
  1053. expp->nd_type = error_type;
  1054. if( !ChkVariable(expp->nd_right) ) return 0;
  1055. MarkUsed(expp->nd_right);
  1056. tp = expp->nd_right->nd_type;
  1057. if( !(tp->tp_fund & (T_POINTER | T_FILE)) ) {
  1058. node_error(expp, "\"^\": illegal operand");
  1059. return 0;
  1060. }
  1061. expp->nd_type = PointedtoType(tp);
  1062. return 1;
  1063. }
  1064. STATIC int
  1065. ChkArr(expp)
  1066. register struct node *expp;
  1067. {
  1068. /* Check an array selection.
  1069. The left hand side must be a variable of an array type,
  1070. and the right hand side must be an expression that is
  1071. assignment compatible with the array-index.
  1072. */
  1073. register struct type *tpl, *tpr;
  1074. int retval;
  1075. assert(expp->nd_class == Arrsel);
  1076. assert(expp->nd_symb == '[');
  1077. expp->nd_type = error_type;
  1078. /* Check the index first, so a[a[j]] is checked in order of
  1079. * evaluation. This to make sure that warnings are generated
  1080. * in the right order.
  1081. */
  1082. retval = ChkExpression(expp->nd_right);
  1083. MarkUsed(expp->nd_right);
  1084. retval &= ChkVariable(expp->nd_left);
  1085. tpl = expp->nd_left->nd_type;
  1086. tpr = expp->nd_right->nd_type;
  1087. if( tpl == error_type || tpr == error_type ) return 0;
  1088. if( tpl->tp_fund != T_ARRAY ) {
  1089. node_error(expp, "not indexing an ARRAY type");
  1090. return 0;
  1091. }
  1092. /* Type of the index must be assignment compatible with
  1093. the index type of the array.
  1094. */
  1095. if( !TstCompat(IndexType(tpl), tpr) ) {
  1096. node_error(expp, "incompatible index type");
  1097. return 0;
  1098. }
  1099. if( tpr == long_type ) {
  1100. expp->nd_right = MkNode(IntReduc, NULLNODE, expp->nd_right, &dot);
  1101. expp->nd_right->nd_type = int_type;
  1102. }
  1103. expp->nd_type = tpl->arr_elem;
  1104. return retval;
  1105. }
  1106. STATIC int
  1107. done_before()
  1108. {
  1109. return 1;
  1110. }
  1111. STATIC int
  1112. no_var_access(expp)
  1113. struct node *expp;
  1114. {
  1115. node_error(expp, "variable-access expected");
  1116. return 0;
  1117. }
  1118. extern int NodeCrash();
  1119. int (*ExprChkTable[])() = {
  1120. #ifdef DEBUG
  1121. ChkValue,
  1122. #else
  1123. done_before,
  1124. #endif
  1125. ChkExLinkOrName,
  1126. ChkUnOper,
  1127. ChkBinOper,
  1128. ChkSet,
  1129. NodeCrash,
  1130. ChkExCall,
  1131. ChkNameOrCall,
  1132. ChkArrow,
  1133. ChkArr,
  1134. NodeCrash,
  1135. ChkExLinkOrName,
  1136. NodeCrash,
  1137. NodeCrash,
  1138. NodeCrash,
  1139. NodeCrash
  1140. };
  1141. int (*VarAccChkTable[])() = {
  1142. no_var_access,
  1143. ChkLinkOrName,
  1144. no_var_access,
  1145. no_var_access,
  1146. no_var_access,
  1147. NodeCrash,
  1148. no_var_access,
  1149. no_var_access,
  1150. ChkArrow,
  1151. ChkArr,
  1152. done_before,
  1153. ChkLinkOrName,
  1154. done_before,
  1155. no_var_access,
  1156. no_var_access,
  1157. no_var_access
  1158. };