chk_expr.c 33 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578
  1. /*
  2. * (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
  3. * See the copyright notice in the ACK home directory, in the file "Copyright".
  4. *
  5. * Author: Ceriel J.H. Jacobs
  6. */
  7. /* E X P R E S S I O N C H E C K I N G */
  8. /* $Id$ */
  9. /* Check expressions, and try to evaluate them as far as possible.
  10. */
  11. #include <stdlib.h>
  12. #include <string.h>
  13. #include "debug.h"
  14. #include <em_arith.h>
  15. #include <em_label.h>
  16. #include <assert.h>
  17. #include <alloc.h>
  18. #include "strict3rd.h"
  19. #include "Lpars.h"
  20. #include "idf.h"
  21. #include "type.h"
  22. #include "LLlex.h"
  23. #include "def.h"
  24. #include "node.h"
  25. #include "scope.h"
  26. #include "standards.h"
  27. #include "chk_expr.h"
  28. #include "misc.h"
  29. #include "warning.h"
  30. #include "main.h"
  31. #include "nostrict.h"
  32. extern char *symbol2str();
  33. extern char *sprint();
  34. extern arith flt_flt2arith();
  35. STATIC
  36. df_error(nd, mess, edf)
  37. t_node *nd; /* node on which error occurred */
  38. char *mess; /* error message */
  39. register t_def *edf; /* do we have a name? */
  40. {
  41. if (edf) {
  42. if (edf->df_kind != D_ERROR) {
  43. node_error(nd,"\"%s\": %s", edf->df_idf->id_text, mess);
  44. }
  45. }
  46. else node_error(nd, mess);
  47. }
  48. MkCoercion(pnd, tp)
  49. t_node **pnd;
  50. register t_type *tp;
  51. {
  52. /* Make a coercion from the node indicated by *pnd to the
  53. type indicated by tp. If the node indicated by *pnd
  54. is constant, try to do the coercion compile-time.
  55. Coercions are inserted in the tree when
  56. - the expression is not constant or
  57. - we are in the second pass and the coercion might cause
  58. an error
  59. */
  60. register t_node *nd = *pnd;
  61. register t_type *nd_tp = nd->nd_type;
  62. extern int pass_1;
  63. char *wmess = 0;
  64. arith op;
  65. if (nd_tp == tp || nd_tp->tp_fund == T_STRING /* Why ??? */) return;
  66. nd_tp = BaseType(nd_tp);
  67. if (nd->nd_class == Value && nd->nd_type != error_type && tp != error_type) {
  68. if (nd_tp->tp_fund == T_REAL) {
  69. switch(tp->tp_fund) {
  70. case T_REAL:
  71. nd->nd_type = tp;
  72. return;
  73. case T_CARDINAL:
  74. op = flt_flt2arith(&nd->nd_RVAL, 1);
  75. break;
  76. case T_INTEGER:
  77. op = flt_flt2arith(&nd->nd_RVAL, 0);
  78. break;
  79. default:
  80. crash("MkCoercion");
  81. /*NOTREACHED*/
  82. }
  83. if (flt_status == FLT_OVFL) {
  84. wmess = "conversion";
  85. }
  86. if (!wmess || pass_1) {
  87. if (nd->nd_RSTR) free(nd->nd_RSTR);
  88. free_real(nd->nd_REAL);
  89. nd->nd_INT = op;
  90. nd->nd_symb = INTEGER;
  91. }
  92. }
  93. switch(tp->tp_fund) {
  94. case T_REAL: {
  95. struct real *p = new_real();
  96. switch(BaseType(nd_tp)->tp_fund) {
  97. case T_CARDINAL:
  98. case T_INTORCARD:
  99. flt_arith2flt(nd->nd_INT, &p->r_val, 1);
  100. break;
  101. case T_INTEGER:
  102. flt_arith2flt(nd->nd_INT, &p->r_val, 0);
  103. break;
  104. default:
  105. crash("MkCoercion");
  106. }
  107. nd->nd_REAL = p;
  108. nd->nd_symb = REAL;
  109. }
  110. break;
  111. case T_SUBRANGE:
  112. case T_ENUMERATION:
  113. case T_CHAR:
  114. if (! in_range(nd->nd_INT, tp)) {
  115. wmess = "range bound";
  116. }
  117. break;
  118. case T_INTORCARD:
  119. case T_CARDINAL:
  120. case T_POINTER:
  121. if ((nd_tp->tp_fund == T_INTEGER && nd->nd_INT < 0) ||
  122. (nd->nd_INT & ~full_mask[(int)(tp->tp_size)])) {
  123. wmess = "conversion";
  124. }
  125. break;
  126. case T_INTEGER:
  127. if (! chk_bounds(nd->nd_INT,
  128. max_int[(int)(tp->tp_size)],
  129. nd_tp->tp_fund) ||
  130. ! chk_bounds(min_int[(int)(tp->tp_size)],
  131. nd->nd_INT,
  132. T_INTEGER)) {
  133. wmess = "conversion";
  134. }
  135. break;
  136. }
  137. if (wmess) {
  138. node_warning(nd, W_ORDINARY, "might cause %s error", wmess);
  139. }
  140. if (!wmess || pass_1) {
  141. nd->nd_type = tp;
  142. return;
  143. }
  144. }
  145. *pnd = nd;
  146. nd = getnode(Uoper);
  147. nd->nd_symb = COERCION;
  148. nd->nd_type = tp;
  149. nd->nd_LEFT = NULLNODE;
  150. nd->nd_RIGHT = *pnd;
  151. nd->nd_lineno = (*pnd)->nd_lineno;
  152. *pnd = nd;
  153. }
  154. int
  155. ChkVariable(expp, flags)
  156. register t_node **expp;
  157. {
  158. /* Check that "expp" indicates an item that can be
  159. assigned to.
  160. */
  161. register t_node *exp;
  162. if (! ChkDesig(expp, flags)) return 0;
  163. exp = *expp;
  164. if (exp->nd_class == Def &&
  165. ! (exp->nd_def->df_kind & (D_FIELD|D_VARIABLE))) {
  166. df_error(exp, "variable expected", exp->nd_def);
  167. return 0;
  168. }
  169. return 1;
  170. }
  171. STATIC int
  172. ChkArrow(expp)
  173. t_node **expp;
  174. {
  175. /* Check an application of the '^' operator.
  176. The operand must be a variable of a pointer type.
  177. */
  178. register t_type *tp;
  179. register t_node *exp = *expp;
  180. assert(exp->nd_class == Arrow);
  181. assert(exp->nd_symb == '^');
  182. exp->nd_type = error_type;
  183. if (! ChkVariable(&(exp->nd_RIGHT), D_USED)) return 0;
  184. tp = exp->nd_RIGHT->nd_type;
  185. if (tp->tp_fund != T_POINTER) {
  186. node_error(exp, "\"^\": illegal operand type");
  187. return 0;
  188. }
  189. if ((tp = RemoveEqual(PointedtoType(tp))) == 0) tp = error_type;
  190. exp->nd_type = tp;
  191. return 1;
  192. }
  193. STATIC int
  194. ChkArr(expp, flags)
  195. t_node **expp;
  196. {
  197. /* Check an array selection.
  198. The left hand side must be a variable of an array type,
  199. and the right hand side must be an expression that is
  200. assignment compatible with the array-index.
  201. */
  202. register t_type *tpl;
  203. register t_node *exp = *expp;
  204. assert(exp->nd_class == Arrsel);
  205. assert(exp->nd_symb == '[' || exp->nd_symb == ',');
  206. exp->nd_type = error_type;
  207. if (! (ChkVariable(&(exp->nd_LEFT), flags) &
  208. ChkExpression(&(exp->nd_RIGHT)))) {
  209. /* Bitwise and, because we want them both evaluated.
  210. */
  211. return 0;
  212. }
  213. tpl = exp->nd_LEFT->nd_type;
  214. if (tpl->tp_fund != T_ARRAY) {
  215. node_error(exp, "not indexing an ARRAY type");
  216. return 0;
  217. }
  218. exp->nd_type = RemoveEqual(tpl->arr_elem);
  219. /* Type of the index must be assignment compatible with
  220. the index type of the array (Def 8.1).
  221. However, the index type of a conformant array is not specified.
  222. In our implementation it is CARDINAL.
  223. */
  224. return ChkAssCompat(&(exp->nd_RIGHT),
  225. BaseType(IndexType(tpl)),
  226. "index type");
  227. }
  228. /*ARGSUSED*/
  229. STATIC int
  230. ChkValue(expp)
  231. t_node **expp;
  232. {
  233. #ifdef DEBUG
  234. switch((*expp)->nd_symb) {
  235. case REAL:
  236. case STRING:
  237. case INTEGER:
  238. break;
  239. default:
  240. crash("(ChkValue)");
  241. }
  242. #endif
  243. return 1;
  244. }
  245. STATIC int
  246. ChkSelOrName(expp, flags)
  247. t_node **expp;
  248. {
  249. /* Check either an ID or a construction of the form
  250. ID.ID [ .ID ]*
  251. */
  252. register t_def *df;
  253. register t_node *exp = *expp;
  254. exp->nd_type = error_type;
  255. if (exp->nd_class == Name) {
  256. df = lookfor(exp, CurrVis, 1, flags);
  257. exp = getnode(Def);
  258. exp->nd_def = df;
  259. exp->nd_lineno = (*expp)->nd_lineno;
  260. exp->nd_type = RemoveEqual(df->df_type);
  261. FreeNode(*expp);
  262. *expp = exp;
  263. }
  264. else if (exp->nd_class == Select) {
  265. /* A selection from a record or a module.
  266. Modules also have a record type.
  267. */
  268. register t_node *left;
  269. assert(exp->nd_symb == '.');
  270. if (! ChkDesig(&(exp->nd_NEXT), flags)) return 0;
  271. left = exp->nd_NEXT;
  272. if (left->nd_class==Def &&
  273. (left->nd_type->tp_fund != T_RECORD ||
  274. !(left->nd_def->df_kind & (D_MODULE|D_VARIABLE|D_FIELD))
  275. )
  276. ) {
  277. df_error(left, "illegal selection", left->nd_def);
  278. return 0;
  279. }
  280. if (left->nd_type->tp_fund != T_RECORD) {
  281. node_error(left, "illegal selection");
  282. return 0;
  283. }
  284. if (!(df = lookup(exp->nd_IDF, left->nd_type->rec_scope, D_IMPORTED, flags))) {
  285. id_not_declared(exp);
  286. return 0;
  287. }
  288. exp = getnode(Def);
  289. exp->nd_def = df;
  290. exp->nd_type = RemoveEqual(df->df_type);
  291. exp->nd_lineno = (*expp)->nd_lineno;
  292. free_node(*expp);
  293. *expp = exp;
  294. if (!(df->df_flags & (D_EXPORTED|D_QEXPORTED))) {
  295. /* Fields of a record are always D_QEXPORTED,
  296. so ...
  297. */
  298. df_error(exp, "not exported from qualifying module", df);
  299. }
  300. if (!(left->nd_class == Def &&
  301. left->nd_def->df_kind == D_MODULE)) {
  302. exp->nd_NEXT = left;
  303. return 1;
  304. }
  305. FreeNode(left);
  306. }
  307. assert(exp->nd_class == Def);
  308. return exp->nd_def->df_kind != D_ERROR;
  309. }
  310. STATIC int
  311. ChkExSelOrName(expp)
  312. t_node **expp;
  313. {
  314. /* Check either an ID or an ID.ID [.ID]* occurring in an
  315. expression.
  316. */
  317. register t_def *df;
  318. register t_node *exp;
  319. if (! ChkSelOrName(expp, D_USED)) return 0;
  320. exp = *expp;
  321. df = exp->nd_def;
  322. if (df->df_kind & (D_ENUM | D_CONST)) {
  323. /* Replace an enum-literal or a CONST identifier by its value.
  324. */
  325. exp = getnode(Value);
  326. exp->nd_type = df->df_type;
  327. if (df->df_kind == D_ENUM) {
  328. exp->nd_INT = df->enm_val;
  329. exp->nd_symb = INTEGER;
  330. }
  331. else {
  332. assert(df->df_kind == D_CONST);
  333. exp->nd_token = df->con_const;
  334. }
  335. exp->nd_lineno = (*expp)->nd_lineno;
  336. if (df->df_type->tp_fund == T_SET) {
  337. exp->nd_class = Set;
  338. inc_refcount(exp->nd_set);
  339. }
  340. else if (df->df_type->tp_fund == T_PROCEDURE) {
  341. /* for procedure constants */
  342. exp->nd_class = Def;
  343. }
  344. if (df->df_type->tp_fund == T_REAL) {
  345. struct real *p = exp->nd_REAL;
  346. exp->nd_REAL = new_real();
  347. *(exp->nd_REAL) = *p;
  348. if (p->r_real) {
  349. p->r_real = Salloc(p->r_real,
  350. (unsigned)(strlen(p->r_real)+1));
  351. }
  352. }
  353. FreeNode(*expp);
  354. *expp = exp;
  355. }
  356. if (!(df->df_kind & D_VALUE)) {
  357. df_error(exp, "value expected", df);
  358. return 0;
  359. }
  360. if (df->df_kind == D_PROCEDURE) {
  361. /* Check that this procedure is one that we may take the
  362. address from.
  363. */
  364. if (df->df_type == std_type || df->df_scope->sc_level > 0) {
  365. /* Address of standard or nested procedure
  366. taken.
  367. */
  368. node_error(exp,
  369. "standard or local procedures may not be assigned");
  370. return 0;
  371. }
  372. }
  373. return 1;
  374. }
  375. STATIC int
  376. ChkEl(expp, tp)
  377. register t_node **expp;
  378. t_type *tp;
  379. {
  380. return ChkExpression(expp) && ChkCompat(expp, tp, "set element");
  381. }
  382. STATIC int
  383. ChkElement(expp, tp, set)
  384. t_node **expp;
  385. t_type *tp;
  386. arith *set;
  387. {
  388. /* Check elements of a set. This routine may call itself
  389. recursively.
  390. Also try to compute the set!
  391. */
  392. register t_node *expr = *expp;
  393. t_type *el_type = ElementType(tp);
  394. register unsigned int i;
  395. arith low, high;
  396. if (expr->nd_class == Link && expr->nd_symb == UPTO) {
  397. /* { ... , expr1 .. expr2, ... }
  398. First check expr1 and expr2, and try to compute them.
  399. */
  400. if (! (ChkEl(&(expr->nd_LEFT), el_type) &
  401. ChkEl(&(expr->nd_RIGHT), el_type))) {
  402. return 0;
  403. }
  404. if (!(expr->nd_LEFT->nd_class == Value &&
  405. expr->nd_RIGHT->nd_class == Value)) {
  406. return 1;
  407. }
  408. /* We have a constant range. Put all elements in the
  409. set
  410. */
  411. low = expr->nd_LEFT->nd_INT;
  412. high = expr->nd_RIGHT->nd_INT;
  413. }
  414. else {
  415. if (! ChkEl(expp, el_type)) return 0;
  416. expr = *expp;
  417. if (expr->nd_class != Value) {
  418. return 1;
  419. }
  420. low = high = expr->nd_INT;
  421. }
  422. if (! chk_bounds(low, high, BaseType(el_type)->tp_fund)) {
  423. node_error(expr, "lower bound exceeds upper bound in range");
  424. return 0;
  425. }
  426. if (! in_range(low, el_type) || ! in_range(high, el_type)) {
  427. node_error(expr, "set element out of range");
  428. return 0;
  429. }
  430. low -= tp->set_low;
  431. high -= tp->set_low;
  432. for (i=(unsigned)low; i<= (unsigned)high; i++) {
  433. set[i/wrd_bits] |= (1<<(i%wrd_bits));
  434. }
  435. FreeNode(expr);
  436. *expp = 0;
  437. return 1;
  438. }
  439. arith *
  440. MkSet(size)
  441. unsigned size;
  442. {
  443. register arith *s, *t;
  444. s = t = (arith *) Malloc(size);
  445. s++;
  446. size /= sizeof(arith);
  447. while (size--) *t++ = 0;
  448. inc_refcount(s);
  449. return s;
  450. }
  451. FreeSet(s)
  452. register arith *s;
  453. {
  454. dec_refcount(s);
  455. if (refcount(s) <= 0) {
  456. assert(refcount(s) == 0);
  457. free((char *) (s-1));
  458. }
  459. }
  460. STATIC int
  461. ChkSet(expp)
  462. t_node **expp;
  463. {
  464. /* Check the legality of a SET aggregate, and try to evaluate it
  465. compile time. Unfortunately this is all rather complicated.
  466. */
  467. register t_type *tp;
  468. register t_node *exp = *expp;
  469. register t_node *nd;
  470. register t_def *df;
  471. int retval = 1;
  472. int SetIsConstant = 1;
  473. assert(exp->nd_symb == SET);
  474. *expp = getnode(Set);
  475. (*expp)->nd_type = error_type;
  476. (*expp)->nd_lineno = exp->nd_lineno;
  477. /* First determine the type of the set
  478. */
  479. if (exp->nd_LEFT) {
  480. /* A type was given. Check it out
  481. */
  482. if (! ChkDesig(&(exp->nd_LEFT), D_USED)) return 0;
  483. nd = exp->nd_LEFT;
  484. assert(nd->nd_class == Def);
  485. df = nd->nd_def;
  486. if (!is_type(df) ||
  487. (df->df_type->tp_fund != T_SET)) {
  488. df_error(nd, "not a SET type", df);
  489. return 0;
  490. }
  491. tp = df->df_type;
  492. }
  493. else tp = bitset_type;
  494. (*expp)->nd_type = tp;
  495. nd = exp->nd_RIGHT;
  496. /* Now check the elements given, and try to compute a constant set.
  497. First allocate room for the set.
  498. */
  499. (*expp)->nd_set = MkSet(tp->set_sz);
  500. /* Now check the elements, one by one
  501. */
  502. while (nd) {
  503. assert(nd->nd_class == Link && nd->nd_symb == ',');
  504. if (!ChkElement(&(nd->nd_LEFT), tp, (*expp)->nd_set)) {
  505. retval = 0;
  506. }
  507. if (nd->nd_LEFT) SetIsConstant = 0;
  508. nd = nd->nd_RIGHT;
  509. }
  510. if (! SetIsConstant) {
  511. (*expp)->nd_NEXT = exp->nd_RIGHT;
  512. exp->nd_RIGHT = 0;
  513. }
  514. FreeNode(exp);
  515. return retval;
  516. }
  517. STATIC t_node *
  518. nextarg(argp, edf)
  519. t_node **argp;
  520. t_def *edf;
  521. {
  522. register t_node *arg = (*argp)->nd_RIGHT;
  523. if (! arg) {
  524. df_error(*argp, "too few arguments supplied", edf);
  525. return 0;
  526. }
  527. *argp = arg;
  528. return arg;
  529. }
  530. STATIC t_node *
  531. getarg(argp, bases, designator, edf)
  532. t_node **argp;
  533. t_def *edf;
  534. {
  535. /* This routine is used to fetch the next argument from an
  536. argument list. The argument list is indicated by "argp".
  537. The parameter "bases" is a bitset indicating which types
  538. are allowed at this point, and "designator" is a flag
  539. indicating that the address from this argument is taken, so
  540. that it must be a designator and may not be a register
  541. variable.
  542. */
  543. register t_node *arg = nextarg(argp, edf);
  544. register t_node *left;
  545. if (! arg ||
  546. ! arg->nd_LEFT ||
  547. ! (designator ? ChkVariable(&(arg->nd_LEFT), D_USED|D_DEFINED) : ChkExpression(&(arg->nd_LEFT)))) {
  548. return 0;
  549. }
  550. left = arg->nd_LEFT;
  551. if (designator && left->nd_class==Def) {
  552. left->nd_def->df_flags |= D_NOREG;
  553. }
  554. if (bases) {
  555. t_type *tp = BaseType(left->nd_type);
  556. if (! designator) MkCoercion(&(arg->nd_LEFT), tp);
  557. left = arg->nd_LEFT;
  558. if (!(tp->tp_fund & bases)) {
  559. df_error(left, "unexpected parameter type", edf);
  560. return 0;
  561. }
  562. }
  563. return left;
  564. }
  565. STATIC t_node *
  566. getname(argp, kinds, bases, edf)
  567. t_node **argp;
  568. t_def *edf;
  569. {
  570. /* Get the next argument from argument list "argp".
  571. The argument must indicate a definition, and the
  572. definition kind must be one of "kinds".
  573. */
  574. register t_node *arg = nextarg(argp, edf);
  575. register t_node *left;
  576. if (!arg || !arg->nd_LEFT || ! ChkDesig(&(arg->nd_LEFT), D_USED)) return 0;
  577. left = arg->nd_LEFT;
  578. if (left->nd_class != Def) {
  579. df_error(left, "identifier expected", edf);
  580. return 0;
  581. }
  582. if (!(left->nd_def->df_kind & kinds) ||
  583. (bases && !(left->nd_type->tp_fund & bases))) {
  584. df_error(left, "unexpected parameter type", edf);
  585. return 0;
  586. }
  587. return left;
  588. }
  589. STATIC int
  590. ChkProcCall(exp)
  591. register t_node *exp;
  592. {
  593. /* Check a procedure call
  594. */
  595. register t_node *left;
  596. t_node *argp;
  597. t_def *edf = 0;
  598. register t_param *param;
  599. int retval = 1;
  600. int cnt = 0;
  601. left = exp->nd_LEFT;
  602. if (left->nd_class == Def) {
  603. edf = left->nd_def;
  604. }
  605. if (left->nd_type == error_type) {
  606. /* Just check parameters as if they were value parameters
  607. */
  608. argp = exp;
  609. while (argp->nd_RIGHT) {
  610. if (getarg(&argp, 0, 0, edf)) { }
  611. }
  612. return 0;
  613. }
  614. exp->nd_type = RemoveEqual(ResultType(left->nd_type));
  615. /* Check parameter list
  616. */
  617. argp = exp;
  618. for (param = ParamList(left->nd_type); param; param = param->par_next) {
  619. if (!(left = getarg(&argp, 0, IsVarParam(param), edf))) {
  620. retval = 0;
  621. cnt++;
  622. continue;
  623. }
  624. cnt++;
  625. if (left->nd_symb == STRING) {
  626. TryToString(left, TypeOfParam(param));
  627. }
  628. if (! TstParCompat(cnt,
  629. RemoveEqual(TypeOfParam(param)),
  630. IsVarParam(param),
  631. &(argp->nd_LEFT),
  632. edf)) {
  633. retval = 0;
  634. }
  635. }
  636. exp = argp;
  637. if (exp->nd_RIGHT) {
  638. df_error(exp->nd_RIGHT,"too many parameters supplied",edf);
  639. while (argp->nd_RIGHT) {
  640. if (getarg(&argp, 0, 0, edf)) { }
  641. }
  642. return 0;
  643. }
  644. return retval;
  645. }
  646. STATIC int
  647. ChkFunCall(expp)
  648. register t_node **expp;
  649. {
  650. /* Check a call that must have a result
  651. */
  652. if (ChkCall(expp)) {
  653. if ((*expp)->nd_type != 0) return 1;
  654. node_error(*expp, "function call expected");
  655. }
  656. (*expp)->nd_type = error_type;
  657. return 0;
  658. }
  659. STATIC int ChkStandard();
  660. STATIC int ChkCast();
  661. int
  662. ChkCall(expp)
  663. t_node **expp;
  664. {
  665. /* Check something that looks like a procedure or function call.
  666. Of course this does not have to be a call at all,
  667. it may also be a cast or a standard procedure call.
  668. */
  669. /* First, get the name of the function or procedure
  670. */
  671. if (ChkDesig(&((*expp)->nd_LEFT), D_USED)) {
  672. register t_node *left = (*expp)->nd_LEFT;
  673. if (IsCast(left)) {
  674. /* It was a type cast.
  675. */
  676. return ChkCast(expp);
  677. }
  678. if (IsProc(left) || left->nd_type == error_type) {
  679. /* A procedure call.
  680. It may also be a call to a standard procedure
  681. */
  682. if (left->nd_type == std_type) {
  683. /* A standard procedure
  684. */
  685. return ChkStandard(expp);
  686. }
  687. /* Here, we have found a real procedure call.
  688. The left hand side may also represent a procedure
  689. variable.
  690. */
  691. }
  692. else {
  693. node_error(left, "procedure, type, or function expected");
  694. left->nd_type = error_type;
  695. }
  696. }
  697. return ChkProcCall(*expp);
  698. }
  699. STATIC t_type *
  700. ResultOfOperation(operator, tp)
  701. t_type *tp;
  702. {
  703. /* Return the result type of the binary operation "operator",
  704. with operand type "tp".
  705. */
  706. switch(operator) {
  707. case '=':
  708. case '#':
  709. case GREATEREQUAL:
  710. case LESSEQUAL:
  711. case '<':
  712. case '>':
  713. case IN:
  714. return bool_type;
  715. }
  716. return tp;
  717. }
  718. #define Boolean(operator) (operator == OR || operator == AND)
  719. STATIC int
  720. AllowedTypes(operator)
  721. {
  722. /* Return a bit mask indicating the allowed operand types
  723. for binary operator "operator".
  724. */
  725. switch(operator) {
  726. case '+':
  727. case '-':
  728. case '*':
  729. return T_NUMERIC|T_SET;
  730. case '/':
  731. return T_REAL|T_SET;
  732. case DIV:
  733. case MOD:
  734. return T_INTORCARD;
  735. case OR:
  736. case AND:
  737. return T_ENUMERATION;
  738. case '=':
  739. case '#':
  740. return T_POINTER|T_HIDDEN|T_SET|T_NUMERIC|T_ENUMERATION|T_CHAR;
  741. case GREATEREQUAL:
  742. case LESSEQUAL:
  743. return T_SET|T_NUMERIC|T_CHAR|T_ENUMERATION;
  744. case '<':
  745. case '>':
  746. return T_NUMERIC|T_CHAR|T_ENUMERATION;
  747. default:
  748. crash("(AllowedTypes)");
  749. }
  750. /*NOTREACHED*/
  751. }
  752. STATIC int
  753. ChkAddressOper(tpl, tpr, expp)
  754. register t_type *tpl, *tpr;
  755. register t_node *expp;
  756. {
  757. /* Check that either "tpl" or "tpr" are both of type
  758. address_type, or that one of them is, but the other is
  759. of a cardinal type.
  760. Also insert proper coercions, making sure that the EM pointer
  761. arithmetic instructions can be generated whenever possible
  762. */
  763. if (tpr == address_type && expp->nd_symb == '+') {
  764. /* use the fact that '+' is a commutative operator */
  765. t_type *tmptype = tpr;
  766. t_node *tmpnode = expp->nd_RIGHT;
  767. tpr = tpl;
  768. expp->nd_RIGHT = expp->nd_LEFT;
  769. tpl = tmptype;
  770. expp->nd_LEFT = tmpnode;
  771. }
  772. if (tpl == address_type) {
  773. expp->nd_type = address_type;
  774. if (tpr == address_type) {
  775. return 1;
  776. }
  777. if (tpr->tp_fund & T_CARDINAL) {
  778. MkCoercion(&(expp->nd_RIGHT),
  779. expp->nd_symb=='+' || expp->nd_symb=='-' ?
  780. tpr :
  781. address_type);
  782. return 1;
  783. }
  784. return 0;
  785. }
  786. if (tpr == address_type && tpl->tp_fund & T_CARDINAL) {
  787. expp->nd_type = address_type;
  788. MkCoercion(&(expp->nd_LEFT), address_type);
  789. return 1;
  790. }
  791. return 0;
  792. }
  793. STATIC int
  794. ChkBinOper(expp)
  795. t_node **expp;
  796. {
  797. /* Check a binary operation.
  798. */
  799. register t_node *exp = *expp;
  800. register t_type *tpl, *tpr;
  801. t_type *result_type;
  802. int allowed;
  803. int retval;
  804. char *symb;
  805. /* First, check BOTH operands */
  806. retval = ChkExpression(&(exp->nd_LEFT));
  807. retval &= ChkExpression(&(exp->nd_RIGHT));
  808. tpl = BaseType(exp->nd_LEFT->nd_type);
  809. tpr = BaseType(exp->nd_RIGHT->nd_type);
  810. if (intorcard(tpl, tpr) != 0) {
  811. if (tpl->tp_fund == T_INTORCARD) {
  812. exp->nd_LEFT->nd_type = tpl = tpr;
  813. }
  814. if (tpr->tp_fund == T_INTORCARD) {
  815. exp->nd_RIGHT->nd_type = tpr = tpl;
  816. }
  817. }
  818. exp->nd_type = result_type = ResultOfOperation(exp->nd_symb, tpr);
  819. /* Check that the application of the operator is allowed on the type
  820. of the operands.
  821. There are three tricky parts:
  822. - Boolean operators are only allowed on boolean operands, but
  823. the "allowed-mask" of "AllowedTypes" can only indicate
  824. an enumeration type.
  825. - All operations that are allowed on CARDINALS are also allowed
  826. on ADDRESS.
  827. - The IN-operator has as right-hand-size operand a set.
  828. */
  829. if (exp->nd_symb == IN) {
  830. if (tpr->tp_fund != T_SET) {
  831. node_error(exp, "\"IN\": right operand must be a set");
  832. return 0;
  833. }
  834. if (!TstAssCompat(ElementType(tpr), tpl)) {
  835. /* Assignment compatible ???
  836. I don't know! Should we be allowed to check
  837. if a INTEGER is a member of a BITSET???
  838. */
  839. node_error(exp->nd_LEFT, "type incompatibility in IN");
  840. return 0;
  841. }
  842. MkCoercion(&(exp->nd_LEFT), word_type);
  843. if (exp->nd_LEFT->nd_class == Value &&
  844. exp->nd_RIGHT->nd_class == Set &&
  845. ! exp->nd_RIGHT->nd_NEXT) {
  846. cstset(expp);
  847. }
  848. return retval;
  849. }
  850. if (!retval) return 0;
  851. allowed = AllowedTypes(exp->nd_symb);
  852. symb = symbol2str(exp->nd_symb);
  853. if (!(tpr->tp_fund & allowed) || !(tpl->tp_fund & allowed)) {
  854. if (!((T_CARDINAL & allowed) &&
  855. ChkAddressOper(tpl, tpr, exp))) {
  856. node_error(exp, "\"%s\": illegal operand type(s)", symb);
  857. return 0;
  858. }
  859. if (result_type == bool_type) exp->nd_type = bool_type;
  860. }
  861. else {
  862. if (Boolean(exp->nd_symb) && tpl != bool_type) {
  863. node_error(exp, "\"%s\": illegal operand type(s)", symb);
  864. return 0;
  865. }
  866. /* Operands must be compatible (distilled from Def 8.2)
  867. */
  868. if (!TstCompat(tpr, tpl)) {
  869. extern char *incompat();
  870. node_error(exp, "\"%s\": %s in operands", symb, incompat(tpl, tpr));
  871. return 0;
  872. }
  873. MkCoercion(&(exp->nd_LEFT), tpl);
  874. MkCoercion(&(exp->nd_RIGHT), tpr);
  875. }
  876. if (tpl->tp_fund == T_SET) {
  877. if (exp->nd_LEFT->nd_class == Set &&
  878. ! exp->nd_LEFT->nd_NEXT &&
  879. exp->nd_RIGHT->nd_class == Set &&
  880. ! exp->nd_RIGHT->nd_NEXT) {
  881. cstset(expp);
  882. }
  883. }
  884. else if ( exp->nd_LEFT->nd_class == Value &&
  885. exp->nd_RIGHT->nd_class == Value) {
  886. if (tpl->tp_fund == T_INTEGER) {
  887. cstibin(expp);
  888. }
  889. else if (tpl->tp_fund == T_REAL) {
  890. cstfbin(expp);
  891. }
  892. else cstubin(expp);
  893. }
  894. return 1;
  895. }
  896. STATIC int
  897. ChkUnOper(expp)
  898. t_node **expp;
  899. {
  900. /* Check an unary operation.
  901. */
  902. register t_node *exp = *expp;
  903. register t_node *right = exp->nd_RIGHT;
  904. register t_type *tpr;
  905. if (exp->nd_symb == COERCION) return 1;
  906. if (exp->nd_symb == '(') {
  907. *expp = right;
  908. free_node(exp);
  909. return ChkExpression(expp);
  910. }
  911. exp->nd_type = error_type;
  912. if (! ChkExpression(&(exp->nd_RIGHT))) return 0;
  913. exp->nd_type = tpr = BaseType(exp->nd_RIGHT->nd_type);
  914. MkCoercion(&(exp->nd_RIGHT), tpr);
  915. right = exp->nd_RIGHT;
  916. if (tpr == address_type) tpr = card_type;
  917. switch(exp->nd_symb) {
  918. case '+':
  919. if (!(tpr->tp_fund & T_NUMERIC)) break;
  920. *expp = right;
  921. free_node(exp);
  922. return 1;
  923. case '-':
  924. if (tpr->tp_fund == T_INTORCARD || tpr->tp_fund == T_INTEGER) {
  925. if (tpr == intorcard_type) {
  926. exp->nd_type = int_type;
  927. }
  928. else if (tpr == longintorcard_type) {
  929. exp->nd_type = longint_type;
  930. }
  931. if (right->nd_class == Value) {
  932. cstunary(expp);
  933. }
  934. return 1;
  935. }
  936. else if (tpr->tp_fund == T_REAL) {
  937. if (right->nd_class == Value) {
  938. *expp = right;
  939. flt_umin(&(right->nd_RVAL));
  940. if (right->nd_RSTR) {
  941. free(right->nd_RSTR);
  942. right->nd_RSTR = 0;
  943. }
  944. free_node(exp);
  945. }
  946. return 1;
  947. }
  948. break;
  949. case NOT:
  950. case '~':
  951. if (tpr == bool_type) {
  952. if (right->nd_class == Value) {
  953. cstunary(expp);
  954. }
  955. return 1;
  956. }
  957. break;
  958. default:
  959. crash("ChkUnOper");
  960. }
  961. node_error(exp, "\"%s\": illegal operand type", symbol2str(exp->nd_symb));
  962. return 0;
  963. }
  964. STATIC t_node *
  965. getvariable(argp, edf, flags)
  966. t_node **argp;
  967. t_def *edf;
  968. {
  969. /* Get the next argument from argument list "argp".
  970. It must obey the rules of "ChkVariable".
  971. */
  972. register t_node *arg = nextarg(argp, edf);
  973. if (! arg ||
  974. ! arg->nd_LEFT ||
  975. ! ChkVariable(&(arg->nd_LEFT), flags)) return 0;
  976. return arg->nd_LEFT;
  977. }
  978. STATIC int
  979. ChkStandard(expp)
  980. t_node **expp;
  981. {
  982. /* Check a call of a standard procedure or function
  983. */
  984. register t_node *exp = *expp;
  985. t_node *arglink = exp;
  986. register t_node *arg;
  987. register t_def *edf = exp->nd_LEFT->nd_def;
  988. int free_it = 0;
  989. int isconstant = 0;
  990. assert(exp->nd_LEFT->nd_class == Def);
  991. exp->nd_type = error_type;
  992. switch(edf->df_value.df_stdname) {
  993. case S_ABS:
  994. if (!(arg = getarg(&arglink, T_NUMERIC, 0, edf))) return 0;
  995. exp->nd_type = BaseType(arg->nd_type);
  996. MkCoercion(&(arglink->nd_LEFT), exp->nd_type);
  997. arg = arglink->nd_LEFT;
  998. if (! (exp->nd_type->tp_fund & (T_INTEGER|T_REAL))) {
  999. free_it = 1;
  1000. }
  1001. if (arg->nd_class == Value) {
  1002. switch(exp->nd_type->tp_fund) {
  1003. case T_REAL:
  1004. arg->nd_RVAL.flt_sign = 0;
  1005. free_it = 1;
  1006. break;
  1007. case T_INTEGER:
  1008. isconstant = 1;
  1009. break;
  1010. }
  1011. }
  1012. break;
  1013. case S_CAP:
  1014. exp->nd_type = char_type;
  1015. if (!(arg = getarg(&arglink, T_CHAR, 0, edf))) return 0;
  1016. if (arg->nd_class == Value) isconstant = 1;
  1017. break;
  1018. case S_FLOATD:
  1019. case S_FLOAT:
  1020. if (! getarg(&arglink, T_INTORCARD, 0, edf)) return 0;
  1021. arg = arglink;
  1022. if (edf->df_value.df_stdname == S_FLOAT) {
  1023. MkCoercion(&(arg->nd_LEFT), card_type);
  1024. }
  1025. MkCoercion(&(arg->nd_LEFT),
  1026. edf->df_value.df_stdname == S_FLOATD ?
  1027. longreal_type :
  1028. real_type);
  1029. free_it = 1;
  1030. break;
  1031. case S_SHORT:
  1032. case S_LONG: {
  1033. t_type *tp;
  1034. t_type *s1, *s2, *s3, *d1, *d2, *d3;
  1035. if (!(arg = getarg(&arglink, 0, 0, edf))) {
  1036. return 0;
  1037. }
  1038. tp = BaseType(arg->nd_type);
  1039. if (edf->df_value.df_stdname == S_SHORT) {
  1040. s1 = longint_type;
  1041. d1 = int_type;
  1042. s2 = longreal_type;
  1043. d2 = real_type;
  1044. s3 = longcard_type;
  1045. d3 = card_type;
  1046. }
  1047. else {
  1048. d1 = longint_type;
  1049. s1 = int_type;
  1050. d2 = longreal_type;
  1051. s2 = real_type;
  1052. d3 = longcard_type;
  1053. s3 = card_type;
  1054. }
  1055. if (tp == s1) {
  1056. MkCoercion(&(arglink->nd_LEFT), d1);
  1057. }
  1058. else if (tp == s2) {
  1059. MkCoercion(&(arglink->nd_LEFT), d2);
  1060. }
  1061. else if (options['l'] && tp == s3) {
  1062. MkCoercion(&(arglink->nd_LEFT), d3);
  1063. }
  1064. else {
  1065. df_error(arg, "unexpected parameter type", edf);
  1066. break;
  1067. }
  1068. free_it = 1;
  1069. break;
  1070. }
  1071. case S_HIGH:
  1072. if (!(arg = getarg(&arglink, T_ARRAY|T_STRING|T_CHAR, 0, edf))) {
  1073. return 0;
  1074. }
  1075. if (arg->nd_type->tp_fund == T_ARRAY) {
  1076. exp->nd_type = IndexType(arg->nd_type);
  1077. if (! IsConformantArray(arg->nd_type)) {
  1078. arg->nd_type = exp->nd_type;
  1079. isconstant = 1;
  1080. }
  1081. break;
  1082. }
  1083. if (arg->nd_symb != STRING) {
  1084. df_error(arg,"array parameter expected", edf);
  1085. return 0;
  1086. }
  1087. exp = getnode(Value);
  1088. exp->nd_type = card_type;
  1089. /* Notice that we could disallow HIGH("") here by checking
  1090. that arg->nd_type->tp_fund != T_CHAR || arg->nd_INT != 0.
  1091. ??? For the time being, we don't. !!!
  1092. Maybe the empty string should not be allowed at all.
  1093. */
  1094. exp->nd_INT = arg->nd_type->tp_fund == T_CHAR ? 0 :
  1095. arg->nd_SLE - 1;
  1096. exp->nd_symb = INTEGER;
  1097. exp->nd_lineno = (*expp)->nd_lineno;
  1098. (*expp)->nd_RIGHT = 0;
  1099. FreeNode(*expp);
  1100. *expp = exp;
  1101. break;
  1102. case S_MAX:
  1103. case S_MIN:
  1104. if (!(arg = getname(&arglink, D_ISTYPE, T_DISCRETE, edf))) {
  1105. return 0;
  1106. }
  1107. exp->nd_type = arg->nd_type;
  1108. isconstant = 1;
  1109. break;
  1110. case S_ODD:
  1111. if (! (arg = getarg(&arglink, T_INTORCARD, 0, edf))) return 0;
  1112. MkCoercion(&(arglink->nd_LEFT), BaseType(arg->nd_type));
  1113. exp->nd_type = bool_type;
  1114. if (arglink->nd_LEFT->nd_class == Value) isconstant = 1;
  1115. break;
  1116. case S_ORD:
  1117. if (! (arg = getarg(&arglink, T_NOSUB, 0, edf))) return 0;
  1118. exp->nd_type = card_type;
  1119. if (arg->nd_class == Value) {
  1120. arg->nd_type = card_type;
  1121. free_it = 1;
  1122. }
  1123. break;
  1124. #ifndef STRICT_3RD_ED
  1125. case S_NEW:
  1126. case S_DISPOSE:
  1127. {
  1128. static int warning_given = 0;
  1129. if (!warning_given) {
  1130. warning_given = 1;
  1131. if (! options['3'])
  1132. node_warning(exp, W_OLDFASHIONED, "NEW and DISPOSE are obsolete");
  1133. else
  1134. node_error(exp, "NEW and DISPOSE are obsolete");
  1135. }
  1136. }
  1137. exp->nd_type = 0;
  1138. arg = getvariable(&arglink, edf, D_USED|D_DEFINED);
  1139. if (! arg) return 0;
  1140. if (! (arg->nd_type->tp_fund == T_POINTER)) {
  1141. df_error(arg, "pointer variable expected", edf);
  1142. return 0;
  1143. }
  1144. /* Now, make it look like a call to ALLOCATE or DEALLOCATE */
  1145. arglink->nd_RIGHT = arg = getnode(Link);
  1146. arg->nd_lineno = exp->nd_lineno;
  1147. arg->nd_symb = ',';
  1148. arg->nd_LEFT = getnode(Value);
  1149. arg = arg->nd_LEFT;
  1150. arg->nd_INT = PointedtoType(arglink->nd_LEFT->nd_type)->tp_size;
  1151. arg->nd_symb = INTEGER;
  1152. arg->nd_lineno = exp->nd_lineno;
  1153. arg->nd_type = card_type;
  1154. /* Ignore other arguments to NEW and/or DISPOSE ??? */
  1155. FreeNode(exp->nd_LEFT);
  1156. exp->nd_LEFT = arg = getnode(Name);
  1157. arg->nd_symb = IDENT;
  1158. arg->nd_lineno = exp->nd_lineno;
  1159. arg->nd_IDF = str2idf(edf->df_value.df_stdname==S_NEW ?
  1160. "ALLOCATE" : "DEALLOCATE", 0);
  1161. return ChkCall(expp);
  1162. #endif
  1163. case S_TSIZE: /* ??? */
  1164. case S_SIZE:
  1165. exp->nd_type = intorcard_type;
  1166. if (!(arg = getname(&arglink,D_FIELD|D_VARIABLE|D_ISTYPE,0,edf))) {
  1167. return 0;
  1168. }
  1169. if (! IsConformantArray(arg->nd_type)) isconstant = 1;
  1170. #ifndef NOSTRICT
  1171. else node_warning(exp,
  1172. W_STRICT,
  1173. "%s on conformant array",
  1174. edf->df_idf->id_text);
  1175. #endif
  1176. #ifndef STRICT_3RD_ED
  1177. if (! options['3'] && edf->df_value.df_stdname == S_TSIZE) {
  1178. if (arg = arglink->nd_RIGHT) {
  1179. node_warning(arg,
  1180. W_OLDFASHIONED,
  1181. "TSIZE with multiple parameters, only first parameter used");
  1182. FreeNode(arg);
  1183. arglink->nd_RIGHT = 0;
  1184. }
  1185. }
  1186. #endif
  1187. break;
  1188. case S_TRUNCD:
  1189. case S_TRUNC:
  1190. if (! getarg(&arglink, T_REAL, 0, edf)) return 0;
  1191. MkCoercion(&(arglink->nd_LEFT),
  1192. edf->df_value.df_stdname == S_TRUNCD ?
  1193. options['l'] ? longcard_type : longint_type
  1194. : card_type);
  1195. free_it = 1;
  1196. break;
  1197. case S_VAL:
  1198. if (!(arg = getname(&arglink, D_ISTYPE, T_NOSUB, edf))) {
  1199. return 0;
  1200. }
  1201. exp->nd_type = arg->nd_def->df_type;
  1202. exp->nd_RIGHT = arglink->nd_RIGHT;
  1203. arglink->nd_RIGHT = 0;
  1204. FreeNode(arglink);
  1205. arglink = exp;
  1206. /* fall through */
  1207. case S_CHR:
  1208. if (! getarg(&arglink, T_CARDINAL, 0, edf)) return 0;
  1209. if (edf->df_value.df_stdname == S_CHR) {
  1210. exp->nd_type = char_type;
  1211. }
  1212. if (exp->nd_type != int_type) {
  1213. MkCoercion(&(arglink->nd_LEFT), exp->nd_type);
  1214. free_it = 1;
  1215. }
  1216. break;
  1217. case S_ADR:
  1218. exp->nd_type = address_type;
  1219. if (! getarg(&arglink, 0, 1, edf)) return 0;
  1220. break;
  1221. case S_DEC:
  1222. case S_INC:
  1223. exp->nd_type = 0;
  1224. if (! (arg = getvariable(&arglink, edf, D_USED|D_DEFINED))) return 0;
  1225. if (! (arg->nd_type->tp_fund & T_DISCRETE)) {
  1226. df_error(arg,"illegal parameter type", edf);
  1227. return 0;
  1228. }
  1229. if (arglink->nd_RIGHT) {
  1230. if (! getarg(&arglink, T_INTORCARD, 0, edf)) return 0;
  1231. }
  1232. break;
  1233. case S_HALT:
  1234. exp->nd_type = 0;
  1235. break;
  1236. case S_EXCL:
  1237. case S_INCL:
  1238. {
  1239. register t_type *tp;
  1240. t_node *dummy;
  1241. exp->nd_type = 0;
  1242. if (!(arg = getvariable(&arglink, edf, D_USED|D_DEFINED))) return 0;
  1243. tp = arg->nd_type;
  1244. if (tp->tp_fund != T_SET) {
  1245. df_error(arg, "SET parameter expected", edf);
  1246. return 0;
  1247. }
  1248. if (!(dummy = getarg(&arglink, 0, 0, edf))) return 0;
  1249. if (!ChkAssCompat(&dummy, ElementType(tp), "EXCL/INCL")) {
  1250. /* What type of compatibility do we want here?
  1251. apparently assignment compatibility! ??? ???
  1252. But we don't want the coercion in the tree, because
  1253. we don't want a range check here. We want a SET
  1254. error.
  1255. */
  1256. return 0;
  1257. }
  1258. MkCoercion(&(arglink->nd_LEFT), word_type);
  1259. break;
  1260. }
  1261. default:
  1262. crash("(ChkStandard)");
  1263. }
  1264. arg = arglink;
  1265. if (arg->nd_RIGHT) {
  1266. df_error(arg->nd_RIGHT, "too many parameters supplied", edf);
  1267. return 0;
  1268. }
  1269. if (isconstant) {
  1270. cstcall(expp, edf->df_value.df_stdname);
  1271. return 1;
  1272. }
  1273. if (free_it) {
  1274. *expp = arg->nd_LEFT;
  1275. exp->nd_RIGHT = arg;
  1276. arg->nd_LEFT = 0;
  1277. FreeNode(exp);
  1278. }
  1279. return 1;
  1280. }
  1281. STATIC int
  1282. ChkCast(expp)
  1283. t_node **expp;
  1284. {
  1285. /* Check a cast and perform it if the argument is constant.
  1286. If the sizes don't match, only complain if at least one of them
  1287. has a size larger than the word size.
  1288. If both sizes are equal to or smaller than the word size, there
  1289. is no problem as such values take a word on the EM stack
  1290. anyway.
  1291. */
  1292. register t_node *exp = *expp;
  1293. register t_node *arg = exp->nd_RIGHT;
  1294. register t_type *lefttype = exp->nd_LEFT->nd_type;
  1295. t_def *df = exp->nd_LEFT->nd_def;
  1296. if ((! arg) || arg->nd_RIGHT) {
  1297. df_error(exp, "type cast must have 1 parameter", df);
  1298. return 0;
  1299. }
  1300. if (! ChkExpression(&(arg->nd_LEFT))) return 0;
  1301. MkCoercion(&(arg->nd_LEFT), BaseType(arg->nd_LEFT->nd_type));
  1302. arg = arg->nd_LEFT;
  1303. if (arg->nd_type->tp_size != lefttype->tp_size &&
  1304. (arg->nd_type->tp_size > word_size ||
  1305. lefttype->tp_size > word_size)) {
  1306. df_error(exp, "unequal sizes in type cast", df);
  1307. return 0;
  1308. }
  1309. if (IsConformantArray(arg->nd_type)) {
  1310. df_error(exp,
  1311. "type transfer function on conformant array not supported",
  1312. df);
  1313. return 0;
  1314. }
  1315. exp->nd_RIGHT->nd_LEFT = 0;
  1316. FreeNode(exp);
  1317. if (arg->nd_class == Value) {
  1318. exp = arg;
  1319. if (lefttype->tp_fund == T_SET) {
  1320. /* User deserves what he gets here ... */
  1321. exp = getnode(Set);
  1322. exp->nd_set = MkSet((unsigned)(lefttype->set_sz));
  1323. exp->nd_set[0] = arg->nd_INT;
  1324. exp->nd_lineno = arg->nd_lineno;
  1325. FreeNode(arg);
  1326. }
  1327. }
  1328. else {
  1329. exp = getnode(Uoper);
  1330. exp->nd_symb = CAST;
  1331. exp->nd_lineno = arg->nd_lineno;
  1332. exp->nd_RIGHT = arg;
  1333. }
  1334. *expp = exp;
  1335. exp->nd_type = lefttype;
  1336. return 1;
  1337. }
  1338. TryToString(nd, tp)
  1339. register t_node *nd;
  1340. t_type *tp;
  1341. {
  1342. /* Try a coercion from character constant to string.
  1343. */
  1344. static char buf[8];
  1345. assert(nd->nd_symb == STRING);
  1346. if (tp->tp_fund == T_ARRAY && nd->nd_type == char_type) {
  1347. buf[0] = nd->nd_INT;
  1348. nd->nd_type = standard_type(T_STRING, 1, (arith) 2);
  1349. nd->nd_SSTR =
  1350. (struct string *) Malloc(sizeof(struct string));
  1351. nd->nd_STR = Salloc(buf, (unsigned) word_size);
  1352. nd->nd_SLE = 1;
  1353. }
  1354. }
  1355. STATIC int
  1356. no_desig(expp)
  1357. t_node **expp;
  1358. {
  1359. node_error(*expp, "designator expected");
  1360. return 0;
  1361. }
  1362. STATIC int
  1363. add_flags(expp, flags)
  1364. t_node **expp;
  1365. {
  1366. (*expp)->nd_def->df_flags |= flags;
  1367. return 1;
  1368. }
  1369. extern int PNodeCrash();
  1370. int (*ExprChkTable[])() = {
  1371. ChkValue,
  1372. ChkArr,
  1373. ChkBinOper,
  1374. ChkUnOper,
  1375. ChkArrow,
  1376. ChkFunCall,
  1377. ChkExSelOrName,
  1378. PNodeCrash,
  1379. ChkSet,
  1380. add_flags,
  1381. PNodeCrash,
  1382. ChkExSelOrName,
  1383. PNodeCrash,
  1384. };
  1385. int (*DesigChkTable[])() = {
  1386. no_desig,
  1387. ChkArr,
  1388. no_desig,
  1389. no_desig,
  1390. ChkArrow,
  1391. no_desig,
  1392. ChkSelOrName,
  1393. PNodeCrash,
  1394. no_desig,
  1395. add_flags,
  1396. PNodeCrash,
  1397. ChkSelOrName,
  1398. PNodeCrash,
  1399. };