modula-2.c 8.3 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556
  1. /* $Header$ */
  2. /* Language dependant support; this one is for Modula-2 */
  3. #include <stdio.h>
  4. #include <alloc.h>
  5. #include <assert.h>
  6. #include "position.h"
  7. #include "class.h"
  8. #include "langdep.h"
  9. #include "Lpars.h"
  10. #include "idf.h"
  11. #include "token.h"
  12. #include "expr.h"
  13. #include "tree.h"
  14. #include "operator.h"
  15. extern FILE *db_out, *db_in;
  16. extern double
  17. atof();
  18. static int
  19. print_string(),
  20. print_char(),
  21. get_number(),
  22. get_name(),
  23. get_token(),
  24. get_string(),
  25. print_op(),
  26. binop_prio(),
  27. unop_prio(),
  28. fix_bin_to_pref();
  29. static long
  30. array_elsize();
  31. static struct langdep m2 = {
  32. 1,
  33. "%ld",
  34. "%loB",
  35. "%lXH",
  36. "%lu",
  37. "%lXH",
  38. "%.14G",
  39. "[",
  40. "]",
  41. "(",
  42. ")",
  43. "{",
  44. "}",
  45. print_string,
  46. print_char,
  47. array_elsize,
  48. binop_prio,
  49. unop_prio,
  50. get_string,
  51. get_name,
  52. get_number,
  53. get_token,
  54. print_op,
  55. fix_bin_to_pref
  56. };
  57. struct langdep *m2_dep = &m2;
  58. static int
  59. print_char(c)
  60. int c;
  61. {
  62. c &= 0377;
  63. fprintf(db_out, (c >= 040 && c < 0177) ? "'%c'" : "%oC", c);
  64. }
  65. static int
  66. print_string(f, s, len)
  67. FILE *f;
  68. char *s;
  69. int len;
  70. {
  71. register char *str = s;
  72. int delim = '\'';
  73. while (*str) {
  74. if (*str++ == '\'') delim = '"';
  75. }
  76. fprintf(f, "%c%.*s%c", delim, len, s, delim);
  77. }
  78. extern long int_size;
  79. static long
  80. array_elsize(size)
  81. long size;
  82. {
  83. if (! (int_size % size)) return size;
  84. if (! (size % int_size)) return size;
  85. return ((size + int_size - 1) / int_size) * int_size;
  86. }
  87. static int
  88. unop_prio(op)
  89. int op;
  90. {
  91. switch(op) {
  92. case E_NOT:
  93. return 5;
  94. case E_MIN:
  95. case E_PLUS:
  96. return 3;
  97. }
  98. return 1;
  99. }
  100. static int
  101. binop_prio(op)
  102. int op;
  103. {
  104. switch(op) {
  105. case E_SELECT:
  106. return 9;
  107. case E_ARRAY:
  108. return 5;
  109. case E_AND:
  110. case E_MUL:
  111. case E_DIV:
  112. case E_MOD:
  113. return 4;
  114. case E_PLUS:
  115. case E_MIN:
  116. case E_OR:
  117. return 3;
  118. case E_IN:
  119. case E_EQUAL:
  120. case E_NOTEQUAL:
  121. case E_LTEQUAL:
  122. case E_GTEQUAL:
  123. case E_LT:
  124. case E_GT:
  125. return 2;
  126. }
  127. return 1;
  128. }
  129. static int
  130. get_number(ch)
  131. register int ch;
  132. {
  133. /* The problem arising with the "parsing" of a number
  134. is that we don't know the base in advance so we
  135. have to read the number with the help of a rather
  136. complex finite automaton.
  137. */
  138. enum statetp {Oct,Hex,Dec,OctEndOrHex,End,Real};
  139. register enum statetp state;
  140. char buf[512+1];
  141. register int base = 10;
  142. register char *np = &buf[0];
  143. *np++ = ch;
  144. state = is_oct(ch) ? Oct : Dec;
  145. ch = getc(db_in);
  146. for (;;) {
  147. switch(state) {
  148. case Oct:
  149. while (is_oct(ch)) {
  150. if (np < &buf[512]) *np++ = ch;
  151. ch = getc(db_in);
  152. }
  153. if (ch == 'B' || ch == 'C') {
  154. state = OctEndOrHex;
  155. break;
  156. }
  157. /* Fall Through */
  158. case Dec:
  159. base = 10;
  160. while (is_dig(ch)) {
  161. if (np < &buf[512]) {
  162. *np++ = ch;
  163. }
  164. ch = getc(db_in);
  165. }
  166. if (is_hex(ch)) state = Hex;
  167. else if (ch == '.') state = Real;
  168. else {
  169. state = End;
  170. if (ch == 'H') base = 16;
  171. else ungetc(ch, db_in);
  172. }
  173. break;
  174. case Hex:
  175. while (is_hex(ch)) {
  176. if (np < &buf[512]) *np++ = ch;
  177. ch = getc(db_in);
  178. }
  179. base = 16;
  180. state = End;
  181. if (ch != 'H') {
  182. error("H expected after hex number");
  183. ungetc(ch, db_in);
  184. }
  185. break;
  186. case OctEndOrHex:
  187. if (np < &buf[512]) *np++ = ch;
  188. ch = getc(db_in);
  189. if (ch == 'H') {
  190. base = 16;
  191. state = End;
  192. break;
  193. }
  194. if (is_hex(ch)) {
  195. state = Hex;
  196. break;
  197. }
  198. ungetc(ch, db_in);
  199. ch = *--np;
  200. *np++ = '\0';
  201. /* Fall through */
  202. case End:
  203. *np = '\0';
  204. if (np >= &buf[512]) {
  205. tok.ival = 1;
  206. error("constant too long");
  207. }
  208. else {
  209. np = &buf[0];
  210. while (*np == '0') np++;
  211. tok.ival = 0;
  212. while (*np) {
  213. int c;
  214. if (is_dig(*np)) {
  215. c = *np++ - '0';
  216. }
  217. else {
  218. c = *np++ - 'A' + 10;
  219. }
  220. tok.ival *= base;
  221. tok.ival += c;
  222. }
  223. }
  224. return INTEGER;
  225. }
  226. if (state == Real) break;
  227. }
  228. /* a real real constant */
  229. if (np < &buf[512]) *np++ = '.';
  230. ch = getc(db_in);
  231. while (is_dig(ch)) {
  232. /* Fractional part
  233. */
  234. if (np < &buf[512]) *np++ = ch;
  235. ch = getc(db_in);
  236. }
  237. if (ch == 'E') {
  238. /* Scale factor
  239. */
  240. if (np < &buf[512]) *np++ = ch;
  241. ch = getc(db_in);
  242. if (ch == '+' || ch == '-') {
  243. /* Signed scalefactor
  244. */
  245. if (np < &buf[512]) *np++ = ch;
  246. ch = getc(db_in);
  247. }
  248. if (is_dig(ch)) {
  249. do {
  250. if (np < &buf[512]) *np++ = ch;
  251. ch = getc(db_in);
  252. } while (is_dig(ch));
  253. }
  254. else {
  255. error("bad scale factor");
  256. }
  257. }
  258. *np++ = '\0';
  259. ungetc(ch, db_in);
  260. if (np >= &buf[512]) {
  261. tok.fval = 0.0;
  262. error("real constant too long");
  263. }
  264. else tok.fval = atof(buf);
  265. return REAL;
  266. }
  267. static int
  268. get_name(c)
  269. register int c;
  270. {
  271. char buf[512+1];
  272. register char *p = &buf[0];
  273. register struct idf *id;
  274. do {
  275. if (p - buf < 512) *p++ = c;
  276. c = getc(db_in);
  277. } while (in_idf(c));
  278. ungetc(c, db_in);
  279. *p = 0;
  280. /* now recognize AND, DIV, IN, MOD, NOT, OR */
  281. switch(buf[0]) {
  282. case 'A':
  283. if (strcmp(buf, "AND") == 0) {
  284. tok.ival = E_AND;
  285. return BIN_OP;
  286. }
  287. break;
  288. case 'D':
  289. if (strcmp(buf, "DIV") == 0) {
  290. tok.ival = E_DIV;
  291. return BIN_OP;
  292. }
  293. break;
  294. case 'I':
  295. if (strcmp(buf, "IN") == 0) {
  296. tok.ival = E_IN;
  297. return BIN_OP;
  298. }
  299. break;
  300. case 'M':
  301. if (strcmp(buf, "MOD") == 0) {
  302. tok.ival = E_MOD;
  303. return BIN_OP;
  304. }
  305. break;
  306. case 'N':
  307. if (strcmp(buf, "NOT") == 0) {
  308. tok.ival = E_NOT;
  309. return PREF_OP;
  310. }
  311. break;
  312. case 'O':
  313. if (strcmp(buf, "OR") == 0) {
  314. tok.ival = E_OR;
  315. return BIN_OP;
  316. }
  317. break;
  318. }
  319. id = str2idf(buf, 1);
  320. tok.idf = id;
  321. tok.str = id->id_text;
  322. return id->id_reserved ? id->id_reserved : NAME;
  323. }
  324. static int
  325. get_token(c)
  326. register int c;
  327. {
  328. switch(c) {
  329. case '[':
  330. tok.ival = E_ARRAY;
  331. /* fall through */
  332. case '(':
  333. case ')':
  334. case ']':
  335. case '`':
  336. case '{':
  337. case '}':
  338. case ':':
  339. case ',':
  340. case '\\':
  341. return c;
  342. case '.':
  343. tok.ival = E_SELECT;
  344. return SEL_OP;
  345. case '+':
  346. tok.ival = E_PLUS;
  347. return PREF_OR_BIN_OP;
  348. case '-':
  349. tok.ival = E_MIN;
  350. return PREF_OR_BIN_OP;
  351. case '*':
  352. tok.ival = E_MUL;
  353. return BIN_OP;
  354. case '/':
  355. tok.ival = E_DIV;
  356. return BIN_OP;
  357. case '&':
  358. tok.ival = E_AND;
  359. return BIN_OP;
  360. case '|':
  361. tok.ival = E_OR;
  362. return BIN_OP;
  363. case '=':
  364. tok.ival = E_EQUAL;
  365. return BIN_OP;
  366. case '#':
  367. tok.ival = E_NOTEQUAL;
  368. return BIN_OP;
  369. case '<':
  370. c = getc(db_in);
  371. if (c == '>') {
  372. tok.ival = E_NOTEQUAL;
  373. return BIN_OP;
  374. }
  375. if (c == '=') {
  376. tok.ival = E_LTEQUAL;
  377. return BIN_OP;
  378. }
  379. ungetc(c, db_in);
  380. tok.ival = E_LT;
  381. return BIN_OP;
  382. case '>':
  383. c = getc(db_in);
  384. if (c == '=') {
  385. tok.ival = E_GTEQUAL;
  386. return BIN_OP;
  387. }
  388. ungetc(c, db_in);
  389. tok.ival = E_GT;
  390. return BIN_OP;
  391. case '^':
  392. tok.ival = E_DEREF;
  393. return POST_OP;
  394. case '~':
  395. tok.ival = E_NOT;
  396. return PREF_OP;
  397. default:
  398. error((c >= 040 && c < 0177) ? "%s'%c'" : "%s'\\0%o'", "illegal character ", c);
  399. return LLlex();
  400. }
  401. }
  402. static int
  403. get_string(c)
  404. int c;
  405. {
  406. register int ch;
  407. char buf[512];
  408. register int len = 0;
  409. while (ch = getc(db_in), ch != c) {
  410. if (ch == '\n') {
  411. error("newline in string");
  412. ungetc(ch, db_in);
  413. break;
  414. }
  415. buf[len++] = ch;
  416. }
  417. buf[len++] = 0;
  418. tok.str = Salloc(buf, (unsigned) len);
  419. return STRING;
  420. }
  421. static int
  422. print_op(f, p)
  423. FILE *f;
  424. p_tree p;
  425. {
  426. switch(p->t_oper) {
  427. case OP_UNOP:
  428. switch(p->t_whichoper) {
  429. case E_MIN:
  430. fputs("-", f);
  431. print_node(f, p->t_args[0], 0);
  432. break;
  433. case E_PLUS:
  434. fputs("+", f);
  435. print_node(f, p->t_args[0], 0);
  436. break;
  437. case E_NOT:
  438. fputs("~", f);
  439. print_node(f, p->t_args[0], 0);
  440. break;
  441. case E_DEREF:
  442. print_node(f, p->t_args[0], 0);
  443. fputs("^", f);
  444. break;
  445. }
  446. break;
  447. case OP_BINOP:
  448. if (p->t_whichoper == E_ARRAY) {
  449. print_node(f, p->t_args[0], 0);
  450. fputs("[", f);
  451. print_node(f, p->t_args[1], 0);
  452. fputs("]", f);
  453. break;
  454. }
  455. if (p->t_whichoper == E_SELECT) {
  456. print_node(f, p->t_args[0], 0);
  457. fputs(".", f);
  458. print_node(f, p->t_args[1], 0);
  459. break;
  460. }
  461. fputs("(", f);
  462. print_node(f, p->t_args[0], 0);
  463. switch(p->t_whichoper) {
  464. case E_AND:
  465. fputs("&", f);
  466. break;
  467. case E_OR:
  468. fputs("|", f);
  469. break;
  470. case E_DIV:
  471. fputs("/", f);
  472. break;
  473. case E_MOD:
  474. fputs(" MOD ", f);
  475. break;
  476. case E_IN:
  477. fputs(" IN ", f);
  478. break;
  479. case E_PLUS:
  480. fputs("+", f);
  481. break;
  482. case E_MIN:
  483. fputs("-", f);
  484. break;
  485. case E_MUL:
  486. fputs("*", f);
  487. break;
  488. case E_EQUAL:
  489. fputs("=", f);
  490. break;
  491. case E_NOTEQUAL:
  492. fputs("#", f);
  493. break;
  494. case E_LTEQUAL:
  495. fputs("<=", f);
  496. break;
  497. case E_GTEQUAL:
  498. fputs(">=", f);
  499. break;
  500. case E_LT:
  501. fputs("<", f);
  502. break;
  503. case E_GT:
  504. fputs(">", f);
  505. break;
  506. }
  507. print_node(f, p->t_args[1], 0);
  508. fputs(")", f);
  509. break;
  510. }
  511. }
  512. static int
  513. fix_bin_to_pref()
  514. {
  515. /* No problems of this kind in Modula-2 */
  516. }