shim.c 26 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953
  1. /* m2compiler-V3 runtime shim (C).
  2. *
  3. * Bridges Modula-2 external procedures to the host. Memory layout
  4. * matches the compiler's: a STRING (ARRAY OF CHAR) value is a
  5. * descriptor [0] = LONGCARD element count, then the bytes; the
  6. * compiler passes the descriptor's address as an `l`.
  7. *
  8. * Linked with every V3 program image.
  9. */
  10. #define _GNU_SOURCE
  11. #include <unistd.h>
  12. #include <stdlib.h>
  13. #include <stdio.h>
  14. #include <string.h>
  15. #include <time.h>
  16. #include <ucontext.h>
  17. /* Write the contents of a string descriptor to fd 1. Returns the
  18. number of bytes written. */
  19. long m2write(long *desc)
  20. {
  21. /* desc[0] is the capacity; the string is NUL-terminated. */
  22. char *s = (char *)(desc + 1);
  23. size_t n = strnlen(s, (size_t)desc[0] + 1);
  24. if (n > 0)
  25. write(1, s, n);
  26. return (long)n;
  27. }
  28. /* Write a newline to fd 1. */
  29. long m2writeln(void)
  30. {
  31. write(1, "\n", 1);
  32. return 0;
  33. }
  34. /* Read one character from stdin (0 at EOF). */
  35. long m2readchar(void)
  36. {
  37. int c = getchar();
  38. return (c == EOF) ? 0 : c;
  39. }
  40. /* Read a signed decimal integer from stdin, skipping leading
  41. whitespace. The first non-digit after the number is consumed. */
  42. long m2readint(void)
  43. {
  44. long v = 0;
  45. int c;
  46. int neg = 0;
  47. do { c = getchar(); } while (c == ' ' || c == '\t' ||
  48. c == '\n' || c == '\r');
  49. if (c == '-') { neg = 1; c = getchar(); }
  50. while (c >= '0' && c <= '9') {
  51. v = v * 10 + (c - '0');
  52. c = getchar();
  53. }
  54. return neg ? -v : v;
  55. }
  56. /* ---------------- sequential files (stdio) ---------------- */
  57. /* Copy a descriptor string into a NUL-terminated buffer. */
  58. static void m2cstr(long *desc, char *buf, size_t cap)
  59. {
  60. char *s = (char *)(desc + 1);
  61. size_t n = strnlen(s, (size_t)desc[0] + 1);
  62. if (n >= cap) n = cap - 1;
  63. if (n > 0) memcpy(buf, s, n);
  64. buf[n] = 0;
  65. }
  66. long m2fopenread(long *desc)
  67. {
  68. char buf[4096];
  69. m2cstr(desc, buf, sizeof buf);
  70. return (long)fopen(buf, "r");
  71. }
  72. long m2fopenwrite(long *desc)
  73. {
  74. char buf[4096];
  75. m2cstr(desc, buf, sizeof buf);
  76. return (long)fopen(buf, "w");
  77. }
  78. long m2fclose(long h)
  79. {
  80. if (h != 0) fclose((FILE *)h);
  81. return 0;
  82. }
  83. /* A handle of 0 means the open failed (Modula-2 NIL). Every file
  84. operation degrades to a safe no-op instead of dereferencing NULL. */
  85. long m2fgetc(long h)
  86. {
  87. int c;
  88. if (h == 0) return 0;
  89. c = fgetc((FILE *)h);
  90. return (c == EOF) ? 0 : c;
  91. }
  92. long m2fputc(long h, long c)
  93. {
  94. if (h != 0) fputc((int)c, (FILE *)h);
  95. return 0;
  96. }
  97. long m2fputs(long h, long *desc)
  98. {
  99. char *s = (char *)(desc + 1);
  100. size_t n = strnlen(s, (size_t)desc[0] + 1);
  101. if (h == 0) return 0;
  102. if (n > 0) fwrite(s, 1, n, (FILE *)h);
  103. return (long)n;
  104. }
  105. long m2freadint(long h)
  106. {
  107. long v = 0;
  108. int c, neg = 0;
  109. if (h == 0) return 0;
  110. do { c = fgetc((FILE *)h); } while (c == ' ' || c == '\t' ||
  111. c == '\n' || c == '\r');
  112. if (c == '-') { neg = 1; c = fgetc((FILE *)h); }
  113. while (c >= '0' && c <= '9') {
  114. v = v * 10 + (c - '0');
  115. c = fgetc((FILE *)h);
  116. }
  117. return neg ? -v : v;
  118. }
  119. long m2fwriteint(long h, long v)
  120. {
  121. char buf[32];
  122. int i = 0, neg = 0;
  123. unsigned long u;
  124. if (h == 0) return 0;
  125. if (v < 0) { neg = 1; u = (unsigned long)(-v); }
  126. else u = (unsigned long)v;
  127. do { buf[i++] = (char)('0' + u % 10); u /= 10; } while (u != 0);
  128. if (neg) buf[i++] = '-';
  129. while (i > 0) fputc(buf[--i], (FILE *)h);
  130. return 0;
  131. }
  132. long m2fwriteln(long h)
  133. {
  134. if (h != 0) fputc('\n', (FILE *)h);
  135. return 0;
  136. }
  137. /* Read one line (up to and including '\n', or EOF) into the
  138. descriptor's data area, dropping the newline; NUL-terminated.
  139. The descriptor's capacity header is left intact (so a caller may
  140. keep using HIGH), and the number of bytes stored is returned.
  141. `max` is declared `int`: Modula-2 CARDINAL arguments arrive in a
  142. 32-bit register (QBE `w`), so only the low 32 bits are defined. */
  143. long m2freadline(long h, long *desc, int max)
  144. {
  145. char *dst = (char *)(desc + 1);
  146. long n = 0;
  147. int c;
  148. if (max < 0) max = 0;
  149. if (h == 0) { if (max > 0) dst[0] = 0; return 0; }
  150. while (n < max) {
  151. c = fgetc((FILE *)h);
  152. if (c == EOF) break;
  153. if (c == '\n') break;
  154. if (c == '\r') continue;
  155. dst[n++] = (char)c;
  156. }
  157. dst[n] = 0;
  158. return n;
  159. }
  160. /* Bulk read: up to max bytes into the descriptor's data area; the
  161. descriptor's header is set to the number actually read. */
  162. long m2fread(long h, long *desc, long max)
  163. {
  164. long n;
  165. if (max < 0) max = 0;
  166. if (h == 0) { desc[0] = 0; return 0; }
  167. n = (long)fread((char *)(desc + 1), 1, (size_t)max, (FILE *)h);
  168. desc[0] = n;
  169. return n;
  170. }
  171. /* Write a signed integer right-justified in a field of width `wid`.
  172. wid = 0 means exactly one leading space (FileIO convention). */
  173. long m2fwriteintw(long h, long v, long wid)
  174. {
  175. char buf[64];
  176. int n;
  177. if (h == 0) return 0;
  178. if (wid == 0)
  179. n = snprintf(buf, sizeof buf, " %ld", v);
  180. else
  181. n = snprintf(buf, sizeof buf, "%*ld", (int)wid, v);
  182. if (n > 0) fwrite(buf, 1, (size_t)n, (FILE *)h);
  183. return 0;
  184. }
  185. /* Byte offset of the current position in h (-1 on error). */
  186. long m2ftell(long h)
  187. {
  188. if (h == 0) return -1;
  189. return (long)ftell((FILE *)h);
  190. }
  191. /* Seek h to absolute byte offset pos; 1 on success, 0 on failure.
  192. Rewinding also clears the stdio error/EOF state. */
  193. long m2fseek(long h, long pos)
  194. {
  195. if (h == 0) return 0;
  196. if (fseek((FILE *)h, (long)pos, SEEK_SET) != 0) return 0;
  197. clearerr((FILE *)h);
  198. return 1;
  199. }
  200. /* Standard streams as file handles. */
  201. long m2stdout(void) { return (long)stdout; }
  202. long m2stderr(void) { return (long)stderr; }
  203. long m2stdin(void) { return (long)stdin; }
  204. /* Command-line arguments, read from /proc/self/cmdline (Linux). */
  205. static char *m2_args[1024];
  206. static long m2_nargs = -1;
  207. static void m2_argv_init(void)
  208. {
  209. static char cmd[65536];
  210. FILE *f;
  211. long i, n;
  212. int c;
  213. if (m2_nargs >= 0) return;
  214. m2_nargs = 0;
  215. f = fopen("/proc/self/cmdline", "rb");
  216. if (f == NULL) return;
  217. n = (long)fread(cmd, 1, sizeof cmd - 1, f);
  218. fclose(f);
  219. if (n <= 0) return;
  220. cmd[n] = 0;
  221. i = 0;
  222. while (i < n && m2_nargs < 1024) {
  223. while (i < n && cmd[i] == 0) i++; /* skip separators */
  224. if (i >= n) break;
  225. m2_args[m2_nargs++] = &cmd[i];
  226. while (i < n && cmd[i] != 0) i++; /* to end of arg */
  227. }
  228. }
  229. long m2argc(void)
  230. {
  231. m2_argv_init();
  232. return m2_nargs;
  233. }
  234. long m2arg(long i, long *desc, long cap)
  235. {
  236. const char *a;
  237. long n;
  238. m2_argv_init();
  239. if (i < 0 || i >= m2_nargs) { ((char *)(desc + 1))[0] = 0; return 0; }
  240. a = m2_args[i];
  241. n = (long)strlen(a);
  242. if (cap > 0 && n >= cap) n = cap - 1;
  243. if (n < 0) n = 0;
  244. memcpy((char *)(desc + 1), a, (size_t)n);
  245. if (n < cap) ((char *)(desc + 1))[n] = 0; /* NUL terminator */
  246. /* desc[0] (capacity) is left intact: length is derived by scanning */
  247. return 1;
  248. }
  249. /* Set a string descriptor's logical length (header). */
  250. long m2setlen(long *desc, long n)
  251. {
  252. desc[0] = n;
  253. return n;
  254. }
  255. /* Write a single character (byte) to fd 1. */
  256. long m2writechar(long c)
  257. {
  258. char ch = (char)c;
  259. write(1, &ch, 1);
  260. return 0;
  261. }
  262. /* Write a signed decimal integer to fd 1. */
  263. long m2writeint(long v)
  264. {
  265. char buf[32];
  266. int i = 0;
  267. int neg = 0;
  268. unsigned long u;
  269. if (v < 0) { neg = 1; u = (unsigned long)(-v); }
  270. else u = (unsigned long)v;
  271. do { buf[i++] = (char)('0' + (u % 10)); u /= 10; } while (u != 0);
  272. if (neg) buf[i++] = '-';
  273. while (i > 0)
  274. write(1, &buf[--i], 1);
  275. return 0;
  276. }
  277. /* Terminate the process. */
  278. long m2exit(long code)
  279. {
  280. exit((int)code);
  281. return 0;
  282. }
  283. /* ---------------- clock (SysClock) ---------------- */
  284. /* Wall-clock time in seconds since the Unix epoch. */
  285. long m2time(void)
  286. {
  287. return (long)time(NULL);
  288. }
  289. /* Processor time used so far, in clock ticks (CLOCKS_PER_SEC per
  290. second). The scaling is exposed as a constant by SysClock. */
  291. long m2clock(void)
  292. {
  293. return (long)clock();
  294. }
  295. /* String content equality: 1 when the NUL-terminated contents of the
  296. two descriptors match. */
  297. long m2streq(long *a, long *b)
  298. {
  299. return (strcmp((char *)(a + 1), (char *)(b + 1)) == 0) ? 1 : 0;
  300. }
  301. /* Number of characters before the NUL. */
  302. long m2strlen(long *s)
  303. {
  304. return (long)strlen((char *)(s + 1));
  305. }
  306. /* UString length: the codepoint count is the descriptor's header. */
  307. long m2ustrlen(long *s)
  308. {
  309. return s[0];
  310. }
  311. /* Build a 1-codepoint UString descriptor from a UCHAR value; returns
  312. its address. A small rotating pool lets an expression supply both
  313. operands to m2ustrcat before it reads them. */
  314. long m2ustrfrom(long cp)
  315. {
  316. static struct { long count; int cp; } pool[16];
  317. static int next = 0;
  318. long *d = (long *)&pool[next];
  319. pool[next].count = 1;
  320. pool[next].cp = (int)cp;
  321. next = (next + 1) & 15;
  322. return (long)d;
  323. }
  324. /* Concatenate two UString descriptors into a static buffer; returns
  325. the result descriptor address. The value is valid until the next
  326. m2ustrcat call. */
  327. long m2ustrcat(long *a, long *b)
  328. {
  329. static struct { long count; int cp[4096]; } buf;
  330. int *pa = (int *)(a + 1);
  331. int *pb = (int *)(b + 1);
  332. long na = a[0], nb = b[0], i;
  333. if (na < 0) na = 0;
  334. if (nb < 0) nb = 0;
  335. if (na > 4096) na = 4096;
  336. if (nb > 4096 - na) nb = 4096 - na;
  337. for (i = 0; i < na; i++) buf.cp[i] = pa[i];
  338. for (i = 0; i < nb; i++) buf.cp[na + i] = pb[i];
  339. buf.count = na + nb;
  340. return (long)&buf;
  341. }
  342. /* Copy a UString descriptor (count + 4-byte codepoints) into the
  343. UCHAR array at dst (capacity dst[0]): min(count, capacity)
  344. codepoints, followed by a 0 codepoint terminator. Returns the
  345. number of codepoints copied. */
  346. long m2uassign(long *dst, long *src)
  347. {
  348. /* Both descriptors are { l count, w codepoints... }: the header is
  349. 64-bit, each codepoint is 32-bit. */
  350. int *d = (int *)(dst + 1);
  351. int *s = (int *)(src + 1);
  352. long cap = dst[0];
  353. long n = src[0];
  354. long i;
  355. if (cap < 0) cap = 0;
  356. if (n > cap) n = cap;
  357. for (i = 0; i < n; i++) d[i] = s[i];
  358. d[n] = 0;
  359. return n;
  360. }
  361. /* Copy the content of src into the CHAR array at dst (capacity
  362. dst[0]); truncated to fit and NUL-terminated. A CHAR array has
  363. `cap` content slots plus a reserved terminator slot at index `cap`,
  364. so up to `cap` characters fit. Returns the length copied. */
  365. long m2strassign(long *dst, long *src)
  366. {
  367. char *d = (char *)(dst + 1);
  368. const char *s = (const char *)(src + 1);
  369. long cap = dst[0];
  370. size_t n;
  371. if (cap < 0) return 0;
  372. n = strlen(s);
  373. if (n > (size_t)cap) n = (size_t)cap;
  374. memmove(d, s, n);
  375. d[n] = 0;
  376. return (long)n;
  377. }
  378. /* Concatenate two string descriptors into a static buffer; returns the
  379. result descriptor address. The value is valid until the next
  380. m2strcat call (so copy it before concatenating again). */
  381. long m2strcat(long *a, long *b)
  382. {
  383. static struct { long count; char data[8192]; } buf;
  384. const char *sa = (const char *)(a + 1);
  385. const char *sb = (const char *)(b + 1);
  386. size_t na = strlen(sa), nb = strlen(sb);
  387. if (na > sizeof buf.data - 1) na = sizeof buf.data - 1;
  388. if (nb > sizeof buf.data - 1 - na)
  389. nb = sizeof buf.data - 1 - na;
  390. memmove(buf.data, sa, na);
  391. memmove(buf.data + na, sb, nb);
  392. buf.data[na + nb] = 0;
  393. buf.count = (long)(na + nb);
  394. return (long)&buf;
  395. }
  396. /* ---------------- reals (Conversions / RealIO) ---------------- */
  397. /* Format a REAL into a descriptor string (6 significant digits,
  398. scientific). desc[0] is the capacity; on return it holds the
  399. length. Returns the number of characters written. */
  400. long m2realstr(double x, long *desc)
  401. {
  402. char buf[64];
  403. char *dst = (char *)(desc + 1);
  404. long cap = desc[0];
  405. int n = snprintf(buf, sizeof buf, "%.6E", x);
  406. if (n < 0) n = 0;
  407. if (cap > 0 && n >= (int)cap) n = (int)cap - 1;
  408. if (n > 0) memcpy(dst, buf, (size_t)n);
  409. if (cap > 0) { dst[n] = 0; desc[0] = n; }
  410. return (long)n;
  411. }
  412. /* Parse a REAL from a descriptor string; *ok := 1 on success. */
  413. double m2strreal(long *desc, long *ok)
  414. {
  415. char buf[4096];
  416. char *end;
  417. double v;
  418. m2cstr(desc, buf, sizeof buf);
  419. v = strtod(buf, &end);
  420. while (*end == ' ' || *end == '\t' || *end == '\n' || *end == '\r') end++;
  421. *ok = (end != buf && *end == 0) ? 1 : 0;
  422. return v;
  423. }
  424. /* Write a REAL right-justified in a field of width `wid` (0 => one
  425. leading space), matching the integer convention. */
  426. long m2writerealf(double x, long wid)
  427. {
  428. char buf[128];
  429. int n;
  430. if (wid == 0)
  431. n = snprintf(buf, sizeof buf, "%.6E", x);
  432. else
  433. n = snprintf(buf, sizeof buf, "%*.*E", (int)wid, 6, x);
  434. if (n > 0) write(1, buf, (size_t)n);
  435. return 0;
  436. }
  437. long m2writereal(double x)
  438. {
  439. return m2writerealf(x, 0);
  440. }
  441. /* Write a REAL right-justified in `wid` with `dec` digits after the
  442. point (FpuIO.WriteReal/WriteLongReal). */
  443. long m2writefix(double x, long wid, long dec)
  444. {
  445. char buf[256];
  446. int n;
  447. if (wid <= 0) wid = 1;
  448. if (dec < 0) dec = 0;
  449. if (dec > 30) dec = 30;
  450. n = snprintf(buf, sizeof buf, "%*.*f", (int)wid, (int)dec, x);
  451. if (n > 0) write(1, buf, (size_t)n);
  452. return 0;
  453. }
  454. /* Read a REAL from stdin. */
  455. double m2readreal(void)
  456. {
  457. double v = 0.0;
  458. if (scanf("%lf", &v) != 1) v = 0.0;
  459. return v;
  460. }
  461. /* ---------------- PIM coroutines (SYSTEM.NEWPROCESS/TRANSFER/...) --------
  462. *
  463. * A PROCESS is a pointer to a ucontext_t. NEWPROCESS builds a context
  464. * over the caller-supplied workspace; TRANSFER saves the running
  465. * context into *a and resumes *b. Coroutine bodies are compiled with a
  466. * leading static-link argument; module-level bodies (the usual case for
  467. * NEWPROCESS) take 0. */
  468. void m2_newprocess(void *p, void *workspace, long size, void **c)
  469. {
  470. ucontext_t *uc;
  471. if (c == NULL) return;
  472. uc = (ucontext_t *)malloc(sizeof(ucontext_t));
  473. if (uc == NULL) { *c = NULL; return; }
  474. if (getcontext(uc) != 0) { free(uc); *c = NULL; return; }
  475. uc->uc_stack.ss_sp = workspace;
  476. uc->uc_stack.ss_size = (size_t)size;
  477. uc->uc_link = NULL;
  478. makecontext(uc, (void (*)(void))p, 1, (int)0);
  479. *c = uc;
  480. }
  481. void m2_transfer(void **a, void **b)
  482. {
  483. ucontext_t *save;
  484. ucontext_t *go;
  485. if ((a == NULL) || (b == NULL)) return;
  486. save = (ucontext_t *)*a;
  487. go = (ucontext_t *)*b;
  488. if (go == NULL) return;
  489. if (save == NULL) {
  490. save = (ucontext_t *)malloc(sizeof(ucontext_t));
  491. if (save == NULL) return;
  492. *a = save;
  493. }
  494. swapcontext(save, go);
  495. }
  496. /* IOTRANSFER: without a device-interrupt subsystem this degrades to a
  497. plain transfer to b (classic PIM resumes a when the interrupt
  498. fires). The interrupt number is accepted and ignored. */
  499. void m2_iotransfer(void **a, void **b, long interruptNo)
  500. {
  501. (void)interruptNo;
  502. m2_transfer(a, b);
  503. }
  504. /* ---------------- text-IO library support ---------------- */
  505. /* Read one line from stdin (newline dropped) into the string
  506. descriptor's data area; NUL-terminated. Returns the length. */
  507. long m2readline(long *desc, int max)
  508. {
  509. char *dst = (char *)(desc + 1);
  510. long n = 0;
  511. int c;
  512. if (max < 0) max = 0;
  513. while (n < max) {
  514. c = getchar();
  515. if (c == EOF) break;
  516. if (c == '\n') break;
  517. if (c == '\r') continue;
  518. dst[n++] = (char)c;
  519. }
  520. dst[n] = 0;
  521. return n;
  522. }
  523. /* Write a signed integer right-justified in a field of width `wid`
  524. to fd 1 (wid = 0 => exactly one leading space). */
  525. long m2writeintwidth(long v, int wid)
  526. {
  527. char buf[64];
  528. int n;
  529. if (wid == 0)
  530. n = snprintf(buf, sizeof buf, " %ld", v);
  531. else
  532. n = snprintf(buf, sizeof buf, "%*ld", wid, v);
  533. if (n > 0) write(1, buf, (size_t)n);
  534. return 0;
  535. }
  536. /* Format a REAL into a descriptor: mode 0 = fixed (prec = decimal
  537. places), 1 = floating (prec = significant figures), 2 = engineering
  538. (prec = significant figures, exponent a multiple of three).
  539. desc[0] is the capacity; on return it holds the length. */
  540. static long m2putstr(char *dst, long cap, const char *src)
  541. {
  542. long n = (long)strlen(src);
  543. if (cap <= 0) return 0;
  544. if (n > cap - 1) n = cap - 1;
  545. memcpy(dst, src, (size_t)n);
  546. dst[n] = 0;
  547. return n;
  548. }
  549. long m2realconv(double x, int mode, int prec, long *desc)
  550. {
  551. char buf[256];
  552. char *dst = (char *)(desc + 1);
  553. long cap = desc[0];
  554. int n = 0;
  555. if (prec < 0) prec = 0;
  556. if (prec > 40) prec = 40;
  557. if (mode == 0) {
  558. n = snprintf(buf, sizeof buf, "%.*f", prec, x);
  559. } else if (mode == 1) {
  560. n = snprintf(buf, sizeof buf, "%.*E",
  561. prec > 0 ? prec - 1 : 0, x);
  562. } else {
  563. /* engineering: mantissa in [1,1000), exponent multiple of 3 */
  564. int e;
  565. double m = x;
  566. if (m != 0.0) {
  567. e = 0;
  568. while (m >= 1000.0) { m /= 1000.0; e += 3; }
  569. while (m < 1.0) { m *= 1000.0; e -= 3; }
  570. } else {
  571. e = 0;
  572. }
  573. n = snprintf(buf, sizeof buf, "%.*fE%+d",
  574. prec > 0 ? prec - 1 : 0, m, e);
  575. }
  576. if (n < 0) n = 0;
  577. return m2putstr(dst, cap, buf);
  578. }
  579. /* Termination flags: HALT aborts the image, so neither is ever
  580. observably TRUE; provided so TERMINATION links. */
  581. long m2terminating(void) { return 0; }
  582. long m2hashalted(void) { return 0; }
  583. /* ---------------- DynamicStrings (heap C strings) ----------------
  584. *
  585. * A DynamicStrings.String is a malloc'd NUL-terminated char buffer.
  586. * Procedures that return a String return the buffer address; those
  587. * that take a String receive it in the first `long` argument. */
  588. static char *m2dsdup(const char *s)
  589. {
  590. size_t n;
  591. char *p;
  592. if (s == NULL) s = "";
  593. n = strlen(s);
  594. p = (char *)malloc(n + 1);
  595. if (p == NULL) return NULL;
  596. memcpy(p, s, n + 1);
  597. return p;
  598. }
  599. long m2dsinit(long *a) { return (long)m2dsdup((const char *)(a + 1)); }
  600. long m2dskill(char *s) { free(s); return 0; }
  601. long m2dslength(const char *s) { return s ? (long)strlen(s) : 0; }
  602. long m2dsdupstr(const char *s) { return (long)m2dsdup(s); }
  603. long m2dsconcat(char *a, const char *b)
  604. {
  605. size_t na, nb;
  606. char *p;
  607. if (b == NULL) b = "";
  608. na = a ? strlen(a) : 0;
  609. nb = strlen(b);
  610. p = (char *)realloc(a, na + nb + 1);
  611. if (p == NULL) return (long)a;
  612. memcpy(p + na, b, nb + 1);
  613. return (long)p;
  614. }
  615. long m2dsconcatchar(char *a, int ch)
  616. {
  617. size_t na = a ? strlen(a) : 0;
  618. char *p = (char *)realloc(a, na + 2);
  619. if (p == NULL) return (long)a;
  620. p[na] = (char)ch;
  621. p[na + 1] = 0;
  622. return (long)p;
  623. }
  624. long m2dsassign(char *a, const char *b)
  625. {
  626. size_t nb;
  627. char *p;
  628. if (b == NULL) b = "";
  629. nb = strlen(b);
  630. p = (char *)realloc(a, nb + 1);
  631. if (p == NULL) return (long)a;
  632. memcpy(p, b, nb + 1);
  633. return (long)p;
  634. }
  635. long m2dseq(const char *a, const char *b)
  636. {
  637. if (a == NULL) a = "";
  638. if (b == NULL) b = "";
  639. return strcmp(a, b) == 0;
  640. }
  641. /* EqualArray: the second operand arrives as the *descriptor* of a V3
  642. CHAR-array actual (V3 passes array actuals as their descriptor). */
  643. long m2dseqarr(const char *s, long *a)
  644. {
  645. return m2dseq(s, (const char *)(a + 1));
  646. }
  647. long m2dschar(const char *s, int i)
  648. {
  649. int n;
  650. if (s == NULL) return 0;
  651. n = (int)strlen(s);
  652. if (i < 0) i = n + i;
  653. if (i < 0 || i >= n) return 0;
  654. return (unsigned char)s[i];
  655. }
  656. long m2dscopyout(long *dst, const char *s)
  657. {
  658. char *d = (char *)(dst + 1);
  659. long cap = dst[0];
  660. size_t n;
  661. if (s == NULL) s = "";
  662. n = strlen(s);
  663. if (cap < 0) cap = 0;
  664. if (n > (size_t)cap) n = (size_t)cap;
  665. memcpy(d, s, n);
  666. d[n] = 0;
  667. return (long)n;
  668. }
  669. long m2dsslice(const char *s, int low, int high)
  670. {
  671. int n, lo, hi;
  672. char *p;
  673. if (s == NULL) s = "";
  674. n = (int)strlen(s);
  675. lo = low;
  676. hi = high;
  677. if (lo < 0) lo = n + lo;
  678. if (lo < 0) lo = 0;
  679. if (hi == 0) hi = n;
  680. else if (hi < 0) hi = n + hi;
  681. if (hi > n) hi = n;
  682. if (hi < lo) hi = lo;
  683. p = (char *)malloc((size_t)(hi - lo) + 1);
  684. if (p == NULL) return 0;
  685. memcpy(p, s + lo, (size_t)(hi - lo));
  686. p[hi - lo] = 0;
  687. return (long)p;
  688. }
  689. long m2dsindex(const char *s, int ch, int o)
  690. {
  691. int i;
  692. if (s == NULL) return -1;
  693. for (i = o; s[i] != 0; i++)
  694. if ((unsigned char)s[i] == (unsigned char)ch) return i;
  695. return -1;
  696. }
  697. long m2dsrindex(const char *s, int ch, int o)
  698. {
  699. int n, i;
  700. if (s == NULL) return -1;
  701. n = (int)strlen(s);
  702. if (o >= n) o = n - 1;
  703. for (i = o; i >= 0; i--)
  704. if ((unsigned char)s[i] == (unsigned char)ch) return i;
  705. return -1;
  706. }
  707. long m2dsmult(const char *s, int n)
  708. {
  709. size_t len, i;
  710. char *p;
  711. if (s == NULL) s = "";
  712. if (n <= 0) return (long)m2dsdup("");
  713. len = strlen(s);
  714. p = (char *)malloc(len * (size_t)n + 1);
  715. if (p == NULL) return 0;
  716. for (i = 0; i < (size_t)n; i++) memcpy(p + i * len, s, len);
  717. p[len * (size_t)n] = 0;
  718. return (long)p;
  719. }
  720. long m2dsreplacechar(char *s, int from, int to)
  721. {
  722. int i;
  723. if (s == NULL) return 0;
  724. for (i = 0; s[i] != 0; i++)
  725. if ((unsigned char)s[i] == (unsigned char)from) s[i] = (char)to;
  726. return (long)s;
  727. }
  728. long m2dsupper(char *s)
  729. {
  730. int i;
  731. if (s == NULL) return 0;
  732. for (i = 0; s[i] != 0; i++)
  733. if (s[i] >= 'a' && s[i] <= 'z') s[i] = (char)(s[i] - 32);
  734. return (long)s;
  735. }
  736. long m2dslower(char *s)
  737. {
  738. int i;
  739. if (s == NULL) return 0;
  740. for (i = 0; s[i] != 0; i++)
  741. if (s[i] >= 'A' && s[i] <= 'Z') s[i] = (char)(s[i] + 32);
  742. return (long)s;
  743. }
  744. long m2dstrimprefix(char *s)
  745. {
  746. char *p;
  747. if (s == NULL) return 0;
  748. p = s;
  749. while (*p == ' ' || *p == '\t' || *p == '\n' || *p == '\r') p++;
  750. if (p != s) memmove(s, p, strlen(p) + 1);
  751. return (long)s;
  752. }
  753. long m2dstrimpostfix(char *s)
  754. {
  755. size_t n;
  756. if (s == NULL) return 0;
  757. n = strlen(s);
  758. while (n > 0 && (s[n-1] == ' ' || s[n-1] == '\t' ||
  759. s[n-1] == '\n' || s[n-1] == '\r')) {
  760. s[--n] = 0;
  761. }
  762. return (long)s;
  763. }
  764. /* ---------------- TimeString / wrapclock / wraptime / wrapc -------- */
  765. #include <sys/stat.h>
  766. #include <sys/time.h>
  767. #include <pwd.h>
  768. #include <math.h>
  769. #include <fcntl.h>
  770. long m2timestring(long *desc)
  771. {
  772. char buf[128];
  773. char *dst = (char *)(desc + 1);
  774. long cap = desc[0], n;
  775. time_t t = time(NULL);
  776. struct tm tmv;
  777. localtime_r(&t, &tmv);
  778. if (strftime(buf, sizeof buf, "%c", &tmv) == 0) buf[0] = 0;
  779. n = (long)strlen(buf);
  780. if (cap < 0) cap = 0;
  781. if (n > cap) n = cap;
  782. memcpy(dst, buf, (size_t)n);
  783. dst[n] = 0;
  784. return n;
  785. }
  786. long m2wctimezone(void) { return (long)timezone; }
  787. long m2wcistimezone(void) { return 1; }
  788. long m2wcdaylight(void) { return (long)daylight; }
  789. long m2wcisdst(void) { return 1; }
  790. long m2wctzname(long d) { return (long)(d ? tzname[1] : tzname[0]); }
  791. void *m2wctsnew(void) { return calloc(1, sizeof(struct timespec)); }
  792. void *m2wctskill(void *ts){ free(ts); return NULL; }
  793. long m2wctsget(void *ts, long *sec, long *nano)
  794. {
  795. struct timespec *t = (struct timespec *)ts;
  796. if (t == NULL) return -1;
  797. *sec = (long)t->tv_sec; *nano = (long)t->tv_nsec; return 0;
  798. }
  799. long m2wctsset(void *ts, long sec, long nano)
  800. {
  801. struct timespec *t = (struct timespec *)ts;
  802. if (t == NULL) return -1;
  803. t->tv_sec = (time_t)sec; t->tv_nsec = (long)nano; return 0;
  804. }
  805. long m2wctsrealtime(void *ts)
  806. { return clock_gettime(CLOCK_REALTIME, (struct timespec *)ts); }
  807. long m2wctssetrealtime(void *ts)
  808. { return clock_settime(CLOCK_REALTIME, (struct timespec *)ts); }
  809. void *m2wttvnew(void) { return calloc(1, sizeof(struct timeval)); }
  810. void *m2wttvkill(void *p) { free(p); return NULL; }
  811. void *m2wttznew(void) { return calloc(1, sizeof(struct timezone)); }
  812. void *m2wttzkill(void *p) { free(p); return NULL; }
  813. void *m2wttmnew(void) { return calloc(1, sizeof(struct tm)); }
  814. void *m2wttmkill(void *p) { free(p); return NULL; }
  815. long m2wtgettimeofday(void *tv, void *tz)
  816. { return gettimeofday((struct timeval *)tv, (struct timezone *)tz); }
  817. long m2wtsettimeofday(void *tv, void *tz)
  818. { return settimeofday((struct timeval *)tv, (struct timezone *)tz); }
  819. long m2wtfractions(void *tv)
  820. { struct timeval *t = (struct timeval *)tv; return t ? (long)t->tv_usec : 0; }
  821. void *m2wtlocaltime(void *tv, void *tm)
  822. { struct timeval *t = (struct timeval *)tv; return localtime_r(&t->tv_sec, (struct tm *)tm); }
  823. long m2wtyear(void *m) { return ((struct tm *)m)->tm_year + 1900; }
  824. long m2wtmonth(void *m) { return ((struct tm *)m)->tm_mon + 1; }
  825. long m2wtday(void *m) { return ((struct tm *)m)->tm_mday; }
  826. long m2wthour(void *m) { return ((struct tm *)m)->tm_hour; }
  827. long m2wtminute(void *m) { return ((struct tm *)m)->tm_min; }
  828. long m2wtsecond(void *m) { return ((struct tm *)m)->tm_sec; }
  829. void m2wttvset(void *tv, long sec, long usec)
  830. { struct timeval *t = (struct timeval *)tv; t->tv_sec = (time_t)sec; t->tv_usec = (long)usec; }
  831. void m2wttzset(void *tz, long minuteswest, long dsttime)
  832. { struct timezone *z = (struct timezone *)tz; z->tz_minuteswest = (int)minuteswest; z->tz_dsttime = (int)dsttime; }
  833. long m2cstrtime(void) { time_t t = time(NULL); return (long)ctime(&t); }
  834. long m2cfilesize(long f, long *low, long *high)
  835. {
  836. struct stat st;
  837. if (fstat((int)f, &st) != 0) { *low = 0; *high = 0; return -1; }
  838. *low = (long)(st.st_size & 0xffffffffL);
  839. *high = (long)((unsigned long long)st.st_size >> 32);
  840. return 0;
  841. }
  842. long m2cfileinode(long f, long *low, long *high)
  843. {
  844. struct stat st;
  845. if (fstat((int)f, &st) != 0) { *low = 0; *high = 0; return -1; }
  846. *low = (long)(st.st_ino & 0xffffffffL);
  847. *high = (long)((unsigned long long)st.st_ino >> 32);
  848. return 0;
  849. }
  850. long m2cfilemtime(long f)
  851. { struct stat st; if (fstat((int)f, &st) != 0) return -1; return (long)st.st_mtime; }
  852. long m2cgetrand(long n) { return n <= 0 ? 0 : (long)(random() % n); }
  853. long m2cgetusername(void)
  854. { struct passwd *pw = getpwuid(getuid()); return pw ? (long)pw->pw_name : (long)""; }
  855. void m2cgetnameuidgid(long name, long *uid, long *gid)
  856. { struct passwd *pw = getpwnam((const char *)name);
  857. if (pw == NULL) { *uid = -1; *gid = -1; } else { *uid = (long)pw->pw_uid; *gid = (long)pw->pw_gid; } }
  858. long m2csignbit(double r) { return signbit(r) ? 1 : 0; }
  859. long m2cisfinite(double x) { return isfinite(x) ? 1 : 0; }
  860. long m2cisnan(double x) { return isnan(x) ? 1 : 0; }
  861. long m2cseekset(void) { return (long)SEEK_SET; }
  862. long m2cseekend(void) { return (long)SEEK_END; }
  863. long m2creadonly(void) { return (long)O_RDONLY; }
  864. long m2cwriteonly(void) { return (long)O_WRONLY; }