modula-2.c 8.3 KB

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