; Mu: An exploration on making the global structure of programs more accessible. ; ; "Is it a language, or an operating system, or a virtual machine? Mu." ; (with apologies to Robert Pirsig: http://en.wikipedia.org/wiki/Mu_%28negative%29#In_popular_culture) ; ;; Motivation ; ; I want to live in a world where I can have an itch to tweak a program, clone ; its open-source repository, orient myself on how it's organized, and make ; the simple change I envisioned, all in an afternoon. This codebase tries to ; make this possible for its readers. (More details: http://akkartik.name/about) ; ; What helps comprehend the global structure of programs? For starters, let's ; enumerate what doesn't: idiomatic code, adherence to a style guide or naming ; convention, consistent indentation, API documentation for each class, etc. ; These conventional considerations improve matters in the small, but don't ; help understand global organization. They help existing programmers manage ; day-to-day operations, but they can't turn outsider programmers into ; insiders. (Elaboration: http://akkartik.name/post/readable-bad) ; ; In my experience, two things have improved matters so far: version control ; and automated tests. Version control lets me rewind back to earlier, simpler ; times when the codebase was simpler, when its core skeleton was easier to ; ascertain. Indeed, arguably what came first is by definition the skeleton of ; a program, modulo major rewrites. Once you understand the skeleton, it ; becomes tractable to 'play back' later major features one by one. (Previous ; project that fleshed out this idea: http://akkartik.name/post/wart-layers) ; ; The second and biggest boost to comprehension comes from tests. Tests are ; good for writers for well-understood reasons: they avoid regressions, and ; they can influence code to be more decoupled and easier to change. In ; addition, tests are also good for the outsider reader because they permit ; active reading. If you can't build a program and run its tests it can't help ; you understand it. It hangs limp at best, and might even be actively ; misleading. If you can run its tests, however, it comes alive. You can step ; through scenarios in a debugger. You can add logging and scan logs to make ; sense of them. You can run what-if scenarios: "why is this line not written ; like this?" Make a change, rerun tests: "Oh, that's why." (Elaboration: ; http://akkartik.name/post/literate-programming) ; ; However, tests are only useful to the extent that they exist. Think back to ; your most recent codebase. Do you feel comfortable releasing a new version ; just because the tests pass? I'm not aware of any such project. There's just ; too many situations envisaged by the authors that were never encoded in a ; test. Even disciplined authors can't test for performance or race conditions ; or fault tolerance. If a line is phrased just so because of some subtle ; performance consideration, it's hard to communicate to newcomers. ; ; This isn't an arcane problem, and it isn't just a matter of altruism. As ; more and more such implicit considerations proliferate, and as the original ; authors are replaced by latecomers for day-to-day operations, knowledge is ; actively forgotten and lost. The once-pristine codebase turns into legacy ; code that is hard to modify without expensive and stress-inducing ; regressions. ; ; How to write tests for performance, fault tolerance, race conditions, etc.? ; How can we state and verify that a codepath doesn't ever perform memory ; allocation, or write to disk? It requires better, more observable primitives ; than we currently have. Modern operating systems have their roots in the ; 70s. Their interfaces were not designed to be testable. They provide no way ; to simulate a full disk, or a specific sequence of writes from different ; threads. We need something better. ; ; This project tries to move, groping, towards that 'something better', a ; platform that is both thoroughly tested and allows programs written for it ; to be thoroughly tested. It tries to answer the question: ; ; If Denis Ritchie and Ken Thompson were to set out today to co-design unix ; and C, knowing what we know about automated tests, what would they do ; differently? ; ; To try to impose *some* constraints on this gigantic yak-shave, we'll try to ; keep both language and OS as simple as possible, focused entirely on ; permitting more kinds of tests, on first *collecting* all the information ; about implicit considerations in some form so that readers and tools can ; have at least some hope of making sense of it. ; ; The initial language will be just assembly. We'll try to make it convenient ; to program in with some simple localized rewrite rules inspired by lisp ; macros and literate programming. Programmers will have to do their own ; memory management and register allocation, but we'll provide libraries to ; help with them. ; ; The initial OS will provide just memory management and concurrency ; primitives. No users or permissions (we don't live on mainframes anymore), ; no kernel- vs user-mode, no virtual memory or process abstraction, all ; threads sharing a single address space (use VMs for security and ; sandboxing). The only use case we care about is getting a test harness to ; run some code, feed it data through blocking channels, stop it and observe ; its internals. The code under test is expected to cooperate in such testing, ; by logging important events for the test harness to observe. (More info: ; http://akkartik.name/post/tracing-tests) ; ; The common thread here is elimination of abstractions, and it's not an ; accident. Abstractions help insiders manage the evolution of a codebase, but ; they actively hinder outsiders in understanding it from scratch. This ; matters, because the funnel to turn outsiders into insiders is critical to ; the long-term life of a codebase. Perhaps authors should raise their ; estimation of the costs of abstraction, and go against their instincts for ; introducing it. That's what I'll be trying to do: question every abstraction ; before I introduce it. We'll see how it goes. ; --- ;; Getting started ; ; Mu is currently built atop Racket and Arc, but this is temporary and ; contingent. We want to keep our options open, whether to port to a different ; host language, and easy to rewrite to native code for any platform. So we'll ; try to avoid 'cheating': relying on the host platform for advanced ; functionality. ; ; Other than that, we'll say no more about the code, and focus in the rest of ; this file on the scenarios the code cares about. (selective-load "mu.arc" section-level) ;? (quit) (section 20 ; Our language is assembly-like in that functions consist of series of ; statements, and statements consist of an operation and its arguments (input ; and output). ; ; oarg1, oarg2, ... <- op arg1, arg2, ... ; ; Args must be atomic, like an integer or a memory address, they can't be ; expressions doing arithmetic or function calls. But we can have any number ; of them. ; ; Since we're building on lisp, our code samples won't look quite like the ; idealized syntax above. For now they will look like this: ; ; (function f [ ; (oarg1 oarg2 ... <- op arg1 arg2 ...) ; ... ; ... ; ]) ; ; Each arg/oarg can contain metadata separated by slashes and colons. In this ; first example below, the only metadata is types: 'integer' for a memory ; location containing an integer, and 'literal' for a value included directly ; in code. (Assembly languages traditionally call them 'immediate' operands.) ; In the future a simple tool will check that the types line up as expected in ; each op. A different tool might add types where they aren't provided. ; Instead of a monolithic compiler I want to build simple, lightweight tools ; that can be combined in various ways, say for using different typecheckers ; in different subsystems. ; ; In our tests we'll define such mu functions using a call to 'add-code', so ; look for it when reading the code examples. Everything outside 'add-code' is ; just test-harness details that can be skipped at first. (reset) ;? (set dump-trace*) (new-trace "literal") (add-code '((function main [ (1:integer <- copy 23:literal) ]))) ;? (set dump-trace*) (run 'main) ;? (prn memory*) (when (~is memory*.1 23) (prn "F - 'copy' writes its lone 'arg' after the instruction name to its lone 'oarg' or output arg before the arrow. After this test, the value 23 is stored in memory address 1.")) ;? (quit) ; Our basic arithmetic ops can operate on memory locations or literals. ; (Ignore hardware details like registers for now.) (reset) (new-trace "add") (add-code '((function main [ (1:integer <- copy 1:literal) (2:integer <- copy 3:literal) (3:integer <- add 1:integer 2:integer) ]))) (run 'main) ;? (prn memory*) (when (~iso memory* (obj 1 1 2 3 3 4)) (prn "F - 'add' operates on two addresses")) ;? (quit) (reset) (new-trace "add-literal") (add-code '((function main [ (1:integer <- add 2:literal 3:literal) ]))) (run 'main) (when (~is memory*.1 5) (prn "F - ops can take 'literal' operands (but not return them)")) (reset) (new-trace "sub-literal") (add-code '((function main [ (1:integer <- subtract 1:literal 3:literal) ]))) (run 'main) ;? (prn memory*) (when (~is memory*.1 -2) (prn "F - 'subtract'")) (reset) (new-trace "mul-literal") (add-code '((function main [ (1:integer <- multiply 2:literal 3:literal) ]))) (run 'main) ;? (prn memory*) (when (~is memory*.1 6) (prn "F - 'multiply'")) (reset) (new-trace "div-literal") (add-code '((function main [ (1:integer <- divide 8:literal 3:literal) ]))) (run 'main) ;? (prn memory*) (when (~is memory*.1 (/ real.8 3)) (prn "F - 'divide'")) (reset) (new-trace "idiv-literal") (add-code '((function main [ (1:integer 2:integer <- divide-with-remainder 23:literal 6:literal) ]))) (run 'main) ;? (prn memory*) (when (~iso memory* (obj 1 3 2 5)) (prn "F - 'divide-with-remainder' performs integer division")) (reset) (new-trace "dummy-oarg") ;? (set dump-trace*) (add-code '((function main [ (_ 2:integer <- divide-with-remainder 23:literal 6:literal) ]))) (run 'main) (when (~iso memory* (obj 2 5)) (prn "F - '_' oarg can ignore some results")) ;? (quit) ; Basic boolean operations: and, or, not ; There are easy ways to encode booleans in binary, but we'll skip past those ; details for now. (reset) (new-trace "and-literal") (add-code '((function main [ (1:boolean <- and t:literal nil:literal) ]))) ;? (set dump-trace*) (run 'main) ;? (prn memory*) (when (~is memory*.1 nil) (prn "F - logical 'and' for booleans")) ; Basic comparison operations (reset) (new-trace "lt-literal") (add-code '((function main [ (1:boolean <- less-than 4:literal 3:literal) ]))) (run 'main) ;? (prn memory*) (when (~is memory*.1 nil) (prn "F - 'less-than' inequality operator")) (reset) (new-trace "le-literal-false") (add-code '((function main [ (1:boolean <- lesser-or-equal 4:literal 3:literal) ]))) (run 'main) ;? (prn memory*) (when (~is memory*.1 nil) (prn "F - 'lesser-or-equal'")) (reset) (new-trace "le-literal-true") (add-code '((function main [ (1:boolean <- lesser-or-equal 4:literal 4:literal) ]))) (run 'main) ;? (prn memory*) (when (~is memory*.1 t) (prn "F - 'lesser-or-equal' returns true for equal operands")) (reset) (new-trace "le-literal-true-2") (add-code '((function main [ (1:boolean <- lesser-or-equal 4:literal 5:literal) ]))) (run 'main) ;? (prn memory*) (when (~is memory*.1 t) (prn "F - 'lesser-or-equal' - 2")) ; Control flow operations: jump, jump-if, jump-unless ; These introduce a new type -- 'offset' -- for literals that refer to memory ; locations relative to the current location. (reset) (new-trace "jump-skip") (add-code '((function main [ (1:integer <- copy 8:literal) (jump 1:offset) (2:integer <- copy 3:literal) ; should be skipped (reply) ]))) ;? (set dump-trace*) (run 'main) ;? (prn memory*) (when (~iso memory* (obj 1 8)) (prn "F - 'jump' skips some instructions")) ;? (quit) (reset) (new-trace "jump-target") (add-code '((function main [ (1:integer <- copy 8:literal) (jump 1:offset) (2:integer <- copy 3:literal) ; should be skipped (reply) (3:integer <- copy 34:literal) ]))) ; never reached (run 'main) ;? (prn memory*) (when (~iso memory* (obj 1 8)) (prn "F - 'jump' doesn't skip too many instructions")) ;? (quit) (reset) (new-trace "jump-if-skip") (add-code '((function main [ (2:integer <- copy 1:literal) (1:boolean <- equal 1:literal 2:integer) (jump-if 1:boolean 1:offset) (2:integer <- copy 3:literal) (reply) (3:integer <- copy 34:literal) ]))) (run 'main) ;? (prn memory*) (when (~iso memory* (obj 1 t 2 1)) (prn "F - 'jump-if' is a conditional 'jump'")) (reset) (new-trace "jump-if-fallthrough") (add-code '((function main [ (1:boolean <- equal 1:literal 2:literal) (jump-if 3:boolean 1:offset) (2:integer <- copy 3:literal) (reply) (3:integer <- copy 34:literal) ]))) (run 'main) ;? (prn memory*) (when (~iso memory* (obj 1 nil 2 3)) (prn "F - if 'jump-if's first arg is false, it doesn't skip any instructions")) (reset) (new-trace "jump-if-backward") (add-code '((function main [ (1:integer <- copy 2:literal) (2:integer <- copy 1:literal) ; loop (2:integer <- add 2:integer 2:integer) (3:boolean <- equal 1:integer 2:integer) (jump-if 3:boolean -3:offset) ; to loop (4:integer <- copy 3:literal) (reply) (3:integer <- copy 34:literal) ]))) (run 'main) ;? (prn memory*) (when (~iso memory* (obj 1 2 2 4 3 nil 4 3)) (prn "F - 'jump-if' can take a negative offset to make backward jumps")) (reset) (new-trace "jump-label") (add-code '((function main [ (1:integer <- copy 2:literal) (2:integer <- copy 1:literal) loop (2:integer <- add 2:integer 2:integer) (3:boolean <- equal 1:integer 2:integer) (jump-if 3:boolean loop:offset) (4:integer <- copy 3:literal) (reply) (3:integer <- copy 34:literal) ]))) ;? (set dump-trace*) ;? (= dump-trace* (obj whitelist '("-"))) (run 'main) ;? (prn memory*) (when (~iso memory* (obj 1 2 2 4 3 nil 4 3)) (prn "F - 'jump-if' can take a negative offset to make backward jumps")) ;? (quit) ; Data movement relies on addressing modes: ; 'direct' - refers to a memory location; default for most types. ; 'literal' - directly encoded in the code; implicit for some types like 'offset'. (reset) (new-trace "direct-addressing") (add-code '((function main [ (1:integer <- copy 34:literal) (2:integer <- copy 1:integer) ]))) (run 'main) ;? (prn memory*) (when (~iso memory* (obj 1 34 2 34)) (prn "F - 'copy' performs direct addressing")) ; 'Indirect' addressing refers to an address stored in a memory location. ; Indicated by the metadata '/deref'. Usually requires an address type. ; In the test below, the memory location 1 contains '2', so an indirect read ; of location 1 returns the value of location 2. (reset) (new-trace "indirect-addressing") (add-code '((function main [ (1:integer-address <- copy 2:literal) ; unsafe; can't do this in general (2:integer <- copy 34:literal) (3:integer <- copy 1:integer-address/deref) ]))) (run 'main) ;? (prn memory*) (when (~iso memory* (obj 1 2 2 34 3 34)) (prn "F - 'copy' performs indirect addressing")) ; Output args can use indirect addressing. In the test below the value is ; stored at the location stored in location 1 (i.e. location 2). (reset) (new-trace "indirect-addressing-oarg") (add-code '((function main [ (1:integer-address <- copy 2:literal) (2:integer <- copy 34:literal) (1:integer-address/deref <- add 2:integer 2:literal) ]))) (run 'main) ;? (prn memory*) (when (~iso memory* (obj 1 2 2 36)) (prn "F - instructions can perform indirect addressing on output arg")) ;; Compound data types ; ; Until now we've dealt with scalar types like integers and booleans and ; addresses, where mu looks like other assembly languages. In addition, mu ; provides first-class support for compound types: arrays and and-records. ; ; 'get' accesses fields in and-records ; 'index' accesses indices in arrays ; ; Both operations require knowledge about the types being worked on, so all ; types used in mu programs are defined in a single global system-wide table ; (see type* in mu.arc for the complete list of types; we'll add to it over ; time). ; first a sanity check that the table of types is consistent (reset) (each (typ typeinfo) type* (when typeinfo!and-record (assert (is typeinfo!size (len typeinfo!elems))) (when typeinfo!fields (assert (is typeinfo!size (len typeinfo!fields)))))) (reset) (new-trace "get-record") (add-code '((function main [ (1:integer <- copy 34:literal) (2:boolean <- copy nil:literal) (3:boolean <- get 1:integer-boolean-pair 1:offset) (4:integer <- get 1:integer-boolean-pair 0:offset) ]))) ;? (set dump-trace*) (run 'main) ;? (prn memory*) (when (~iso memory* (obj 1 34 2 nil 3 nil 4 34)) (prn "F - 'get' accesses fields of and-records")) ;? (quit) (reset) (new-trace "get-indirect") (add-code '((function main [ (1:integer <- copy 34:literal) (2:boolean <- copy nil:literal) (3:integer-boolean-pair-address <- copy 1:literal) (4:boolean <- get 3:integer-boolean-pair-address/deref 1:offset) (5:integer <- get 3:integer-boolean-pair-address/deref 0:offset) ]))) ;? (set dump-trace*) (run 'main) ;? (prn memory*) (when (~iso memory* (obj 1 34 2 nil 3 1 4 nil 5 34)) (prn "F - 'get' accesses fields of and-record address")) (reset) (new-trace "get-indirect-repeated") (add-code '((function main [ (1:integer <- copy 34:literal) (2:integer <- copy 35:literal) (3:integer <- copy 36:literal) (4:integer-point-pair-address <- copy 1:literal) ; unsafe (5:integer-point-pair-address-address <- copy 4:literal) ; unsafe (6:integer-integer-pair <- get 5:integer-point-pair-address-address/deref/deref 1:offset) (8:integer <- get 5:integer-point-pair-address-address/deref/deref 0:offset) ]))) (run 'main) (when (~memory-contains 6 '(35 36 34)) (prn "F - 'get' can deref multiple times")) ;? (quit) (reset) (new-trace "get-compound-field") (add-code '((function main [ (1:integer <- copy 34:literal) (2:integer <- copy 35:literal) (3:integer <- copy 36:literal) (4:integer-integer-pair <- get 1:integer-point-pair 1:offset) ]))) (run 'main) ;? (prn memory*) (when (~iso memory* (obj 1 34 2 35 3 36 4 35 5 36)) (prn "F - 'get' accesses fields spanning multiple locations")) (reset) (new-trace "get-address") (add-code '((function main [ (1:integer <- copy 34:literal) (2:boolean <- copy t:literal) (3:boolean-address <- get-address 1:integer-boolean-pair 1:offset) ]))) (run 'main) ;? (prn memory*) (when (~iso memory* (obj 1 34 2 t 3 2)) (prn "F - 'get-address' returns address of fields of and-records")) (reset) (new-trace "get-address-indirect") (add-code '((function main [ (1:integer <- copy 34:literal) (2:boolean <- copy t:literal) (3:integer-boolean-pair-address <- copy 1:literal) (4:boolean-address <- get-address 3:integer-boolean-pair-address/deref 1:offset) ]))) (run 'main) ;? (prn memory*) (when (~iso memory* (obj 1 34 2 t 3 1 4 2)) (prn "F - 'get-address' accesses fields of and-record address")) (reset) (new-trace "index-literal") (add-code '((function main [ (1:integer <- copy 2:literal) (2:integer <- copy 23:literal) (3:boolean <- copy nil:literal) (4:integer <- copy 24:literal) (5:boolean <- copy t:literal) (6:integer-boolean-pair <- index 1:integer-boolean-pair-array 1:liter /* Generic.Subheading */ .highlight .gt { color: #aa0000 } /* Generic.Traceback */ .highlight .kc { color: #008800; font-weight: bold } /* Keyword.Constant */ .highlight .kd { color: #008800; font-weight: bold } /* Keyword.Declaration */ .highlight .kn { color: #008800; font-weight: bold } /* Keyword.Namespace */ .highlight .kp { color: #008800 } /* Keyword.Pseudo */ .highlight .kr { color: #008800; font-weight: bold } /* Keyword.Reserved */ .highlight .kt { color: #888888; font-weight: bold } /* Keyword.Type */ .highlight .m { color: #0000DD; font-weight: bold } /* Literal.Number */ .highlight .s { color: #dd2200; background-color: #fff0f0 } /* Literal.String */ .highlight .na { color: #336699 } /* Name.Attribute */ .highlight .nb { color: #003388 } /* Name.Builtin */ .highlight .nc { color: #bb0066; font-weight: bold } /* Name.Class */ .highlight .no { color: #003366; font-weight: bold } /* Name.Constant */ .highlight .nd { color: #555555 } /* Name.Decorator */ .highlight .ne { color: #bb0066; font-weight: bold } /* Name.Exception */ .highlight .nf { color: #0066bb; font-weight: bold } /* Name.Function */ .highlight .nl { color: #336699; font-style: italic } /* Name.Label */ .highlight .nn { color: #bb0066; font-weight: bold } /* Name.Namespace */ .highlight .py { color: #336699; font-weight: bold } /* Name.Property */ .highlight .nt { color: #bb0066; font-weight: bold } /* Name.Tag */ .highlight .nv { color: #336699 } /* Name.Variable */ .highlight .ow { color: #008800 } /* Operator.Word */ .highlight .w { color: #bbbbbb } /* Text.Whitespace */ .highlight .mb { color: #0000DD; font-weight: bold } /* Literal.Number.Bin */ .highlight .mf { color: #0000DD; font-weight: bold } /* Literal.Number.Float */ .highlight .mh { color: #0000DD; font-weight: bold } /* Literal.Number.Hex */ .highlight .mi { color: #0000DD; font-weight: bold } /* Literal.Number.Integer */ .highlight .mo { color: #0000DD; font-weight: bold } /* Literal.Number.Oct */ .highlight .sa { color: #dd2200; background-color: #fff0f0 } /* Literal.String.Affix */ .highlight .sb { color: #dd2200; background-color: #fff0f0 } /* Literal.String.Backtick */ .highlight .sc { color: #dd2200; background-color: #fff0f0 } /* Literal.String.Char */ .highlight .dl { color: #dd2200; background-color: #fff0f0 } /* Literal.String.Delimiter */ .highlight .sd { color: #dd2200; background-color: #fff0f0 } /* Literal.String.Doc */ .highlight .s2 { color: #dd2200; background-color: #fff0f0 } /* Literal.String.Double */ .highlight .se { color: #0044dd; background-color: #fff0f0 } /* Literal.String.Escape */ .highlight .sh { color: #dd2200; background-color: #fff0f0 } /* Literal.String.Heredoc */ .highlight .si { color: #3333bb; background-color: #fff0f0 } /* Literal.String.Interpol */ .highlight .sx { color: #22bb22; background-color: #f0fff0 } /* Literal.String.Other */ .highlight .sr { color: #008800; background-color: #fff0ff } /* Literal.String.Regex */ .highlight .s1 { color: #dd2200; background-color: #fff0f0 } /* Literal.String.Single */ .highlight .ss { color: #aa6600; background-color: #fff0f0 } /* Literal.String.Symbol */ .highlight .bp { color: #003388 } /* Name.Builtin.Pseudo */ .highlight .fm { color: #0066bb; font-weight: bold } /* Name.Function.Magic */ .highlight .vc { color: #336699 } /* Name.Variable.Class */ .highlight .vg { color: #dd7700 } /* Name.Variable.Global */ .highlight .vi { color: #3333bb } /* Name.Variable.Instance */ .highlight .vm { color: #336699 } /* Name.Variable.Magic */ .highlight .il { color: #0000DD; font-weight: bold } /* Literal.Number.Integer.Long */
//: Take raw control of the text-mode display and console, putting it in
//: 'console' mode rather than the usual automatically-scrolling 'typewriter'
//: mode.

//:: Display management

:(before "End Globals")
int Display_row = 0;
int Display_column = 0;

:(before "End Includes")
#define CHECK_SCREEN \
    if (!tb_is_active()) { \
      if (Run_tests) \
        raise << maybe(current_recipe_name()) << "tried to print to real screen in a test!\n" << end(); \
      else \
        raise << maybe(current_recipe_name()) << "tried to print to real screen before 'open-console' or after 'close-console'\n" << end(); \
      break; \
    }
#define CHECK_CONSOLE \
    if (!tb_is_active()) { \
      if (Run_tests) \
        raise << maybe(current_recipe_name()) << "tried to read event from real keyboard/mouse in a test!\n" << end(); \
      else \
        raise << maybe(current_recipe_name()) << "tried to read event from real keyboard/mouse before 'open-console' or after 'close-console'\n" << end(); \
      break; \
    }

:(before "End Primitive Recipe Declarations")
OPEN_CONSOLE,
:(before "End Primitive Recipe Numbers")
put(Recipe_ordinal, "open-console", OPEN_CONSOLE);
:(before "End Primitive Recipe Checks")
case OPEN_CONSOLE: {
  break;
}
:(before "End Primitive Recipe Implementations")
case OPEN_CONSOLE: {
  tb_init();
  std::setvbuf(stdout, NULL, _IONBF, 0);  // disable buffering in cout
  Display_row = Display_column = 0;
  int width = tb_width();
  int height = tb_height();
  if (width > 222 || height > 222) {
    if (width > 222)
      raise << "sorry, Mu doesn't support windows wider than 222 characters in console mode. Please resize your window.\n" << end();
    if (height > 222)
      raise << "sorry, Mu doesn't support windows taller than 222 characters in console mode. Please resize your window.\n" << end();
    exit(1);
  }
  break;
}

:(before "End Primitive Recipe Declarations")
CLOSE_CONSOLE,
:(before "End Primitive Recipe Numbers")
put(Recipe_ordinal, "close-console", CLOSE_CONSOLE);
:(before "End Primitive Recipe Checks")
case CLOSE_CONSOLE: {
  break;
}
:(before "End Primitive Recipe Implementations")
case CLOSE_CONSOLE: {
  tb_shutdown();
  break;
}

:(before "End Primitive Recipe Declarations")
CLEAR_DISPLAY,
:(before "End Primitive Recipe Numbers")
put(Recipe_ordinal, "clear-display", CLEAR_DISPLAY);
:(before "End Primitive Recipe Checks")
case CLEAR_DISPLAY: {
  break;
}
:(before "End Primitive Recipe Implementations")
case CLEAR_DISPLAY: {
  CHECK_SCREEN;
  tb_clear();
  Display_row = Display_column = 0;
  break;
}

:(before "End Primitive Recipe Declarations")
PRINT_CHARACTER_TO_DISPLAY,
:(before "End Primitive Recipe Numbers")
put(Recipe_ordinal, "print-character-to-display", PRINT_CHARACTER_TO_DISPLAY);
:(before "End Primitive Recipe Checks")
case PRINT_CHARACTER_TO_DISPLAY: {
  if (inst.ingredients.empty()) {
    raise << maybe(get(Recipe, r).name) << "'print-character-to-display' requires at least one ingredient, but got '" << to_original_string(inst) << "'\n" << end();
    break;
  }
  if (!is_mu_number(inst.ingredients.at(0))) {
    raise << maybe(get(Recipe, r).name) << "first ingredient of 'print-character-to-display' should be a character, but got '" << inst.ingredients.at(0).original_string << "'\n" << end();
    break;
  }
  if (SIZE(inst.ingredients) > 1) {
    if (!is_mu_number(inst.ingredients.at(1))) {
      raise << maybe(get(Recipe, r).name) << "second ingredient of 'print-character-to-display' should be a foreground color number, but got '" << inst.ingredients.at(1).original_string << "'\n" << end();
      break;
    }
  }
  if (SIZE(inst.ingredients) > 2) {
    if (!is_mu_number(inst.ingredients.at(2))) {
      raise << maybe(get(Recipe, r).name) << "third ingredient of 'print-character-to-display' should be a background color number, but got '" << inst.ingredients.at(2).original_string << "'\n" << end();
      break;
    }
  }
  break;
}
:(before "End Primitive Recipe Implementations")
case PRINT_CHARACTER_TO_DISPLAY: {
  CHECK_SCREEN;
  int h=tb_height(), w=tb_width();
  int height = (h >= 0) ? h : 0;
  int width = (w >= 0) ? w : 0;
  int c = ingredients.at(0).at(0);
  int color = TB_WHITE;
  if (SIZE(ingredients) > 1) {
    color = ingredients.at(1).at(0);
  }
  int bg_color = TB_BLACK;
  if (SIZE(ingredients) > 2) {
    bg_color = ingredients.at(2).at(0);
    if (bg_color == 0) bg_color = TB_BLACK;
  }
  tb_print(c, color, bg_color);
  // track row and column, mimicking what happens on screen
  if (c == '\n') {
    if (Display_row < height-1) ++Display_row;  // otherwise we scroll and Display_row remains unchanged
  }
  else if (c == '\r') {
    Display_column = 0;
  }
  else if (c == '\b') {
    if (Display_column > 0) --Display_column;
  }
  else {
    ++Display_column;
    if (Display_column >= width) {
      Display_column = 0;
      if (Display_row < height-1) ++Display_row;
    }
  }
  break;
}

:(before "End Primitive Recipe Declarations")
CURSOR_POSITION_ON_DISPLAY,
:(before "End Primitive Recipe Numbers")
put(Recipe_ordinal, "cursor-position-on-display", CURSOR_POSITION_ON_DISPLAY);
:(before "End Primitive Recipe Checks")
case CURSOR_POSITION_ON_DISPLAY: {
  break;
}
:(before "End Primitive Recipe Implementations")
case CURSOR_POSITION_ON_DISPLAY: {
  CHECK_SCREEN;
  products.resize(2);
  products.at(0).push_back(Display_row);
  products.at(1).push_back(Display_column);
  break;
}

:(before "End Primitive Recipe Declarations")
MOVE_CURSOR_ON_DISPLAY,
:(before "End Primitive Recipe Numbers")
put(Recipe_ordinal, "move-cursor-on-display", MOVE_CURSOR_ON_DISPLAY);
:(before "End Primitive Recipe Checks")
case MOVE_CURSOR_ON_DISPLAY: {
  if (SIZE(inst.ingredients) != 2) {
    raise << maybe(get(Recipe, r).name) << "'move-cursor-on-display' requires two ingredients, but got '" << to_original_string(inst) << "'\n" << end();
    break;
  }
  if (!is_mu_number(inst.ingredients.at(0))) {
    raise << maybe(get(Recipe, r).name) << "first ingredient of 'move-cursor-on-display' should be a row number, but got '" << inst.ingredients.at(0).original_string << "'\n" << end();
    break;
  }
  if (!is_mu_number(inst.ingredients.at(1))) {
    raise << maybe(get(Recipe, r).name) << "second ingredient of 'move-cursor-on-display' should be a column number, but got '" << inst.ingredients.at(1).original_string << "'\n" << end();
    break;
  }
  break;
}
:(before "End Primitive Recipe Implementations")
case MOVE_CURSOR_ON_DISPLAY: {
  CHECK_SCREEN;
  Display_row = ingredients.at(0).at(0);
  Display_column = ingredients.at(1).at(0);
  tb_set_cursor(Display_column, Display_row);
  break;
}

:(before "End Primitive Recipe Declarations")
MOVE_CURSOR_DOWN_ON_DISPLAY,
:(before "End Primitive Recipe Numbers")
put(Recipe_ordinal, "move-cursor-down-on-display", MOVE_CURSOR_DOWN_ON_DISPLAY);
:(before "End Primitive Recipe Checks")
case MOVE_CURSOR_DOWN_ON_DISPLAY: {
  break;
}
:(before "End Primitive Recipe Implementations")
case MOVE_CURSOR_DOWN_ON_DISPLAY: {
  CHECK_SCREEN;
  int h=tb_height();
  int height = (h >= 0) ? h : 0;
  if (Display_row < height-1) {
    ++Display_row;
    tb_set_cursor(Display_column, Display_row);
  }
  break;
}

:(before "End Primitive Recipe Declarations")
MOVE_CURSOR_UP_ON_DISPLAY,
:(before "End Primitive Recipe Numbers")
put(Recipe_ordinal, "move-cursor-up-on-display", MOVE_CURSOR_UP_ON_DISPLAY);
:(before "End Primitive Recipe Checks")
case MOVE_CURSOR_UP_ON_DISPLAY: {
  break;
}
:(before "End Primitive Recipe Implementations")
case MOVE_CURSOR_UP_ON_DISPLAY: {
  CHECK_SCREEN;
  if (Display_row > 0) {
    --Display_row;
    tb_set_cursor(Display_column, Display_row);
  }
  break;
}

:(before "End Primitive Recipe Declarations")
MOVE_CURSOR_RIGHT_ON_DISPLAY,
:(before "End Primitive Recipe Numbers")
put(Recipe_ordinal, "move-cursor-right-on-display", MOVE_CURSOR_RIGHT_ON_DISPLAY);
:(before "End Primitive Recipe Checks")
case MOVE_CURSOR_RIGHT_ON_DISPLAY: {
  break;
}
:(before "End Primitive Recipe Implementations")
case MOVE_CURSOR_RIGHT_ON_DISPLAY: {
  CHECK_SCREEN;
  int w=tb_width();
  int width = (w >= 0) ? w : 0;
  if (Display_column < width-1) {
    ++Display_column;
    tb_set_cursor(Display_column, Display_row);
  }
  break;
}

:(before "End Primitive Recipe Declarations")
MOVE_CURSOR_LEFT_ON_DISPLAY,
:(before "End Primitive Recipe Numbers")
put(Recipe_ordinal, "move-cursor-left-on-display", MOVE_CURSOR_LEFT_ON_DISPLAY);
:(before "End Primitive Recipe Checks")
case MOVE_CURSOR_LEFT_ON_DISPLAY: {
  break;
}
:(before "End Primitive Recipe Implementations")
case MOVE_CURSOR_LEFT_ON_DISPLAY: {
  CHECK_SCREEN;
  if (Display_column > 0) {
    --Display_column;
    tb_set_cursor(Display_column, Display_row);
  }
  break;
}

//: as a convenience, make $print mostly work in console mode
:(before "End $print 10/newline Special-cases")
else if (tb_is_active()) {
  move_cursor_to_start_of_next_line_on_display();
}
:(code)
void move_cursor_to_start_of_next_line_on_display() {
  if (Display_row < tb_height()-1) ++Display_row;
  else Display_row = 0;
  Display_column = 0;
  tb_set_cursor(Display_column, Display_row);
}

:(before "End Primitive Recipe Declarations")
DISPLAY_WIDTH,
:(before "End Primitive Recipe Numbers")
put(Recipe_ordinal, "display-width", DISPLAY_WIDTH);
:(before "End Primitive Recipe Checks")
case DISPLAY_WIDTH: {
  break;
}
:(before "End Primitive Recipe Implementations")
case DISPLAY_WIDTH: {
  CHECK_SCREEN;
  products.resize(1);
  products.at(0).push_back(tb_width());
  break;
}

:(before "End Primitive Recipe Declarations")
DISPLAY_HEIGHT,
:(before "End Primitive Recipe Numbers")
put(Recipe_ordinal, "display-height", DISPLAY_HEIGHT);
:(before "End Primitive Recipe Checks")
case DISPLAY_HEIGHT: {
  break;
}
:(before "End Primitive Recipe Implementations")
case DISPLAY_HEIGHT: {
  CHECK_SCREEN;
  products.resize(1);
  products.at(0).push_back(tb_height());
  break;
}

//:: Keyboard/mouse management

:(before "End Primitive Recipe Declarations")
WAIT_FOR_SOME_INTERACTION,
:(before "End Primitive Recipe Numbers")
put(Recipe_ordinal, "wait-for-some-interaction", WAIT_FOR_SOME_INTERACTION);
:(before "End Primitive Recipe Checks")
case WAIT_FOR_SOME_INTERACTION: {
  break;
}
:(before "End Primitive Recipe Implementations")
case WAIT_FOR_SOME_INTERACTION: {
  CHECK_SCREEN;
  tb_event event;
  tb_poll_event(&event);
  break;
}

:(before "End Primitive Recipe Declarations")
CHECK_FOR_INTERACTION,
:(before "End Primitive Recipe Numbers")
put(Recipe_ordinal, "check-for-interaction", CHECK_FOR_INTERACTION);
:(before "End Primitive Recipe Checks")
case CHECK_FOR_INTERACTION: {
  break;
}
:(before "End Primitive Recipe Implementations")
case CHECK_FOR_INTERACTION: {
  CHECK_CONSOLE;
  products.resize(2);  // result and status
  tb_event event;
  int event_type = tb_peek_event(&event, 5/*ms*/);
  if (event_type == TB_EVENT_KEY && event.ch) {
    products.at(0).push_back(/*text event*/0);
    products.at(0).push_back(event.ch);
    products.at(0).push_back(0);
    products.at(0).push_back(0);
    products.at(1).push_back(/*found*/true);
    break;
  }
  // treat keys within ascii as unicode characters
  if (event_type == TB_EVENT_KEY && event.key < 0xff) {
    products.at(0).push_back(/*text event*/0);
    if (event.key == TB_KEY_CTRL_C) exit(1);
    if (event.key == TB_KEY_BACKSPACE2) event.key = TB_KEY_BACKSPACE;
    if (event.key == TB_KEY_CARRIAGE_RETURN) event.key = TB_KEY_NEWLINE;
    products.at(0).push_back(event.key);
    products.at(0).push_back(0);
    products.at(0).push_back(0);
    products.at(1).push_back(/*found*/true);
    break;
  }
  // keys outside ascii aren't unicode characters but arbitrary termbox inventions
  if (event_type == TB_EVENT_KEY) {
    products.at(0).push_back(/*keycode event*/1);
    products.at(0).push_back(event.key);
    products.at(0).push_back(0);
    products.at(0).push_back(0);
    products.at(1).push_back(/*found*/true);
    break;
  }
  if (event_type == TB_EVENT_MOUSE) {
    products.at(0).push_back(/*touch event*/2);
    products.at(0).push_back(event.key);  // which button, etc.
    products.at(0).push_back(event.y);  // row
    products.at(0).push_back(event.x);  // column
    products.at(1).push_back(/*found*/true);
    break;
  }
  if (event_type == TB_EVENT_RESIZE) {
    products.at(0).push_back(/*resize event*/3);
    products.at(0).push_back(event.w);  // width
    products.at(0).push_back(event.h);  // height
    products.at(0).push_back(0);
    products.at(1).push_back(/*found*/true);
    break;
  }
  assert(event_type == 0);
  products.at(0).push_back(0);
  products.at(0).push_back(0);
  products.at(0).push_back(0);
  products.at(0).push_back(0);
  products.at(1).push_back(/*found*/false);
  break;
}

:(before "End Primitive Recipe Declarations")
INTERACTIONS_LEFT,
:(before "End Primitive Recipe Numbers")
put(Recipe_ordinal, "interactions-left?", INTERACTIONS_LEFT);
:(before "End Primitive Recipe Checks")
case INTERACTIONS_LEFT: {
  break;
}
:(before "End Primitive Recipe Implementations")
case INTERACTIONS_LEFT: {
  CHECK_CONSOLE;
  products.resize(1);
  products.at(0).push_back(tb_event_ready());
  break;
}

//: hacks to make text-mode apps more responsive under Unix

:(before "End Primitive Recipe Declarations")
CLEAR_LINE_ON_DISPLAY,
:(before "End Primitive Recipe Numbers")
put(Recipe_ordinal, "clear-line-on-display", CLEAR_LINE_ON_DISPLAY);
:(before "End Primitive Recipe Checks")
case CLEAR_LINE_ON_DISPLAY: {
  break;
}
:(before "End Primitive Recipe Implementations")
case CLEAR_LINE_ON_DISPLAY: {
  CHECK_SCREEN;
  int width = tb_width();
  for (int x = Display_column;  x < width;  ++x)
    tb_print(' ', TB_WHITE, TB_BLACK);
  tb_set_cursor(Display_column, Display_row);
  break;
}

:(before "End Primitive Recipe Declarations")
CLEAR_DISPLAY_FROM,
:(before "End Primitive Recipe Numbers")
put(Recipe_ordinal, "clear-display-from", CLEAR_DISPLAY_FROM);
:(before "End Primitive Recipe Checks")
case CLEAR_DISPLAY_FROM: {
  break;
}
:(before "End Primitive Recipe Implementations")
case CLEAR_DISPLAY_FROM: {
  CHECK_SCREEN;
  // todo: error checking
  int row = ingredients.at(0).at(0);
  int column = ingredients.at(1).at(0);
  int left = ingredients.at(2).at(0);
  int right = ingredients.at(3).at(0);
  int height=tb_height();
  for (/*nada*/;  row < height;  ++row, column=left) {  // start column from left in every inner loop except first
    tb_set_cursor(column, row);
    for (/*nada*/;  column <= right;  ++column)
      tb_print(' ', TB_WHITE, TB_BLACK);
  }
  tb_set_cursor(Display_column, Display_row);
  break;
}
generated by cgit-pink 1.4.1-2-gfad0 (git 2.36.2.497.gbbea4dcf42) at 2024-07-03 03:05:42 +0000
ons before*!label1) '(; fragment ( (2:integer <- copy 0:literal)))) (prn "F - 'before' records fragments of code to insert before labels")) (when (~iso (insert-code '((1:integer <- copy 0:literal) label1 (3:integer <- copy 0:literal))) '((1:integer <- copy 0:literal) (2:integer <- copy 0:literal) label1 (3:integer <- copy 0:literal))) (prn "F - 'insert-code' can insert fragments before labels")) (reset) (new-trace "before-multiple") (= traces* (queue)) (add-code '((before label1 [ (2:integer <- copy 0:literal) ]) (before label1 [ (3:integer <- copy 0:literal) ]))) (when (~iso (as cons before*!label1) '(; fragment ( (2:integer <- copy 0:literal)) ( (3:integer <- copy 0:literal)))) (prn "F - 'before' records fragments in order")) (when (~iso (insert-code '((1:integer <- copy 0:literal) label1 (4:integer <- copy 0:literal))) '((1:integer <- copy 0:literal) (2:integer <- copy 0:literal) (3:integer <- copy 0:literal) label1 (4:integer <- copy 0:literal))) (prn "F - 'insert-code' can insert multiple fragments in order before label")) (reset) (new-trace "before-scoped") (= traces* (queue)) (add-code '((before f/label1 [ ; label1 only inside function f (2:integer <- copy 0:literal) ]))) (when (~iso (insert-code '((1:integer <- copy 0:literal) label1 (3:integer <- copy 0:literal)) 'f) '((1:integer <- copy 0:literal) (2:integer <- copy 0:literal) label1 (3:integer <- copy 0:literal))) (prn "F - 'insert-code' can insert fragments before labels just in specified functions")) (reset) (new-trace "before-scoped2") (= traces* (queue)) (add-code '((before f/label1 [ ; label1 only inside function f (2:integer <- copy 0:literal) ]))) (when (~iso (insert-code '((1:integer <- copy 0:literal) label1 (3:integer <- copy 0:literal))) '((1:integer <- copy 0:literal) label1 (3:integer <- copy 0:literal))) (prn "F - 'insert-code' ignores labels not in specified functions")) (reset) (new-trace "after") (= traces* (queue)) (add-code '((after label1 [ (2:integer <- copy 0:literal) ]))) (when (~iso (as cons after*!label1) '(; fragment ( (2:integer <- copy 0:literal)))) (prn "F - 'after' records fragments of code to insert after labels")) (when (~iso (insert-code '((1:integer <- copy 0:literal) label1 (3:integer <- copy 0:literal))) '((1:integer <- copy 0:literal) label1 (2:integer <- copy 0:literal) (3:integer <- copy 0:literal))) (prn "F - 'insert-code' can insert fragments after labels")) (reset) (new-trace "after-multiple") (= traces* (queue)) (add-code '((after label1 [ (2:integer <- copy 0:literal) ]) (after label1 [ (3:integer <- copy 0:literal) ]))) (when (~iso (as cons after*!label1) '(; fragment ( (3:integer <- copy 0:literal)) ( (2:integer <- copy 0:literal)))) (prn "F - 'after' records fragments in *reverse* order")) (when (~iso (insert-code '((1:integer <- copy 0:literal) label1 (4:integer <- copy 0:literal))) '((1:integer <- copy 0:literal) label1 (3:integer <- copy 0:literal) (2:integer <- copy 0:literal) (4:integer <- copy 0:literal))) (prn "F - 'insert-code' can insert multiple fragments in order after label")) (reset) (new-trace "before-after") (= traces* (queue)) (add-code '((before label1 [ (2:integer <- copy 0:literal) ]) (after label1 [ (3:integer <- copy 0:literal) ]))) (when (and (~iso (as cons before*!label1) '(; fragment ( (2:integer <- copy 0:literal)))) (~iso (as cons after*!label1) '(; fragment ( (3:integer <- copy 0:literal))))) (prn "F - 'before' and 'after' fragments work together")) (when (~iso (insert-code '((1:integer <- copy 0:literal) label1 (4:integer <- copy 0:literal))) '((1:integer <- copy 0:literal) (2:integer <- copy 0:literal) label1 (3:integer <- copy 0:literal) (4:integer <- copy 0:literal))) (prn "F - 'insert-code' can insert multiple fragments around label")) (reset) (new-trace "before-after-multiple") (= traces* (queue)) (add-code '((before label1 [ (2:integer <- copy 0:literal) (3:integer <- copy 0:literal) ]) (after label1 [ (4:integer <- copy 0:literal) ]) (before label1 [ (5:integer <- copy 0:literal) ]) (after label1 [ (6:integer <- copy 0:literal) (7:integer <- copy 0:literal) ]))) (when (or (~iso (as cons before*!label1) '(; fragment ( (2:integer <- copy 0:literal) (3:integer <- copy 0:literal)) ( (5:integer <- copy 0:literal)))) (~iso (as cons after*!label1) '(; fragment ( (6:integer <- copy 0:literal) (7:integer <- copy 0:literal)) ( (4:integer <- copy 0:literal))))) (prn "F - multiple 'before' and 'after' fragments at once")) (when (~iso (insert-code '((1:integer <- copy 0:literal) label1 (8:integer <- copy 0:literal))) '((1:integer <- copy 0:literal) (2:integer <- copy 0:literal) (3:integer <- copy 0:literal) (5:integer <- copy 0:literal) label1 (6:integer <- copy 0:literal) (7:integer <- copy 0:literal) (4:integer <- copy 0:literal) (8:integer <- copy 0:literal))) (prn "F - 'insert-code' can insert multiple fragments around label - 2")) (reset) (new-trace "before-after-independent") (= traces* (queue)) (when (~iso (do (reset) (add-code '((before label1 [ (2:integer <- copy 0:literal) ]) (after label1 [ (3:integer <- copy 0:literal) ]) (before label1 [ (4:integer <- copy 0:literal) ]) (after label1 [ (5:integer <- copy 0:literal) ]))) (list before*!label1 after*!label1)) (do (reset) (add-code '((before label1 [ (2:integer <- copy 0:literal) ]) (before label1 [ (4:integer <- copy 0:literal) ]) (after label1 [ (3:integer <- copy 0:literal) ]) (after label1 [ (5:integer <- copy 0:literal) ]))) (list before*!label1 after*!label1))) (prn "F - order matters between 'before' and between 'after' fragments, but not *across* 'before' and 'after' fragments")) (reset) (new-trace "before-after-braces") (= traces* (queue)) (= function* (table)) (add-code '((after label1 [ (1:integer <- copy 0:literal) ]) (function f1 [ { begin label1 } ]))) ;? (= dump-trace* (obj whitelist '("cn0"))) (freeze function*) (when (~iso function*!f1 '(label1 (((1 integer)) <- ((copy)) ((0 literal))))) (prn "F - before/after works inside blocks")) (reset) (new-trace "before-after-any-order") (= traces* (queue)) (= function* (table)) (add-code '((function f1 [ { begin label1 } ]) (after label1 [ (1:integer <- copy 0:literal) ]))) (freeze function*) (when (~iso function*!f1 '(label1 (((1 integer)) <- ((copy)) ((0 literal))))) (prn "F - before/after can come after the function they need to modify")) ;? (quit) (reset) (new-trace "multiple-defs") (= traces* (queue)) (= function* (table)) (add-code '((function f1 [ (1:integer <- copy 0:literal) ]) (function f1 [ (2:integer <- copy 0:literal) ]))) (freeze function*) (when (~iso function*!f1 '((((2 integer)) <- ((copy)) ((0 literal))) (((1 integer)) <- ((copy)) ((0 literal))))) (prn "F - multiple 'def' of the same function add clauses")) (reset) (new-trace "def!") (= traces* (queue)) (= function* (table)) (add-code '((function f1 [ (1:integer <- copy 0:literal) ]) (function! f1 [ (2:integer <- copy 0:literal) ]))) (freeze function*) (when (~iso function*!f1 '((((2 integer)) <- ((copy)) ((0 literal))))) (prn "F - 'def!' clears all previous clauses")) ) ; section 10 ;; --- (section 100 ; String utilities (reset) (new-trace "string-new") (add-code '((function main [ (1:string-address <- new string:literal 5:literal) ]))) (let routine make-routine!main (enq routine running-routines*) (let before rep.routine!alloc (run) (when (~iso rep.routine!alloc (+ before 5 1)) (prn "F - 'new' allocates arrays of bytes for strings")))) ; Convenience: initialize strings using string literals (reset) (new-trace "string-literal") (add-code '((function main [ (1:string-address <- new "hello") ]))) (let routine make-routine!main (enq routine running-routines*) (let before rep.routine!alloc ;? (set dump-trace*) ;? (= dump-trace* (obj whitelist '("schedule" "run" "addr"))) (run) (when (~iso rep.routine!alloc (+ before 5 1)) (prn "F - 'new' allocates arrays of bytes for string literals")) (when (~memory-contains-array before "hello") (prn "F - 'new' initializes allocated memory to string literal")))) (reset) (new-trace "strcat") (add-code '((function main [ (1:string-address <- new "hello,") (2:string-address <- new " world!") (3:string-address <- strcat 1:string-address 2:string-address) ]))) (run 'main) (when (~memory-contains-array memory*.3 "hello, world!") (prn "F - 'strcat' concatenates strings")) (reset) (new-trace "interpolate") (add-code '((function main [ (1:string-address <- new "hello, _!") (2:string-address <- new "abc") (3:string-address <- interpolate 1:string-address 2:string-address) ]))) ;? (= dump-trace* (obj whitelist '("run"))) (run 'main) (when (~memory-contains-array memory*.3 "hello, abc!") (prn "F - 'interpolate' splices strings")) (reset) (new-trace "interpolate-empty") (add-code '((function main [ (1:string-address <- new "hello!") (2:string-address <- new "abc") (3:string-address <- interpolate 1:string-address 2:string-address) ]))) ;? (= dump-trace* (obj whitelist '("run"))) (run 'main) (when (~memory-contains-array memory*.3 "hello!") (prn "F - 'interpolate' without underscore returns template")) (reset) (new-trace "interpolate-at-start") (add-code '((function main [ (1:string-address <- new "_, hello!") (2:string-address <- new "abc") (3:string-address <- interpolate 1:string-address 2:string-address) ]))) ;? (= dump-trace* (obj whitelist '("run"))) (run 'main) (when (~memory-contains-array memory*.3 "abc, hello") (prn "F - 'interpolate' splices strings at start")) (reset) (new-trace "interpolate-at-end") (add-code '((function main [ (1:string-address <- new "hello, _") (2:string-address <- new "abc") (3:string-address <- interpolate 1:string-address 2:string-address) ]))) ;? (= dump-trace* (obj whitelist '("run"))) (run 'main) (when (~memory-contains-array memory*.3 "hello, abc") (prn "F - 'interpolate' splices strings at start")) (reset) (new-trace "interpolate-varargs") (add-code '((function main [ (1:string-address <- new "hello, _, _, and _!") (2:string-address <- new "abc") (3:string-address <- new "def") (4:string-address <- new "ghi") (5:string-address <- interpolate 1:string-address 2:string-address 3:string-address 4:string-address) ]))) ;? (= dump-trace* (obj whitelist '("run"))) ;? (= dump-trace* (obj whitelist '("run" "array-info"))) ;? (set dump-trace*) (run 'main) ;? (quit) ;? (up i 1 (+ 1 (memory* memory*.5)) ;? (prn (memory* (+ memory*.5 i)))) (when (~memory-contains-array memory*.5 "hello, abc, def, and ghi!") (prn "F - 'interpolate' splices in any number of strings")) (reset) (new-trace "string-find-next") (add-code '((function main [ (1:string-address <- new "a/b") (2:integer <- find-next 1:string-address ((#\/ literal)) 0:literal) ]))) (run 'main) (when (~is memory*.2 1) (prn "F - 'find-next' finds first location of a character")) (reset) (new-trace "string-find-next-empty") (add-code '((function main [ (1:string-address <- new "") (2:integer <- find-next 1:string-address ((#\/ literal)) 0:literal) ]))) (run 'main) (each routine completed-routines* (aif rep.routine!error (prn "error - " it))) (when (~is memory*.2 0) (prn "F - 'find-next' finds first location of a character")) (reset) (new-trace "string-find-next-initial") (add-code '((function main [ (1:string-address <- new "/abc") (2:integer <- find-next 1:string-address ((#\/ literal)) 0:literal) ]))) (run 'main) (when (~is memory*.2 0) (prn "F - 'find-next' handles prefix match")) (reset) (new-trace "string-find-next-final") (add-code '((function main [ (1:string-address <- new "abc/") (2:integer <- find-next 1:string-address ((#\/ literal)) 0:literal) ]))) (run 'main) ;? (prn memory*.2) (when (~is memory*.2 3) (prn "F - 'find-next' handles suffix match")) (reset) (new-trace "string-find-next-missing") (add-code '((function main [ (1:string-address <- new "abc") (2:integer <- find-next 1:string-address ((#\/ literal)) 0:literal) ]))) (run 'main) ;? (prn memory*.2) (when (~is memory*.2 3) (prn "F - 'find-next' handles no match")) (reset) (new-trace "string-find-next-invalid-index") (add-code '((function main [ (1:string-address <- new "abc") (2:integer <- find-next 1:string-address ((#\/ literal)) 4:literal) ]))) ;? (= dump-trace* (obj whitelist '("run"))) (run 'main) (each routine completed-routines* (aif rep.routine!error (prn "error - " it))) ;? (prn memory*.2) (when (~is memory*.2 4) (prn "F - 'find-next' skips invalid index (past end of string)")) (reset) (new-trace "string-find-next-first") (add-code '((function main [ (1:string-address <- new "ab/c/") (2:integer <- find-next 1:string-address ((#\/ literal)) 0:literal) ]))) (run 'main) (when (~is memory*.2 2) (prn "F - 'find-next' finds first of multiple options")) (reset) (new-trace "string-find-next-second") (add-code '((function main [ (1:string-address <- new "ab/c/") (2:integer <- find-next 1:string-address ((#\/ literal)) 3:literal) ]))) (run 'main) (when (~is memory*.2 4) (prn "F - 'find-next' finds second of multiple options")) (reset) (new-trace "string-split") (add-code '((function main [ (1:string-address <- new "a/b") (2:string-address-array-address <- split 1:string-address ((#\/ literal))) ]))) ;? (set dump-trace*) (run 'main) (each routine completed-routines* (aif rep.routine!error (prn "error - " it))) (let base memory*.2 ;? (prn base " " memory*.base) (when (or (~is memory*.base 2) ;? (do1 nil prn.111) (~memory-contains-array (memory* (+ base 1)) "a") ;? (do1 nil prn.111) (~memory-contains-array (memory* (+ base 2)) "b")) (prn "F - 'split' cuts string at delimiter"))) (reset) (new-trace "string-split2") (add-code '((function main [ (1:string-address <- new "a/b/c") (2:string-address-array-address <- split 1:string-address ((#\/ literal))) ]))) ;? (set dump-trace*) (run 'main) (each routine completed-routines* (aif rep.routine!error (prn "error - " it))) (let base memory*.2 ;? (prn base " " memory*.base) (when (or (~is memory*.base 3) ;? (do1 nil prn.111) (~memory-contains-array (memory* (+ base 1)) "a") ;? (do1 nil prn.111) (~memory-contains-array (memory* (+ base 2)) "b") ;? (do1 nil prn.111) (~memory-contains-array (memory* (+ base 3)) "c")) (prn "F - 'split' cuts string at two delimiters"))) (reset) (new-trace "string-split-missing") (add-code '((function main [ (1:string-address <- new "abc") (2:string-address-array-address <- split 1:string-address ((#\/ literal))) ]))) (run 'main) (each routine completed-routines* (aif rep.routine!error (prn "error - " it))) (let base memory*.2 (when (or (~is memory*.base 1) (~memory-contains-array (memory* (+ base 1)) "abc")) (prn "F - 'split' handles missing delimiter"))) (reset) (new-trace "string-split-empty") (add-code '((function main [ (1:string-address <- new "") (2:string-address-array-address <- split 1:string-address ((#\/ literal))) ]))) ;? (= dump-trace* (obj whitelist '("run"))) (run 'main) (each routine completed-routines* (aif rep.routine!error (prn "error - " it))) (let base memory*.2 ;? (prn base " " memory*.base) (when (~is memory*.base 0) (prn "F - 'split' handles empty string"))) (reset) (new-trace "string-split-empty-piece") (add-code '((function main [ (1:string-address <- new "a/b//c") (2:string-address-array-address <- split 1:string-address ((#\/ literal))) ]))) (run 'main) (each routine completed-routines* (aif rep.routine!error (prn "error - " it))) (let base memory*.2 (when (or (~is memory*.base 4) (~memory-contains-array (memory* (+ base 1)) "a") (~memory-contains-array (memory* (+ base 2)) "b") (~memory-contains-array (memory* (+ base 3)) "") (~memory-contains-array (memory* (+ base 4)) "c")) (prn "F - 'split' cuts string at two delimiters"))) (reset) (new-trace "integer-to-decimal-string") (add-code '((function main [ (1:string-address/raw <- integer-to-decimal-string 34:literal) ]))) ;? (set dump-trace*) ;? (= dump-trace* (obj whitelist '("run"))) (run 'main) (let base memory*.1 (when (~memory-contains-array base "34") (prn "F - converting integer to decimal string"))) (reset) (new-trace "integer-to-decimal-string-zero") (add-code '((function main [ (1:string-address/raw <- integer-to-decimal-string 0:literal) ]))) (run 'main) (let base memory*.1 (when (~memory-contains-array base "0") (prn "F - converting zero to decimal string"))) (reset) (new-trace "integer-to-decimal-string-negative") (add-code '((function main [ (1:string-address/raw <- integer-to-decimal-string -237:literal) ]))) (run 'main) (let base memory*.1 (when (~memory-contains-array base "-237") (prn "F - converting negative integer to decimal string"))) ; fake screen for tests; prints go to a string (reset) (new-trace "fake-screen-initial") (add-code:readfile "chessboard-cursor.mu") (add-code '((function! main [ (default-space:space-address <- new space:literal 30:literal/capacity) (screen:terminal-address <- init-fake-terminal 20:literal 10:literal) (5:string-address/raw <- get screen:terminal-address/deref data:offset) ]))) (run 'main) (each routine completed-routines* (awhen rep.routine!error (prn "error - " it))) (when (~memory-contains-array memory*.5 (+ " " " " " " " " " " " " " " " " " " " ")) (prn "F - fake screen starts out with all spaces")) ) ; section 100 (reset) (new-trace "parse-and-record") (add-code '((and-record foo [ x:string y:integer z:boolean ]))) (when (~iso type*!foo (obj size 3 and-record t elems '((string) (integer) (boolean)) fields '(x y z))) (prn "F - 'add-code' can add new and-records")) ;; unit tests for various helpers ; tokenize-args (prn "== tokenize-args") (assert:iso '((a b) (c d)) (tokenize-arg 'a:b/c:d)) ; numbers are not symbols (assert:iso '((a b) (1 d)) (tokenize-arg 'a:b/1:d)) ; special symbols are skipped (assert:iso '<- (tokenize-arg '<-)) (assert:iso '_ (tokenize-arg '_)) ; idempotent (assert:iso (tokenize-arg:tokenize-arg 'a:b/c:d) (tokenize-arg 'a:b/c:d)) ; support labels (assert:iso '((((default-space space-address)) <- ((new)) ((space literal)) ((30 literal))) foo) (tokenize-args '((default-space:space-address <- new space:literal 30:literal) foo))) ; support braces (assert:iso '((((default-space space-address)) <- ((new)) ((space literal)) ((30 literal))) foo { begin bar (((a b)) <- ((op)) ((c d)) ((e f))) }) (tokenize-args '((default-space:space-address <- new space:literal 30:literal) foo { begin bar (a:b <- op c:d e:f) }))) ; space (prn "== space") (reset) (when (~iso 0 (space '((4 integer)))) (prn "F - 'space' is 0 by default")) (when (~iso 1 (space '((4 integer) (space 1)))) (prn "F - 'space' picks up space when available")) (when (~iso 'global (space '((4 integer) (space global)))) (prn "F - 'space' understands routine-global space")) ; absolutize (prn "== absolutize") (reset) (when (~iso '((4 integer)) (absolutize '((4 integer)))) (prn "F - 'absolutize' works without routine")) (= routine* make-routine!foo) (when (~iso '((4 integer)) (absolutize '((4 integer)))) (prn "F - 'absolutize' works without default-space")) (= rep.routine*!call-stack.0!default-space 10) (= memory*.10 5) ; bounds check for default-space (when (~iso '((15 integer) (raw)) (absolutize '((4 integer)))) (prn "F - 'absolutize' works with default-space")) (absolutize '((5 integer))) (when (~posmatch "no room" rep.routine*!error) (prn "F - 'absolutize' checks against default-space bounds")) (when (~iso '((_ integer)) (absolutize '((_ integer)))) (prn "F - 'absolutize' passes dummy args right through")) (when (~iso '((default-space integer)) (absolutize '((default-space integer)))) (prn "F - 'absolutize' passes 'default-space' right through")) (= memory*.20 5) ; pretend array (= rep.routine*!globals 20) ; provide it to routine global (when (~iso '((22 integer) (raw)) (absolutize '((1 integer) (space global)))) (prn "F - 'absolutize' handles variables in the global space")) ; deref (prn "== deref") (reset) (= memory*.3 4) (when (~iso '((4 integer)) (deref '((3 integer-address) (deref)))) (prn "F - 'deref' handles simple addresses")) (when (~iso '((4 integer) (deref)) (deref '((3 integer-address) (deref) (deref)))) (prn "F - 'deref' deletes just one deref")) (= memory*.4 5) (when (~iso '((5 integer)) (deref:deref '((3 integer-address-address) (deref) (deref)))) (prn "F - 'deref' can be chained")) (when (~iso '((5 integer) (foo)) (deref:deref '((3 integer-address-address) (deref) (foo) (deref)))) (prn "F - 'deref' skips junk")) ; addr (prn "== addr") (reset) (= routine* nil) ;? (prn 111) (when (~is 4 (addr '((4 integer)))) (prn "F - directly addressed operands are their own address")) ;? (quit) (when (~is 4 (addr '((4 integer-address)))) (prn "F - directly addressed operands are their own address - 2")) (when (~is 4 (addr '((4 literal)))) (prn "F - 'addr' doesn't understand literals")) ;? (prn 201) (= memory*.4 23) ;? (prn 202) (when (~is 23 (addr '((4 integer-address) (deref)))) (prn "F - 'addr' works with indirectly-addressed 'deref'")) ;? (quit) (= memory*.3 4) (when (~is 23 (addr '((3 integer-address-address) (deref) (deref)))) (prn "F - 'addr' works with multiple 'deref'")) (= routine* make-routine!foo) (when (~is 4 (addr '((4 integer)))) (prn "F - directly addressed operands are their own address inside routines")) (when (~is 4 (addr '((4 integer-address)))) (prn "F - directly addressed operands are their own address inside routines - 2")) (when (~is 4 (addr '((4 literal)))) (prn "F - 'addr' doesn't understand literals inside routines")) (= memory*.4 23) (when (~is 23 (addr '((4 integer-address) (deref)))) (prn "F - 'addr' works with indirectly-addressed 'deref' inside routines")) ;? (prn 301) (= rep.routine*!call-stack.0!default-space 10) ;? (prn 302) (= memory*.10 5) ; bounds check for default-space ;? (prn 303) (when (~is 15 (addr '((4 integer)))) (prn "F - directly addressed operands in routines add default-space")) ;? (quit) (when (~is 15 (addr '((4 integer-address)))) (prn "F - directly addressed operands in routines add default-space - 2")) (when (~is 15 (addr '((4 literal)))) (prn "F - 'addr' doesn't understand literals")) (= memory*.15 23) (when (~is 23 (addr '((4 integer-address) (deref)))) (prn "F - 'addr' adds default-space before 'deref', not after")) ;? (quit) ; array-len (prn "== array-len") (reset) (= memory*.35 4) (when (~is 4 (array-len '((35 integer-boolean-pair-array)))) (prn "F - 'array-len'")) (= memory*.34 35) (when (~is 4 (array-len '((34 integer-boolean-pair-array-address) (deref)))) (prn "F - 'array-len'")) ;? (quit) ; sizeof (prn "== sizeof") (reset) ;? (set dump-trace*) ;? (prn 401) (when (~is 1 (sizeof '((_ integer)))) (prn "F - 'sizeof' works on primitives")) (when (~is 1 (sizeof '((_ integer-address)))) (prn "F - 'sizeof' works on addresses")) (when (~is 2 (sizeof '((_ integer-boolean-pair)))) (prn "F - 'sizeof' works on and-records")) (when (~is 3 (sizeof '((_ integer-point-pair)))) (prn "F - 'sizeof' works on and-records with and-record fields")) ;? (prn 410) (when (~is 1 (sizeof '((34 integer)))) (prn "F - 'sizeof' works on primitive operands")) (when (~is 1 (sizeof '((34 integer-address)))) (prn "F - 'sizeof' works on address operands")) (when (~is 2 (sizeof '((34 integer-boolean-pair)))) (prn "F - 'sizeof' works on and-record operands")) (when (~is 3 (sizeof '((34 integer-point-pair)))) (prn "F - 'sizeof' works on and-record operands with and-record fields")) (when (~is 2 (sizeof '((34 integer-boolean-pair-address) (deref)))) (prn "F - 'sizeof' works on pointers to and-records")) (= memory*.35 4) ; size of array (= memory*.34 35) ;? (= dump-trace* (obj whitelist '("sizeof" "array-len"))) (when (~is 9 (sizeof '((34 integer-boolean-pair-array-address) (deref)))) (prn "F - 'sizeof' works on pointers to arrays")) ;? (quit) ;? (prn 420) (= memory*.4 23) (when (~is 24 (sizeof '((4 integer-array)))) (prn "F - 'sizeof' reads array lengths from memory")) (= memory*.3 4) (when (~is 24 (sizeof '((3 integer-array-address) (deref)))) (prn "F - 'sizeof' handles pointers to arrays")) (= memory*.15 34) (= routine* make-routine!foo) (when (~is 24 (sizeof '((4 integer-array)))) (prn "F - 'sizeof' reads array lengths from memory inside routines")) (= rep.routine*!call-stack.0!default-space 10) (= memory*.10 5) ; bounds check for default-space (when (~is 35 (sizeof '((4 integer-array)))) (prn "F - 'sizeof' reads array lengths from memory using default-space")) (= memory*.35 4) ; size of array (= memory*.15 35) ;? (= dump-trace* (obj whitelist '("sizeof"))) (aif rep.routine*!error (prn "error - " it)) (when (~is 9 (sizeof '((4 integer-boolean-pair-array-address) (deref)))) (prn "F - 'sizeof' works on pointers to arrays using default-space")) ;? (quit) ; m (prn "== m") (reset) (when (~is 4 (m '((4 literal)))) (prn "F - 'm' avoids reading memory for literals")) (when (~is 4 (m '((4 offset)))) (prn "F - 'm' avoids reading memory for offsets")) (= memory*.4 34) (when (~is 34 (m '((4 integer)))) (prn "F - 'm' reads memory for simple types")) (= memory*.3 4) (when (~is 34 (m '((3 integer-address) (deref)))) (prn "F - 'm' redirects addresses")) (= memory*.2 3) (when (~is 34 (m '((2 integer-address-address) (deref) (deref)))) (prn "F - 'm' multiply redirects addresses")) (when (~iso (annotate 'record '(34 nil)) (m '((4 integer-boolean-pair)))) (prn "F - 'm' supports compound records")) (= memory*.5 35) (= memory*.6 36) (when (~iso (annotate 'record '(34 35 36)) (m '((4 integer-point-pair)))) (prn "F - 'm' supports records with compound fields")) (when (~iso (annotate 'record '(34 35 36)) (m '((3 integer-point-pair-address) (deref)))) (prn "F - 'm' supports indirect access to records")) (= memory*.4 2) (when (~iso (annotate 'record '(2 35 36)) (m '((4 integer-array)))) (prn "F - 'm' supports access to arrays")) (when (~iso (annotate 'record '(2 35 36)) (m '((3 integer-array-address) (deref)))) (prn "F - 'm' supports indirect access to arrays")) (= routine* make-routine!foo) (= memory*.10 5) ; fake array (= memory*.12 34) (= rep.routine*!globals 10) (when (~iso 34 (m '((1 integer) (space global)))) (prn "F - 'm' supports access to per-routine globals")) ; setm (prn "== setm") (reset) (setm '((4 integer)) 34) (when (~is 34 memory*.4) (prn "F - 'setm' writes primitives to memory")) (setm '((3 integer-address)) 4) (when (~is 4 memory*.3) (prn "F - 'setm' writes addresses to memory")) (setm '((3 integer-address) (deref)) 35) (when (~is 35 memory*.4) (prn "F - 'setm' redirects writes")) (= memory*.2 3) (setm '((2 integer-address-address) (deref) (deref)) 36) (when (~is 36 memory*.4) (prn "F - 'setm' multiply redirects writes")) ;? (prn 505) (setm '((4 integer-integer-pair)) (annotate 'record '(23 24))) (when (~memory-contains 4 '(23 24)) (prn "F - 'setm' writes compound records")) (assert (is memory*.7 nil)) ;? (prn 506) (setm '((7 integer-point-pair)) (annotate 'record '(23 24 25))) (when (~memory-contains 7 '(23 24 25)) (prn "F - 'setm' writes records with compound fields")) (= routine* make-routine!foo) (setm '((4 integer-point-pair)) (annotate 'record '(33 34))) (when (~posmatch "incorrect size" rep.routine*!error) (prn "F - 'setm' checks size of target")) (wipe routine*) (setm '((3 integer-point-pair-address) (deref)) (annotate 'record '(43 44 45))) (when (~memory-contains 4 '(43 44 45)) (prn "F - 'setm' supports indirect writes to records")) (setm '((2 integer-point-pair-address-address) (deref) (deref)) (annotate 'record '(53 54 55))) (when (~memory-contains 4 '(53 54 55)) (prn "F - 'setm' supports multiply indirect writes to records")) (setm '((4 integer-array)) (annotate 'record '(2 31 32))) (when (~memory-contains 4 '(2 31 32)) (prn "F - 'setm' writes arrays")) (setm '((3 integer-array-address) (deref)) (annotate 'record '(2 41 42))) (when (~memory-contains 4 '(2 41 42)) (prn "F - 'setm' supports indirect writes to arrays")) (= routine* make-routine!foo) (setm '((4 integer-array)) (annotate 'record '(2 31 32 33))) (when (~posmatch "invalid array" rep.routine*!error) (prn "F - 'setm' checks that array written is well-formed")) (= routine* make-routine!foo) ;? (prn 111) ;? (= dump-trace* (obj whitelist '("sizeof" "setm"))) (setm '((4 integer-boolean-pair-array)) (annotate 'record '(2 31 nil 32 nil 33))) (when (~posmatch "invalid array" rep.routine*!error) (prn "F - 'setm' checks that array of records is well-formed")) (= routine* make-routine!foo) ;? (prn 222) (setm '((4 integer-boolean-pair-array)) (annotate 'record '(2 31 nil 32 nil))) (when (posmatch "invalid array" rep.routine*!error) (prn "F - 'setm' checks that array of records is well-formed - 2")) (wipe routine*) (reset) ; end file with this to persist the trace for the final test