diff options
author | Kartik K. Agaram <vc@akkartik.com> | 2015-05-05 21:17:24 -0700 |
---|---|---|
committer | Kartik K. Agaram <vc@akkartik.com> | 2015-05-05 21:17:24 -0700 |
commit | b96af395b9af2ff9df94b3e82213171f30827c8d (patch) | |
tree | 17c8c12648ccc25625e2534ec8d74fbe8f1542cc /mu.arc.t | |
parent | 2e3b597fe85b654e82b891c22d50754fa5a26156 (diff) | |
download | mu-b96af395b9af2ff9df94b3e82213171f30827c8d.tar.gz |
1276 - make C++ version the default
I've tried to update the Readme, but there are at least a couple of issues.
Diffstat (limited to 'mu.arc.t')
-rw-r--r-- | mu.arc.t | 5208 |
1 files changed, 0 insertions, 5208 deletions
diff --git a/mu.arc.t b/mu.arc.t deleted file mode 100644 index 6c0464f9..00000000 --- a/mu.arc.t +++ /dev/null @@ -1,5208 +0,0 @@ -; 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) -(ero "running tests in mu.ar.c.t (takes ~30s)") -;? (quit) - -(set allow-raw-addresses*) - -(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.")) -;? (reset) ;? 2 -;? (quit) ;? 2 - -; 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")) -;? (reset) ;? 1 -;? (quit) ;? 1 - -(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:literal) - ]))) -(run 'main) -;? (prn memory*) -(when (~iso memory* (obj 1 2 2 23 3 nil 4 24 5 t 6 24 7 t)) - (prn "F - 'index' accesses indices of arrays")) -;? (quit) - -(reset) -(new-trace "index-direct") -(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 <- copy 1:literal) - (7:integer-boolean-pair <- index 1:integer-boolean-pair-array 6:integer) - ]))) -(run 'main) -;? (prn memory*) -(when (~iso memory* (obj 1 2 2 23 3 nil 4 24 5 t 6 1 7 24 8 t)) - (prn "F - 'index' accesses indices of arrays")) -;? (quit) - -(reset) -(new-trace "index-indirect") -(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 <- copy 1:literal) - (7:integer-boolean-pair-array-address <- copy 1:literal) - (8:integer-boolean-pair <- index 7:integer-boolean-pair-array-address/deref 6:integer) - ]))) -;? (= dump-trace* (obj blacklist '("sz" "mem" "addr" "cvt0" "cvt1"))) -;? (set dump-trace*) -(run 'main) -;? (prn memory*) -(when (~iso memory* (obj 1 2 2 23 3 nil 4 24 5 t 6 1 7 1 8 24 9 t)) - (prn "F - 'index' accesses indices of array address")) -;? (quit) - -(reset) -(new-trace "index-indirect-multiple") -(add-code - '((function main [ - (1:integer <- copy 4:literal) - (2:integer <- copy 23:literal) - (3:integer <- copy 24:literal) - (4:integer <- copy 25:literal) - (5:integer <- copy 26:literal) - (6:integer-array-address <- copy 1:literal) ; unsafe - (7:integer-array-address-address <- copy 6:literal) ; unsafe - (8:integer <- index 7:integer-array-address-address/deref/deref 1:literal) - ]))) -(run 'main) -(when (~is memory*.8 24) - (prn "F - 'index' can deref multiple times")) - -(reset) -(new-trace "index-address") -(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 <- copy 1:literal) - (7:integer-boolean-pair-address <- index-address 1:integer-boolean-pair-array 6:integer) - ]))) -(run 'main) -;? (prn memory*) -(when (~iso memory* (obj 1 2 2 23 3 nil 4 24 5 t 6 1 7 4)) - (prn "F - 'index-address' returns addresses of indices of arrays")) - -(reset) -(new-trace "index-address-indirect") -(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 <- copy 1:literal) - (7:integer-boolean-pair-array-address <- copy 1:literal) - (8:integer-boolean-pair-address <- index-address 7:integer-boolean-pair-array-address/deref 6:integer) - ]))) -(run 'main) -;? (prn memory*) -(when (~iso memory* (obj 1 2 2 23 3 nil 4 24 5 t 6 1 7 1 8 4)) - (prn "F - 'index-address' returns addresses of indices of array addresses")) - -; Array values know their length. Record lengths are saved in the types table. - -(reset) -(new-trace "len-array") -(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 <- length 1:integer-boolean-pair-array) - ]))) -(run 'main) -;? (prn memory*) -(when (~is memory*.6 2) - (prn "F - 'length' of array")) - -(reset) -(new-trace "len-array-indirect") -(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-address <- copy 1:literal) - (7:integer <- length 6:integer-boolean-pair-array-address/deref) - ]))) -;? (set dump-trace*) -;? (= dump-trace* (obj blacklist '("sz" "mem" "addr" "cvt0" "cvt1"))) -(run 'main) -;? (prn memory*) -(when (~is memory*.7 2) - (prn "F - 'length' of array address")) - -; 'sizeof' is a helper to determine the amount of memory required by a type. -; Only for non-arrays. - -(reset) -(new-trace "sizeof-record") -(add-code - '((function main [ - (1:integer <- sizeof integer-boolean-pair:literal) - ]))) -(run 'main) -;? (prn memory*) -(when (~is memory*.1 2) - (prn "F - 'sizeof' returns space required by arg")) - -(reset) -(new-trace "sizeof-record-not-len") -(add-code - '((function main [ - (1:integer <- sizeof integer-point-pair:literal) - ]))) -(run 'main) -;? (prn memory*) -(when (is memory*.1 2) - (prn "F - 'sizeof' is different from number of elems")) - -; Regardless of a type's length, you can move it around just like a primitive. - -(reset) -(new-trace "copy-record") -(add-code - '((function main [ - (1:integer <- copy 34:literal) - (2:boolean <- copy nil:literal) - (4:boolean <- copy t:literal) - (3:integer-boolean-pair <- copy 1:integer-boolean-pair) - ]))) -(run 'main) -;? (prn memory*) -(when (~iso memory* (obj 1 34 2 nil 3 34 4 nil)) - (prn "F - ops can operate on records spanning multiple locations")) - -(reset) -(new-trace "copy-record2") -(add-code - '((function main [ - (1:integer <- copy 34:literal) - (2:integer <- copy 35:literal) - (3:integer <- copy 36:literal) - (4:integer <- copy 0:literal) - (5:integer <- copy 0:literal) - (6:integer <- copy 0:literal) - (4:integer-point-pair <- copy 1:integer-point-pair) - ]))) -;? (= dump-trace* (obj whitelist '("run" "sizeof"))) -(run 'main) -;? (prn memory*) -(when (~iso memory* (obj 1 34 2 35 3 36 - ; result - 4 34 5 35 6 36)) - (prn "F - ops can operate on records with fields spanning multiple locations")) - -) ; section 20 - -(section 100 - -; A special kind of record is the 'tagged type'. It lets us represent -; dynamically typed values, which save type information in memory rather than -; in the code to use them. This will let us do things like create heterogenous -; lists containing both integers and strings. Tagged values admit two -; operations: -; -; 'save-type' - turns a regular value into a tagged-value of the appropriate type -; 'maybe-coerce' - turns a tagged value into a regular value if the type matches -; -; The payload of a tagged value must occupy just one location. Save pointers -; to records. - -(reset) -(new-trace "tagged-value") -;? (= dump-trace* (obj blacklist '("sz" "mem" "addr" "cvt0" "cvt1"))) -(add-code - '((function main [ - (1:type <- copy integer:literal) - (2:integer <- copy 34:literal) - (3:integer 4:boolean <- maybe-coerce 1:tagged-value integer:literal) - ]))) -;? (set dump-trace*) -(run 'main) -;? (prn completed-routines*) -(each routine completed-routines* - (aif rep.routine!error (prn "error - " it))) -;? (prn memory*) -(when (or (~is memory*.3 34) - (~is memory*.4 t)) - (prn "F - 'maybe-coerce' copies value only if type tag matches")) -;? (quit) - -(reset) -(new-trace "tagged-value-2") -;? (set dump-trace*) -(add-code - '((function main [ - (1:type <- copy integer-address:literal) - (2:integer <- copy 34:literal) - (3:boolean 4:boolean <- maybe-coerce 1:tagged-value boolean:literal) - ]))) -(run 'main) -;? (prn memory*) -(when (or (~is memory*.3 0) - (~is memory*.4 nil)) - (prn "F - 'maybe-coerce' doesn't copy value when type tag doesn't match")) - -(reset) -(new-trace "save-type") -(add-code - '((function main [ - (1:integer <- copy 34:literal) - (2:tagged-value <- save-type 1:integer) - ]))) -(run 'main) -;? (prn memory*) -(when (~iso memory* (obj 1 34 2 'integer 3 34)) - (prn "F - 'save-type' saves the type of a value at runtime, turning it into a tagged-value")) - -(reset) -(new-trace "init-tagged-value") -(add-code - '((function main [ - (1:integer <- copy 34:literal) - (2:tagged-value-address <- init-tagged-value integer:literal 1:integer) - (3:integer 4:boolean <- maybe-coerce 2:tagged-value-address/deref integer:literal) - ]))) -;? (= dump-trace* (obj blacklist '("sz" "mem" "addr" "cvt0" "cvt1" "sizeof"))) -(run 'main) -;? (prn memory*) -(when (or (~is memory*.3 34) - (~is memory*.4 t)) - (prn "F - 'init-tagged-value' is the converse of 'maybe-coerce'")) -;? (quit) - -; Now that we can package values together with their types, we can construct a -; dynamically typed list. - -(reset) -(new-trace "list") -;? (set dump-trace*) -(add-code - '((function main [ - ; 1 points at first node: tagged-value (int 34) - (1:list-address <- new list:literal) - (2:tagged-value-address <- list-value-address 1:list-address) - (3:type-address <- get-address 2:tagged-value-address/deref type:offset) - (3:type-address/deref <- copy integer:literal) - (4:location <- get-address 2:tagged-value-address/deref payload:offset) - (4:location/deref <- copy 34:literal) - (5:list-address-address <- get-address 1:list-address/deref cdr:offset) - (5:list-address-address/deref <- new list:literal) - ; 6 points at second node: tagged-value (boolean t) - (6:list-address <- copy 5:list-address-address/deref) - (7:tagged-value-address <- list-value-address 6:list-address) - (8:type-address <- get-address 7:tagged-value-address/deref type:offset) - (8:type-address/deref <- copy boolean:literal) - (9:location <- get-address 7:tagged-value-address/deref payload:offset) - (9:location/deref <- copy t:literal) - (10:list-address <- get 6:list-address/deref 1:offset) - ]))) -(let routine make-routine!main - (enq routine running-routines*) - (let first rep.routine!alloc -;? (= dump-trace* (obj whitelist '("run"))) -;? (set dump-trace*) - (run) -;? (prn memory*) - (each routine completed-routines* - (aif rep.routine!error (prn "error - " it))) - (when (or (~all first (map memory* '(1 2 3))) - (~is memory*.first 'integer) - (~is memory*.4 (+ first 1)) - (~is (memory* (+ first 1)) 34) - (~is memory*.5 (+ first 2)) - (let second memory*.6 - (or - (~is (memory* (+ first 2)) second) - (~all second (map memory* '(6 7 8))) - (~is memory*.second 'boolean) - (~is memory*.9 (+ second 1)) - (~is (memory* (+ second 1)) t) - (~is memory*.10 nil)))) - (prn "F - lists can contain elements of different types")))) -(run-code test2 - (10:list-address <- list-next 1:list-address)) -(each routine completed-routines* - (aif rep.routine!error (prn "error - " it))) -(when (~is memory*.10 memory*.6) - (prn "F - 'list-next can move a list pointer to the next node")) -;? (quit) - -; 'init-list' takes a variable number of args and constructs a list containing -; them. Just integers for now. - -(reset) -(new-trace "init-list") -(add-code - '((function main [ - (1:integer <- init-list 3:literal 4:literal 5:literal) - ]))) -;? (= dump-trace* (obj blacklist '("sz" "mem" "addr" "cvt0" "cvt1" "sizeof"))) -(run 'main) -;? (prn memory*) -(let first memory*.1 -;? (prn first) - (when (or (~is memory*.first 'integer) - (~is (memory* (+ first 1)) 3) - (let second (memory* (+ first 2)) -;? (prn second) - (or (~is memory*.second 'integer) - (~is (memory* (+ second 1)) 4) - (let third (memory* (+ second 2)) -;? (prn third) - (or (~is memory*.third 'integer) - (~is (memory* (+ third 1)) 5) - (~is (memory* (+ third 2) nil))))))) - (prn "F - 'init-list' can construct a list of integers"))) - -) ; section 100 - -(section 20 - -;; Functions -; -; Just like the table of types is centralized, functions are conceptualized as -; a centralized table of operations just like the "primitives" we've seen so -; far. If you create a function you can call it like any other op. - -(reset) -(new-trace "new-fn") -(add-code - '((function test1 [ - (3:integer <- add 1:integer 2:integer) - ]) - (function main [ - (1:integer <- copy 1:literal) - (2:integer <- copy 3:literal) - (test1) - ]))) -(run 'main) -;? (prn memory*) -(when (~iso memory* (obj 1 1 2 3 3 4)) - (prn "F - calling a user-defined function runs its instructions")) -;? (quit) - -(reset) -(new-trace "new-fn-once") -(add-code - '((function test1 [ - (1:integer <- copy 1:literal) - ]) - (function main [ - (test1) - ]))) -;? (= dump-trace* (obj whitelist '("run"))) -(run 'main) -(when (~is 2 curr-cycle*) - (prn "F - calling a user-defined function runs its instructions exactly once " curr-cycle*)) -;? (quit) - -; User-defined functions communicate with their callers through two -; primitives: -; -; 'arg' - to access inputs -; 'reply' - to return outputs - -(reset) -(new-trace "new-fn-reply") -(add-code - '((function test1 [ - (3:integer <- add 1:integer 2:integer) - (reply) - (4:integer <- copy 34:literal) - ]) - (function main [ - (1:integer <- copy 1:literal) - (2:integer <- copy 3:literal) - (test1) - ]))) -(run 'main) -;? (prn memory*) -(when (~iso memory* (obj 1 1 2 3 3 4)) - (prn "F - 'reply' stops executing the current function")) -;? (quit) - -(reset) -(new-trace "new-fn-reply-nested") -(add-code - '((function test1 [ - (3:integer <- test2) - ]) - (function test2 [ - (reply 2:integer) - ]) - (function main [ - (2:integer <- copy 34:literal) - (test1) - ]))) -(run 'main) -;? (prn memory*) -(when (~iso memory* (obj 2 34 3 34)) - (prn "F - 'reply' stops executing any callers as necessary")) -;? (quit) - -(reset) -(new-trace "new-fn-reply-once") -(add-code - '((function test1 [ - (3:integer <- add 1:integer 2:integer) - (reply) - (4:integer <- copy 34:literal) - ]) - (function main [ - (1:integer <- copy 1:literal) - (2:integer <- copy 3:literal) - (test1) - ]))) -;? (= dump-trace* (obj whitelist '("run"))) -(run 'main) -(when (~is 5 curr-cycle*) - (prn "F - 'reply' executes instructions exactly once " curr-cycle*)) -;? (quit) - -(reset) -(new-trace "reply-increments-caller-pc") -(add-code - '((function callee [ - (reply) - ]) - (function caller [ - (1:integer <- copy 0:literal) - (2:integer <- copy 0:literal) - ]))) -(freeze function*) -(= routine* (make-routine 'caller)) -(assert (is 0 pc.routine*)) -(push-stack routine* 'callee) ; pretend call was at first instruction of caller -(run-for-time-slice 1) -(when (~is 1 pc.routine*) - (prn "F - 'reply' increments pc in caller (to move past calling instruction)")) - -(reset) -(new-trace "new-fn-arg-sequential") -(add-code - '((function test1 [ - (4:integer <- next-input) - (5:integer <- next-input) - (3:integer <- add 4:integer 5:integer) - (reply) - (4:integer <- copy 34:literal) - ]) - (function main [ - (1:integer <- copy 1:literal) - (2:integer <- copy 3:literal) - (test1 1:integer 2:integer) - ]))) -(run 'main) -;? (prn memory*) -(when (~iso memory* (obj 1 1 2 3 3 4 - ; test1's temporaries - 4 1 5 3)) - (prn "F - 'arg' accesses in order the operands of the most recent function call (the caller)")) -;? (quit) - -(reset) -(new-trace "new-fn-arg-random-access") -;? (set dump-trace*) -(add-code - '((function test1 [ - (5:integer <- input 1:literal) - (4:integer <- input 0:literal) - (3:integer <- add 4:integer 5:integer) - (reply) - (4:integer <- copy 34:literal) ; should never run - ]) - (function main [ - (1:integer <- copy 1:literal) - (2:integer <- copy 3:literal) - (test1 1:integer 2:integer) - ]))) -(run 'main) -;? (prn memory*) -(when (~iso memory* (obj 1 1 2 3 3 4 - ; test's temporaries - 4 1 5 3)) - (prn "F - 'arg' with index can access function call arguments out of order")) -;? (quit) - -(reset) -(new-trace "new-fn-arg-random-then-sequential") -;? (set dump-trace*) -(add-code - '((function test1 [ - (_ <- input 1:literal) - (1:integer <- next-input) ; takes next arg after index 1 - ]) ; should never run - (function main [ - (test1 1:literal 2:literal 3:literal) - ]))) -(run 'main) -;? (prn memory*) -(when (~iso memory* (obj 1 3)) - (prn "F - 'arg' with index resets index for later calls")) -;? (quit) - -(reset) -(new-trace "new-fn-arg-status") -(add-code - '((function test1 [ - (4:integer 5:boolean <- next-input) - ]) - (function main [ - (test1 1:literal) - ]))) -(run 'main) -;? (prn memory*) -(when (~iso memory* (obj 4 1 5 t)) - (prn "F - 'arg' sets a second oarg when arg exists")) -;? (quit) - -(reset) -(new-trace "new-fn-arg-missing") -(add-code - '((function test1 [ - (4:integer <- next-input) - (5:integer <- next-input) - ]) - (function main [ - (test1 1:literal) - ]))) -(run 'main) -;? (prn memory*) -(when (~iso memory* (obj 4 1)) - (prn "F - missing 'arg' doesn't cause error")) -;? (quit) - -(reset) -(new-trace "new-fn-arg-missing-2") -(add-code - '((function test1 [ - (4:integer <- next-input) - (5:integer 6:boolean <- next-input) - ]) - (function main [ - (test1 1:literal) - ]))) -(run 'main) -;? (prn memory*) -(when (~iso memory* (obj 4 1 6 nil)) - (prn "F - missing 'arg' wipes second oarg when provided")) -;? (quit) - -(reset) -(new-trace "new-fn-arg-missing-3") -(add-code - '((function test1 [ - (4:integer <- next-input) - (5:integer <- copy 34:literal) - (5:integer 6:boolean <- next-input) - ]) - (function main [ - (test1 1:literal) - ]))) -(run 'main) -;? (prn memory*) -(when (~iso memory* (obj 4 1 6 nil)) - (prn "F - missing 'arg' consistently wipes its oarg")) -;? (quit) - -(reset) -(new-trace "new-fn-arg-missing-4") -(add-code - '((function test1 [ - ; if given two args, adds them; if given one arg, increments - (4:integer <- next-input) - (5:integer 6:boolean <- next-input) - { begin - (break-if 6:boolean) - (5:integer <- copy 1:literal) - } - (7:integer <- add 4:integer 5:integer) - ]) - (function main [ - (test1 34:literal) - ]))) -;? (set dump-trace*) -(run 'main) -;? (prn memory*) -(when (~iso memory* (obj 4 34 5 1 6 nil 7 35)) - (prn "F - function with optional second arg")) -;? (quit) - -(reset) -(new-trace "new-fn-arg-by-value") -(add-code - '((function test1 [ - (1:integer <- copy 0:literal) ; overwrite caller memory - (2:integer <- next-input) - ]) ; arg not clobbered - (function main [ - (1:integer <- copy 34:literal) - (test1 1:integer) - ]))) -(run 'main) -;? (prn memory*) -(when (~iso memory* (obj 1 0 2 34)) - (prn "F - 'arg' passes by value")) - -(reset) -(new-trace "arg-record") -(add-code - '((function test1 [ - (4:integer-boolean-pair <- next-input) - ]) - (function main [ - (1:integer <- copy 34:literal) - (2:boolean <- copy nil:literal) - (test1 1:integer-boolean-pair) - ]))) -(run 'main) -(when (~iso memory* (obj 1 34 2 nil 4 34 5 nil)) - (prn "F - 'arg' can copy records spanning multiple locations")) - -(reset) -(new-trace "arg-record-indirect") -;? (set dump-trace*) -(add-code - '((function test1 [ - (4:integer-boolean-pair <- next-input) - ]) - (function main [ - (1:integer <- copy 34:literal) - (2:boolean <- copy nil:literal) - (3:integer-boolean-pair-address <- copy 1:literal) - (test1 3:integer-boolean-pair-address/deref) - ]))) -(run 'main) -;? (prn memory*) -(when (~iso memory* (obj 1 34 2 nil 3 1 4 34 5 nil)) - (prn "F - 'arg' can copy records spanning multiple locations in indirect mode")) - -(reset) -(new-trace "new-fn-reply-oarg") -(add-code - '((function test1 [ - (4:integer <- next-input) - (5:integer <- next-input) - (6:integer <- add 4:integer 5:integer) - (reply 6:integer) - (4:integer <- copy 34:literal) - ]) - (function main [ - (1:integer <- copy 1:literal) - (2:integer <- copy 3:literal) - (3:integer <- test1 1:integer 2:integer) - ]))) -(run 'main) -;? (prn memory*) -(when (~iso memory* (obj 1 1 2 3 3 4 - ; test1's temporaries - 4 1 5 3 6 4)) - (prn "F - 'reply' can take aguments that are returned, or written back into output args of caller")) - -(reset) -(new-trace "new-fn-reply-oarg-multiple") -(add-code - '((function test1 [ - (4:integer <- next-input) - (5:integer <- next-input) - (6:integer <- add 4:integer 5:integer) - (reply 6:integer 5:integer) - (4:integer <- copy 34:literal) - ]) - (function main [ - (1:integer <- copy 1:literal) - (2:integer <- copy 3:literal) - (3:integer 7:integer <- test1 1:integer 2:integer) - ]))) -(run 'main) -;? (prn memory*) -(when (~iso memory* (obj 1 1 2 3 3 4 7 3 - ; test1's temporaries - 4 1 5 3 6 4)) - (prn "F - 'reply' permits a function to return multiple values at once")) - -; 'prepare-reply' is useful for doing cleanup before exiting a function -(reset) -(new-trace "new-fn-prepare-reply") -(add-code - '((function test1 [ - (4:integer <- next-input) - (5:integer <- next-input) - (6:integer <- add 4:integer 5:integer) - (prepare-reply 6:integer 5:integer) - (reply) - (4:integer <- copy 34:literal) - ]) - (function main [ - (1:integer <- copy 1:literal) - (2:integer <- copy 3:literal) - (3:integer 7:integer <- test1 1:integer 2:integer) - ]))) -(run 'main) -;? (prn memory*) -(when (~iso memory* (obj 1 1 2 3 3 4 7 3 - ; test1's temporaries - 4 1 5 3 6 4)) - (prn "F - without args, 'reply' returns values from previous 'prepare-reply'.")) - -; When you have arguments that are both read from and written to, include them -; redundantly in both ingredients and results. That'll help tools track what -; changed. - -; To enforce that the result and ingredient must always match, use the -; 'same-as-arg' property. Results with 'same-as-arg' properties should only be -; copied to a caller output arg identical to the specified caller arg. -(reset) -(new-trace "new-fn-same-as-arg") -(add-code - '((function test1 [ - ; increment the contents of an address - (default-space:space-address <- new space:literal 2:literal) - (x:integer-address <- next-input) - (x:integer-address/deref <- add x:integer-address/deref 1:literal) - (reply x:integer-address/same-as-arg:0) - ]) - (function main [ - (2:integer-address <- new integer:literal) - (2:integer-address/deref <- copy 0:literal) - (3:integer-address <- test1 2:integer-address) - ]))) -(run 'main) -(let routine (car completed-routines*) -;? (prn rep.routine!error) ;? 1 - (when (no rep.routine!error) - (prn "F - 'same-as-arg' results must be identical to a given input"))) -;? (quit) ;? 2 - -) ; section 20 - -(section 11 - -;; Structured programming -; -; Our jump operators are quite inconvenient to use, so mu provides a -; lightweight tool called 'convert-braces' to work in a slightly more -; convenient format with nested braces: -; -; { -; some instructions -; { -; more instructions -; } -; } -; -; Braces are like labels in assembly language, they require no special -; parsing. The operations 'loop' and 'break' jump to just after the enclosing -; '{' and '}' respectively. -; -; Conditional and unconditional 'loop' and 'break' should give us 80% of the -; benefits of the control-flow primitives we're used to in other languages, -; like 'if', 'while', 'for', etc. -; -; Compare 'unquoted blocks' using {} with 'quoted blocks' using [] that we've -; gotten used to seeing. Quoted blocks are used by top-level instructions to -; provide code without running it. - -(reset) -(new-trace "convert-braces") -(= traces* (queue)) -;? (= dump-trace* (obj whitelist '("c{0" "c{1"))) -(when (~iso (convert-braces - '((((1 integer)) <- ((copy)) ((0 literal))) - (((2 integer)) <- ((copy)) ((0 literal))) - (((3 integer)) <- ((copy)) ((0 literal))) - { begin ; 'begin' is just a hack because racket turns braces into parens - (((4 boolean)) <- ((not-equal)) ((1 integer)) ((3 integer))) - (((break-if)) ((4 boolean))) - (((5 integer)) <- ((copy)) ((0 literal))) - } - (((reply))))) - '((((1 integer)) <- ((copy)) ((0 literal))) - (((2 integer)) <- ((copy)) ((0 literal))) - (((3 integer)) <- ((copy)) ((0 literal))) - (((4 boolean)) <- ((not-equal)) ((1 integer)) ((3 integer))) - (((jump-if)) ((4 boolean)) ((1 offset))) - (((5 integer)) <- ((copy)) ((0 literal))) - (((reply))))) - (prn "F - convert-braces replaces break-if with a jump-if to after the next close-brace")) -;? (quit) - -(reset) -(new-trace "convert-braces-empty-block") -(= traces* (queue)) -;? (= dump-trace* (obj whitelist '("c{0" "c{1"))) -(when (~iso (convert-braces - '((((1 integer)) <- ((copy)) ((0 literal))) - (((2 integer)) <- ((copy)) ((0 literal))) - (((3 integer)) <- ((copy)) ((0 literal))) - { begin - (((break))) - } - (((reply))))) - '((((1 integer)) <- ((copy)) ((0 literal))) - (((2 integer)) <- ((copy)) ((0 literal))) - (((3 integer)) <- ((copy)) ((0 literal))) - (((jump)) ((0 offset))) - (((reply))))) - (prn "F - convert-braces works for degenerate blocks")) -;? (quit) - -(reset) -(new-trace "convert-braces-nested-break") -(= traces* (queue)) -(when (~iso (convert-braces - '((((1 integer)) <- ((copy)) ((0 literal))) - (((2 integer)) <- ((copy)) ((0 literal))) - (((3 integer)) <- ((copy)) ((0 literal))) - { begin - (((4 boolean)) <- ((not-equal)) ((1 integer)) ((3 integer))) - (((break-if)) ((4 boolean))) - { begin - (((5 integer)) <- ((copy)) ((0 literal))) - } - } - (((reply))))) - '((((1 integer)) <- ((copy)) ((0 literal))) - (((2 integer)) <- ((copy)) ((0 literal))) - (((3 integer)) <- ((copy)) ((0 literal))) - (((4 boolean)) <- ((not-equal)) ((1 integer)) ((3 integer))) - (((jump-if)) ((4 boolean)) ((1 offset))) - (((5 integer)) <- ((copy)) ((0 literal))) - (((reply))))) - (prn "F - convert-braces balances braces when converting break")) - -(reset) -(new-trace "convert-braces-repeated-jump") -(= traces* (queue)) -;? (= dump-trace* (obj whitelist '("c{0" "c{1"))) -(when (~iso (convert-braces - '((((1 integer)) <- ((copy)) ((0 literal))) - { begin - (((break))) - (((2 integer)) <- ((copy)) ((0 literal))) - } - { begin - (((break))) - (((3 integer)) <- ((copy)) ((0 literal))) - } - (((4 integer)) <- ((copy)) ((0 literal))))) - '((((1 integer)) <- ((copy)) ((0 literal))) - (((jump)) ((1 offset))) - (((2 integer)) <- ((copy)) ((0 literal))) - (((jump)) ((1 offset))) - (((3 integer)) <- ((copy)) ((0 literal))) - (((4 integer)) <- ((copy)) ((0 literal))))) - (prn "F - convert-braces handles jumps on jumps")) -;? (quit) - -(reset) -(new-trace "convert-braces-nested-loop") -(= traces* (queue)) -(when (~iso (convert-braces - '((((1 integer)) <- ((copy)) ((0 literal))) - (((2 integer)) <- ((copy)) ((0 literal))) - { begin - (((3 integer)) <- ((copy)) ((0 literal))) - { begin - (((4 boolean)) <- ((not-equal)) ((1 integer)) ((3 integer))) - } - (((loop-if)) ((4 boolean))) - (((5 integer)) <- ((copy)) ((0 literal))) - } - (((reply))))) - '((((1 integer)) <- ((copy)) ((0 literal))) - (((2 integer)) <- ((copy)) ((0 literal))) - (((3 integer)) <- ((copy)) ((0 literal))) - (((4 boolean)) <- ((not-equal)) ((1 integer)) ((3 integer))) - (((jump-if)) ((4 boolean)) ((-3 offset))) - (((5 integer)) <- ((copy)) ((0 literal))) - (((reply))))) - (prn "F - convert-braces balances braces when converting 'loop'")) - -(reset) -(new-trace "convert-braces-label") -(= traces* (queue)) -(when (~iso (convert-braces - '((((1 integer)) <- ((copy)) ((0 literal))) - foo - (((2 integer)) <- ((copy)) ((0 literal))))) - '((((1 integer)) <- ((copy)) ((0 literal))) - foo - (((2 integer)) <- ((copy)) ((0 literal))))) - (prn "F - convert-braces skips past labels")) -;? (quit) - -(reset) -(new-trace "convert-braces-label-increments-offset") -(= traces* (queue)) -(when (~iso (convert-braces - '((((1 integer)) <- ((copy)) ((0 literal))) - { begin - (((break))) - foo - } - (((2 integer)) <- ((copy)) ((0 literal))))) - '((((1 integer)) <- ((copy)) ((0 literal))) - (((jump)) ((1 offset))) - foo - (((2 integer)) <- ((copy)) ((0 literal))))) - (prn "F - convert-braces treats labels as instructions")) -;? (quit) - -(reset) -(new-trace "convert-braces-label-increments-offset2") -(= traces* (queue)) -;? (= dump-trace* (obj whitelist '("c{0" "c{1"))) -(when (~iso (convert-braces - '((((1 integer)) <- ((copy)) ((0 literal))) - { begin - (((break))) - foo - } - (((2 integer)) <- ((copy)) ((0 literal))) - { begin - (((break))) - (((3 integer)) <- ((copy)) ((0 literal))) - } - (((4 integer)) <- ((copy)) ((0 literal))))) - '((((1 integer)) <- ((copy)) ((0 literal))) - (((jump)) ((1 offset))) - foo - (((2 integer)) <- ((copy)) ((0 literal))) - (((jump)) ((1 offset))) - (((3 integer)) <- ((copy)) ((0 literal))) - (((4 integer)) <- ((copy)) ((0 literal))))) - (prn "F - convert-braces treats labels as instructions - 2")) -;? (quit) - -(reset) -(new-trace "break-multiple") -(= traces* (queue)) -;? (= dump-trace* (obj whitelist '("-"))) -(when (~iso (convert-braces - '((((1 integer)) <- ((copy)) ((0 literal))) - { begin - { begin - (((break)) ((2 blocks))) - } - (((2 integer)) <- ((copy)) ((0 literal))) - (((3 integer)) <- ((copy)) ((0 literal))) - (((4 integer)) <- ((copy)) ((0 literal))) - (((5 integer)) <- ((copy)) ((0 literal))) - })) - '((((1 integer)) <- ((copy)) ((0 literal))) - (((jump)) ((4 offset))) - (((2 integer)) <- ((copy)) ((0 literal))) - (((3 integer)) <- ((copy)) ((0 literal))) - (((4 integer)) <- ((copy)) ((0 literal))) - (((5 integer)) <- ((copy)) ((0 literal))))) - (prn "F - 'break' can take an extra arg with number of nested blocks to exit")) -;? (quit) - -(reset) -(new-trace "loop") -;? (set dump-trace*) -(when (~iso (convert-braces - '((((1 integer)) <- ((copy)) ((0 literal))) - (((2 integer)) <- ((copy)) ((0 literal))) - { begin - (((3 integer)) <- ((copy)) ((0 literal))) - (((loop))) - })) - '((((1 integer)) <- ((copy)) ((0 literal))) - (((2 integer)) <- ((copy)) ((0 literal))) - (((3 integer)) <- ((copy)) ((0 literal))) - (((jump)) ((-2 offset))))) - (prn "F - 'loop' jumps to start of containing block")) -;? (quit) - -; todo: fuzz-test invariant: convert-braces offsets should be robust to any -; number of inner blocks inside but not around the loop block. - -(reset) -(new-trace "loop-nested") -;? (set dump-trace*) -(when (~iso (convert-braces - '((((1 integer)) <- ((copy)) ((0 literal))) - (((2 integer)) <- ((copy)) ((0 literal))) - { begin - (((3 integer)) <- ((copy)) ((0 literal))) - { begin - (((4 integer)) <- ((copy)) ((0 literal))) - } - (((loop))) - })) - '((((1 integer)) <- ((copy)) ((0 literal))) - (((2 integer)) <- ((copy)) ((0 literal))) - (((3 integer)) <- ((copy)) ((0 literal))) - (((4 integer)) <- ((copy)) ((0 literal))) - (((jump)) ((-3 offset))))) - (prn "F - 'loop' correctly jumps back past nested braces")) - -(reset) -(new-trace "loop-multiple") -(= traces* (queue)) -;? (= dump-trace* (obj whitelist '("-"))) -(when (~iso (convert-braces - '((((1 integer)) <- ((copy)) ((0 literal))) - { begin - (((2 integer)) <- ((copy)) ((0 literal))) - (((3 integer)) <- ((copy)) ((0 literal))) - { begin - (((loop)) ((2 blocks))) - } - })) - '((((1 integer)) <- ((copy)) ((0 literal))) - (((2 integer)) <- ((copy)) ((0 literal))) - (((3 integer)) <- ((copy)) ((0 literal))) - (((jump)) ((-3 offset))))) - (prn "F - 'loop' can take an extra arg with number of nested blocks to exit")) -;? (quit) - -(reset) -(new-trace "convert-labels") -(= traces* (queue)) -(when (~iso (convert-labels - '(loop - (((jump)) ((loop offset))))) - '(loop - (((jump)) ((-2 offset))))) - (prn "F - 'convert-labels' rewrites jumps to labels")) - -;; Variables -; -; A big convenience high-level languages provide is the ability to name memory -; locations. In mu, a lightweight tool called 'convert-names' provides this -; convenience. - -(reset) -(new-trace "convert-names") -(= traces* (queue)) -;? (set dump-trace*) -(when (~iso (convert-names - '((((x integer)) <- ((copy)) ((0 literal))) - (((y integer)) <- ((copy)) ((0 literal))) - (((z integer)) <- ((copy)) ((0 literal))))) - '((((1 integer)) <- ((copy)) ((0 literal))) - (((2 integer)) <- ((copy)) ((0 literal))) - (((3 integer)) <- ((copy)) ((0 literal))))) - (prn "F - convert-names renames symbolic names to integer locations")) - -(reset) -(new-trace "convert-names-compound") -(= traces* (queue)) -(when (~iso (convert-names - ; copying 0 into pair is meaningless; just for testing - '((((x integer-boolean-pair)) <- ((copy)) ((0 literal))) - (((y integer)) <- ((copy)) ((0 literal))))) - '((((1 integer-boolean-pair)) <- ((copy)) ((0 literal))) - (((3 integer)) <- ((copy)) ((0 literal))))) - (prn "F - convert-names increments integer locations by the size of the type of the previous var")) - -(reset) -(new-trace "convert-names-nil") -(= traces* (queue)) -;? (set dump-trace*) -(when (~iso (convert-names - '((((x integer)) <- ((copy)) ((0 literal))) - (((y integer)) <- ((copy)) ((0 literal))) - ; nil location is meaningless; just for testing - (((nil integer)) <- ((copy)) ((0 literal))))) - '((((1 integer)) <- ((copy)) ((0 literal))) - (((2 integer)) <- ((copy)) ((0 literal))) - (((nil integer)) <- ((copy)) ((0 literal))))) - (prn "F - convert-names never renames nil")) - -(reset) -(new-trace "convert-names-string") -;? (set dump-trace*) -(when (~iso (convert-names - '((((1 integer-address)) <- ((new)) "foo"))) - '((((1 integer-address)) <- ((new)) "foo"))) - (prn "convert-names passes through raw strings (just a convenience arg for 'new')")) - -(reset) -(new-trace "convert-names-raw") -(= traces* (queue)) -(when (~iso (convert-names - '((((x integer)) <- ((copy)) ((0 literal))) - (((y integer) (raw)) <- ((copy)) ((0 literal))))) - '((((1 integer)) <- ((copy)) ((0 literal))) - (((y integer) (raw)) <- ((copy)) ((0 literal))))) - (prn "F - convert-names never renames raw operands")) - -(reset) -(new-trace "convert-names-literal") -(= traces* (queue)) -(when (~iso (convert-names - ; meaningless; just for testing - '((((x literal)) <- ((copy)) ((0 literal))))) - '((((x literal)) <- ((copy)) ((0 literal))))) - (prn "F - convert-names never renames literals")) - -(reset) -(new-trace "convert-names-literal-2") -(= traces* (queue)) -(when (~iso (convert-names - '((((x boolean)) <- ((copy)) ((x literal))))) - '((((1 boolean)) <- ((copy)) ((x literal))))) - (prn "F - convert-names never renames literals, even when the name matches a variable")) - -; kludgy support for 'fork' below -(reset) -(new-trace "convert-names-functions") -(= traces* (queue)) -(when (~iso (convert-names - '((((x integer)) <- ((copy)) ((0 literal))) - (((y integer)) <- ((copy)) ((0 literal))) - ; meaningless; just for testing - (((z fn)) <- ((copy)) ((0 literal))))) - '((((1 integer)) <- ((copy)) ((0 literal))) - (((2 integer)) <- ((copy)) ((0 literal))) - (((z fn)) <- ((copy)) ((0 literal))))) - (prn "F - convert-names never renames fns")) - -(reset) -(new-trace "convert-names-record-fields") -(= traces* (queue)) -;? (= dump-trace* (obj whitelist '("cn0"))) -(when (~iso (convert-names - '((((x integer)) <- ((get)) ((34 integer-boolean-pair)) ((bool offset))))) - '((((1 integer)) <- ((get)) ((34 integer-boolean-pair)) ((1 offset))))) - (prn "F - convert-names replaces record field offsets")) - -(reset) -(new-trace "convert-names-record-fields-ambiguous") -(= traces* (queue)) -(when (errsafe (convert-names - '((((bool boolean)) <- ((copy)) ((t literal))) - (((x integer)) <- ((get)) ((34 integer-boolean-pair)) ((bool offset)))))) - (prn "F - convert-names doesn't allow offsets and variables with the same name in a function")) - -(reset) -(new-trace "convert-names-record-fields-ambiguous-2") -(= traces* (queue)) -(when (errsafe (convert-names - '((((x integer)) <- ((get)) ((34 integer-boolean-pair)) ((bool offset))) - (((bool boolean)) <- ((copy)) ((t literal)))))) - (prn "F - convert-names doesn't allow offsets and variables with the same name in a function - 2")) - -(reset) -(new-trace "convert-names-record-fields-indirect") -(= traces* (queue)) -;? (= dump-trace* (obj whitelist '("cn0"))) -(when (~iso (convert-names - '((((x integer)) <- ((get)) ((34 integer-boolean-pair-address) (deref)) ((bool offset))))) - '((((1 integer)) <- ((get)) ((34 integer-boolean-pair-address) (deref)) ((1 offset))))) - (prn "F - convert-names replaces field offsets for record addresses")) -;? (quit) - -(reset) -(new-trace "convert-names-record-fields-multiple") -(= traces* (queue)) -(when (~iso (convert-names - '((((2 boolean)) <- ((get)) ((1 integer-boolean-pair)) ((bool offset))) - (((3 boolean)) <- ((get)) ((1 integer-boolean-pair)) ((bool offset))))) - '((((2 boolean)) <- ((get)) ((1 integer-boolean-pair)) ((1 offset))) - (((3 boolean)) <- ((get)) ((1 integer-boolean-pair)) ((1 offset))))) - (prn "F - convert-names replaces field offsets with multiple mentions")) -;? (quit) - -(reset) -(new-trace "convert-names-label") -(= traces* (queue)) -(when (~iso (convert-names - '((((1 integer)) <- ((copy)) ((0 literal))) - foo)) - '((((1 integer)) <- ((copy)) ((0 literal))) - foo)) - (prn "F - convert-names skips past labels")) -;? (quit) - -) ; section 11 - -(section 20 - -; A rudimentary memory allocator. Eventually we want to write this in mu. -; -; No deallocation yet; let's see how much code we can build in mu before we -; feel the need for it. - -(reset) -(new-trace "new-primitive") -(add-code - '((function main [ - (1:integer-address <- new integer:literal) - ]))) -(let routine make-routine!main - (enq routine running-routines*) - (let before rep.routine!alloc -;? (set dump-trace*) - (run) -;? (prn memory*) - (when (~iso memory*.1 before) - (prn "F - 'new' returns current high-water mark")) - (when (~iso rep.routine!alloc (+ before 1)) - (prn "F - 'new' on primitive types increments high-water mark by their size")))) -;? (quit) - -(reset) -(new-trace "new-array-literal") -(add-code - '((function main [ - (1:type-array-address <- new type-array:literal 5:literal) - ]))) -(let routine make-routine!main - (enq routine running-routines*) - (let before rep.routine!alloc - (run) -;? (prn memory*) - (when (~iso memory*.1 before) - (prn "F - 'new' on array with literal size returns current high-water mark")) - (when (~iso rep.routine!alloc (+ before 6)) - (prn "F - 'new' on primitive arrays increments high-water mark by their size")))) - -(reset) -(new-trace "new-array-direct") -(add-code - '((function main [ - (1:integer <- copy 5:literal) - (2:type-array-address <- new type-array:literal 1:integer) - ]))) -(let routine make-routine!main - (enq routine running-routines*) - (let before rep.routine!alloc - (run) -;? (prn memory*) - (when (~iso memory*.2 before) - (prn "F - 'new' on array with variable size returns current high-water mark")) - (when (~iso rep.routine!alloc (+ before 6)) - (prn "F - 'new' on primitive arrays increments high-water mark by their (variable) size")))) - -(reset) -(new-trace "new-allocation-chunk") -(add-code - '((function main [ - (1:integer-address <- new integer:literal) - ]))) -; start allocating from address 30, in chunks of 10 locations each -(= Memory-allocated-until 30 - Allocation-chunk 10) -(let routine make-routine!main - (assert:is rep.routine!alloc 30) - (assert:is rep.routine!alloc-max 40) - ; pretend the current chunk is full - (= rep.routine!alloc 40) - (enq routine running-routines*) - (run) - (each routine completed-routines* - (aif rep.routine!error (prn "error - " it))) - (when (~is rep.routine!alloc 41) - (prn "F - 'new' can allocate past initial routine memory")) - (when (~is rep.routine!alloc-max 50) - (prn "F - 'new' updates upper bound for routine memory @rep.routine!alloc-max"))) - -(reset) -(new-trace "new-skip") -(add-code - '((function main [ - (1:integer-boolean-pair-address <- new integer-boolean-pair:literal) - ]))) -; start allocating from address 30, in chunks of 10 locations each -(= Memory-allocated-until 30 - Allocation-chunk 10) -(let routine make-routine!main - (assert:is rep.routine!alloc 30) - (assert:is rep.routine!alloc-max 40) - ; pretend the current chunk has just one location left - (= rep.routine!alloc 39) - (enq routine running-routines*) - ; request 2 locations - (run) - (each routine completed-routines* - (aif rep.routine!error (prn "error - " it))) - (when (or (~is memory*.1 40) - (~is rep.routine!alloc 42) - (~is rep.routine!alloc-max 50) - (~is Memory-allocated-until 50)) - (prn "F - 'new' skips past current chunk if insufficient space"))) - -(reset) -(new-trace "new-skip-noncontiguous") -(add-code - '((function main [ - (1:integer-boolean-pair-address <- new integer-boolean-pair:literal) - ]))) -; start allocating from address 30, in chunks of 10 locations each -(= Memory-allocated-until 30 - Allocation-chunk 10) -(let routine make-routine!main - (assert:is rep.routine!alloc 30) - (assert:is rep.routine!alloc-max 40) - ; pretend the current chunk has just one location left - (= rep.routine!alloc 39) - ; pretend we allocated more memory since we created the routine - (= Memory-allocated-until 90) - (enq routine running-routines*) - ; request 2 locations - (run) - (each routine completed-routines* - (aif rep.routine!error (prn "error - " it))) - (when (or (~is memory*.1 90) - (~is rep.routine!alloc 92) - (~is rep.routine!alloc-max 100) - (~is Memory-allocated-until 100)) - (prn "F - 'new' allocates a new chunk if insufficient space"))) - -(reset) -(new-trace "new-array-skip-noncontiguous") -(add-code - '((function main [ - (1:integer-array-address <- new integer-array:literal 4:literal) - ]))) -; start allocating from address 30, in chunks of 10 locations each -(= Memory-allocated-until 30 - Allocation-chunk 10) -(let routine make-routine!main - (assert:is rep.routine!alloc 30) - (assert:is rep.routine!alloc-max 40) - ; pretend the current chunk has just one location left - (= rep.routine!alloc 39) - ; pretend we allocated more memory since we created the routine - (= Memory-allocated-until 90) - (enq routine running-routines*) - ; request 4 locations - (run) - (each routine completed-routines* - (aif rep.routine!error (prn "error - " it))) -;? (prn memory*.1) ;? 1 -;? (prn rep.routine) ;? 1 -;? (prn Memory-allocated-until) ;? 1 - (when (or (~is memory*.1 90) - (~is rep.routine!alloc 95) - (~is rep.routine!alloc-max 100) - (~is Memory-allocated-until 100)) - (prn "F - 'new-array' allocates a new chunk if insufficient space"))) - -;? (quit) ;? 1 - -; Even though our memory locations can now have names, the names are all -; globals, accessible from any function. To isolate functions from their -; callers we need local variables, and mu provides them using a special -; variable called default-space. When you initialize such a variable (likely -; with a call to our just-defined memory allocator) mu interprets memory -; locations as offsets from its value. If default-space is set to 1000, for -; example, reads and writes to memory location 1 will really go to 1001. -; -; 'default-space' is itself hard-coded to be function-local; it's nil in a new -; function, and it's restored when functions return to their callers. But the -; actual space allocation is independent. So you can define closures, or do -; even more funky things like share locals between two coroutines. - -(reset) -(new-trace "set-default-space") -(add-code - '((function main [ - (default-space:space-address <- new space:literal 2:literal) - (1:integer <- copy 23:literal) - ]))) -(let routine make-routine!main - (enq routine running-routines*) - (let before rep.routine!alloc -;? (set dump-trace*) - (run) -;? (prn memory*) - (when (~and (~is 23 memory*.1) - (is 23 (memory* (+ before 2)))) - (prn "F - default-space implicitly modifies variable locations")))) -;? (quit) - -(reset) -(new-trace "set-default-space-skips-offset") -(add-code - '((function main [ - (default-space:space-address <- new space:literal 2:literal) - (1:integer <- copy 23:offset) - ]))) -(let routine make-routine!main - (enq routine running-routines*) - (let before rep.routine!alloc -;? (set dump-trace*) - (run) -;? (prn memory*) - (when (~and (~is 23 memory*.1) - (is 23 (memory* (+ before 2)))) - (prn "F - default-space skips 'offset' types just like literals")))) - -(reset) -(new-trace "default-space-bounds-check") -(add-code - '((function main [ - (default-space:space-address <- new space:literal 2:literal) - (2:integer <- copy 23:literal) - ]))) -;? (set dump-trace*) -(run 'main) -;? (prn memory*) -(let routine (car completed-routines*) - (when (no rep.routine!error) - (prn "F - default-space checks bounds"))) - -(reset) -(new-trace "default-space-and-get-indirect") -(add-code - '((function main [ - (default-space:space-address <- new space:literal 5:literal) - (1:integer-boolean-pair-address <- new integer-boolean-pair:literal) - (2:integer-address <- get-address 1:integer-boolean-pair-address/deref 0:offset) - (2:integer-address/deref <- copy 34:literal) - (3:integer/raw <- get 1:integer-boolean-pair-address/deref 0:offset) - ]))) -;? (= dump-trace* (obj blacklist '("sz" "mem" "addr" "cvt0" "cvt1"))) -(run 'main) -;? (prn memory*) -;? (prn completed-routines*) -(each routine completed-routines* - (aif rep.routine!error (prn "error - " it))) -(when (~is 34 memory*.3) - (prn "F - indirect 'get' works in the presence of default-space")) -;? (quit) - -(reset) -(new-trace "default-space-and-index-indirect") -(add-code - '((function main [ - (default-space:space-address <- new space:literal 5:literal) - (1:integer-array-address <- new integer-array:literal 4:literal) - (2:integer-address <- index-address 1:integer-array-address/deref 2:offset) - (2:integer-address/deref <- copy 34:literal) - (3:integer/raw <- index 1:integer-array-address/deref 2:offset) - ]))) -;? (= dump-trace* (obj whitelist '("run" "array-info"))) -(run 'main) -;? (prn memory*) -;? (prn completed-routines*) -(each routine completed-routines* - (aif rep.routine!error (prn "error - " it))) -(when (~is 34 memory*.3) - (prn "F - indirect 'index' works in the presence of default-space")) -;? (quit) - -(reset) -(new-trace "convert-names-default-space") -(= traces* (queue)) -(when (~iso (convert-names - '((((x integer)) <- ((copy)) ((4 literal))) - (((y integer)) <- ((copy)) ((2 literal))) - ; unsafe in general; don't write random values to 'default-space' - (((default-space integer)) <- ((add)) ((x integer)) ((y integer))))) - '((((1 integer)) <- ((copy)) ((4 literal))) - (((2 integer)) <- ((copy)) ((2 literal))) - (((default-space integer)) <- ((add)) ((1 integer)) ((2 integer))))) - (prn "F - convert-names never renames default-space")) - -(reset) -(new-trace "suppress-default-space") -(add-code - '((function main [ - (default-space:space-address <- new space:literal 2:literal) - (1:integer/raw <- copy 23:literal) - ]))) -(let routine make-routine!main - (enq routine running-routines*) - (let before rep.routine!alloc -;? (set dump-trace*) - (run) -;? (prn memory*) - (when (~and (is 23 memory*.1) - (~is 23 (memory* (+ before 1)))) - (prn "F - default-space skipped for locations with metadata 'raw'")))) -;? (quit) - -(reset) -(new-trace "array-copy-indirect-scoped") -(add-code - '((function main [ - (10:integer <- copy 30:literal) ; pretend allocation - (default-space:space-address <- copy 10:literal) ; unsafe - (1:integer <- copy 2:literal) ; raw location 12 - (2:integer <- copy 23:literal) - (3:boolean <- copy nil:literal) - (4:integer <- copy 24:literal) - (5:boolean <- copy t:literal) - (6:integer-boolean-pair-array-address <- copy 12:literal) ; unsafe - (7:integer-boolean-pair-array <- copy 6:integer-boolean-pair-array-address/deref) - ]))) -;? (set dump-trace*) -;? (= dump-trace* (obj whitelist '("run" "mem" "sizeof"))) -(run 'main) -;? (prn memory*) -(each routine completed-routines* - (aif rep.routine!error (prn "error - " it))) -(when (~iso memory*.18 2) ; variable 7 - (prn "F - indirect array copy in the presence of 'default-space'")) -;? (quit) - -(reset) -(new-trace "len-array-indirect-scoped") -(add-code - '((function main [ - (10:integer <- copy 30:literal) ; pretend allocation - (default-space:space-address <- copy 10:literal) ; unsafe - (1:integer <- copy 2:literal) ; raw location 12 - (2:integer <- copy 23:literal) - (3:boolean <- copy nil:literal) - (4:integer <- copy 24:literal) - (5:boolean <- copy t:literal) - (6:integer-address <- copy 12:literal) ; unsafe - (7:integer <- length 6:integer-boolean-pair-array-address/deref) - ]))) -;? (= dump-trace* (obj whitelist '("run" "addr" "sz" "array-len"))) -(run 'main) -;? (prn memory*) -(when (~iso memory*.18 2) - (prn "F - 'len' accesses length of array address")) -;? (quit) - -(reset) -(new-trace "default-space-shared") -(add-code - '((function init-counter [ - (default-space:space-address <- new space:literal 30:literal) - (1:integer <- copy 3:literal) ; initialize to 3 - (reply default-space:space-address) - ]) - (function increment-counter [ - (default-space:space-address <- next-input) - (1:integer <- add 1:integer 1:literal) ; increment - (reply 1:integer) - ]) - (function main [ - (1:space-address <- init-counter) - (2:integer <- increment-counter 1:space-address) - (3:integer <- increment-counter 1:space-address) - ]))) -(run 'main) -(each routine completed-routines* - (aif rep.routine!error (prn "error - " it))) -;? (prn memory*) -(when (or (~is memory*.2 4) - (~is memory*.3 5)) - (prn "F - multiple calls to a function can share locals")) -;? (quit) - -(reset) -(new-trace "default-space-closure") -(add-code - '((function init-counter [ - (default-space:space-address <- new space:literal 30:literal) - (1:integer <- copy 3:literal) ; initialize to 3 - (reply default-space:space-address) - ]) - (function increment-counter [ - (default-space:space-address <- new space:literal 30:literal) - (0:space-address <- next-input) ; share outer space - (1:integer/space:1 <- add 1:integer/space:1 1:literal) ; increment - (1:integer <- copy 34:literal) ; dummy - (reply 1:integer/space:1) - ]) - (function main [ - (1:space-address <- init-counter) - (2:integer <- increment-counter 1:space-address) - (3:integer <- increment-counter 1:space-address) - ]))) -;? (set dump-trace*) -(run 'main) -(each routine completed-routines* - (aif rep.routine!error (prn "error - " it))) -;? (prn memory*) -(when (or (~is memory*.2 4) - (~is memory*.3 5)) - (prn "F - closures using /space metadata")) -;? (quit) - -(reset) -(new-trace "default-space-closure-with-names") -(add-code - '((function init-counter [ - (default-space:space-address <- new space:literal 30:literal) - (x:integer <- copy 23:literal) - (y:integer <- copy 3:literal) ; correct copy of y - (reply default-space:space-address) - ]) - (function increment-counter [ - (default-space:space-address <- new space:literal 30:literal) - (0:space-address/names:init-counter <- next-input) ; outer space must be created by 'init-counter' above - (y:integer/space:1 <- add y:integer/space:1 1:literal) ; increment - (y:integer <- copy 34:literal) ; dummy - (reply y:integer/space:1) - ]) - (function main [ - (1:space-address/names:init-counter <- init-counter) - (2:integer <- increment-counter 1:space-address/names:init-counter) - (3:integer <- increment-counter 1:space-address/names:init-counter) - ]))) -;? (set dump-trace*) -(run 'main) -(each routine completed-routines* - (aif rep.routine!error (prn "error - " it))) -;? (prn memory*) -(when (or (~is memory*.2 4) - (~is memory*.3 5)) - (prn "F - /names to name variables in outer spaces")) -;? (quit) - -(reset) -(new-trace "default-space-shared-with-names") -(add-code - '((function f [ - (default-space:space-address <- new space:literal 30:literal) - (x:integer <- copy 3:literal) - (y:integer <- copy 4:literal) - (reply default-space:space-address) - ]) - (function g [ - (default-space:space-address/names:f <- next-input) - (y:integer <- add y:integer 1:literal) - (x:integer <- add x:integer 2:literal) - (reply x:integer y:integer) - ]) - (function main [ - (1:space-address <- f) - (2:integer 3:integer <- g 1:space-address) - ]))) -(run 'main) -(each routine completed-routines* - (aif rep.routine!error (prn "error - " it))) -(when (or (~is memory*.2 5) - (~is memory*.3 5)) - (prn "F - override names for the default space")) - -(reset) -(new-trace "default-space-shared-with-extra-names") -(add-code - '((function f [ - (default-space:space-address <- new space:literal 30:literal) - (x:integer <- copy 3:literal) - (y:integer <- copy 4:literal) - (reply default-space:space-address) - ]) - (function g [ - (default-space:space-address/names:f <- next-input) - (y:integer <- add y:integer 1:literal) - (x:integer <- add x:integer 2:literal) - (z:integer <- add x:integer y:integer) - (reply z:integer) - ]) - (function main [ - (1:space-address <- f) - (2:integer <- g 1:space-address) - ]))) -(run 'main) -(each routine completed-routines* - (aif rep.routine!error (prn "error - " it))) -(when (~is memory*.2 10) - (prn "F - shared spaces can add new names")) - -(reset) -(new-trace "default-space-shared-extra-names-dont-overlap-bindings") -(add-code - '((function f [ - (default-space:space-address <- new space:literal 30:literal) - (x:integer <- copy 3:literal) - (y:integer <- copy 4:literal) - (reply default-space:space-address) - ]) - (function g [ - (default-space:space-address/names:f <- next-input) - (y:integer <- add y:integer 1:literal) - (x:integer <- add x:integer 2:literal) - (z:integer <- copy 2:literal) - (reply x:integer y:integer) - ]) - (function main [ - (1:space-address <- f) - (2:integer 3:integer <- g 1:space-address) - ]))) -(run 'main) -(each routine completed-routines* - (aif rep.routine!error (prn "error - " it))) -;? (prn memory*) ;? 1 -(when (or (~is memory*.2 5) - (~is memory*.3 5)) - (prn "F - new names in shared spaces don't override old ones")) -;? (quit) ;? 1 - -) ; section 20 - -(section 100 - -;; Dynamic dispatch -; -; Putting it all together, here's how you define generic functions that run -; different code based on the types of their args. - -(reset) -(new-trace "dispatch-clause") -;? (set dump-trace*) -(add-code - '((function test1 [ - ; doesn't matter too much how many locals you allocate space for (here 20) - ; if it's slightly too many -- memory is plentiful - ; if it's too few -- mu will raise an error - (default-space:space-address <- new space:literal 20:literal) - (first-arg-box:tagged-value-address <- next-input) - ; if given integers, add them - { begin - (first-arg:integer match?:boolean <- maybe-coerce first-arg-box:tagged-value-address/deref integer:literal) - (break-unless match?:boolean) - (second-arg-box:tagged-value-address <- next-input) - (second-arg:integer <- maybe-coerce second-arg-box:tagged-value-address/deref integer:literal) - (result:integer <- add first-arg:integer second-arg:integer) - (reply result:integer) - } - (reply nil:literal) - ]) - (function main [ - (1:tagged-value-address <- init-tagged-value integer:literal 34:literal) - (2:tagged-value-address <- init-tagged-value integer:literal 3:literal) - (3:integer <- test1 1:tagged-value-address 2:tagged-value-address) - ]))) -(run 'main) -;? (prn memory*) -(when (~is memory*.3 37) - (prn "F - an example function that checks that its oarg is an integer")) -;? (quit) - -(reset) -(new-trace "dispatch-multiple-clauses") -;? (set dump-trace*) -(add-code - '((function test1 [ - (default-space:space-address <- new space:literal 20:literal) - (first-arg-box:tagged-value-address <- next-input) - ; if given integers, add them - { begin - (first-arg:integer match?:boolean <- maybe-coerce first-arg-box:tagged-value-address/deref integer:literal) - (break-unless match?:boolean) - (second-arg-box:tagged-value-address <- next-input) - (second-arg:integer <- maybe-coerce second-arg-box:tagged-value-address/deref integer:literal) - (result:integer <- add first-arg:integer second-arg:integer) - (reply result:integer) - } - ; if given booleans, or them (it's a silly kind of generic function) - { begin - (first-arg:boolean match?:boolean <- maybe-coerce first-arg-box:tagged-value-address/deref boolean:literal) - (break-unless match?:boolean) - (second-arg-box:tagged-value-address <- next-input) - (second-arg:boolean <- maybe-coerce second-arg-box:tagged-value-address/deref boolean:literal) - (result:boolean <- or first-arg:boolean second-arg:boolean) - (reply result:integer) - } - (reply nil:literal) - ]) - (function main [ - (1:tagged-value-address <- init-tagged-value boolean:literal t:literal) - (2:tagged-value-address <- init-tagged-value boolean:literal nil:literal) - (3:boolean <- test1 1:tagged-value-address 2:tagged-value-address) - ]))) -;? (each stmt function*!test-fn -;? (prn " " stmt)) -(run 'main) -;? (wipe dump-trace*) -;? (prn memory*) -(when (~is memory*.3 t) - (prn "F - an example function that can do different things (dispatch) based on the type of its args or oargs")) -;? (quit) - -(reset) -(new-trace "dispatch-multiple-calls") -(add-code - '((function test1 [ - (default-space:space-address <- new space:literal 20:literal) - (first-arg-box:tagged-value-address <- next-input) - ; if given integers, add them - { begin - (first-arg:integer match?:boolean <- maybe-coerce first-arg-box:tagged-value-address/deref integer:literal) - (break-unless match?:boolean) - (second-arg-box:tagged-value-address <- next-input) - (second-arg:integer <- maybe-coerce second-arg-box:tagged-value-address/deref integer:literal) - (result:integer <- add first-arg:integer second-arg:integer) - (reply result:integer) - } - ; if given booleans, or them (it's a silly kind of generic function) - { begin - (first-arg:boolean match?:boolean <- maybe-coerce first-arg-box:tagged-value-address/deref boolean:literal) - (break-unless match?:boolean) - (second-arg-box:tagged-value-address <- next-input) - (second-arg:boolean <- maybe-coerce second-arg-box:tagged-value-address/deref boolean:literal) - (result:boolean <- or first-arg:boolean second-arg:boolean) - (reply result:integer) - } - (reply nil:literal) - ]) - (function main [ - (1:tagged-value-address <- init-tagged-value boolean:literal t:literal) - (2:tagged-value-address <- init-tagged-value boolean:literal nil:literal) - (3:boolean <- test1 1:tagged-value-address 2:tagged-value-address) - (10:tagged-value-address <- init-tagged-value integer:literal 34:literal) - (11:tagged-value-address <- init-tagged-value integer:literal 3:literal) - (12:integer <- test1 10:tagged-value-address 11:tagged-value-address) - ]))) -(run 'main) -;? (prn memory*) -(when (~and (is memory*.3 t) (is memory*.12 37)) - (prn "F - different calls can exercise different clauses of the same function")) - -; We can also dispatch based on the type of the operands or results at the -; caller. - -(reset) -(new-trace "dispatch-otype") -(add-code - '((function test1 [ - (4:type <- otype 0:offset) - { begin - (5:boolean <- equal 4:type integer:literal) - (break-unless 5:boolean) - (6:integer <- next-input) - (7:integer <- next-input) - (8:integer <- add 6:integer 7:integer) - } - (reply 8:integer) - ]) - (function main [ - (1:integer <- test1 1:literal 3:literal) - ]))) -(run 'main) -;? (prn memory*) -(when (~iso memory*.1 4) - (prn "F - an example function that checks that its oarg is an integer")) -;? (quit) - -(reset) -(new-trace "dispatch-otype-multiple-clauses") -;? (set dump-trace*) -(add-code - '((function test1 [ - (4:type <- otype 0:offset) - { begin - ; integer needed? add args - (5:boolean <- equal 4:type integer:literal) - (break-unless 5:boolean) - (6:integer <- next-input) - (7:integer <- next-input) - (8:integer <- add 6:integer 7:integer) - (reply 8:integer) - } - { begin - ; boolean needed? 'or' args - (5:boolean <- equal 4:type boolean:literal) - (break-unless 5:boolean 4:offset) - (6:boolean <- next-input) - (7:boolean <- next-input) - (8:boolean <- or 6:boolean 7:boolean) - (reply 8:boolean) - }]) - (function main [ - (1:boolean <- test1 t:literal t:literal) - ]))) -;? (each stmt function*!test1 -;? (prn " " stmt)) -(run 'main) -;? (wipe dump-trace*) -;? (prn memory*) -(when (~is memory*.1 t) - (prn "F - an example function that can do different things (dispatch) based on the type of its args or oargs")) -;? (quit) - -(reset) -(new-trace "dispatch-otype-multiple-calls") -(add-code - '((function test1 [ - (4:type <- otype 0:offset) - { begin - (5:boolean <- equal 4:type integer:literal) - (break-unless 5:boolean) - (6:integer <- next-input) - (7:integer <- next-input) - (8:integer <- add 6:integer 7:integer) - (reply 8:integer) - } - { begin - (5:boolean <- equal 4:type boolean:literal) - (break-unless 5:boolean) - (6:boolean <- next-input) - (7:boolean <- next-input) - (8:boolean <- or 6:boolean 7:boolean) - (reply 8:boolean) - }]) - (function main [ - (1:boolean <- test1 t:literal t:literal) - (2:integer <- test1 3:literal 4:literal) - ]))) -(run 'main) -;? (prn memory*) -(when (~and (is memory*.1 t) (is memory*.2 7)) - (prn "F - different calls can exercise different clauses of the same function")) - -) ; section 100 - -(section 20 - -;; Concurrency -; -; A rudimentary process scheduler. You can 'run' multiple functions at once, -; and they share the virtual processor. -; -; There's also a 'fork' primitive to let functions create new threads of -; execution (we call them routines). -; -; Eventually we want to allow callers to influence how much of their CPU they -; give to their 'children', or to rescind a child's running privileges. - -(reset) -(new-trace "scheduler") -(= traces* (queue)) -(add-code - '((function f1 [ - (1:integer <- copy 3:literal) - ]) - (function f2 [ - (2:integer <- copy 4:literal) - ]))) -(run 'f1 'f2) -(when (~iso 2 curr-cycle*) - (prn "F - scheduler didn't run the right number of instructions: " curr-cycle*)) -(when (~iso memory* (obj 1 3 2 4)) - (prn "F - scheduler runs multiple functions: " memory*)) -(check-trace-contents "scheduler orders functions correctly" - '(("schedule" "f1") - ("schedule" "f2") - )) -(check-trace-contents "scheduler orders schedule and run events correctly" - '(("schedule" "f1") - ("run" "f1 0") - ("schedule" "f2") - ("run" "f2 0") - )) - -(reset) -(new-trace "scheduler-alternate") -(= traces* (queue)) -(add-code - '((function f1 [ - (1:integer <- copy 0:literal) - (1:integer <- copy 0:literal) - ]) - (function f2 [ - (2:integer <- copy 0:literal) - (2:integer <- copy 0:literal) - ]))) -;? (= dump-trace* (obj whitelist '("schedule"))) -(= scheduling-interval* 1) -(run 'f1 'f2) -(check-trace-contents "scheduler alternates between routines" - '(("run" "f1 0") - ("run" "f2 0") - ("run" "f1 1") - ("run" "f2 1") - )) - -(reset) -(new-trace "scheduler-sleep") -(= traces* (queue)) -(add-code - '((function f1 [ - (1:integer <- copy 0:literal) - ]) - (function f2 [ - (2:integer <- copy 0:literal) - ]))) -; add one baseline routine to run (empty running-routines* handled below) -(enq make-routine!f1 running-routines*) -(assert (is 1 len.running-routines*)) -; sleeping routine -(let routine make-routine!f2 - (= rep.routine!sleep '(until 23)) - (set sleeping-routines*.routine)) -; not yet time for it to wake up -(= curr-cycle* 23) -;? (set dump-trace*) -;? (= dump-trace* (obj whitelist '("run" "schedule"))) -(update-scheduler-state) -(when (~is 1 len.running-routines*) - (prn "F - scheduler lets routines sleep")) - -(reset) -(new-trace "scheduler-wakeup") -(= traces* (queue)) -(add-code - '((function f1 [ - (1:integer <- copy 0:literal) - ]) - (function f2 [ - (2:integer <- copy 0:literal) - ]))) -; add one baseline routine to run (empty running-routines* handled below) -(enq make-routine!f1 running-routines*) -(assert (is 1 len.running-routines*)) -; sleeping routine -(let routine make-routine!f2 - (= rep.routine!sleep '(until 23)) - (set sleeping-routines*.routine)) -; time for it to wake up -(= curr-cycle* 24) -(update-scheduler-state) -(when (~is 2 len.running-routines*) - (prn "F - scheduler wakes up sleeping routines at the right time")) - -(reset) -(new-trace "scheduler-sleep-location") -(= traces* (queue)) -(add-code - '((function f1 [ - (1:integer <- copy 0:literal) - ]) - (function f2 [ - (2:integer <- copy 0:literal) - ]))) -; add one baseline routine to run (empty running-routines* handled below) -(enq make-routine!f1 running-routines*) -(assert (is 1 len.running-routines*)) -; blocked routine waiting for location 23 to change -(let routine make-routine!f2 - (= rep.routine!sleep '(until-location-changes 23 0)) - (set sleeping-routines*.routine)) -; leave memory location 23 unchanged -(= memory*.23 0) -;? (prn memory*) -;? (prn running-routines*) -;? (prn sleeping-routines*) -;? (set dump-trace*) -;? (= dump-trace* (obj whitelist '("run" "schedule"))) -(update-scheduler-state) -;? (prn running-routines*) -;? (prn sleeping-routines*) -; routine remains blocked -(when (~is 1 len.running-routines*) - (prn "F - scheduler lets routines block on locations")) -;? (quit) - -(reset) -(new-trace "scheduler-wakeup-location") -(= traces* (queue)) -(add-code - '((function f1 [ - (1:integer <- copy 0:literal) - ]) - (function f2 [ - (2:integer <- copy 0:literal) - ]))) -; add one baseline routine to run (empty running-routines* handled below) -(enq make-routine!f1 running-routines*) -(assert (is 1 len.running-routines*)) -; blocked routine waiting for location 23 to change -(let routine make-routine!f2 - (= rep.routine!sleep '(until-location-changes 23 0)) - (set sleeping-routines*.routine)) -; change memory location 23 -(= memory*.23 1) -(update-scheduler-state) -; routine unblocked -(when (~is 2 len.running-routines*) - (prn "F - scheduler unblocks routines blocked on locations")) - -(reset) -(new-trace "scheduler-skip") -(= traces* (queue)) -(add-code - '((function f1 [ - (1:integer <- copy 0:literal) - ]))) -; running-routines* is empty -(assert (empty running-routines*)) -; sleeping routine -(let routine make-routine!f1 - (= rep.routine!sleep '(until 34)) - (set sleeping-routines*.routine)) -; long time left for it to wake up -(= curr-cycle* 0) -(update-scheduler-state) -;? (prn curr-cycle*) -(assert (is curr-cycle* 35)) -(when (~is 1 len.running-routines*) - (prn "F - scheduler skips ahead to earliest sleeping routines when nothing to run")) - -(reset) -(new-trace "scheduler-deadlock") -(= traces* (queue)) -(add-code - '((function f1 [ - (1:integer <- copy 0:literal) - ]))) -(assert (empty running-routines*)) -(assert (empty completed-routines*)) -; blocked routine -(let routine make-routine!f1 - (= rep.routine!sleep '(until-location-changes 23 0)) - (set sleeping-routines*.routine)) -; location it's waiting on is 'unchanged' -(= memory*.23 0) -(update-scheduler-state) -(assert (~empty completed-routines*)) -;? (prn completed-routines*) -(let routine completed-routines*.0 - (when (~posmatch "deadlock" rep.routine!error) - (prn "F - scheduler detects deadlock"))) -;? (quit) - -(reset) -(new-trace "scheduler-deadlock2") -(= traces* (queue)) -(add-code - '((function f1 [ - (1:integer <- copy 0:literal) - ]))) -; running-routines* is empty -(assert (empty running-routines*)) -; blocked routine -(let routine make-routine!f1 - (= rep.routine!sleep '(until-location-changes 23 0)) - (set sleeping-routines*.routine)) -; but is about to become ready -(= memory*.23 1) -(update-scheduler-state) -(when (~empty completed-routines*) - (prn "F - scheduler ignores sleeping but ready threads when detecting deadlock")) - -; Helper routines are just to sidestep the deadlock test; they stop running -; when there's no non-helper routines left to run. -; -; Be careful not to overuse them. In particular, the component under test -; should never run in a helper routine; that'll make interrupting and -; restarting it very brittle. -(reset) -(new-trace "scheduler-helper") -(= traces* (queue)) -(add-code - '((function f1 [ - (1:integer <- copy 0:literal) - ]))) -; just a helper routine -(= routine* make-routine!f1) -(set rep.routine*!helper) -;? (= dump-trace* (obj whitelist '("schedule"))) -(update-scheduler-state) -(when (or (~empty running-routines*) (~empty sleeping-routines*)) - (prn "F - scheduler stops when there's only helper routines left")) - -(reset) -(new-trace "scheduler-helper-sleeping") -(= traces* (queue)) -(add-code - '((function f1 [ - (1:integer <- copy 0:literal) - ]))) -; just a helper routine -(let routine make-routine!f1 - (set rep.routine!helper) - (= rep.routine!sleep '(until-location-changes 23 nil)) - (set sleeping-routines*.routine)) -;? (= dump-trace* (obj whitelist '("schedule"))) -;? (prn "1 " running-routines*) -;? (prn sleeping-routines*) -(update-scheduler-state) -;? (prn "2 " running-routines*) -;? (prn sleeping-routines*) -(when (or (~empty running-routines*) (~empty sleeping-routines*)) - (prn "F - scheduler stops when there's only sleeping helper routines left")) - -(reset) -(new-trace "scheduler-termination") -(= traces* (queue)) -(add-code - '((function f1 [ - (1:integer <- copy 0:literal) - ]))) -; all routines done -(update-scheduler-state) -(check-trace-doesnt-contain "scheduler helper check shouldn't trigger unless necessary" - '(("schedule" "just helpers left"))) - -; both running and sleeping helpers -; running helper and sleeping non-helper -; sleeping helper and running non-helper - -(reset) -(new-trace "scheduler-account-slice") -; function running an infinite loop -(add-code - '((function f1 [ - { begin - (1:integer <- copy 0:literal) - (loop) - } - ]))) -(let routine make-routine!f1 - (= rep.routine!limit 10) - (enq routine running-routines*)) -(= scheduling-interval* 20) -(run) -(when (or (empty completed-routines*) - (~is -10 ((rep completed-routines*.0) 'limit))) - (prn "F - when given a low cycle limit, a routine runs to end of time slice")) - -(reset) -(new-trace "scheduler-account-slice-multiple") -; function running an infinite loop -(add-code - '((function f1 [ - { begin - (1:integer <- copy 0:literal) - (loop) - } - ]))) -(let routine make-routine!f1 - (= rep.routine!limit 100) - (enq routine running-routines*)) -(= scheduling-interval* 20) -(run) -(when (or (empty completed-routines*) - (~is -0 ((rep completed-routines*.0) 'limit))) - (prn "F - when given a high limit, a routine successfully stops after multiple time slices")) - -(reset) -(new-trace "scheduler-account-run-while-asleep") -(add-code - ; f1 needs 4 cycles of sleep time, 4 cycles of work - '((function f1 [ - (sleep for-some-cycles:literal 4:literal) - (i:integer <- copy 0:literal) - (i:integer <- copy 0:literal) - (i:integer <- copy 0:literal) - (i:integer <- copy 0:literal) - ]))) -(let routine make-routine!f1 - (= rep.routine!limit 6) ; enough time excluding sleep - (enq routine running-routines*)) -(= scheduling-interval* 1) -;? (= dump-trace* (obj whitelist '("schedule"))) -(run) -; if time slept counts against limit, routine doesn't have time to complete -(when (ran-to-completion 'f1) - (prn "F - time slept counts against a routine's cycle limit")) -;? (quit) - -(reset) -(new-trace "scheduler-account-stop-on-preempt") -(add-code - '((function baseline [ - (i:integer <- copy 0:literal) - { begin - (done?:boolean <- greater-or-equal i:integer 10:literal) - (break-if done?:boolean) - (1:integer <- add i:integer 1:literal) - (loop) - } - ]) - (function f1 [ - (i:integer <- copy 0:literal) - { begin - (done?:boolean <- greater-or-equal i:integer 6:literal) - (break-if done?:boolean) - (1:integer <- add i:integer 1:literal) - (loop) - } - ]))) -(let routine make-routine!baseline - (enq routine running-routines*)) -; now add the routine we care about -(let routine make-routine!f1 - (= rep.routine!limit 40) ; less than 2x time f1 needs to complete - (enq routine running-routines*)) -(= scheduling-interval* 1) -; if baseline's time were to count against f1's limit, it wouldn't be able to -; complete. -(when (~ran-to-completion 'f1) - (prn "F - preempted time doesn't count against a routine's limit")) -;? (quit) - -(reset) -(new-trace "scheduler-sleep-timeout") -(add-code - '((function baseline [ - (i:integer <- copy 0:literal) - { begin - (done?:boolean <- greater-or-equal i:integer 10:literal) - (break-if done?:boolean) - (1:integer <- add i:integer 1:literal) - (loop) - } - ]) - (function f1 [ - (sleep for-some-cycles:literal 10:literal) ; less time than baseline would take to run - ]))) -; add baseline routine to prevent cycle-skipping -(let routine make-routine!baseline - (enq routine running-routines*)) -; now add the routine we care about -(let routine make-routine!f1 - (= rep.routine!limit 4) ; less time than f1 would take to run - (enq routine running-routines*)) -(= scheduling-interval* 1) -;? (= dump-trace* (obj whitelist '("schedule"))) -(run) -(when (ran-to-completion 'f1) - (prn "F - sleeping routines can time out")) -;? (quit) - -(reset) -(new-trace "sleep") -(add-code - '((function f1 [ - (sleep for-some-cycles:literal 1:literal) - (1:integer <- copy 0:literal) - (1:integer <- copy 0:literal) - ]) - (function f2 [ - (2:integer <- copy 0:literal) - (2:integer <- copy 0:literal) - ]))) -;? (= dump-trace* (obj whitelist '("run" "schedule"))) -(run 'f1 'f2) -(check-trace-contents "scheduler handles sleeping routines" - '(("run" "f1 0") - ("run" "sleeping until 2") - ("schedule" "pushing f1 to sleep queue") - ("run" "f2 0") - ("run" "f2 1") - ("schedule" "waking up f1") - ("run" "f1 1") - ("run" "f1 2") - )) - -(reset) -(new-trace "sleep-long") -(add-code - '((function f1 [ - (sleep for-some-cycles:literal 20:literal) - (1:integer <- copy 0:literal) - (1:integer <- copy 0:literal) - ]) - (function f2 [ - (2:integer <- copy 0:literal) - (2:integer <- copy 0:literal) - ]))) -;? (= dump-trace* (obj whitelist '("run" "schedule"))) -(run 'f1 'f2) -(check-trace-contents "scheduler progresses sleeping routines when there are no routines left to run" - '(("run" "f1 0") - ("run" "sleeping until 21") - ("schedule" "pushing f1 to sleep queue") - ("run" "f2 0") - ("run" "f2 1") - ("schedule" "waking up f1") - ("run" "f1 1") - ("run" "f1 2") - )) - -(reset) -(new-trace "sleep-location") -(add-code - '((function f1 [ - ; waits for memory location 1 to be set, before computing its successor - (1:integer <- copy 0:literal) - (sleep until-location-changes:literal 1:integer) - (2:integer <- add 1:integer 1:literal) - ]) - (function f2 [ - (sleep for-some-cycles:literal 30:literal) - (1:integer <- copy 3:literal) ; set to value - ]))) -;? (= dump-trace* (obj whitelist '("run" "schedule"))) -;? (set dump-trace*) -(run 'f1 'f2) -;? (prn int-canon.memory*) -(each routine completed-routines* - (aif rep.routine!error (prn "error - " it))) -(when (~is memory*.2 4) ; successor of value - (prn "F - sleep can block on a memory location")) -;? (quit) - -(reset) -(new-trace "sleep-scoped-location") -(add-code - '((function f1 [ - ; waits for memory location 1 to be changed, before computing its successor - (10:integer <- copy 5:literal) ; array of locals - (default-space:space-address <- copy 10:literal) - (1:integer <- copy 23:literal) ; really location 12 - (sleep until-location-changes:literal 1:integer) - (2:integer <- add 1:integer 1:literal) - ]) - (function f2 [ - (sleep for-some-cycles:literal 30:literal) - (12:integer <- copy 3:literal) ; set to value - ]))) -;? (= dump-trace* (obj whitelist '("run" "schedule"))) -(run 'f1 'f2) -(when (~is memory*.13 4) ; successor of value - (prn "F - sleep can block on a scoped memory location")) -;? (quit) - -(reset) -(new-trace "fork") -(add-code - '((function f1 [ - (1:integer <- copy 4:literal) - ]) - (function main [ - (fork f1:fn) - ]))) -(run 'main) -(when (~iso memory*.1 4) - (prn "F - fork works")) - -(reset) -(new-trace "fork-returns-id") -(add-code - '((function f1 [ - (1:integer <- copy 4:literal) - ]) - (function main [ - (2:integer <- fork f1:fn) - ]))) -(run 'main) -;? (prn memory*) -(when (no memory*.2) - (prn "F - fork returns a pid for the new routine")) - -(reset) -(new-trace "fork-returns-unique-id") -(add-code - '((function f1 [ - (1:integer <- copy 4:literal) - ]) - (function main [ - (2:integer <- fork f1:fn) - (3:integer <- fork f1:fn) - ]))) -(run 'main) -(when (or (no memory*.2) - (no memory*.3) - (is memory*.2 memory*.3)) - (prn "F - fork returns a unique pid everytime")) - -(reset) -(new-trace "fork-with-args") -(add-code - '((function f1 [ - (2:integer <- next-input) - ]) - (function main [ - (fork f1:fn nil:literal/globals nil:literal/limit 4:literal) - ]))) -(run 'main) -(when (~iso memory*.2 4) - (prn "F - fork can pass args")) - -(reset) -(new-trace "fork-copies-args") -(add-code - '((function f1 [ - (2:integer <- next-input) - ]) - (function main [ - (default-space:space-address <- new space:literal 5:literal) - (x:integer <- copy 4:literal) - (fork f1:fn nil:literal/globals nil:literal/limit x:integer) - (x:integer <- copy 0:literal) ; should be ignored - ]))) -(run 'main) -(when (~iso memory*.2 4) - (prn "F - fork passes args by value")) - -(reset) -(new-trace "fork-global") -(add-code - '((function f1 [ - (1:integer/raw <- copy 2:integer/space:global) - ]) - (function main [ - (default-space:space-address <- new space:literal 5:literal) - (2:integer <- copy 4:literal) - (fork f1:fn default-space:space-address/globals nil:literal/limit) - ]))) -(run 'main) -(each routine completed-routines* - (awhen rep.routine!error (prn "error - " it))) -(when (~iso memory*.1 4) - (prn "F - fork can take a space of global variables to access")) - -(reset) -(new-trace "fork-limit") -(add-code - '((function f1 [ - { begin - (loop) - } - ]) - (function main [ - (fork f1:fn nil:literal/globals 30:literal/limit) - ]))) -(= scheduling-interval* 5) -(run 'main) -(each routine completed-routines* - (awhen rep.routine!error (prn "error - " it))) -(when (ran-to-completion 'f1) - (prn "F - fork can specify a maximum cycle limit")) - -(reset) -(new-trace "fork-then-wait") -(add-code - '((function f1 [ - { begin - (loop) - } - ]) - (function main [ - (1:integer/routine-id <- fork f1:fn nil:literal/globals 30:literal/limit) - (sleep until-routine-done:literal 1:integer/routine-id) - (2:integer <- copy 34:literal) - ]))) -(= scheduling-interval* 5) -;? (= dump-trace* (obj whitelist '("schedule"))) -(run 'main) -(each routine completed-routines* - (awhen rep.routine!error (prn "error - " it))) -(check-trace-contents "scheduler orders functions correctly" - '(("schedule" "pushing main to sleep queue") - ("schedule" "scheduling f1") - ("schedule" "ran out of time") - ("schedule" "waking up main") - )) -;? (quit) - -; todo: Haven't yet written several tests -; that restarting a routine works -; when it died -; when it timed out -; when it completed -; running multiple routines in tandem -; first example using these features: read-move-incomplete in chessboard-cursor.arc.t - -; The scheduler needs to keep track of the call stack for each routine. -; Eventually we'll want to save this information in mu's address space itself, -; along with the types array, the magic buffers for args and oargs, and so on. -; -; Eventually we want the right stack-management primitives to build delimited -; continuations in mu. - -; Routines can throw errors. -(reset) -(new-trace "array-bounds-check") -(add-code - '((function main [ - (1:integer <- copy 2:literal) - (2:integer <- copy 23:literal) - (3:integer <- copy 24:literal) - (4:integer <- index 1:integer-array 2:literal) - ]))) -;? (set dump-trace*) -(run 'main) -;? (prn memory*) -(let routine (car completed-routines*) - (when (no rep.routine!error) - (prn "F - 'index' throws an error if out of bounds"))) - -) ; section 20 - -(section 100 - -;; Synchronization -; -; Mu synchronizes using channels rather than locks, like Erlang and Go. -; -; The two ends of a channel will usually belong to different routines, but -; each end should only be used by a single one. Don't try to read from or -; write to it from multiple routines at once. -; -; To avoid locking, writer and reader will never write to the same location. -; So channels will include fields in pairs, one for the writer and one for the -; reader. - -; The core circular buffer contains values at index 'first-full' up to (but -; not including) index 'first-empty'. The reader always modifies it at -; first-full, while the writer always modifies it at first-empty. -(reset) -(new-trace "channel-new") -(add-code - '((function main [ - (1:channel-address <- init-channel 3:literal) - (2:integer <- get 1:channel-address/deref first-full:offset) - (3:integer <- get 1:channel-address/deref first-free:offset) - ]))) -;? (set dump-trace*) -(run 'main) -;? (prn memory*) -(when (or (~is 0 memory*.2) - (~is 0 memory*.3)) - (prn "F - 'init-channel' initializes 'first-full and 'first-free to 0")) - -(reset) -(new-trace "channel-write") -(add-code - '((function main [ - (1:channel-address <- init-channel 3:literal) - (2:integer <- copy 34:literal) - (3:tagged-value <- save-type 2:integer) - (1:channel-address/deref <- write 1:channel-address 3:tagged-value) - (5:integer <- get 1:channel-address/deref first-full:offset) - (6:integer <- get 1:channel-address/deref first-free:offset) - ]))) -;? (prn function*!write) -;? (set dump-trace*) -;? (= dump-trace* (obj blacklist '("sz" "mem" "addr" "array-len" "cvt0" "cvt1"))) -;? (= dump-trace* (obj whitelist '("jump"))) -;? (= dump-trace* (obj whitelist '("run" "reply"))) -(run 'main) -(each routine completed-routines* - (aif rep.routine!error (prn "error - " it))) -;? (prn canon.memory*) -(when (or (~is 0 memory*.5) - (~is 1 memory*.6)) - (prn "F - 'write' enqueues item to channel")) -;? (quit) - -(reset) -(new-trace "channel-read") -(add-code - '((function main [ - (1:channel-address <- init-channel 3:literal) - (2:integer <- copy 34:literal) - (3:tagged-value <- save-type 2:integer) - (1:channel-address/deref <- write 1:channel-address 3:tagged-value) - (5:tagged-value 1:channel-address/deref <- read 1:channel-address) - (7:integer <- maybe-coerce 5:tagged-value integer:literal) - (8:integer <- get 1:channel-address/deref first-full:offset) - (9:integer <- get 1:channel-address/deref first-free:offset) - ]))) -;? (set dump-trace*) -;? (= dump-trace* (obj blacklist '("sz" "mem" "addr" "array-len" "cvt0" "cvt1"))) -(run 'main) -;? (prn int-canon.memory*) -(when (~is memory*.7 34) - (prn "F - 'read' returns written value")) -(when (or (~is 1 memory*.8) - (~is 1 memory*.9)) - (prn "F - 'read' dequeues item from channel")) - -(reset) -(new-trace "channel-write-wrap") -(add-code - '((function main [ - ; channel with 1 slot - (1:channel-address <- init-channel 1:literal) - ; write a value - (2:integer <- copy 34:literal) - (3:tagged-value <- save-type 2:integer) - (1:channel-address/deref <- write 1:channel-address 3:tagged-value) - ; first-free will now be 1 - (5:integer <- get 1:channel-address/deref first-free:offset) - ; read one value - (_ 1:channel-address/deref <- read 1:channel-address) - ; write a second value; verify that first-free wraps around to 0. - (1:channel-address/deref <- write 1:channel-address 3:tagged-value) - (6:integer <- get 1:channel-address/deref first-free:offset) - ]))) -;? (set dump-trace*) -;? (= dump-trace* (obj blacklist '("sz" "mem" "addr" "array-len" "cvt0" "cvt1"))) -(run 'main) -;? (prn canon.memory*) -(when (or (~is 1 memory*.5) - (~is 0 memory*.6)) - (prn "F - 'write' can wrap pointer back to start")) - -(reset) -(new-trace "channel-read-wrap") -(add-code - '((function main [ - ; channel with 1 slot - (1:channel-address <- init-channel 1:literal) - ; write a value - (2:integer <- copy 34:literal) - (3:tagged-value <- save-type 2:integer) - (1:channel-address/deref <- write 1:channel-address 3:tagged-value) - ; read one value - (_ 1:channel-address/deref <- read 1:channel-address) - ; first-full will now be 1 - (5:integer <- get 1:channel-address/deref first-full:offset) - ; write a second value - (1:channel-address/deref <- write 1:channel-address 3:tagged-value) - ; read second value; verify that first-full wraps around to 0. - (_ 1:channel-address/deref <- read 1:channel-address) - (6:integer <- get 1:channel-address/deref first-full:offset) - ]))) -;? (set dump-trace*) -;? (= dump-trace* (obj blacklist '("sz" "mem" "addr" "array-len" "cvt0" "cvt1"))) -(run 'main) -;? (prn canon.memory*) -(when (or (~is 1 memory*.5) - (~is 0 memory*.6)) - (prn "F - 'read' can wrap pointer back to start")) - -(reset) -(new-trace "channel-new-empty-not-full") -(add-code - '((function main [ - (1:channel-address <- init-channel 3:literal) - (2:boolean <- empty? 1:channel-address/deref) - (3:boolean <- full? 1:channel-address/deref) - ]))) -;? (set dump-trace*) -(run 'main) -;? (prn memory*) -(when (or (~is t memory*.2) - (~is nil memory*.3)) - (prn "F - a new channel is always empty, never full")) - -(reset) -(new-trace "channel-write-not-empty") -(add-code - '((function main [ - (1:channel-address <- init-channel 3:literal) - (2:integer <- copy 34:literal) - (3:tagged-value <- save-type 2:integer) - (1:channel-address/deref <- write 1:channel-address 3:tagged-value) - (5:boolean <- empty? 1:channel-address/deref) - (6:boolean <- full? 1:channel-address/deref) - ]))) -;? (set dump-trace*) -(run 'main) -;? (prn memory*) -(when (or (~is nil memory*.5) - (~is nil memory*.6)) - (prn "F - a channel after writing is never empty")) - -(reset) -(new-trace "channel-write-full") -(add-code - '((function main [ - (1:channel-address <- init-channel 1:literal) - (2:integer <- copy 34:literal) - (3:tagged-value <- save-type 2:integer) - (1:channel-address/deref <- write 1:channel-address 3:tagged-value) - (5:boolean <- empty? 1:channel-address/deref) - (6:boolean <- full? 1:channel-address/deref) - ]))) -;? (set dump-trace*) -(run 'main) -;? (prn memory*) -(when (or (~is nil memory*.5) - (~is t memory*.6)) - (prn "F - a channel after writing may be full")) - -(reset) -(new-trace "channel-read-not-full") -(add-code - '((function main [ - (1:channel-address <- init-channel 3:literal) - (2:integer <- copy 34:literal) - (3:tagged-value <- save-type 2:integer) - (1:channel-address/deref <- write 1:channel-address 3:tagged-value) - (1:channel-address/deref <- write 1:channel-address 3:tagged-value) - (_ 1:channel-address/deref <- read 1:channel-address) - (5:boolean <- empty? 1:channel-address/deref) - (6:boolean <- full? 1:channel-address/deref) - ]))) -;? (set dump-trace*) -(run 'main) -;? (prn memory*) -(when (or (~is nil memory*.5) - (~is nil memory*.6)) - (prn "F - a channel after reading is never full")) - -(reset) -(new-trace "channel-read-empty") -(add-code - '((function main [ - (1:channel-address <- init-channel 3:literal) - (2:integer <- copy 34:literal) - (3:tagged-value <- save-type 2:integer) - (1:channel-address/deref <- write 1:channel-address 3:tagged-value) - (_ 1:channel-address/deref <- read 1:channel-address) - (5:boolean <- empty? 1:channel-address/deref) - (6:boolean <- full? 1:channel-address/deref) - ]))) -;? (set dump-trace*) -(run 'main) -;? (prn memory*) -(when (or (~is t memory*.5) - (~is nil memory*.6)) - (prn "F - a channel after reading may be empty")) - -; The key property of channels; writing to a full channel blocks the current -; routine until it creates space. Ditto reading from an empty channel. - -(reset) -(new-trace "channel-read-block") -(add-code - '((function main [ - (1:channel-address <- init-channel 3:literal) - ; channel is empty, but receives a read - (2:tagged-value 1:channel-address/deref <- read 1:channel-address) - ]))) -;? (set dump-trace*) -;? (= dump-trace* (obj whitelist '("run" "schedule"))) -(run 'main) -;? (prn int-canon.memory*) -;? (prn sleeping-routines*) -;? (prn completed-routines*) -; read should cause the routine to sleep, and -; the sole sleeping routine should trigger the deadlock detector -(let routine (car completed-routines*) - (when (or (no routine) - (no rep.routine!error) - (~posmatch "deadlock" rep.routine!error)) - (prn "F - 'read' on empty channel blocks (puts the routine to sleep until the channel gets data)"))) -;? (quit) - -(reset) -(new-trace "channel-write-block") -(add-code - '((function main [ - (1:channel-address <- init-channel 1:literal) - (2:integer <- copy 34:literal) - (3:tagged-value <- save-type 2:integer) - (1:channel-address/deref <- write 1:channel-address 3:tagged-value) - ; channel has capacity 1, but receives a second write - (1:channel-address/deref <- write 1:channel-address 3:tagged-value) - ]))) -;? (set dump-trace*) -;? (= dump-trace* (obj whitelist '("run" "schedule" "addr"))) -(run 'main) -;? (prn int-canon.memory*) -;? (prn running-routines*) -;? (prn sleeping-routines*) -;? (prn completed-routines*) -; second write should cause the routine to sleep, and -; the sole sleeping routine should trigger the deadlock detector -(let routine (car completed-routines*) - (when (or (no routine) - (no rep.routine!error) - (~posmatch "deadlock" rep.routine!error)) - (prn "F - 'write' on full channel blocks (puts the routine to sleep until the channel gets data)"))) -;? (quit) - -(reset) -(new-trace "channel-handoff") -(add-code - '((function consumer [ - (default-space:space-address <- new space:literal 30:literal) - (chan:channel-address <- init-channel 3:literal) ; create a channel - (fork producer:fn nil:literal/globals nil:literal/limit chan:channel-address) ; fork a routine to produce a value in it - (1:tagged-value/raw <- read chan:channel-address) ; wait for input on channel - ]) - (function producer [ - (default-space:space-address <- new space:literal 30:literal) - (n:integer <- copy 24:literal) - (ochan:channel-address <- next-input) - (x:tagged-value <- save-type n:integer) - (ochan:channel-address/deref <- write ochan:channel-address x:tagged-value) - ]))) -;? (set dump-trace*) -;? (= dump-trace* (obj whitelist '("schedule" "run" "addr"))) -;? (= dump-trace* (obj whitelist '("-"))) -(run 'consumer) -;? (prn memory*) -(each routine completed-routines* - (aif rep.routine!error (prn "error - " it))) -(when (~is 24 memory*.2) ; location 1 contains tagged-value x above - (prn "F - channels are meant to be shared between routines")) -;? (quit) - -(reset) -(new-trace "channel-handoff-routine") -(add-code - '((function consumer [ - (default-space:space-address <- new space:literal 30:literal) - (1:channel-address <- init-channel 3:literal) ; create a channel - (fork producer:fn default-space:space-address/globals nil:literal/limit) ; pass it as a global to another routine - (1:tagged-value/raw <- read 1:channel-address) ; wait for input on channel - ]) - (function producer [ - (default-space:space-address <- new space:literal 30:literal) - (n:integer <- copy 24:literal) - (x:tagged-value <- save-type n:integer) - (1:channel-address/space:global/deref <- write 1:channel-address/space:global x:tagged-value) - ]))) -(run 'consumer) -(each routine completed-routines* - (aif rep.routine!error (prn "error - " it))) -(when (~is 24 memory*.2) ; location 1 contains tagged-value x above - (prn "F - channels are meant to be shared between routines")) - -) ; section 100 - -(section 10 - -;; Separating concerns -; -; Lightweight tools can also operate on quoted lists of statements surrounded -; by square brackets. In the example below, we mimic Go's 'defer' keyword -; using 'convert-quotes'. It lets us write code anywhere in a function, but -; have it run just before the function exits. Great for keeping code to -; reclaim memory or other resources close to the code to allocate it. (C++ -; programmers know this as RAII.) We'll use 'defer' when we build a memory -; deallocation routine like C's 'free'. -; -; More powerful reorderings are also possible like in Literate Programming or -; Aspect-Oriented Programming; one advantage of prohibiting arbitrarily nested -; code is that we can naturally name 'join points' wherever we want. - -(reset) -(new-trace "convert-quotes-defer") -(= traces* (queue)) -(when (~iso (convert-quotes - '((1:integer <- copy 4:literal) - (defer [ - (3:integer <- copy 6:literal) - ]) - (2:integer <- copy 5:literal))) - '((1:integer <- copy 4:literal) - (2:integer <- copy 5:literal) - (3:integer <- copy 6:literal))) - (prn "F - convert-quotes can handle 'defer'")) - -(reset) -(new-trace "convert-quotes-defer-reply") -(= traces* (queue)) -(when (~iso (convert-quotes - '((1:integer <- copy 0:literal) - (defer [ - (5:integer <- copy 0:literal) - ]) - (2:integer <- copy 0:literal) - (reply) - (3:integer <- copy 0:literal) - (4:integer <- copy 0:literal))) - '((1:integer <- copy 0:literal) - (2:integer <- copy 0:literal) - (5:integer <- copy 0:literal) - (reply) - (3:integer <- copy 0:literal) - (4:integer <- copy 0:literal) - (5:integer <- copy 0:literal))) - (prn "F - convert-quotes inserts code at early exits")) - -(reset) -(new-trace "convert-quotes-defer-reply-arg") -(= traces* (queue)) -(when (~iso (convert-quotes - '((1:integer <- copy 0:literal) - (defer [ - (5:integer <- copy 0:literal) - ]) - (2:integer <- copy 0:literal) - (reply 2:literal) - (3:integer <- copy 0:literal) - (4:integer <- copy 0:literal))) - '((1:integer <- copy 0:literal) - (2:integer <- copy 0:literal) - (prepare-reply 2:literal) - (5:integer <- copy 0:literal) - (reply) - (3:integer <- copy 0:literal) - (4:integer <- copy 0:literal) - (5:integer <- copy 0:literal))) - (prn "F - convert-quotes inserts code at early exits")) - -(reset) -(new-trace "convert-quotes-label") -(= traces* (queue)) -(when (~iso (convert-quotes - '((1:integer <- copy 4:literal) - foo - (2:integer <- copy 5:literal))) - '((1:integer <- copy 4:literal) - foo - (2:integer <- copy 5:literal))) - (prn "F - convert-quotes can handle labels")) - -(reset) -(new-trace "before") -(= traces* (queue)) -(add-code - '((before label1 [ - (2:integer <- copy 0:literal) - ]))) -(when (~iso (as cons 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 "string-equal") -(add-code - '((function main [ - (1:string-address <- new "hello") - (2:string-address <- new "hello") - (3:boolean <- string-equal 1:string-address 2:string-address) - ]))) -(run 'main) -(when (~iso memory*.3 t) - (prn "F - 'string-equal'")) - -(reset) -(new-trace "string-equal-empty") -(add-code - '((function main [ - (1:string-address <- new "") - (2:string-address <- new "") - (3:boolean <- string-equal 1:string-address 2:string-address) - ]))) -(run 'main) -(when (~iso memory*.3 t) - (prn "F - 'string-equal' works on empty strings")) - -(reset) -(new-trace "string-equal-compare-with-empty") -(add-code - '((function main [ - (1:string-address <- new "a") - (2:string-address <- new "") - (3:boolean <- string-equal 1:string-address 2:string-address) - ]))) -(run 'main) -(when (~iso memory*.3 nil) - (prn "F - 'string-equal' compares correctly with empty strings")) - -(reset) -(new-trace "string-equal-compares-length") -(add-code - '((function main [ - (1:string-address <- new "a") - (2:string-address <- new "ab") - (3:boolean <- string-equal 1:string-address 2:string-address) - ]))) -(run 'main) -(when (~iso memory*.3 nil) - (prn "F - 'string-equal' handles differing lengths")) - -(reset) -(new-trace "string-equal-compares-initial-element") -(add-code - '((function main [ - (1:string-address <- new "aa") - (2:string-address <- new "ba") - (3:boolean <- string-equal 1:string-address 2:string-address) - ]))) -(run 'main) -(when (~iso memory*.3 nil) - (prn "F - 'string-equal' handles inequal final byte")) - -(reset) -(new-trace "string-equal-compares-final-element") -(add-code - '((function main [ - (1:string-address <- new "ab") - (2:string-address <- new "aa") - (3:boolean <- string-equal 1:string-address 2:string-address) - ]))) -(run 'main) -(when (~iso memory*.3 nil) - (prn "F - 'string-equal' handles inequal final byte")) - -(reset) -(new-trace "string-equal-reflexive") -(add-code - '((function main [ - (1:string-address <- new "ab") - (3:boolean <- string-equal 1:string-address 1:string-address) - ]))) -(run 'main) -(when (~iso memory*.3 t) - (prn "F - 'string-equal' handles identical pointer")) - -(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) - ]))) -;? (= dump-trace* (obj whitelist '("run"))) ;? 1 -(run 'main) -(when (~memory-contains-array memory*.3 "hello, world!") - (prn "F - 'strcat' concatenates strings")) -;? (quit) ;? 1 - -(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 "match-at") -(add-code - '((function main [ - (1:string-address <- new "abc") - (2:string-address <- new "ab") - (3:boolean <- match-at 1:string-address 2:string-address 0:literal) - ]))) -(run 'main) -(when (~is memory*.3 t) - (prn "F - 'match-at' matches substring at given index")) - -(reset) -(new-trace "match-at-reflexive") -(add-code - '((function main [ - (1:string-address <- new "abc") - (3:boolean <- match-at 1:string-address 1:string-address 0:literal) - ]))) -(run 'main) -(when (~is memory*.3 t) - (prn "F - 'match-at' always matches a string at itself at index 0")) - -(reset) -(new-trace "match-at-outside-bounds") -(add-code - '((function main [ - (1:string-address <- new "abc") - (2:string-address <- new "a") - (3:boolean <- match-at 1:string-address 2:string-address 4:literal) - ]))) -(run 'main) -(when (~is memory*.3 nil) - (prn "F - 'match-at' always fails to match outside the bounds of the text")) - -(reset) -(new-trace "match-at-empty-pattern") -(add-code - '((function main [ - (1:string-address <- new "abc") - (2:string-address <- new "") - (3:boolean <- match-at 1:string-address 2:string-address 0:literal) - ]))) -(run 'main) -(when (~is memory*.3 t) - (prn "F - 'match-at' always matches empty pattern")) - -(reset) -(new-trace "match-at-empty-pattern-outside-bounds") -(add-code - '((function main [ - (1:string-address <- new "abc") - (2:string-address <- new "") - (3:boolean <- match-at 1:string-address 2:string-address 4:literal) - ]))) -(run 'main) -(when (~is memory*.3 nil) - (prn "F - 'match-at' matches empty pattern -- unless index is out of bounds")) - -(reset) -(new-trace "match-at-empty-text") -(add-code - '((function main [ - (1:string-address <- new "") - (2:string-address <- new "abc") - (3:boolean <- match-at 1:string-address 2:string-address 0:literal) - ]))) -(run 'main) -(when (~is memory*.3 nil) - (prn "F - 'match-at' never matches empty text")) - -(reset) -(new-trace "match-at-empty-against-empty") -(add-code - '((function main [ - (1:string-address <- new "") - (3:boolean <- match-at 1:string-address 1:string-address 0:literal) - ]))) -(run 'main) -(when (~is memory*.3 t) - (prn "F - 'match-at' never matches empty text -- unless pattern is also empty")) - -(reset) -(new-trace "match-at-inside-bounds") -(add-code - '((function main [ - (1:string-address <- new "abc") - (2:string-address <- new "bc") - (3:boolean <- match-at 1:string-address 2:string-address 1:literal) - ]))) -(run 'main) -(when (~is memory*.3 t) - (prn "F - 'match-at' matches inner substring")) - -(reset) -(new-trace "match-at-inside-bounds-2") -(add-code - '((function main [ - (1:string-address <- new "abc") - (2:string-address <- new "bc") - (3:boolean <- match-at 1:string-address 2:string-address 0:literal) - ]))) -(run 'main) -(when (~is memory*.3 nil) - (prn "F - 'match-at' matches inner substring - 2")) - -(reset) -(new-trace "find-substring") -(add-code - '((function main [ - (1:string-address <- new "abc") - (2:string-address <- new "bc") - (3:integer <- find-substring 1:string-address 2:string-address 0:literal) - ]))) -(run 'main) -;? (prn memory*.3) ;? 1 -(when (~is memory*.3 1) - (prn "F - 'find-substring' returns index of match")) - -(reset) -(new-trace "find-substring-2") -(add-code - '((function main [ - (1:string-address <- new "abcd") - (2:string-address <- new "bc") - (3:integer <- find-substring 1:string-address 2:string-address 1:literal) - ]))) -(run 'main) -(when (~is memory*.3 1) - (prn "F - 'find-substring' returns provided index if it matches")) - -(reset) -(new-trace "find-substring-no-match") -(add-code - '((function main [ - (1:string-address <- new "abc") - (2:string-address <- new "bd") - (3:integer <- find-substring 1:string-address 2:string-address 0:literal) - ]))) -(run 'main) -(when (~is memory*.3 3) - (prn "F - 'find-substring' returns out-of-bounds index on no-match")) - -(reset) -(new-trace "find-substring-suffix-match") -(add-code - '((function main [ - (1:string-address <- new "abcd") - (2:string-address <- new "cd") - (3:integer <- find-substring 1:string-address 2:string-address 0:literal) - ]))) -(run 'main) -(when (~is memory*.3 2) - (prn "F - 'find-substring' returns provided index if it matches")) - -(reset) -(new-trace "find-substring-suffix-match-2") -(add-code - '((function main [ - (1:string-address <- new "abcd") - (2:string-address <- new "cde") - (3:integer <- find-substring 1:string-address 2:string-address 0:literal) - ]))) -(run 'main) -(when (~is memory*.3 4) - (prn "F - 'find-substring' returns provided index if it matches")) - -;? (quit) ;? 1 - -(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"))) -;? (quit) ;? 1 - -(reset) -(new-trace "string-split-first") -(add-code - '((function main [ - (1:string-address <- new "a/b") - (2:string-address 3:string-address <- split-first 1:string-address ((#\/ literal))) - ]))) -(run 'main) -(each routine completed-routines* - (aif rep.routine!error (prn "error - " it))) -(when (or (~memory-contains-array memory*.2 "a") - (~memory-contains-array memory*.3 "b")) - (prn "F - 'split-first' cuts string at first occurrence of delimiter")) - -(reset) -(new-trace "string-split-first-at-substring") -(add-code - '((function main [ - (1:string-address <- new "a//b") - (2:string-address <- new "//") - (3:string-address 4:string-address <- split-first-at-substring 1:string-address 2:string-address) - ]))) -(run 'main) -(each routine completed-routines* - (aif rep.routine!error (prn "error - " it))) -;? (prn int-canon.memory*) ;? 1 -(when (or (~memory-contains-array memory*.3 "a") - (~memory-contains-array memory*.4 "b")) - (prn "F - 'split-first-at-substring' is like split-first but with a string delimiter")) - -(reset) -(new-trace "string-copy") -(add-code - '((function main [ - (1:string-address <- new "abc") - (2:string-address <- string-copy 1:string-address 1:literal 3:literal) - ]))) -(run 'main) -(each routine completed-routines* - (aif rep.routine!error (prn "error - " it))) -(when (~memory-contains-array memory*.2 "bc") - (prn "F - 'string-copy' returns a copy of a substring")) - -(reset) -(new-trace "string-copy-out-of-bounds") -(add-code - '((function main [ - (1:string-address <- new "abc") - (2:string-address <- string-copy 1:string-address 2:literal 4:literal) - ]))) -(run 'main) -(each routine completed-routines* - (aif rep.routine!error (prn "error - " it))) -(when (~memory-contains-array memory*.2 "c") - (prn "F - 'string-copy' stops at bounds")) - -(reset) -(new-trace "string-copy-out-of-bounds-2") -(add-code - '((function main [ - (1:string-address <- new "abc") - (2:string-address <- string-copy 1:string-address 3:literal 3:literal) - ]))) -(run 'main) -(each routine completed-routines* - (aif rep.routine!error (prn "error - " it))) -(when (~memory-contains-array memory*.2 "") - (prn "F - 'string-copy' returns empty string when range is out of bounds")) - -(reset) -(new-trace "min") -(add-code - '((function main [ - (1:integer <- min 3:literal 4:literal) - ]))) -(run 'main) -(each routine completed-routines* - (aif rep.routine!error (prn "error - " it))) -;? (prn int-canon.memory*) ;? 1 -(when (~is memory*.1 3) - (prn "F - 'min' returns smaller of two numbers")) - -;? (quit) ;? 2 - -(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-empty") -(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")) - -; fake keyboard for tests; must initialize keys in advance -(reset) -(new-trace "fake-keyboard") -(add-code - '((function main [ - (default-space:space-address <- new space:literal 30:literal) - (s:string-address <- new "foo") - (x:keyboard-address <- init-keyboard s:string-address) - (1:character-address/raw <- read-key x:keyboard-address) - ]))) -(run 'main) -(when (~is memory*.1 #\f) - (prn "F - 'read-key' reads character from provided 'fake keyboard' string")) - -; fake keyboard for tests; must initialize keys in advance -(reset) -(new-trace "fake-keyboard2") -(add-code - '((function main [ - (default-space:space-address <- new space:literal 30:literal) - (s:string-address <- new "foo") - (x:keyboard-address <- init-keyboard s:string-address) - (1:character-address/raw <- read-key x:keyboard-address) - (1:character-address/raw <- read-key x:keyboard-address) - ]))) -(run 'main) -(when (~is memory*.1 #\o) - (prn "F - 'read-key' advances cursor in provided string")) - -; to receive input line by line, run send-keys-buffered-to-stdin -(reset) -(new-trace "buffer-stdin-until-newline") -(add-code - '((function main [ - (default-space:space-address <- new space:literal 30:literal) - (s:string-address <- new "foo") - (k:keyboard-address <- init-keyboard s:string-address) - (stdin:channel-address <- init-channel 1:literal) - (fork send-keys-to-stdin:fn nil:literal/globals nil:literal/limit k:keyboard-address stdin:channel-address) - (buffered-stdin:channel-address <- init-channel 1:literal) - (r:integer/routine <- fork buffer-lines:fn nil:literal/globals nil:literal/limit stdin:channel-address buffered-stdin:channel-address) - (screen:terminal-address <- init-fake-terminal 20:literal 10:literal) - (5:string-address/raw <- get screen:terminal-address/deref data:offset) - (fork-helper send-prints-to-stdout:fn nil:literal/globals nil:literal/limit screen:terminal-address buffered-stdin:channel-address) - (sleep until-routine-done:literal r:integer/routine) - ]))) -;? (set dump-trace*) ;? 3 -;? (= dump-trace* (obj whitelist '("schedule" "run"))) ;? 0 -(run 'main) -;? (prn int-canon.memory*) ;? 0 -(each routine completed-routines* - (awhen rep.routine!error - (prn "error - " it))) -(when (~memory-contains-array memory*.5 - (+ " " - " " - " " - " " - " " - " " - " " - " " - " " - " ")) - (prn "F - 'buffer-lines' prints nothing until newline is encountered")) -;? (quit) ;? 3 - -(reset) -(new-trace "print-buffered-contents-on-newline") -(add-code - '((function main [ - (default-space:space-address <- new space:literal 30:literal) - (s:string-address <- new "foo\nline2") - (k:keyboard-address <- init-keyboard s:string-address) - (stdin:channel-address <- init-channel 1:literal) - (fork send-keys-to-stdin:fn nil:literal/globals nil:literal/limit k:keyboard-address stdin:channel-address) - (buffered-stdin:channel-address <- init-channel 1:literal) - (r:integer/routine <- fork buffer-lines:fn nil:literal/globals nil:literal/limit stdin:channel-address buffered-stdin:channel-address) - (screen:terminal-address <- init-fake-terminal 20:literal 10:literal) - (5:string-address/raw <- get screen:terminal-address/deref data:offset) - (fork-helper send-prints-to-stdout:fn nil:literal/globals nil:literal/limit screen:terminal-address buffered-stdin:channel-address) - (sleep until-routine-done:literal r:integer/routine) - ]))) -;? (= dump-trace* (obj whitelist '("schedule" "run"))) ;? 1 -(run 'main) -(each routine completed-routines* - (awhen rep.routine!error - (prn "error - " it))) -(when (~memory-contains-array memory*.5 - (+ "foo\n " - " " - " " - " " - " " - " " - " " - " " - " " - " ")) - (prn "F - 'buffer-lines' prints lines to screen")) - -(reset) -(new-trace "print-buffered-contents-right-at-newline") -(add-code - '((function main [ - (default-space:space-address <- new space:literal 30:literal) - (s:string-address <- new "foo\n") - (k:keyboard-address <- init-keyboard s:string-address) - (stdin:channel-address <- init-channel 1:literal) - (fork send-keys-to-stdin:fn nil:literal/globals nil:literal/limit k:keyboard-address stdin:channel-address) - (buffered-stdin:channel-address <- init-channel 1:literal) - (r:integer/routine <- fork buffer-lines:fn nil:literal/globals nil:literal/limit stdin:channel-address buffered-stdin:channel-address) - (screen:terminal-address <- init-fake-terminal 20:literal 10:literal) - (5:string-address/raw <- get screen:terminal-address/deref data:offset) - (fork-helper send-prints-to-stdout:fn nil:literal/globals nil:literal/limit screen:terminal-address buffered-stdin:channel-address) - (sleep until-routine-done:literal r:integer/routine) - ; hack: give helper some time to finish printing - (sleep for-some-cycles:literal 500:literal) - ]))) -;? (= dump-trace* (obj whitelist '("schedule" "run"))) ;? 1 -(run 'main) -(each routine completed-routines* - (awhen rep.routine!error - (prn "error - " it))) -(when (~memory-contains-array memory*.5 - (+ "foo\n " - " " - " " - " " - " " - " " - " " - " " - " " - " ")) - (prn "F - 'buffer-lines' prints lines to screen immediately on newline")) - -(reset) -(new-trace "buffered-contents-skip-backspace") -(add-code - '((function main [ - (default-space:space-address <- new space:literal 30:literal) - (s:string-address <- new "fooa\b\nline2") - (k:keyboard-address <- init-keyboard s:string-address) - (stdin:channel-address <- init-channel 1:literal) - (fork send-keys-to-stdin:fn nil:literal/globals nil:literal/limit k:keyboard-address stdin:channel-address) - (buffered-stdin:channel-address <- init-channel 1:literal) - (r:integer/routine <- fork buffer-lines:fn nil:literal/globals nil:literal/limit stdin:channel-address buffered-stdin:channel-address) - (screen:terminal-address <- init-fake-terminal 20:literal 10:literal) - (5:string-address/raw <- get screen:terminal-address/deref data:offset) - (fork-helper send-prints-to-stdout:fn nil:literal/globals nil:literal/limit screen:terminal-address buffered-stdin:channel-address) - (sleep until-routine-done:literal r:integer/routine) - ]))) -;? (= dump-trace* (obj whitelist '("schedule" "run"))) ;? 1 -(run 'main) -(each routine completed-routines* - (awhen rep.routine!error - (prn "error - " it))) -(when (~memory-contains-array memory*.5 - (+ "foo\n " - " " - " " - " " - " " - " " - " " - " " - " " - " ")) - (prn "F - 'buffer-lines' handles backspace")) - -(reset) -(new-trace "buffered-contents-ignore-excess-backspace") -(add-code - '((function main [ - (default-space:space-address <- new space:literal 30:literal) - (s:string-address <- new "a\b\bfoo\n") - (k:keyboard-address <- init-keyboard s:string-address) - (stdin:channel-address <- init-channel 1:literal) - (fork send-keys-to-stdin:fn nil:literal/globals nil:literal/limit k:keyboard-address stdin:channel-address) - (buffered-stdin:channel-address <- init-channel 1:literal) - (r:integer/routine <- fork buffer-lines:fn nil:literal/globals nil:literal/limit stdin:channel-address buffered-stdin:channel-address) - (screen:terminal-address <- init-fake-terminal 20:literal 10:literal) - (5:string-address/raw <- get screen:terminal-address/deref data:offset) - (fork-helper send-prints-to-stdout:fn nil:literal/globals nil:literal/limit screen:terminal-address buffered-stdin:channel-address) - (sleep until-routine-done:literal r:integer/routine) - ; hack: give helper some time to finish printing - (sleep for-some-cycles:literal 500:literal) - ]))) -;? (= dump-trace* (obj whitelist '("schedule" "run"))) ;? 1 -(run 'main) -(each routine completed-routines* - (awhen rep.routine!error - (prn "error - " it))) -;? (prn memory*.5) ;? 1 -(when (~memory-contains-array memory*.5 - (+ "foo\n " - " " - " " - " " - " " - " " - " " - " " - " " - " ")) - (prn "F - 'buffer-lines' ignores backspace when there's nothing to backspace over")) - -) ; 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" "mem"))) -(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 |