chk_expr.c 25 KB

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