modula-2.c 8.4 KB

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