chemoelectric

Untitled

Mar 27th, 2023 (edited)
306
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
text 17.71 KB | Source Code | 0 0
  1. (*------------------------------------------------------------------*)
  2. (* Translation from the Rosetta Code VM to an ATS program. *)
  3.  
  4. #include "share/atspre_staload.hats"
  5.  
  6. #define NIL list_nil ()
  7. #define :: list_cons
  8.  
  9. exception Exc_premature_end of string
  10. exception Exc_illegal_null_char of string
  11. exception Exc_illegal_char of string
  12. exception Exc_illegal_opcode of string
  13. exception Exc_internal_error of string
  14.  
  15. typedef character = int
  16. typedef reader =
  17. @{
  18. inpf = FILEref,
  19. queue = List0 character
  20. }
  21.  
  22. typedef instruction =
  23. @{
  24. address = uint,
  25. opcode = string,
  26. pushval = int,
  27. index = uint,
  28. reladdr = int
  29. }
  30.  
  31. typedef continuation = List1 string
  32.  
  33. macdef c2i = char2int0
  34. macdef newline outf = fprintln! ,(outf)
  35.  
  36. (*------------------------------------------------------------------*)
  37.  
  38. fn
  39. character_code (c : character) : int =
  40. c
  41.  
  42. fn
  43. character_is_newline (c : character) : bool =
  44. character_code c = c2i '\n'
  45.  
  46. fn
  47. character_is_digit (c : character) : bool =
  48. isdigit (character_code c)
  49.  
  50. fn
  51. character_is_minus_or_digit (c : character) : bool =
  52. character_code c = c2i '-' || isdigit (character_code c)
  53.  
  54. fn
  55. character_is_alpha (c : character) : bool =
  56. isalpha (character_code c)
  57.  
  58. fn
  59. character_is_space (c : character) : bool =
  60. isspace (character_code c)
  61.  
  62. fn
  63. addr2kont_uint (addr : uint) : string =
  64. strptr2string (string_append ("kont", tostring_val<uint> addr))
  65.  
  66. fn
  67. addr2kont_int (addr : int) : string =
  68. addr2kont_uint (g0i2u addr)
  69.  
  70. overload addr2kont with addr2kont_uint
  71. overload addr2kont with addr2kont_int
  72.  
  73. fn
  74. jmp2kont (instr : instruction) : string =
  75. addr2kont (g0u2i instr.address + instr.reladdr + 1)
  76.  
  77. fn
  78. skip_nothing (instr : instruction) : string =
  79. addr2kont (instr.address + 1U)
  80.  
  81. fn
  82. skip_immed (instr : instruction) : string =
  83. addr2kont (instr.address + 5U)
  84.  
  85. fn
  86. index2var (instr : instruction) : string =
  87. strptr2string
  88. (string_append ("var", tostring_val<uint> (instr.index)))
  89.  
  90. fn
  91. character_list_to_string
  92. (lst : List0 character,
  93. caller : string)
  94. : string =
  95. let
  96. implement
  97. list_map$fopr<character><charNZ> c =
  98. let
  99. val ch = int2char0 (character_code c)
  100. val ch = g1ofg0 ch
  101. in
  102. if ch = '\0' then
  103. $raise (Exc_illegal_null_char caller)
  104. else
  105. ch
  106. end
  107. val lst = list_vt2t (list_map<character><charNZ> lst)
  108. in
  109. strnptr2string (string_implode lst)
  110. end
  111.  
  112. fn
  113. get_character (rd : &reader) : character =
  114. case+ rd.queue of
  115. | hd :: tl =>
  116. begin
  117. rd := @{inpf = rd.inpf, queue = tl};
  118. hd
  119. end
  120. | NIL => fileref_getc (rd.inpf)
  121.  
  122. fn
  123. unget_character (rd : &reader,
  124. c : character) : void =
  125. rd := @{inpf = rd.inpf,
  126. queue = list_append (rd.queue, c :: NIL)}
  127.  
  128. fn
  129. skip_until (rd : &reader,
  130. pred : character -<cloref1> bool) : character =
  131. let
  132. fun
  133. loop (rd : &reader) : int =
  134. let
  135. val c = get_character rd
  136. in
  137. if pred c then
  138. c
  139. else if c < 0 then
  140. $raise (Exc_premature_end "skip_until")
  141. else
  142. loop rd
  143. end
  144. in
  145. loop rd
  146. end
  147.  
  148. fn
  149. read_unsigned (rd : &reader) : uint =
  150. let
  151. fun
  152. loop (rd : &reader,
  153. num : uint) : uint =
  154. let
  155. val c = get_character rd
  156. in
  157. if character_is_digit c then
  158. let
  159. val digit = character_code c - c2i ('0')
  160. in
  161. loop (rd, (10U * num) + g0i2u digit)
  162. end
  163. else
  164. begin
  165. unget_character (rd, c);
  166. num
  167. end
  168. end
  169. in
  170. loop (rd, 0U)
  171. end
  172.  
  173. fn
  174. read_signed (rd : &reader) : int =
  175. let
  176. val c = get_character rd
  177. in
  178. if character_code c = '-' then
  179. let
  180. val num = read_unsigned rd
  181. in
  182. ~(g0u2i num)
  183. end
  184. else
  185. let
  186. val () = unget_character (rd, c)
  187. val num = read_unsigned rd
  188. in
  189. g0u2i num
  190. end
  191. end
  192.  
  193. fn
  194. read_header (rd : &reader) : @(uint, uint) =
  195. let
  196. val c = skip_until (rd, lam c => character_is_digit c)
  197. val () = unget_character (rd, c)
  198. val data_size = read_unsigned rd
  199. val c = skip_until (rd, lam c => character_is_digit c)
  200. val () = unget_character (rd, c)
  201. val strings_size = read_unsigned rd
  202. val _ = skip_until (rd, lam c => character_is_newline c)
  203. in
  204. @(data_size, strings_size)
  205. end
  206.  
  207. fn
  208. read_string (rd : &reader) : string =
  209. let
  210. fun
  211. loop (rd : &reader,
  212. lst : List1 character) : List1 character =
  213. let
  214. val c = get_character rd
  215. in
  216. if character_code c < 0 then
  217. $raise (Exc_premature_end "read_string")
  218. else if character_code c = c2i '"' then
  219. c :: lst
  220. else
  221. loop (rd, c :: lst)
  222. end
  223.  
  224. val c = skip_until (rd, lam c => character_code c = c2i '"')
  225. val lst = list_vt2t (list_reverse (loop (rd, c :: NIL)))
  226. val _ = skip_until (rd, lam c => character_code c = c2i '\n')
  227. in
  228. character_list_to_string (lst, "read_string")
  229. end
  230.  
  231. fn
  232. read_strings_pool
  233. (rd : &reader,
  234. strings_size : uint)
  235. : List0 string =
  236. let
  237. fun
  238. loop (rd : &reader,
  239. count : uint,
  240. pool : List0 string) : List0 string =
  241. if count = 0 then
  242. pool
  243. else
  244. let
  245. val s = read_string rd
  246. in
  247. loop (rd, pred count, s :: pool)
  248. end
  249. in
  250. list_vt2t (list_reverse (loop (rd, strings_size, NIL)))
  251. end
  252.  
  253. fn
  254. read_opcode (rd : &reader) : string =
  255. let
  256. fun
  257. loop (rd : &reader,
  258. lst : List0 character) : List0 character =
  259. let
  260. val c = get_character rd
  261. val code = character_code c
  262. in
  263. if code < 0 then
  264. $raise (Exc_premature_end "read_opcode")
  265. else if isalpha code then
  266. loop (rd, c :: lst)
  267. else
  268. begin
  269. unget_character (rd, c);
  270. list_vt2t (list_reverse lst)
  271. end
  272. end
  273. in
  274. character_list_to_string (loop (rd, NIL), "read_opcode")
  275. end
  276.  
  277. fn
  278. read_args (rd : &reader,
  279. instr : &instruction) : void =
  280. if instr.opcode = "push" then
  281. let
  282. val c = skip_until (rd, lam c => character_is_minus_or_digit c)
  283. val () = unget_character (rd, c)
  284. val pushval = read_signed rd
  285. val _ = skip_until (rd, lam c => character_is_newline c)
  286. in
  287. instr := @{address = instr.address,
  288. opcode = instr.opcode,
  289. pushval = pushval,
  290. index = 0U,
  291. reladdr = 0}
  292. end
  293. else if instr.opcode = "fetch" || instr.opcode = "store" then
  294. let
  295. val _ = skip_until (rd, lam c => character_code c = c2i '\[')
  296. val c = skip_until (rd, lam c => character_is_digit c)
  297. val () = unget_character (rd, c)
  298. val index = read_unsigned rd
  299. val _ = skip_until (rd, lam c => character_is_newline c)
  300. in
  301. instr := @{address = instr.address,
  302. opcode = instr.opcode,
  303. pushval = 0,
  304. index = index,
  305. reladdr = 0}
  306. end
  307. else if instr.opcode = "jmp" || instr.opcode = "jz" then
  308. let
  309. val _ = skip_until (rd, lam c => character_code c = c2i '\(')
  310. val c = skip_until (rd, lam c => character_is_minus_or_digit c)
  311. val () = unget_character (rd, c)
  312. val relative_addr = read_signed rd
  313. val _ = skip_until (rd, lam c => character_is_newline c)
  314. in
  315. instr := @{address = instr.address,
  316. opcode = instr.opcode,
  317. pushval = 0,
  318. index = 0U,
  319. reladdr = relative_addr}
  320. end
  321.  
  322. fn
  323. read_instruc (rd : &reader) : instruction =
  324. let
  325. val c = skip_until (rd, lam c => character_is_digit c)
  326. val () = unget_character (rd, c)
  327. val address = read_unsigned rd
  328. val c = skip_until (rd, lam c => character_is_alpha c)
  329. val () = unget_character (rd, c)
  330. val opcode = read_opcode rd
  331. var instr = @{address = address,
  332. opcode = opcode,
  333. pushval = 0,
  334. index = 0U,
  335. reladdr = 0} : instruction
  336. val () = read_args (rd, instr)
  337. in
  338. instr
  339. end
  340.  
  341. fn
  342. read_instructions (rd : &reader) : List0 instruction =
  343. let
  344. fun
  345. loop (rd : &reader,
  346. lst : List0 instruction) : List0 instruction =
  347. let
  348. val c = skip_until (rd, lam c => ~character_is_space c)
  349. in
  350. if c < 0 then
  351. lst
  352. else if ~character_is_digit c then
  353. $raise (Exc_illegal_char "read_instructions")
  354. else
  355. let
  356. val () = unget_character (rd, c)
  357. val instr = read_instruc rd
  358. in
  359. loop (rd, instr :: lst)
  360. end
  361. end
  362. in
  363. list_vt2t (list_reverse (loop (rd, NIL)))
  364. end
  365.  
  366. (*------------------------------------------------------------------*)
  367.  
  368. fn
  369. write_kont_body_ats_style
  370. (outf : FILEref,
  371. args : List0 string) : void =
  372. case+ args of
  373. | NIL =>
  374. $raise (Exc_internal_error "write_kont_body_ats_style")
  375. | hd :: tl =>
  376. let
  377. fun
  378. loop (args : List0 string,
  379. separator : string) : void =
  380. case+ args of
  381. | NIL => ()
  382. | hd :: tl =>
  383. begin
  384. fprint! (outf, separator, hd);
  385. loop (tl, ", ")
  386. end
  387. in
  388. fprint! (outf, hd, " (");
  389. loop (tl, "");
  390. fprint! (outf, ")");
  391. end
  392.  
  393. fn
  394. instruc2args_simple (instr : instruction) : List0 string =
  395. instr.opcode :: skip_nothing instr :: NIL
  396.  
  397. fn
  398. instruc2args_unary
  399. (instr : instruction,
  400. operation : string)
  401. : List0 string =
  402. "unary" :: operation :: skip_nothing instr :: NIL
  403.  
  404. fn
  405. instruc2args_binary
  406. (instr : instruction,
  407. operation : string)
  408. : List0 string =
  409. "binary" :: operation :: skip_nothing instr :: NIL
  410.  
  411. fn
  412. instruc2args_store_fetch (instr : instruction) : List0 string =
  413. instr.opcode :: index2var instr :: skip_immed instr :: NIL
  414.  
  415. fn
  416. instruc2args_push (instr : instruction) : List0 string =
  417. let
  418. val pushval = tostring_val<int> instr.pushval
  419. in
  420. instr.opcode :: pushval :: skip_immed instr :: NIL
  421. end
  422.  
  423. fn
  424. instruc2args_jmp (instr : instruction) : List0 string =
  425. instr.opcode :: jmp2kont instr :: NIL
  426.  
  427. fn
  428. instruc2args_jz (instr : instruction) : List0 string =
  429. instr.opcode :: jmp2kont instr :: skip_immed instr :: NIL
  430.  
  431. fn
  432. instruc2args_halt (instr : instruction) : List0 string =
  433. instr.opcode :: NIL
  434.  
  435. fn
  436. instruc2args (instr : instruction) : List0 string =
  437. case instr.opcode of
  438. | "push" => instruc2args_push instr
  439. | "jmp" => instruc2args_jmp instr
  440. | "jz" => instruc2args_jz instr
  441. | "store" => instruc2args_store_fetch instr
  442. | "fetch" => instruc2args_store_fetch instr
  443. | "prtc" => instruc2args_simple instr
  444. | "prti" => instruc2args_simple instr
  445. | "prts" => instruc2args_simple instr
  446. | "neg" => instruc2args_unary (instr, "g0int_neg")
  447. | "not" => instruc2args_unary (instr, "logical_not")
  448. | "add" => instruc2args_binary (instr, "g0int_add")
  449. | "sub" => instruc2args_binary (instr, "g0int_sub")
  450. | "mul" => instruc2args_binary (instr, "g0int_mul")
  451. | "div" => instruc2args_binary (instr, "g0int_div")
  452. | "mod" => instruc2args_binary (instr, "g0int_mod")
  453. | "and" => instruc2args_binary (instr, "logical_and")
  454. | "or" => instruc2args_binary (instr, "logical_or")
  455. | "lt" => instruc2args_binary (instr, "binary_lt")
  456. | "le" => instruc2args_binary (instr, "binary_le")
  457. | "gt" => instruc2args_binary (instr, "binary_gt")
  458. | "ge" => instruc2args_binary (instr, "binary_ge")
  459. | "eq" => instruc2args_binary (instr, "binary_eq")
  460. | "ne" => instruc2args_binary (instr, "binary_ne")
  461. | "halt" => instruc2args_halt instr
  462. | _ => $raise (Exc_illegal_opcode "instruc2args")
  463.  
  464. fn
  465. vm2cps (instructions : List0 instruction)
  466. : List0 continuation =
  467. let
  468. fun
  469. loop (instructions : List0 instruction,
  470. continuations : List0 continuation)
  471. : List0 continuation =
  472. case+ instructions of
  473. | NIL => continuations
  474. | hd :: tl =>
  475. let
  476. val addr = tostring_val<uint> hd.address
  477. val name = strptr2string (string_append ("kont", addr))
  478. val kont = name :: instruc2args hd
  479. in
  480. loop (tl, kont :: continuations)
  481. end
  482. in
  483. list_vt2t (list_reverse (loop (instructions, NIL)))
  484. end
  485.  
  486. (*------------------------------------------------------------------*)
  487.  
  488. fn
  489. write_ats_stack (outf : FILEref,
  490. stack_max : uint) : void =
  491. begin
  492. fprintln! (outf, "val stack = arrszref_make_elt<int> (",
  493. "g0u2u ", stack_max, "U, 0)");
  494. fprintln! (outf, "val stack_ptr : ref uint = ref 0U");
  495. end
  496.  
  497. fn
  498. write_ats_named_variables
  499. (outf : FILEref,
  500. data_size : uint)
  501. : void =
  502. let
  503. fun
  504. loop (i : uint) : void =
  505. if i <> data_size then
  506. begin
  507. fprintln! (outf, "val var", i, " : ref int = ref 0");
  508. loop (succ i)
  509. end
  510. in
  511. loop (0U)
  512. end
  513.  
  514. fn
  515. write_ats_strings_pool
  516. (outf : FILEref,
  517. pool : List0 string)
  518. : void =
  519. let
  520. fun
  521. loop (i : uint, pool : List0 string) : void =
  522. case+ pool of
  523. | hd :: tl =>
  524. begin
  525. fprintln! (outf, "val () = strings[", i, "] := ", hd);
  526. loop (succ i, tl)
  527. end
  528. | NIL => ()
  529.  
  530. val n = length pool
  531. in
  532. fprintln! (outf, "val strings = arrszref_make_elt<string> ",
  533. "(i2sz ", max (n, 1), ", \"\")");
  534. if isneqz n then
  535. loop (0U, pool)
  536. end
  537.  
  538. fn
  539. write_ats_procedures
  540. (outf : FILEref,
  541. konts : List0 continuation) : void =
  542. begin
  543. fprint! (outf, "fnx ");
  544. fprint! (outf, "start_here () : void = ");
  545. case+ konts of
  546. | NIL => fprintln! (outf, " ()")
  547. | hd :: _ =>
  548. let
  549. fun
  550. loop (konts : List0 continuation) : void =
  551. case+ konts of
  552. | NIL => ()
  553. | hd :: tl =>
  554. let
  555. val+ kontname :: arguments = hd
  556. in
  557. fprint! (outf, "and ");
  558. fprint! (outf, kontname, " () : void = ");
  559. write_kont_body_ats_style (outf, arguments);
  560. newline outf;
  561. loop tl
  562. end
  563. in
  564. fprintln! (outf, "kont0 ()");
  565. loop konts
  566. end
  567. end
  568.  
  569. fn
  570. write_ats_macros (outf : FILEref) : void =
  571. fprint! (outf,
  572. "macdef logical_not (x) =
  573. if iseqz ,(x) then 1 else 0
  574.  
  575. macdef logical_and (x, y) =
  576. if (isneqz ,(x)) * (isneqz ,(y)) then 1 else 0
  577.  
  578. macdef logical_or (x, y) =
  579. if (isneqz ,(x)) + (isneqz ,(y)) then 1 else 0
  580.  
  581. macdef binary_lt (x, y) =
  582. if ,(x) < ,(y) then 1 else 0
  583.  
  584. macdef binary_le (x, y) =
  585. if ,(x) <= ,(y) then 1 else 0
  586.  
  587. macdef binary_gt (x, y) =
  588. if ,(x) > ,(y) then 1 else 0
  589.  
  590. macdef binary_ge (x, y) =
  591. if ,(x) >= ,(y) then 1 else 0
  592.  
  593. macdef binary_eq (x, y) =
  594. if ,(x) = ,(y) then 1 else 0
  595.  
  596. macdef binary_ne (x, y) =
  597. if ,(x) <> ,(y) then 1 else 0
  598.  
  599. macdef unary (operation, kont) =
  600. let
  601. val sp = pred !stack_ptr
  602. in
  603. stack[sp] := ,(operation) (stack[sp]);
  604. ,(kont) ()
  605. end
  606.  
  607. macdef binary (operation, kont) =
  608. let
  609. val sp2 = pred !stack_ptr
  610. val sp1 = pred sp2
  611. in
  612. stack[sp1] := ,(operation) (stack[sp1], stack[sp2]);
  613. !stack_ptr := sp2;
  614. ,(kont) ()
  615. end
  616.  
  617. macdef jmp (kont) =
  618. ,(kont) ()
  619.  
  620. macdef jz (kont_if, kont_else) =
  621. let
  622. val sp = pred !stack_ptr;
  623. in
  624. !stack_ptr := sp;
  625. if iseqz stack[sp] then
  626. ,(kont_if) ()
  627. else
  628. ,(kont_else) ()
  629. end
  630.  
  631. macdef push (pushval, kont) =
  632. let
  633. val sp = !stack_ptr
  634. in
  635. stack[sp] := ,(pushval);
  636. !stack_ptr := succ sp;
  637. ,(kont) ()
  638. end
  639.  
  640. macdef store (variable, kont) =
  641. let
  642. val sp = pred !stack_ptr
  643. in
  644. !stack_ptr := sp;
  645. !,(variable) := stack[sp];
  646. ,(kont) ()
  647. end
  648.  
  649. macdef fetch (variable, kont) =
  650. let
  651. val sp = !stack_ptr
  652. in
  653. stack[sp] := !,(variable);
  654. !stack_ptr := succ sp;
  655. ,(kont) ()
  656. end
  657.  
  658. macdef prtc (kont) =
  659. let
  660. val sp = pred !stack_ptr
  661. in
  662. print! (int2char0 stack[sp]);
  663. !stack_ptr := sp;
  664. ,(kont) ()
  665. end
  666.  
  667. macdef prti (kont) =
  668. let
  669. val sp = pred !stack_ptr
  670. in
  671. print! (stack[sp]);
  672. !stack_ptr := sp;
  673. ,(kont) ()
  674. end
  675.  
  676. macdef prts (kont) =
  677. let
  678. val sp = pred !stack_ptr
  679. in
  680. print! (strings[stack[sp]]);
  681. !stack_ptr := sp;
  682. ,(kont) ()
  683. end
  684.  
  685. macdef halt () = ()
  686. ")
  687.  
  688. fn
  689. compile2ats (rd : &reader,
  690. outf : FILEref,
  691. stack_max : uint) : void =
  692. let
  693. val @(data_size, strings_size) = read_header rd
  694. val strings_pool = read_strings_pool (rd, strings_size)
  695. val instructions = read_instructions rd
  696. val continuations = vm2cps instructions
  697. in
  698. fprintln! (outf, "#include \"share/atspre_staload.hats\"");
  699. newline outf;
  700. write_ats_stack (outf, stack_max);
  701. newline outf;
  702. write_ats_named_variables (outf, data_size);
  703. newline outf;
  704. write_ats_strings_pool (outf, strings_pool);
  705. newline outf;
  706. write_ats_macros outf;
  707. newline outf;
  708. write_ats_procedures (outf, continuations);
  709. newline outf;
  710. fprintln! (outf, "implement main0 () = start_here ()")
  711. end
  712.  
  713. (*------------------------------------------------------------------*)
  714.  
  715. implement
  716. main0 () =
  717. let
  718. var rd : reader = @{inpf = stdin_ref, queue = NIL}
  719. in
  720. compile2ats (rd, stdout_ref, 1000U)
  721. end
  722.  
  723. (*------------------------------------------------------------------*)
Add Comment
Please, Sign In to add comment