2014-10-10 22:04:14 +00:00
; 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)
;
2014-11-08 17:26:18 +00:00
; ; Motivation
;
2014-10-10 22:04:14 +00:00
; 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
; 70 s . 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
2014-10-11 21:17:50 +00:00
; accident . Abstractions help insiders manage the evolution of a codebase , but
2014-10-10 22:04:14 +00:00
; 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 .
; - - -
2014-11-07 21:00:44 +00:00
; ; Getting started
;
2014-10-10 22:04:14 +00:00
; 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
2014-10-11 21:17:50 +00:00
; try to avoid 'cheating' : relying on the host platform for advanced
; functionality .
2014-10-10 22:04:14 +00:00
;
; 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 .
2014-07-06 07:07:03 +00:00
( load "mu.arc" )
2014-12-04 10:50:33 +00:00
; ? ( quit )
2014-07-06 07:07:03 +00:00
2014-10-10 22:04:14 +00:00
; 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 be lists of lists:
;
; ( function - name
; ( ( oarg1 oarg2 ... < - op arg1 arg2 ... )
; ...
; ... ) )
;
; Each arg / oarg is itself a list , with the payload value at the head , and
; various metadata in the rest . In this first example 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
2014-10-11 06:49:53 +00:00
; '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 .
2014-11-01 22:06:24 +00:00
;
2014-11-25 05:09:07 +00:00
; In our tests we 'll define such mu functions using a call to ' add - code ' , so
; look for it . Everything outside 'add-code' is just test - harness details .
2014-10-10 22:04:14 +00:00
2014-08-19 17:31:58 +00:00
( reset )
2014-11-07 22:09:59 +00:00
; ? ( set dump - trace * )
2014-10-07 17:26:14 +00:00
( new - trace "literal" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
( ( 1 integer ) < - copy ( 23 literal ) )
] ) ) )
2014-11-22 02:21:15 +00:00
; ? ( set dump - trace * )
2014-10-18 23:58:51 +00:00
( run ' main )
2014-08-19 18:58:22 +00:00
; ? ( prn memory * )
2014-10-07 16:29:40 +00:00
( if ( ~ is memory * .1 23 )
2014-10-07 15:42:54 +00:00
( 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." ) )
2014-08-29 02:23:38 +00:00
; ? ( quit )
2014-07-17 15:16:22 +00:00
2014-10-10 22:04:14 +00:00
; Our basic arithmetic ops can operate on memory locations or literals .
; ( Ignore hardware details like registers for now . )
2014-08-19 17:31:58 +00:00
( reset )
2014-10-07 17:26:14 +00:00
( new - trace "add" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
2014-10-07 15:42:54 +00:00
( ( 1 integer ) < - copy ( 1 literal ) )
( ( 2 integer ) < - copy ( 3 literal ) )
2014-11-25 05:09:07 +00:00
( ( 3 integer ) < - add ( 1 integer ) ( 2 integer ) )
] ) ) )
2014-10-18 23:58:51 +00:00
( run ' main )
2014-07-06 07:07:03 +00:00
( if ( ~ iso memory * ( obj 1 1 2 3 3 4 ) )
2014-07-17 15:16:22 +00:00
( prn "F - 'add' operates on two addresses" ) )
2014-07-06 08:53:18 +00:00
2014-10-05 17:36:09 +00:00
( reset )
2014-10-07 17:26:14 +00:00
( new - trace "add-literal" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
( ( 1 integer ) < - add ( 2 literal ) ( 3 literal ) )
] ) ) )
2014-10-18 23:58:51 +00:00
( run ' main )
2014-10-07 16:29:40 +00:00
( if ( ~ is memory * .1 5 )
2014-10-05 17:36:09 +00:00
( prn "F - ops can take 'literal' operands (but not return them)" ) )
2014-08-19 17:31:58 +00:00
( reset )
2014-10-07 17:26:14 +00:00
( new - trace "sub-literal" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
2014-12-13 01:54:31 +00:00
( ( 1 integer ) < - subtract ( 1 literal ) ( 3 literal ) )
2014-11-25 05:09:07 +00:00
] ) ) )
2014-10-18 23:58:51 +00:00
( run ' main )
2014-07-12 04:04:38 +00:00
; ? ( prn memory * )
2014-10-07 16:29:40 +00:00
( if ( ~ is memory * .1 - 2 )
2014-12-13 01:54:31 +00:00
( prn "F - 'subtract'" ) )
2014-07-12 04:04:38 +00:00
2014-08-19 17:31:58 +00:00
( reset )
2014-10-07 17:26:14 +00:00
( new - trace "mul-literal" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
2014-12-13 01:54:31 +00:00
( ( 1 integer ) < - multiply ( 2 literal ) ( 3 literal ) )
2014-11-25 05:09:07 +00:00
] ) ) )
2014-10-18 23:58:51 +00:00
( run ' main )
2014-07-12 04:04:38 +00:00
; ? ( prn memory * )
2014-10-07 16:29:40 +00:00
( if ( ~ is memory * .1 6 )
2014-12-13 01:54:31 +00:00
( prn "F - 'multiply'" ) )
2014-07-12 04:04:38 +00:00
2014-08-19 17:31:58 +00:00
( reset )
2014-10-07 17:26:14 +00:00
( new - trace "div-literal" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
2014-12-13 01:54:31 +00:00
( ( 1 integer ) < - divide ( 8 literal ) ( 3 literal ) )
2014-11-25 05:09:07 +00:00
] ) ) )
2014-10-18 23:58:51 +00:00
( run ' main )
2014-07-12 04:04:38 +00:00
; ? ( prn memory * )
2014-10-07 16:29:40 +00:00
( if ( ~ is memory * .1 ( / real .8 3 ) )
2014-12-13 01:54:31 +00:00
( prn "F - 'divide'" ) )
2014-07-12 04:04:38 +00:00
2014-08-19 17:31:58 +00:00
( reset )
2014-10-07 17:26:14 +00:00
( new - trace "idiv-literal" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
2014-12-13 01:54:31 +00:00
( ( 1 integer ) ( 2 integer ) < - divide - with - remainder ( 23 literal ) ( 6 literal ) )
2014-11-25 05:09:07 +00:00
] ) ) )
2014-10-18 23:58:51 +00:00
( run ' main )
2014-07-12 04:04:38 +00:00
; ? ( prn memory * )
2014-11-01 19:24:53 +00:00
( if ( ~ iso memory * ( obj 1 3 2 5 ) )
2014-12-13 01:54:31 +00:00
( prn "F - 'divide-with-remainder' performs integer division" ) )
2014-07-12 04:22:32 +00:00
2014-11-07 19:50:41 +00:00
( reset )
( new - trace "dummy-oarg" )
; ? ( set dump - trace * )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
2014-12-13 01:54:31 +00:00
( _ ( 2 integer ) < - divide - with - remainder ( 23 literal ) ( 6 literal ) )
2014-11-25 05:09:07 +00:00
] ) ) )
2014-11-07 19:50:41 +00:00
( run ' main )
( if ( ~ iso memory * ( obj 2 5 ) )
( prn "F - '_' oarg can ignore some results" ) )
; ? ( quit )
2014-10-10 22:04:14 +00:00
; Basic boolean operations: and , or , not
; There are easy ways to encode booleans in binary , but we ' ll skip past those
2014-11-01 19:32:10 +00:00
; details for now .
2014-10-10 22:04:14 +00:00
2014-08-19 17:31:58 +00:00
( reset )
2014-10-07 17:26:14 +00:00
( new - trace "and-literal" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
( ( 1 boolean ) < - and ( t literal ) ( nil literal ) )
] ) ) )
2014-10-18 23:58:51 +00:00
( run ' main )
2014-07-12 05:50:55 +00:00
; ? ( prn memory * )
2014-10-07 16:29:40 +00:00
( if ( ~ is memory * .1 nil )
2014-07-17 15:16:22 +00:00
( prn "F - logical 'and' for booleans" ) )
2014-07-12 05:50:55 +00:00
2014-12-13 01:54:31 +00:00
; Basic comparison operations
2014-10-10 22:04:14 +00:00
2014-08-19 17:31:58 +00:00
( reset )
2014-10-07 17:26:14 +00:00
( new - trace "lt-literal" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
2014-12-13 01:54:31 +00:00
( ( 1 boolean ) < - less - than ( 4 literal ) ( 3 literal ) )
2014-11-25 05:09:07 +00:00
] ) ) )
2014-10-18 23:58:51 +00:00
( run ' main )
2014-07-14 04:27:23 +00:00
; ? ( prn memory * )
2014-10-07 16:29:40 +00:00
( if ( ~ is memory * .1 nil )
2014-12-13 01:54:31 +00:00
( prn "F - 'less-than' inequality operator" ) )
2014-07-14 04:27:23 +00:00
2014-08-19 17:31:58 +00:00
( reset )
2014-10-07 17:26:14 +00:00
( new - trace "le-literal-false" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
2014-12-13 01:54:31 +00:00
( ( 1 boolean ) < - lesser - or - equal ( 4 literal ) ( 3 literal ) )
2014-11-25 05:09:07 +00:00
] ) ) )
2014-10-18 23:58:51 +00:00
( run ' main )
2014-07-14 04:27:23 +00:00
; ? ( prn memory * )
2014-10-07 16:29:40 +00:00
( if ( ~ is memory * .1 nil )
2014-12-13 01:54:31 +00:00
( prn "F - 'lesser-or-equal'" ) )
2014-07-17 15:16:22 +00:00
2014-08-19 17:31:58 +00:00
( reset )
2014-10-07 17:26:14 +00:00
( new - trace "le-literal-true" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
2014-12-13 01:54:31 +00:00
( ( 1 boolean ) < - lesser - or - equal ( 4 literal ) ( 4 literal ) )
2014-11-25 05:09:07 +00:00
] ) ) )
2014-10-18 23:58:51 +00:00
( run ' main )
2014-07-17 15:16:22 +00:00
; ? ( prn memory * )
2014-10-07 16:29:40 +00:00
( if ( ~ is memory * .1 t )
2014-12-13 01:54:31 +00:00
( prn "F - 'lesser-or-equal' returns true for equal operands" ) )
2014-07-14 04:27:23 +00:00
2014-08-19 17:31:58 +00:00
( reset )
2014-10-07 17:26:14 +00:00
( new - trace "le-literal-true-2" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
2014-12-13 01:54:31 +00:00
( ( 1 boolean ) < - lesser - or - equal ( 4 literal ) ( 5 literal ) )
2014-11-25 05:09:07 +00:00
] ) ) )
2014-10-18 23:58:51 +00:00
( run ' main )
2014-07-14 04:27:23 +00:00
; ? ( prn memory * )
2014-10-07 16:29:40 +00:00
( if ( ~ is memory * .1 t )
2014-12-13 01:54:31 +00:00
( prn "F - 'lesser-or-equal' - 2" ) )
2014-07-14 04:27:23 +00:00
2014-11-01 22:55:42 +00:00
; Control flow operations: jump , jump - if , jump - unless
2014-10-10 22:04:14 +00:00
; These introduce a new type - - 'offset' - - for literals that refer to memory
; locations relative to the current location .
2014-08-19 17:31:58 +00:00
( reset )
2014-10-15 00:51:30 +00:00
( new - trace "jump-skip" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
2014-10-07 15:42:54 +00:00
( ( 1 integer ) < - copy ( 8 literal ) )
2014-10-15 00:51:30 +00:00
( jump ( 1 offset ) )
2014-10-07 16:29:40 +00:00
( ( 2 integer ) < - copy ( 3 literal ) ) ; should be skipped
2014-11-25 05:09:07 +00:00
( reply )
] ) ) )
2014-10-18 23:58:51 +00:00
( run ' main )
2014-07-12 04:22:32 +00:00
; ? ( prn memory * )
( if ( ~ iso memory * ( obj 1 8 ) )
2014-10-15 00:51:30 +00:00
( prn "F - 'jump' skips some instructions" ) )
2014-07-12 04:29:43 +00:00
2014-08-19 17:31:58 +00:00
( reset )
2014-10-15 00:51:30 +00:00
( new - trace "jump-target" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
2014-10-07 15:42:54 +00:00
( ( 1 integer ) < - copy ( 8 literal ) )
2014-10-15 00:51:30 +00:00
( jump ( 1 offset ) )
2014-10-07 16:29:40 +00:00
( ( 2 integer ) < - copy ( 3 literal ) ) ; should be skipped
2014-07-12 05:26:19 +00:00
( reply )
2014-11-25 05:09:07 +00:00
( ( 3 integer ) < - copy ( 34 literal ) )
] ) ) ) ; never reached
2014-10-18 23:58:51 +00:00
( run ' main )
2014-07-12 04:29:43 +00:00
; ? ( prn memory * )
( if ( ~ iso memory * ( obj 1 8 ) )
2014-10-15 00:51:30 +00:00
( prn "F - 'jump' doesn't skip too many instructions" ) )
2014-08-28 23:40:28 +00:00
; ? ( quit )
2014-07-12 04:29:43 +00:00
2014-08-19 17:31:58 +00:00
( reset )
2014-10-15 00:51:30 +00:00
( new - trace "jump-if-skip" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
2014-10-07 15:42:54 +00:00
( ( 2 integer ) < - copy ( 1 literal ) )
2014-12-13 01:54:31 +00:00
( ( 1 boolean ) < - equal ( 1 literal ) ( 2 integer ) )
2014-10-15 00:51:30 +00:00
( jump - if ( 1 boolean ) ( 1 offset ) )
2014-10-07 15:42:54 +00:00
( ( 2 integer ) < - copy ( 3 literal ) )
2014-07-12 05:26:19 +00:00
( reply )
2014-11-25 05:09:07 +00:00
( ( 3 integer ) < - copy ( 34 literal ) )
] ) ) )
2014-10-18 23:58:51 +00:00
( run ' main )
2014-07-12 04:29:43 +00:00
; ? ( prn memory * )
2014-10-07 16:29:40 +00:00
( if ( ~ iso memory * ( obj 1 t 2 1 ) )
2014-10-15 00:51:30 +00:00
( prn "F - 'jump-if' is a conditional 'jump'" ) )
2014-07-12 04:29:43 +00:00
2014-08-19 17:31:58 +00:00
( reset )
2014-10-15 00:51:30 +00:00
( new - trace "jump-if-fallthrough" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
2014-12-13 01:54:31 +00:00
( ( 1 boolean ) < - equal ( 1 literal ) ( 2 literal ) )
2014-10-15 00:51:30 +00:00
( jump - if ( 3 boolean ) ( 1 offset ) )
2014-10-07 16:29:40 +00:00
( ( 2 integer ) < - copy ( 3 literal ) )
2014-07-12 05:26:19 +00:00
( reply )
2014-11-25 05:09:07 +00:00
( ( 3 integer ) < - copy ( 34 literal ) )
] ) ) )
2014-10-18 23:58:51 +00:00
( run ' main )
2014-07-12 04:29:43 +00:00
; ? ( prn memory * )
2014-10-07 16:29:40 +00:00
( if ( ~ iso memory * ( obj 1 nil 2 3 ) )
2014-10-15 00:51:30 +00:00
( prn "F - if 'jump-if's first arg is false, it doesn't skip any instructions" ) )
2014-07-12 05:26:19 +00:00
2014-08-19 17:31:58 +00:00
( reset )
2014-10-15 00:51:30 +00:00
( new - trace "jump-if-backward" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
2014-10-07 15:42:54 +00:00
( ( 1 integer ) < - copy ( 2 literal ) )
( ( 2 integer ) < - copy ( 1 literal ) )
2014-10-07 16:29:40 +00:00
; loop
2014-07-31 08:47:32 +00:00
( ( 2 integer ) < - add ( 2 integer ) ( 2 integer ) )
2014-12-13 01:54:31 +00:00
( ( 3 boolean ) < - equal ( 1 integer ) ( 2 integer ) )
2014-10-15 00:51:30 +00:00
( jump - if ( 3 boolean ) ( - 3 offset ) ) ; to loop
2014-10-07 15:42:54 +00:00
( ( 4 integer ) < - copy ( 3 literal ) )
2014-07-17 16:21:27 +00:00
( reply )
2014-11-25 05:09:07 +00:00
( ( 3 integer ) < - copy ( 34 literal ) )
] ) ) )
2014-10-18 23:58:51 +00:00
( run ' main )
2014-07-17 16:21:27 +00:00
; ? ( prn memory * )
( if ( ~ iso memory * ( obj 1 2 2 4 3 nil 4 3 ) )
2014-10-15 00:51:30 +00:00
( prn "F - 'jump-if' can take a negative offset to make backward jumps" ) )
2014-11-27 16:49:18 +00:00
( reset )
( new - trace "jump-label" )
( add - code
' ( ( def main [
( ( 1 integer ) < - copy ( 2 literal ) )
( ( 2 integer ) < - copy ( 1 literal ) )
loop
( ( 2 integer ) < - add ( 2 integer ) ( 2 integer ) )
2014-12-13 01:54:31 +00:00
( ( 3 boolean ) < - equal ( 1 integer ) ( 2 integer ) )
2014-11-27 16:49:18 +00:00
( 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 * )
( if ( ~ iso memory * ( obj 1 2 2 4 3 nil 4 3 ) )
( prn "F - 'jump-if' can take a negative offset to make backward jumps" ) )
2014-07-17 16:21:27 +00:00
2014-10-10 22:04:14 +00:00
; 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' .
2014-08-19 17:31:58 +00:00
( reset )
2014-10-07 17:26:14 +00:00
( new - trace "direct-addressing" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
2014-10-07 15:42:54 +00:00
( ( 1 integer ) < - copy ( 34 literal ) )
2014-11-25 05:09:07 +00:00
( ( 2 integer ) < - copy ( 1 integer ) )
] ) ) )
2014-10-18 23:58:51 +00:00
( run ' main )
2014-07-31 09:18:00 +00:00
; ? ( prn memory * )
( if ( ~ iso memory * ( obj 1 34 2 34 ) )
( prn "F - 'copy' performs direct addressing" ) )
2014-10-10 22:04:14 +00:00
; '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 .
2014-08-19 17:31:58 +00:00
( reset )
2014-10-07 17:26:14 +00:00
( new - trace "indirect-addressing" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
2014-11-01 09:23:32 +00:00
( ( 1 integer - address ) < - copy ( 2 literal ) ) ; unsafe ; can ' t do this in general
2014-10-07 15:42:54 +00:00
( ( 2 integer ) < - copy ( 34 literal ) )
2014-11-25 05:09:07 +00:00
( ( 3 integer ) < - copy ( 1 integer - address deref ) )
] ) ) )
2014-10-18 23:58:51 +00:00
( run ' main )
2014-07-31 09:18:00 +00:00
; ? ( prn memory * )
( if ( ~ iso memory * ( obj 1 2 2 34 3 34 ) )
2014-07-31 09:27:41 +00:00
( prn "F - 'copy' performs indirect addressing" ) )
2014-07-31 09:18:00 +00:00
2014-10-10 22:04:14 +00:00
; 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 ) .
2014-08-19 17:31:58 +00:00
( reset )
2014-10-07 17:26:14 +00:00
( new - trace "indirect-addressing-oarg" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
2014-10-07 15:42:54 +00:00
( ( 1 integer - address ) < - copy ( 2 literal ) )
( ( 2 integer ) < - copy ( 34 literal ) )
2014-11-25 05:09:07 +00:00
( ( 1 integer - address deref ) < - add ( 2 integer ) ( 2 literal ) )
] ) ) )
2014-10-18 23:58:51 +00:00
( run ' main )
2014-07-31 10:46:05 +00:00
; ? ( prn memory * )
2014-10-07 16:29:40 +00:00
( if ( ~ iso memory * ( obj 1 2 2 36 ) )
2014-08-22 03:08:22 +00:00
( prn "F - instructions can perform indirect addressing on output arg" ) )
2014-07-31 10:46:05 +00:00
2014-11-07 21:00:44 +00:00
; ; Compound data types
;
2014-10-10 22:04:14 +00:00
; Until now we ' ve dealt with scalar types like integers and booleans and
2014-10-28 18:32:00 +00:00
; addresses , where mu looks like other assembly languages . In addition , mu
; provides first - class support for compound types: arrays and records .
2014-10-10 22:04:14 +00:00
;
; 'get' accesses fields in records
; 'index' accesses indices in arrays
2014-10-28 18:32:00 +00:00
;
; 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 types * in mu . arc for the complete list of types ; we ' ll add to it over
; time ) .
2014-10-10 22:04:14 +00:00
2014-11-07 05:45:07 +00:00
; first a sanity check that the table of types is consistent
( reset )
( each ( typ typeinfo ) types *
( when typeinfo ! record
( assert ( is typeinfo ! size ( len typeinfo ! elems ) ) )
( when typeinfo ! fields
( assert ( is typeinfo ! size ( len typeinfo ! fields ) ) ) ) ) )
2014-08-20 04:33:48 +00:00
( reset )
2014-10-07 17:26:14 +00:00
( new - trace "get-record" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
2014-10-07 15:42:54 +00:00
( ( 1 integer ) < - copy ( 34 literal ) )
( ( 2 boolean ) < - copy ( nil literal ) )
2014-08-20 04:33:48 +00:00
( ( 3 boolean ) < - get ( 1 integer - boolean - pair ) ( 1 offset ) )
2014-11-25 05:09:07 +00:00
( ( 4 integer ) < - get ( 1 integer - boolean - pair ) ( 0 offset ) )
] ) ) )
2014-11-01 00:35:24 +00:00
; ? ( set dump - trace * )
2014-10-18 23:58:51 +00:00
( run ' main )
2014-08-20 04:33:48 +00:00
; ? ( prn memory * )
( if ( ~ iso memory * ( obj 1 34 2 nil 3 nil 4 34 ) )
( prn "F - 'get' accesses fields of records" ) )
2014-10-05 22:02:28 +00:00
( reset )
2014-10-07 17:26:14 +00:00
( new - trace "get-indirect" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
2014-10-07 15:42:54 +00:00
( ( 1 integer ) < - copy ( 34 literal ) )
( ( 2 boolean ) < - copy ( nil literal ) )
( ( 3 integer - boolean - pair - address ) < - copy ( 1 literal ) )
2014-10-05 22:02:28 +00:00
( ( 4 boolean ) < - get ( 3 integer - boolean - pair - address deref ) ( 1 offset ) )
2014-11-25 05:09:07 +00:00
( ( 5 integer ) < - get ( 3 integer - boolean - pair - address deref ) ( 0 offset ) )
] ) ) )
2014-11-01 00:35:24 +00:00
; ? ( set dump - trace * )
2014-10-18 23:58:51 +00:00
( run ' main )
2014-10-05 22:02:28 +00:00
; ? ( prn memory * )
( if ( ~ iso memory * ( obj 1 34 2 nil 3 1 4 nil 5 34 ) )
( prn "F - 'get' accesses fields of record address" ) )
2014-12-04 02:52:56 +00:00
( def memory - contains ( addr value )
; ? ( prn "Looking for @value starting at @addr" )
( loop ( addr addr
idx 0 )
; ? ( prn "@idx vs @addr" )
( if ( >= idx len . value )
t
( ~ is memory * . addr value . idx )
( do1 nil
( prn "@addr should contain @value.idx but contains @memory*.addr" ) )
: else
( recur ( + addr 1 ) ( + idx 1 ) ) ) ) )
2014-11-29 03:52:50 +00:00
( reset )
( new - trace "get-indirect-repeated" )
( add - code
' ( ( def 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 )
2014-12-04 02:52:56 +00:00
( if ( ~ memory - contains 6 ' ( 35 36 34 ) )
2014-11-29 03:52:50 +00:00
( prn "F - 'get' can deref multiple times" ) )
2014-12-04 02:52:56 +00:00
; ? ( quit )
2014-11-29 03:52:50 +00:00
2014-08-22 03:08:22 +00:00
( reset )
2014-10-07 17:26:14 +00:00
( new - trace "get-compound-field" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
2014-10-07 15:42:54 +00:00
( ( 1 integer ) < - copy ( 34 literal ) )
( ( 2 integer ) < - copy ( 35 literal ) )
( ( 3 integer ) < - copy ( 36 literal ) )
2014-11-25 05:09:07 +00:00
( ( 4 integer - integer - pair ) < - get ( 1 integer - point - pair ) ( 1 offset ) )
] ) ) )
2014-10-18 23:58:51 +00:00
( run ' main )
2014-08-22 03:08:22 +00:00
; ? ( prn memory * )
( if ( ~ iso memory * ( obj 1 34 2 35 3 36 4 35 5 36 ) )
( prn "F - 'get' accesses fields spanning multiple locations" ) )
2014-10-05 18:34:23 +00:00
( reset )
2014-10-07 17:26:14 +00:00
( new - trace "get-address" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
2014-10-07 15:42:54 +00:00
( ( 1 integer ) < - copy ( 34 literal ) )
2014-10-29 04:17:09 +00:00
( ( 2 boolean ) < - copy ( t literal ) )
2014-11-25 05:09:07 +00:00
( ( 3 boolean - address ) < - get - address ( 1 integer - boolean - pair ) ( 1 offset ) )
] ) ) )
2014-10-18 23:58:51 +00:00
( run ' main )
2014-10-05 18:34:23 +00:00
; ? ( prn memory * )
( if ( ~ iso memory * ( obj 1 34 2 t 3 2 ) )
( prn "F - 'get-address' returns address of fields of records" ) )
2014-10-05 22:10:29 +00:00
( reset )
2014-10-07 17:26:14 +00:00
( new - trace "get-address-indirect" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
2014-10-07 15:42:54 +00:00
( ( 1 integer ) < - copy ( 34 literal ) )
2014-10-29 04:17:09 +00:00
( ( 2 boolean ) < - copy ( t literal ) )
2014-10-07 15:42:54 +00:00
( ( 3 integer - boolean - pair - address ) < - copy ( 1 literal ) )
2014-11-25 05:09:07 +00:00
( ( 4 boolean - address ) < - get - address ( 3 integer - boolean - pair - address deref ) ( 1 offset ) )
] ) ) )
2014-10-18 23:58:51 +00:00
( run ' main )
2014-10-05 22:10:29 +00:00
; ? ( prn memory * )
( if ( ~ iso memory * ( obj 1 34 2 t 3 1 4 2 ) )
2014-10-06 03:03:03 +00:00
( prn "F - 'get-address' accesses fields of record address" ) )
2014-10-05 22:10:29 +00:00
2014-08-21 07:57:57 +00:00
( reset )
2014-11-01 04:22:23 +00:00
( new - trace "index-literal" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
2014-10-07 15:42:54 +00:00
( ( 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 ) )
2014-11-25 05:09:07 +00:00
( ( 6 integer - boolean - pair ) < - index ( 1 integer - boolean - pair - array ) ( 1 literal ) )
] ) ) )
2014-10-18 23:58:51 +00:00
( run ' main )
2014-08-21 07:57:57 +00:00
; ? ( prn memory * )
2014-10-05 18:32:25 +00:00
( if ( ~ iso memory * ( obj 1 2 2 23 3 nil 4 24 5 t 6 24 7 t ) )
2014-10-06 03:03:03 +00:00
( prn "F - 'index' accesses indices of arrays" ) )
2014-11-01 09:23:32 +00:00
; ? ( quit )
2014-10-06 03:03:03 +00:00
( reset )
2014-11-01 04:22:23 +00:00
( new - trace "index-direct" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
2014-10-07 15:42:54 +00:00
( ( 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 ) )
2014-11-25 05:09:07 +00:00
( ( 7 integer - boolean - pair ) < - index ( 1 integer - boolean - pair - array ) ( 6 integer ) )
] ) ) )
2014-10-18 23:58:51 +00:00
( run ' main )
2014-10-06 03:03:03 +00:00
; ? ( prn memory * )
( if ( ~ 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" ) )
2014-11-01 09:23:32 +00:00
; ? ( quit )
( reset )
( new - trace "index-indirect" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
2014-11-01 09:23:32 +00:00
( ( 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 ) )
2014-11-25 05:09:07 +00:00
( ( 8 integer - boolean - pair ) < - index ( 7 integer - boolean - pair - array - address deref ) ( 6 integer ) )
] ) ) )
2014-11-01 09:23:32 +00:00
; ? ( = dump - trace * ( obj blacklist ' ( "sz" "m" "setm" "addr" "cvt0" "cvt1" ) ) )
; ? ( set dump - trace * )
( run ' main )
; ? ( prn memory * )
( if ( ~ 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 )
2014-08-22 03:33:29 +00:00
2014-11-29 03:28:13 +00:00
( reset )
( new - trace "index-indirect-multiple" )
( add - code
' ( ( def 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 )
( if ( ~ is memory * .8 24 )
( prn "F - 'index' can deref multiple times" ) )
2014-10-05 18:34:23 +00:00
( reset )
2014-10-07 17:26:14 +00:00
( new - trace "index-address" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
2014-10-07 15:42:54 +00:00
( ( 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 ) )
2014-11-25 05:09:07 +00:00
( ( 7 integer - boolean - pair - address ) < - index - address ( 1 integer - boolean - pair - array ) ( 6 integer ) )
] ) ) )
2014-10-18 23:58:51 +00:00
( run ' main )
2014-10-05 18:34:23 +00:00
; ? ( prn memory * )
2014-10-06 03:03:03 +00:00
( if ( ~ 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" ) )
2014-10-05 18:34:23 +00:00
2014-11-01 09:23:32 +00:00
( reset )
( new - trace "index-address-indirect" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
2014-11-01 09:23:32 +00:00
( ( 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 ) )
2014-11-25 05:09:07 +00:00
( ( 8 integer - boolean - pair - address ) < - index - address ( 7 integer - boolean - pair - array - address deref ) ( 6 integer ) )
] ) ) )
2014-11-01 09:23:32 +00:00
( run ' main )
; ? ( prn memory * )
( if ( ~ 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" ) )
2014-10-10 22:04:14 +00:00
; Array values know their length . Record lengths are saved in the types table .
2014-08-22 03:33:29 +00:00
( reset )
2014-10-07 17:26:14 +00:00
( new - trace "len-array" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
2014-10-07 15:42:54 +00:00
( ( 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 ) )
2014-12-13 01:54:31 +00:00
( ( 6 integer ) < - length ( 1 integer - boolean - pair - array ) )
2014-11-25 05:09:07 +00:00
] ) ) )
2014-10-18 23:58:51 +00:00
( run ' main )
2014-08-22 03:33:29 +00:00
; ? ( prn memory * )
2014-12-13 01:54:31 +00:00
( if ( ~ is memory * .6 2 )
( prn "F - 'length' of array" ) )
2014-10-05 18:32:25 +00:00
2014-11-01 09:16:16 +00:00
( reset )
( new - trace "len-array-indirect" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
2014-11-01 09:16:16 +00:00
( ( 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 ) )
2014-12-13 01:54:31 +00:00
( ( 7 integer ) < - length ( 6 integer - boolean - pair - array - address deref ) )
2014-11-25 05:09:07 +00:00
] ) ) )
2014-11-01 09:16:16 +00:00
; ? ( set dump - trace * )
; ? ( = dump - trace * ( obj blacklist ' ( "sz" "m" "setm" "addr" "cvt0" "cvt1" ) ) )
( run ' main )
; ? ( prn memory * )
2014-12-13 01:54:31 +00:00
( if ( ~ is memory * .7 2 )
( prn "F - 'length' of array address" ) )
2014-11-01 09:16:16 +00:00
2014-10-10 22:04:14 +00:00
; 'sizeof' is a helper to determine the amount of memory required by a type .
2014-11-27 03:50:40 +00:00
; Only for non - arrays .
2014-10-10 22:04:14 +00:00
2014-10-05 18:32:25 +00:00
( reset )
2014-10-07 17:26:14 +00:00
( new - trace "sizeof-record" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
( ( 1 integer ) < - sizeof ( integer - boolean - pair literal ) )
] ) ) )
2014-10-18 23:58:51 +00:00
( run ' main )
2014-10-05 18:32:25 +00:00
; ? ( prn memory * )
2014-10-07 16:29:40 +00:00
( if ( ~ is memory * .1 2 )
2014-10-05 18:32:25 +00:00
( prn "F - 'sizeof' returns space required by arg" ) )
( reset )
2014-10-07 17:26:14 +00:00
( new - trace "sizeof-record-not-len" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
( ( 1 integer ) < - sizeof ( integer - point - pair literal ) )
] ) ) )
2014-10-18 23:58:51 +00:00
( run ' main )
2014-10-05 18:32:25 +00:00
; ? ( prn memory * )
2014-11-27 03:50:40 +00:00
( if ( is memory * .1 2 )
2014-10-05 18:32:25 +00:00
( prn "F - 'sizeof' is different from number of elems" ) )
2014-08-21 07:57:57 +00:00
2014-10-11 18:17:04 +00:00
; Regardless of a type ' s length , you can move it around just like a primitive .
2014-11-29 02:40:47 +00:00
2014-08-20 06:37:50 +00:00
( reset )
2014-11-28 04:09:45 +00:00
( new - trace "copy-record" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
2014-10-07 15:42:54 +00:00
( ( 1 integer ) < - copy ( 34 literal ) )
( ( 2 boolean ) < - copy ( nil literal ) )
( ( 4 boolean ) < - copy ( t literal ) )
2014-11-25 05:09:07 +00:00
( ( 3 integer - boolean - pair ) < - copy ( 1 integer - boolean - pair ) )
] ) ) )
2014-10-18 23:58:51 +00:00
( run ' main )
2014-08-20 06:37:50 +00:00
; ? ( prn memory * )
( if ( ~ iso memory * ( obj 1 34 2 nil 3 34 4 nil ) )
2014-08-22 03:08:22 +00:00
( prn "F - ops can operate on records spanning multiple locations" ) )
2014-08-20 06:37:50 +00:00
2014-11-29 04:11:59 +00:00
( reset )
( new - trace "copy-record2" )
( add - code
' ( ( def 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 * )
( if ( ~ 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" ) )
2014-10-11 03:20:55 +00:00
; 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
2014-10-24 18:38:02 +00:00
; 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
2014-10-11 03:20:55 +00:00
( reset )
( new - trace "tagged-value" )
2014-11-01 00:35:24 +00:00
; ? ( = dump - trace * ( obj blacklist ' ( "sz" "m" "setm" "addr" "cvt0" "cvt1" ) ) )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
2014-10-11 03:26:06 +00:00
( ( 1 type ) < - copy ( integer - address literal ) )
2014-10-12 18:29:02 +00:00
( ( 2 integer - address ) < - copy ( 34 literal ) ) ; pointer to nowhere
2014-11-25 05:09:07 +00:00
( ( 3 integer - address ) ( 4 boolean ) < - maybe - coerce ( 1 tagged - value ) ( integer - address literal ) )
] ) ) )
2014-12-04 10:50:33 +00:00
; ? ( set dump - trace * )
2014-10-18 23:58:51 +00:00
( run ' main )
2014-10-11 03:20:55 +00:00
; ? ( prn memory * )
2014-11-01 00:35:24 +00:00
; ? ( prn completed - routines * )
2014-11-21 22:36:22 +00:00
( each routine completed - routines *
( aif rep . routine ! error ( prn "error - " it ) ) )
2014-12-04 02:52:56 +00:00
( if ( ~ memory - contains 3 ' ( 34 t ) )
2014-10-11 03:20:55 +00:00
( prn "F - 'maybe-coerce' copies value only if type tag matches" ) )
2014-11-01 00:35:24 +00:00
; ? ( quit )
2014-10-11 03:20:55 +00:00
2014-10-12 18:29:02 +00:00
( reset )
( new - trace "tagged-value-2" )
; ? ( set dump - trace * )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
2014-10-12 18:29:02 +00:00
( ( 1 type ) < - copy ( integer - address literal ) )
( ( 2 integer - address ) < - copy ( 34 literal ) ) ; pointer to nowhere
2014-11-25 05:09:07 +00:00
( ( 3 integer - address ) ( 4 boolean ) < - maybe - coerce ( 1 tagged - value ) ( boolean - address literal ) )
] ) ) )
2014-10-18 23:58:51 +00:00
( run ' main )
2014-10-12 21:10:14 +00:00
; ? ( prn memory * )
2014-12-04 02:52:56 +00:00
( if ( ~ memory - contains 3 ' ( 0 nil ) )
2014-10-12 18:29:02 +00:00
( prn "F - 'maybe-coerce' doesn't copy value when type tag doesn't match" ) )
2014-10-24 18:38:02 +00:00
( reset )
( new - trace "save-type" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
2014-10-25 09:32:30 +00:00
( ( 1 integer - address ) < - copy ( 34 literal ) ) ; pointer to nowhere
2014-11-25 05:09:07 +00:00
( ( 2 tagged - value ) < - save - type ( 1 integer - address ) )
] ) ) )
2014-10-24 18:38:02 +00:00
( run ' main )
; ? ( prn memory * )
2014-10-25 09:32:30 +00:00
( if ( ~ iso memory * ( obj 1 34 2 ' integer - address 3 34 ) )
2014-10-24 18:38:02 +00:00
( prn "F - 'save-type' saves the type of a value at runtime, turning it into a tagged-value" ) )
2014-10-12 19:01:04 +00:00
( reset )
( new - trace "new-tagged-value" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
2014-10-12 19:01:04 +00:00
( ( 1 integer - address ) < - copy ( 34 literal ) ) ; pointer to nowhere
( ( 2 tagged - value - address ) < - new - tagged - value ( integer - address literal ) ( 1 integer - address ) )
2014-11-25 05:09:07 +00:00
( ( 3 integer - address ) ( 4 boolean ) < - maybe - coerce ( 2 tagged - value - address deref ) ( integer - address literal ) )
] ) ) )
2014-11-01 00:35:24 +00:00
; ? ( = dump - trace * ( obj blacklist ' ( "sz" "m" "setm" "addr" "cvt0" "cvt1" "sizeof" ) ) )
2014-10-18 23:58:51 +00:00
( run ' main )
2014-10-12 19:01:04 +00:00
; ? ( prn memory * )
2014-12-04 02:52:56 +00:00
( if ( ~ memory - contains 3 ' ( 34 t ) )
2014-10-12 19:01:04 +00:00
( prn "F - 'new-tagged-value' is the converse of 'maybe-coerce'" ) )
2014-11-01 00:35:24 +00:00
; ? ( quit )
2014-10-12 19:01:04 +00:00
2014-10-12 21:10:14 +00:00
; Now that we can record types for values we can construct a dynamically typed
; list .
( reset )
( new - trace "list" )
; ? ( set dump - trace * )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
2014-10-12 21:10:14 +00:00
; 1 points at first node: tagged - value ( int 34 )
2014-10-31 00:24:51 +00:00
( ( 1 list - address ) < - new ( list literal ) )
2014-10-12 21:27:26 +00:00
( ( 2 tagged - value - address ) < - list - value - address ( 1 list - address ) )
2014-10-12 21:10:14 +00:00
( ( 3 type - address ) < - get - address ( 2 tagged - value - address deref ) ( 0 offset ) )
( ( 3 type - address deref ) < - copy ( integer literal ) )
( ( 4 location ) < - get - address ( 2 tagged - value - address deref ) ( 1 offset ) )
( ( 4 location deref ) < - copy ( 34 literal ) )
( ( 5 list - address - address ) < - get - address ( 1 list - address deref ) ( 1 offset ) )
2014-10-31 00:24:51 +00:00
( ( 5 list - address - address deref ) < - new ( list literal ) )
2014-10-12 21:10:14 +00:00
; 6 points at second node: tagged - value ( boolean t )
( ( 6 list - address ) < - copy ( 5 list - address - address deref ) )
2014-10-12 21:32:23 +00:00
( ( 7 tagged - value - address ) < - list - value - address ( 6 list - address ) )
( ( 8 type - address ) < - get - address ( 7 tagged - value - address deref ) ( 0 offset ) )
( ( 8 type - address deref ) < - copy ( boolean literal ) )
( ( 9 location ) < - get - address ( 7 tagged - value - address deref ) ( 1 offset ) )
2014-10-24 18:36:38 +00:00
( ( 9 location deref ) < - copy ( t literal ) )
( ( 10 list - address ) < - get ( 6 list - address deref ) ( 1 offset ) )
2014-11-25 05:09:07 +00:00
] ) ) )
2014-12-04 10:50:33 +00:00
( let routine make - routine ! main
( enq routine running - routines * )
( let first rep . routine ! alloc
( run )
; ? ( prn memory * )
( if ( 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" ) ) ) )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def test2 [
( ( 10 list - address ) < - list - next ( 1 list - address ) )
] ) ) )
2014-10-13 01:04:29 +00:00
( run ' test2 )
; ? ( prn memory * )
( if ( ~ is memory * .10 memory * .6 )
( prn "F - 'list-next can move a list pointer to the next node" ) )
2014-10-12 21:10:14 +00:00
2014-10-25 09:32:30 +00:00
; 'new-list' takes a variable number of args and constructs a list containing
; them .
( reset )
( new - trace "new-list" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
( ( 1 integer ) < - new - list ( 3 literal ) ( 4 literal ) ( 5 literal ) )
] ) ) )
2014-11-01 00:35:24 +00:00
; ? ( = dump - trace * ( obj blacklist ' ( "sz" "m" "setm" "addr" "cvt0" "cvt1" "sizeof" ) ) )
2014-10-25 09:32:30 +00:00
( run ' main )
; ? ( prn memory * )
( let first memory * .1
; ? ( prn first )
( if ( 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 - 'new-list' can construct a list of integers" ) ) )
2014-11-07 21:00:44 +00:00
; ; Functions
;
2014-10-10 22:04:14 +00:00
; Just like the table of types is centralized , functions are conceptualized as
2014-11-01 19:38:33 +00:00
; a centralized table of operations just like the "primitives" we ' ve seen so
2014-10-10 22:04:14 +00:00
; far . If you create a function you can call it like any other op .
( reset )
( new - trace "new-fn" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def test1 [
( ( 3 integer ) < - add ( 1 integer ) ( 2 integer ) )
] )
( def main [
2014-10-10 22:04:14 +00:00
( ( 1 integer ) < - copy ( 1 literal ) )
( ( 2 integer ) < - copy ( 3 literal ) )
2014-11-25 05:09:07 +00:00
( test1 )
] ) ) )
2014-10-10 22:04:14 +00:00
( run ' main )
; ? ( prn memory * )
( if ( ~ 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" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def test1 [
( ( 1 integer ) < - copy ( 1 literal ) )
] )
( def main [
( test1 )
] ) ) )
2014-11-06 19:36:16 +00:00
; ? ( = dump - trace * ( obj whitelist ' ( "run" ) ) )
( run ' main )
( if ( ~ is 2 curr - cycle * )
( prn "F - calling a user-defined function runs its instructions exactly once " curr - cycle * ) )
2014-10-10 22:04:14 +00:00
; ? ( 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" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def test1 [
2014-10-10 22:04:14 +00:00
( ( 3 integer ) < - add ( 1 integer ) ( 2 integer ) )
( reply )
2014-11-25 05:09:07 +00:00
( ( 4 integer ) < - copy ( 34 literal ) )
] )
( def main [
2014-10-10 22:04:14 +00:00
( ( 1 integer ) < - copy ( 1 literal ) )
( ( 2 integer ) < - copy ( 3 literal ) )
2014-11-25 05:09:07 +00:00
( test1 )
] ) ) )
2014-10-10 22:04:14 +00:00
( run ' main )
; ? ( prn memory * )
( if ( ~ 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" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def test1 [
( ( 3 integer ) < - test2 )
] )
( def test2 [
( reply ( 2 integer ) )
] )
( def main [
2014-10-10 22:04:14 +00:00
( ( 2 integer ) < - copy ( 34 literal ) )
2014-11-25 05:09:07 +00:00
( test1 )
] ) ) )
2014-10-10 22:04:14 +00:00
( run ' main )
; ? ( prn memory * )
( if ( ~ iso memory * ( obj 2 34 3 34 ) )
( prn "F - 'reply' stops executing any callers as necessary" ) )
; ? ( quit )
( reset )
( new - trace "new-fn-reply-once" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def test1 [
2014-10-10 22:04:14 +00:00
( ( 3 integer ) < - add ( 1 integer ) ( 2 integer ) )
( reply )
2014-11-25 05:09:07 +00:00
( ( 4 integer ) < - copy ( 34 literal ) )
] )
( def main [
2014-10-10 22:04:14 +00:00
( ( 1 integer ) < - copy ( 1 literal ) )
( ( 2 integer ) < - copy ( 3 literal ) )
2014-11-25 05:09:07 +00:00
( test1 )
] ) ) )
2014-11-06 19:36:16 +00:00
; ? ( = dump - trace * ( obj whitelist ' ( "run" ) ) )
( run ' main )
( if ( ~ is 5 curr - cycle * )
( prn "F - 'reply' executes instructions exactly once " curr - cycle * ) )
2014-10-10 22:04:14 +00:00
; ? ( quit )
( reset )
( new - trace "new-fn-arg-sequential" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def test1 [
2014-12-13 01:54:31 +00:00
( ( 4 integer ) < - next - input )
( ( 5 integer ) < - next - input )
2014-10-10 22:04:14 +00:00
( ( 3 integer ) < - add ( 4 integer ) ( 5 integer ) )
( reply )
2014-11-25 05:09:07 +00:00
( ( 4 integer ) < - copy ( 34 literal ) )
] )
( def main [
2014-10-10 22:04:14 +00:00
( ( 1 integer ) < - copy ( 1 literal ) )
( ( 2 integer ) < - copy ( 3 literal ) )
( test1 ( 1 integer ) ( 2 integer ) )
2014-11-25 05:09:07 +00:00
] ) ) )
2014-10-10 22:04:14 +00:00
( run ' main )
; ? ( prn memory * )
( if ( ~ iso memory * ( obj 1 1 2 3 3 4
2014-11-27 14:04:25 +00:00
; test1 ' s temporaries
2014-10-10 22:04:14 +00:00
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" )
2014-11-01 04:16:17 +00:00
; ? ( set dump - trace * )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def test1 [
2014-12-13 01:54:31 +00:00
( ( 5 integer ) < - input ( 1 literal ) )
( ( 4 integer ) < - input ( 0 literal ) )
2014-10-10 22:04:14 +00:00
( ( 3 integer ) < - add ( 4 integer ) ( 5 integer ) )
( reply )
2014-11-27 14:04:25 +00:00
( ( 4 integer ) < - copy ( 34 literal ) ) ; should never run
] )
2014-11-25 05:09:07 +00:00
( def main [
2014-10-10 22:04:14 +00:00
( ( 1 integer ) < - copy ( 1 literal ) )
( ( 2 integer ) < - copy ( 3 literal ) )
( test1 ( 1 integer ) ( 2 integer ) )
2014-11-25 05:09:07 +00:00
] ) ) )
2014-10-10 22:04:14 +00:00
( run ' main )
; ? ( prn memory * )
( if ( ~ iso memory * ( obj 1 1 2 3 3 4
2014-11-27 14:04:25 +00:00
; test ' s temporaries
2014-10-10 22:04:14 +00:00
4 1 5 3 ) )
( prn "F - 'arg' with index can access function call arguments out of order" ) )
; ? ( quit )
2014-11-27 14:16:02 +00:00
( reset )
( new - trace "new-fn-arg-random-then-sequential" )
; ? ( set dump - trace * )
( add - code
' ( ( def test1 [
2014-12-13 01:54:31 +00:00
( _ < - input ( 1 literal ) )
( ( 1 integer ) < - next - input ) ; takes next arg after index 1
2014-11-27 14:16:02 +00:00
] ) ; should never run
( def main [
( test1 ( 1 literal ) ( 2 literal ) ( 3 literal ) )
] ) ) )
( run ' main )
; ? ( prn memory * )
( if ( ~ iso memory * ( obj 1 3 ) )
( prn "F - 'arg' with index resets index for later calls" ) )
; ? ( quit )
2014-10-12 17:49:08 +00:00
( reset )
( new - trace "new-fn-arg-status" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def test1 [
2014-12-13 01:54:31 +00:00
( ( 4 integer ) ( 5 boolean ) < - next - input )
2014-11-25 05:09:07 +00:00
] )
( def main [
2014-10-12 17:49:08 +00:00
( test1 ( 1 literal ) )
2014-11-25 05:09:07 +00:00
] ) ) )
2014-10-12 17:49:08 +00:00
( run ' main )
; ? ( prn memory * )
( if ( ~ iso memory * ( obj 4 1 5 t ) )
( prn "F - 'arg' sets a second oarg when arg exists" ) )
; ? ( quit )
2014-10-12 17:17:46 +00:00
( reset )
( new - trace "new-fn-arg-missing" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def test1 [
2014-12-13 01:54:31 +00:00
( ( 4 integer ) < - next - input )
( ( 5 integer ) < - next - input )
2014-11-25 05:09:07 +00:00
] )
( def main [
2014-10-12 17:17:46 +00:00
( test1 ( 1 literal ) )
2014-11-25 05:09:07 +00:00
] ) ) )
2014-10-12 17:17:46 +00:00
( run ' main )
; ? ( prn memory * )
( if ( ~ iso memory * ( obj 4 1 ) )
( prn "F - missing 'arg' doesn't cause error" ) )
; ? ( quit )
2014-10-12 17:23:02 +00:00
( reset )
( new - trace "new-fn-arg-missing-2" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def test1 [
2014-12-13 01:54:31 +00:00
( ( 4 integer ) < - next - input )
( ( 5 integer ) ( 6 boolean ) < - next - input )
2014-11-25 05:09:07 +00:00
] )
( def main [
2014-10-12 17:23:02 +00:00
( test1 ( 1 literal ) )
2014-11-25 05:09:07 +00:00
] ) ) )
2014-10-12 17:23:02 +00:00
( run ' main )
; ? ( prn memory * )
2014-10-12 17:49:08 +00:00
( if ( ~ iso memory * ( obj 4 1 6 nil ) )
( prn "F - missing 'arg' wipes second oarg when provided" ) )
2014-10-12 17:23:02 +00:00
; ? ( quit )
2014-10-12 17:27:23 +00:00
( reset )
( new - trace "new-fn-arg-missing-3" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def test1 [
2014-12-13 01:54:31 +00:00
( ( 4 integer ) < - next - input )
2014-10-12 17:27:23 +00:00
( ( 5 integer ) < - copy ( 34 literal ) )
2014-12-13 01:54:31 +00:00
( ( 5 integer ) ( 6 boolean ) < - next - input )
2014-11-25 05:09:07 +00:00
] )
( def main [
2014-10-12 17:27:23 +00:00
( test1 ( 1 literal ) )
2014-11-25 05:09:07 +00:00
] ) ) )
2014-10-12 17:27:23 +00:00
( run ' main )
; ? ( prn memory * )
2014-10-12 17:49:08 +00:00
( if ( ~ iso memory * ( obj 4 1 6 nil ) )
2014-10-12 17:27:23 +00:00
( prn "F - missing 'arg' consistently wipes its oarg" ) )
; ? ( quit )
2014-10-12 17:49:08 +00:00
( reset )
2014-11-01 19:38:33 +00:00
( new - trace "new-fn-arg-missing-4" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def test1 [
2014-10-12 17:49:08 +00:00
; if given two args , adds them ; if given one arg , increments
2014-12-13 01:54:31 +00:00
( ( 4 integer ) < - next - input )
( ( 5 integer ) ( 6 boolean ) < - next - input )
2014-10-12 17:49:08 +00:00
{ begin
2014-10-15 00:51:30 +00:00
( break - if ( 6 boolean ) )
2014-10-12 17:49:08 +00:00
( ( 5 integer ) < - copy ( 1 literal ) )
}
2014-11-25 05:09:07 +00:00
( ( 7 integer ) < - add ( 4 integer ) ( 5 integer ) )
] )
( def main [
2014-10-12 17:49:08 +00:00
( test1 ( 34 literal ) )
2014-11-25 05:09:07 +00:00
] ) ) )
2014-10-12 17:49:08 +00:00
( run ' main )
; ? ( prn memory * )
( if ( ~ iso memory * ( obj 4 34 5 1 6 nil 7 35 ) )
( prn "F - function with optional second arg" ) )
; ? ( quit )
2014-10-31 22:21:07 +00:00
( reset )
( new - trace "new-fn-arg-by-value" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def test1 [
2014-11-01 19:38:33 +00:00
( ( 1 integer ) < - copy ( 0 literal ) ) ; overwrite caller memory
2014-12-13 01:54:31 +00:00
( ( 2 integer ) < - next - input )
2014-11-25 05:09:07 +00:00
] ) ; arg not clobbered
( def main [
2014-10-31 22:21:07 +00:00
( ( 1 integer ) < - copy ( 34 literal ) )
2014-11-25 05:09:07 +00:00
( test1 ( 1 integer ) )
] ) ) )
2014-10-31 22:21:07 +00:00
( run ' main )
; ? ( prn memory * )
( if ( ~ iso memory * ( obj 1 0 2 34 ) )
( prn "F - 'arg' passes by value" ) )
2014-11-28 04:09:45 +00:00
( reset )
( new - trace "arg-record" )
( add - code
' ( ( def test1 [
2014-12-13 01:54:31 +00:00
( ( 4 integer - boolean - pair ) < - next - input )
2014-11-28 04:09:45 +00:00
] )
( def main [
( ( 1 integer ) < - copy ( 34 literal ) )
( ( 2 boolean ) < - copy ( nil literal ) )
( test1 ( 1 integer - boolean - pair ) )
] ) ) )
( run ' main )
( if ( ~ 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
' ( ( def test1 [
2014-12-13 01:54:31 +00:00
( ( 4 integer - boolean - pair ) < - next - input )
2014-11-28 04:09:45 +00:00
] )
( def 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 * )
( if ( ~ 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" ) )
2014-10-10 22:04:14 +00:00
( reset )
( new - trace "new-fn-reply-oarg" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def test1 [
2014-12-13 01:54:31 +00:00
( ( 4 integer ) < - next - input )
( ( 5 integer ) < - next - input )
2014-10-10 22:04:14 +00:00
( ( 6 integer ) < - add ( 4 integer ) ( 5 integer ) )
( reply ( 6 integer ) )
2014-11-25 05:09:07 +00:00
( ( 4 integer ) < - copy ( 34 literal ) )
] )
( def main [
2014-10-10 22:04:14 +00:00
( ( 1 integer ) < - copy ( 1 literal ) )
( ( 2 integer ) < - copy ( 3 literal ) )
2014-11-25 05:09:07 +00:00
( ( 3 integer ) < - test1 ( 1 integer ) ( 2 integer ) )
] ) ) )
2014-10-10 22:04:14 +00:00
( run ' main )
; ? ( prn memory * )
( if ( ~ iso memory * ( obj 1 1 2 3 3 4
2014-11-27 14:04:25 +00:00
; test1 ' s temporaries
2014-10-10 22:04:14 +00:00
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" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def test1 [
2014-12-13 01:54:31 +00:00
( ( 4 integer ) < - next - input )
( ( 5 integer ) < - next - input )
2014-10-10 22:04:14 +00:00
( ( 6 integer ) < - add ( 4 integer ) ( 5 integer ) )
( reply ( 6 integer ) ( 5 integer ) )
2014-11-25 05:09:07 +00:00
( ( 4 integer ) < - copy ( 34 literal ) )
] )
( def main [
2014-10-10 22:04:14 +00:00
( ( 1 integer ) < - copy ( 1 literal ) )
( ( 2 integer ) < - copy ( 3 literal ) )
2014-11-25 05:09:07 +00:00
( ( 3 integer ) ( 7 integer ) < - test1 ( 1 integer ) ( 2 integer ) )
] ) ) )
2014-10-10 22:04:14 +00:00
( run ' main )
; ? ( prn memory * )
( if ( ~ iso memory * ( obj 1 1 2 3 3 4 7 3
2014-11-27 14:04:25 +00:00
; test1 ' s temporaries
2014-10-10 22:04:14 +00:00
4 1 5 3 6 4 ) )
( prn "F - 'reply' permits a function to return multiple values at once" ) )
2014-10-31 23:22:21 +00:00
( reset )
( new - trace "new-fn-prepare-reply" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def test1 [
2014-12-13 01:54:31 +00:00
( ( 4 integer ) < - next - input )
( ( 5 integer ) < - next - input )
2014-10-31 23:22:21 +00:00
( ( 6 integer ) < - add ( 4 integer ) ( 5 integer ) )
( prepare - reply ( 6 integer ) ( 5 integer ) )
( reply )
2014-11-25 05:09:07 +00:00
( ( 4 integer ) < - copy ( 34 literal ) )
] )
( def main [
2014-10-31 23:22:21 +00:00
( ( 1 integer ) < - copy ( 1 literal ) )
( ( 2 integer ) < - copy ( 3 literal ) )
2014-11-25 05:09:07 +00:00
( ( 3 integer ) ( 7 integer ) < - test1 ( 1 integer ) ( 2 integer ) )
] ) ) )
2014-10-31 23:22:21 +00:00
( run ' main )
; ? ( prn memory * )
( if ( ~ iso memory * ( obj 1 1 2 3 3 4 7 3
2014-11-27 14:04:25 +00:00
; test1 ' s temporaries
2014-10-31 23:22:21 +00:00
4 1 5 3 6 4 ) )
( prn "F - without args, 'reply' returns values from previous 'prepare-reply'." ) )
2014-11-07 21:00:44 +00:00
; ; Structured programming
;
2014-11-24 23:22:06 +00:00
; Our jump operators are quite inconvenient to use , so mu provides a
2014-10-10 22:04:14 +00:00
; lightweight tool called 'convert-braces' to work in a slightly more
; convenient format with nested braces:
;
; {
; some instructions
; {
; more instructions
; }
; }
;
2014-11-25 02:52:15 +00:00
; Braces are like labels in assembly language , they require no special
2014-11-27 06:09:23 +00:00
; parsing . The operations 'loop' and 'break' jump to just after the enclosing
; '{' and '}' respectively .
2014-10-10 22:04:14 +00:00
;
2014-11-27 06:09:23 +00:00
; 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 .
2014-11-27 03:51:29 +00:00
;
; 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 .
2014-10-10 22:04:14 +00:00
2014-10-07 17:26:14 +00:00
( reset )
( new - trace "convert-braces" )
2014-11-27 07:23:44 +00:00
( = traces * ( queue ) )
2014-11-23 14:06:04 +00:00
; ? ( = dump - trace * ( obj whitelist ' ( "c{0" "c{1" ) ) )
2014-10-19 00:57:24 +00:00
( if ( ~ iso ( convert - braces
' ( ( ( 1 integer ) < - copy ( 4 literal ) )
( ( 2 integer ) < - copy ( 2 literal ) )
( ( 3 integer ) < - add ( 2 integer ) ( 2 integer ) )
2014-11-27 16:48:38 +00:00
{ begin ; 'begin' is just a hack because racket turns braces into parens
2014-12-13 01:54:31 +00:00
( ( 4 boolean ) < - not - equal ( 1 integer ) ( 3 integer ) )
2014-11-01 19:40:59 +00:00
( break - if ( 4 boolean ) )
( ( 5 integer ) < - copy ( 34 literal ) )
2014-10-19 00:57:24 +00:00
}
( reply ) ) )
2014-10-07 15:42:54 +00:00
' ( ( ( 1 integer ) < - copy ( 4 literal ) )
( ( 2 integer ) < - copy ( 2 literal ) )
2014-07-31 08:47:32 +00:00
( ( 3 integer ) < - add ( 2 integer ) ( 2 integer ) )
2014-12-13 01:54:31 +00:00
( ( 4 boolean ) < - not - equal ( 1 integer ) ( 3 integer ) )
2014-10-15 00:51:30 +00:00
( jump - if ( 4 boolean ) ( 1 offset ) )
2014-10-07 15:42:54 +00:00
( ( 5 integer ) < - copy ( 34 literal ) )
2014-07-17 16:02:43 +00:00
( reply ) ) )
2014-11-27 16:48:38 +00:00
( prn "F - convert-braces replaces break-if with a jump-if to after the next close-brace" ) )
2014-11-23 14:06:04 +00:00
; ? ( quit )
2014-07-17 16:21:27 +00:00
2014-10-07 17:26:14 +00:00
( reset )
( new - trace "convert-braces-empty-block" )
2014-11-27 07:23:44 +00:00
( = traces * ( queue ) )
2014-11-23 14:06:04 +00:00
; ? ( = dump - trace * ( obj whitelist ' ( "c{0" "c{1" ) ) )
2014-10-19 00:57:24 +00:00
( if ( ~ iso ( convert - braces
' ( ( ( 1 integer ) < - copy ( 4 literal ) )
( ( 2 integer ) < - copy ( 2 literal ) )
( ( 3 integer ) < - add ( 2 integer ) ( 2 integer ) )
{ begin
2014-11-01 19:40:59 +00:00
( break )
2014-10-19 00:57:24 +00:00
}
( reply ) ) )
2014-10-07 15:42:54 +00:00
' ( ( ( 1 integer ) < - copy ( 4 literal ) )
( ( 2 integer ) < - copy ( 2 literal ) )
2014-07-31 08:47:32 +00:00
( ( 3 integer ) < - add ( 2 integer ) ( 2 integer ) )
2014-10-15 00:51:30 +00:00
( jump ( 0 offset ) )
2014-07-17 16:21:27 +00:00
( reply ) ) )
( prn "F - convert-braces works for degenerate blocks" ) )
2014-11-23 14:06:04 +00:00
; ? ( quit )
2014-07-17 16:21:27 +00:00
2014-10-07 17:26:14 +00:00
( reset )
( new - trace "convert-braces-nested-break" )
2014-11-27 07:23:44 +00:00
( = traces * ( queue ) )
2014-10-19 00:57:24 +00:00
( if ( ~ iso ( convert - braces
' ( ( ( 1 integer ) < - copy ( 4 literal ) )
( ( 2 integer ) < - copy ( 2 literal ) )
( ( 3 integer ) < - add ( 2 integer ) ( 2 integer ) )
{ begin
2014-12-13 01:54:31 +00:00
( ( 4 boolean ) < - not - equal ( 1 integer ) ( 3 integer ) )
2014-10-19 00:57:24 +00:00
( break - if ( 4 boolean ) )
{ begin
( ( 5 integer ) < - copy ( 34 literal ) )
}
}
( reply ) ) )
2014-10-07 15:42:54 +00:00
' ( ( ( 1 integer ) < - copy ( 4 literal ) )
( ( 2 integer ) < - copy ( 2 literal ) )
2014-07-31 08:47:32 +00:00
( ( 3 integer ) < - add ( 2 integer ) ( 2 integer ) )
2014-12-13 01:54:31 +00:00
( ( 4 boolean ) < - not - equal ( 1 integer ) ( 3 integer ) )
2014-10-15 00:51:30 +00:00
( jump - if ( 4 boolean ) ( 1 offset ) )
2014-10-07 15:42:54 +00:00
( ( 5 integer ) < - copy ( 34 literal ) )
2014-07-17 16:21:27 +00:00
( reply ) ) )
2014-11-27 16:48:38 +00:00
( prn "F - convert-braces balances braces when converting break" ) )
2014-07-17 16:21:27 +00:00
2014-11-23 14:06:04 +00:00
( reset )
( new - trace "convert-braces-repeated-jump" )
2014-11-27 07:23:44 +00:00
( = traces * ( queue ) )
2014-11-23 14:06:04 +00:00
; ? ( = dump - trace * ( obj whitelist ' ( "c{0" "c{1" ) ) )
( if ( ~ iso ( convert - braces
' ( ( ( 1 integer ) < - copy ( 4 literal ) )
{ begin
( break )
( ( 2 integer ) < - copy ( 5 literal ) )
}
{ begin
( break )
( ( 3 integer ) < - copy ( 6 literal ) )
}
( ( 4 integer ) < - copy ( 7 literal ) ) ) )
' ( ( ( 1 integer ) < - copy ( 4 literal ) )
( jump ( 1 offset ) )
( ( 2 integer ) < - copy ( 5 literal ) )
( jump ( 1 offset ) )
( ( 3 integer ) < - copy ( 6 literal ) )
( ( 4 integer ) < - copy ( 7 literal ) ) ) )
( prn "F - convert-braces handles jumps on jumps" ) )
; ? ( quit )
2014-10-07 17:26:14 +00:00
( reset )
2014-11-27 06:09:23 +00:00
( new - trace "convert-braces-nested-loop" )
2014-11-27 07:23:44 +00:00
( = traces * ( queue ) )
2014-10-19 00:57:24 +00:00
( if ( ~ iso ( convert - braces
' ( ( ( 1 integer ) < - copy ( 4 literal ) )
( ( 2 integer ) < - copy ( 2 literal ) )
{ begin
( ( 3 integer ) < - add ( 2 integer ) ( 2 integer ) )
{ begin
2014-12-13 01:54:31 +00:00
( ( 4 boolean ) < - not - equal ( 1 integer ) ( 3 integer ) )
2014-10-19 00:57:24 +00:00
}
2014-11-27 06:09:23 +00:00
( loop - if ( 4 boolean ) )
2014-10-19 00:57:24 +00:00
( ( 5 integer ) < - copy ( 34 literal ) )
}
( reply ) ) )
2014-10-07 15:42:54 +00:00
' ( ( ( 1 integer ) < - copy ( 4 literal ) )
( ( 2 integer ) < - copy ( 2 literal ) )
2014-07-31 08:47:32 +00:00
( ( 3 integer ) < - add ( 2 integer ) ( 2 integer ) )
2014-12-13 01:54:31 +00:00
( ( 4 boolean ) < - not - equal ( 1 integer ) ( 3 integer ) )
2014-10-15 00:51:30 +00:00
( jump - if ( 4 boolean ) ( - 3 offset ) )
2014-10-07 15:42:54 +00:00
( ( 5 integer ) < - copy ( 34 literal ) )
2014-07-17 16:21:27 +00:00
( reply ) ) )
2014-11-27 16:48:38 +00:00
( prn "F - convert-braces balances braces when converting 'loop'" ) )
2014-07-20 08:34:35 +00:00
2014-11-23 06:26:11 +00:00
( reset )
( new - trace "convert-braces-label" )
2014-11-27 07:23:44 +00:00
( = traces * ( queue ) )
2014-11-23 06:26:11 +00:00
( if ( ~ iso ( convert - braces
' ( ( ( 1 integer ) < - copy ( 4 literal ) )
foo
( ( 2 integer ) < - copy ( 2 literal ) ) ) )
' ( ( ( 1 integer ) < - copy ( 4 literal ) )
foo
( ( 2 integer ) < - copy ( 2 literal ) ) ) )
( prn "F - convert-braces skips past labels" ) )
; ? ( quit )
( reset )
( new - trace "convert-braces-label-increments-offset" )
2014-11-27 07:23:44 +00:00
( = traces * ( queue ) )
2014-11-23 06:26:11 +00:00
( if ( ~ iso ( convert - braces
' ( ( ( 1 integer ) < - copy ( 4 literal ) )
{ begin
( break )
foo
}
( ( 2 integer ) < - copy ( 2 literal ) ) ) )
' ( ( ( 1 integer ) < - copy ( 4 literal ) )
( jump ( 1 offset ) )
foo
( ( 2 integer ) < - copy ( 2 literal ) ) ) )
2014-11-23 14:06:04 +00:00
( prn "F - convert-braces treats labels as instructions" ) )
; ? ( quit )
( reset )
( new - trace "convert-braces-label-increments-offset2" )
2014-11-27 07:23:44 +00:00
( = traces * ( queue ) )
2014-11-23 14:06:04 +00:00
; ? ( = dump - trace * ( obj whitelist ' ( "c{0" "c{1" ) ) )
( if ( ~ iso ( convert - braces
' ( ( ( 1 integer ) < - copy ( 4 literal ) )
{ begin
( break )
foo
}
( ( 2 integer ) < - copy ( 5 literal ) )
{ begin
( break )
( ( 3 integer ) < - copy ( 6 literal ) )
}
( ( 4 integer ) < - copy ( 7 literal ) ) ) )
' ( ( ( 1 integer ) < - copy ( 4 literal ) )
( jump ( 1 offset ) )
foo
( ( 2 integer ) < - copy ( 5 literal ) )
( jump ( 1 offset ) )
( ( 3 integer ) < - copy ( 6 literal ) )
( ( 4 integer ) < - copy ( 7 literal ) ) ) )
( prn "F - convert-braces treats labels as instructions - 2" ) )
2014-11-23 06:26:11 +00:00
; ? ( quit )
2014-11-27 17:30:43 +00:00
( reset )
( new - trace "break-multiple" )
( = traces * ( queue ) )
; ? ( = dump - trace * ( obj whitelist ' ( "-" ) ) )
( if ( ~ 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 )
2014-08-19 17:31:58 +00:00
( reset )
2014-11-27 06:09:23 +00:00
( new - trace "loop" )
2014-10-07 20:26:01 +00:00
; ? ( set dump - trace * )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
2014-10-19 00:57:24 +00:00
( ( 1 integer ) < - copy ( 4 literal ) )
( ( 2 integer ) < - copy ( 1 literal ) )
{ begin
( ( 2 integer ) < - add ( 2 integer ) ( 2 integer ) )
2014-12-13 01:54:31 +00:00
( ( 3 boolean ) < - not - equal ( 1 integer ) ( 2 integer ) )
2014-11-27 06:09:23 +00:00
( loop - if ( 3 boolean ) )
2014-10-19 00:57:24 +00:00
( ( 4 integer ) < - copy ( 34 literal ) )
}
2014-11-25 05:09:07 +00:00
( reply )
] ) ) )
2014-10-07 20:26:01 +00:00
; ? ( each stmt function * ! main
; ? ( prn stmt ) )
( run ' main )
; ? ( prn memory * )
( if ( ~ iso memory * ( obj 1 4 2 4 3 nil 4 34 ) )
2014-11-27 06:09:23 +00:00
( prn "F - 'loop' correctly loops" ) )
2014-10-07 20:26:01 +00:00
; todo: fuzz - test invariant: convert - braces offsets should be robust to any
2014-11-27 06:09:23 +00:00
; number of inner blocks inside but not around the loop block .
2014-10-07 20:26:01 +00:00
( reset )
2014-11-27 06:09:23 +00:00
( new - trace "loop-nested" )
2014-10-07 20:26:01 +00:00
; ? ( set dump - trace * )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
2014-10-19 00:57:24 +00:00
( ( 1 integer ) < - copy ( 4 literal ) )
( ( 2 integer ) < - copy ( 1 literal ) )
{ begin
( ( 2 integer ) < - add ( 2 integer ) ( 2 integer ) )
{ begin
2014-12-13 01:54:31 +00:00
( ( 3 boolean ) < - not - equal ( 1 integer ) ( 2 integer ) )
2014-10-19 00:57:24 +00:00
}
2014-11-27 06:09:23 +00:00
( loop - if ( 3 boolean ) )
2014-10-19 00:57:24 +00:00
( ( 4 integer ) < - copy ( 34 literal ) )
}
2014-11-25 05:09:07 +00:00
( reply )
] ) ) )
2014-10-07 20:26:01 +00:00
; ? ( each stmt function * ! main
; ? ( prn stmt ) )
2014-08-28 19:44:01 +00:00
( run ' main )
2014-07-20 08:34:35 +00:00
; ? ( prn memory * )
( if ( ~ iso memory * ( obj 1 4 2 4 3 nil 4 34 ) )
2014-11-27 16:48:38 +00:00
( prn "F - 'loop' correctly jumps back past nested braces" ) )
2014-07-20 08:34:35 +00:00
2014-08-19 17:31:58 +00:00
( reset )
2014-11-27 06:09:23 +00:00
( new - trace "loop-fail" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
2014-10-19 00:57:24 +00:00
( ( 1 integer ) < - copy ( 4 literal ) )
( ( 2 integer ) < - copy ( 2 literal ) )
{ begin
( ( 2 integer ) < - add ( 2 integer ) ( 2 integer ) )
{ begin
2014-12-13 01:54:31 +00:00
( ( 3 boolean ) < - not - equal ( 1 integer ) ( 2 integer ) )
2014-10-19 00:57:24 +00:00
}
2014-11-27 06:09:23 +00:00
( loop - if ( 3 boolean ) )
2014-10-19 00:57:24 +00:00
( ( 4 integer ) < - copy ( 34 literal ) )
}
2014-11-25 05:09:07 +00:00
( reply )
] ) ) )
2014-08-28 19:44:01 +00:00
( run ' main )
2014-07-20 08:34:35 +00:00
; ? ( prn memory * )
( if ( ~ iso memory * ( obj 1 4 2 4 3 nil 4 34 ) )
2014-11-27 06:09:23 +00:00
( prn "F - 'loop-if' might never trigger" ) )
2014-08-26 19:20:08 +00:00
2014-11-27 17:30:43 +00:00
( reset )
( new - trace "loop-multiple" )
( = traces * ( queue ) )
; ? ( = dump - trace * ( obj whitelist ' ( "-" ) ) )
( if ( ~ 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 )
2014-11-07 21:00:44 +00:00
; ; Variables
;
2014-11-01 20:58:58 +00:00
; 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 .
2014-11-01 19:43:45 +00:00
( reset )
2014-11-23 04:50:54 +00:00
( new - trace "convert-names" )
2014-11-27 07:23:44 +00:00
( = traces * ( queue ) )
2014-11-01 19:43:45 +00:00
( if ( ~ iso ( convert - names
' ( ( ( x integer ) < - copy ( 4 literal ) )
( ( y integer ) < - copy ( 2 literal ) )
( ( z integer ) < - add ( x integer ) ( y integer ) ) ) )
' ( ( ( 1 integer ) < - copy ( 4 literal ) )
( ( 2 integer ) < - copy ( 2 literal ) )
( ( 3 integer ) < - add ( 1 integer ) ( 2 integer ) ) ) )
2014-11-01 20:58:58 +00:00
( prn "F - convert-names renames symbolic names to integer locations" ) )
2014-11-01 19:43:45 +00:00
2014-11-04 21:43:57 +00:00
( reset )
2014-11-23 04:50:54 +00:00
( new - trace "convert-names-compound" )
2014-11-27 07:23:44 +00:00
( = traces * ( queue ) )
2014-11-04 21:43:57 +00:00
( if ( ~ iso ( convert - names
' ( ( ( x integer - boolean - pair ) < - copy ( 4 literal ) )
( ( y integer ) < - copy ( 2 literal ) ) ) )
' ( ( ( 1 integer - boolean - pair ) < - copy ( 4 literal ) )
( ( 3 integer ) < - copy ( 2 literal ) ) ) )
( prn "F - convert-names increments integer locations by the size of the type of the previous var" ) )
2014-11-01 19:43:45 +00:00
( reset )
2014-11-23 04:50:54 +00:00
( new - trace "convert-names-nil" )
2014-11-27 07:23:44 +00:00
( = traces * ( queue ) )
2014-11-01 19:43:45 +00:00
( if ( ~ iso ( convert - names
' ( ( ( x integer ) < - copy ( 4 literal ) )
( ( y integer ) < - copy ( 2 literal ) )
( ( nil integer ) < - add ( x integer ) ( y integer ) ) ) )
' ( ( ( 1 integer ) < - copy ( 4 literal ) )
( ( 2 integer ) < - copy ( 2 literal ) )
( ( nil integer ) < - add ( 1 integer ) ( 2 integer ) ) ) )
( prn "F - convert-names never renames nil" ) )
2014-11-04 06:32:56 +00:00
( reset )
2014-11-23 04:50:54 +00:00
( new - trace "convert-names-global" )
2014-11-27 07:23:44 +00:00
( = traces * ( queue ) )
2014-11-04 06:32:56 +00:00
( if ( ~ iso ( convert - names
' ( ( ( x integer ) < - copy ( 4 literal ) )
( ( y integer global ) < - copy ( 2 literal ) )
( ( default - scope integer ) < - add ( x integer ) ( y integer global ) ) ) )
' ( ( ( 1 integer ) < - copy ( 4 literal ) )
( ( y integer global ) < - copy ( 2 literal ) )
( ( default - scope integer ) < - add ( 1 integer ) ( y integer global ) ) ) )
( prn "F - convert-names never renames global operands" ) )
2014-11-07 21:00:44 +00:00
; kludgy support for 'fork' below
2014-11-01 23:34:33 +00:00
( reset )
2014-11-23 04:50:54 +00:00
( new - trace "convert-names-functions" )
2014-11-27 07:23:44 +00:00
( = traces * ( queue ) )
2014-11-01 23:34:33 +00:00
( if ( ~ iso ( convert - names
' ( ( ( x integer ) < - copy ( 4 literal ) )
( ( y integer ) < - copy ( 2 literal ) )
( ( z fn ) < - add ( x integer ) ( y integer ) ) ) )
' ( ( ( 1 integer ) < - copy ( 4 literal ) )
( ( 2 integer ) < - copy ( 2 literal ) )
( ( z fn ) < - add ( 1 integer ) ( 2 integer ) ) ) )
( prn "F - convert-names never renames nil" ) )
2014-11-04 06:34:58 +00:00
( reset )
2014-11-23 04:50:54 +00:00
( new - trace "convert-names-record-fields" )
2014-11-27 07:23:44 +00:00
( = traces * ( queue ) )
2014-11-04 06:34:58 +00:00
( if ( ~ 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 )
2014-11-23 04:50:54 +00:00
( new - trace "convert-names-record-fields-ambiguous" )
2014-11-27 07:23:44 +00:00
( = traces * ( queue ) )
2014-11-04 06:34:58 +00:00
( if ( 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 )
2014-11-23 04:50:54 +00:00
( new - trace "convert-names-record-fields-ambiguous-2" )
2014-11-27 07:23:44 +00:00
( = traces * ( queue ) )
2014-11-04 06:34:58 +00:00
( if ( 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" ) )
2014-11-04 07:58:06 +00:00
( reset )
2014-11-23 04:50:54 +00:00
( new - trace "convert-names-record-fields-indirect" )
2014-11-27 07:23:44 +00:00
( = traces * ( queue ) )
2014-11-04 07:58:06 +00:00
( if ( ~ 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" ) )
2014-11-07 08:56:42 +00:00
( reset )
2014-11-23 04:50:54 +00:00
( new - trace "convert-names-record-fields-multiple" )
2014-11-27 07:23:44 +00:00
( = traces * ( queue ) )
2014-11-07 08:56:42 +00:00
( if ( ~ 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 )
2014-11-23 06:26:11 +00:00
( reset )
( new - trace "convert-names-label" )
2014-11-27 07:23:44 +00:00
( = traces * ( queue ) )
2014-11-23 06:26:11 +00:00
( if ( ~ iso ( convert - names
' ( ( ( 1 integer ) < - copy ( 4 literal ) )
foo ) )
' ( ( ( 1 integer ) < - copy ( 4 literal ) )
foo ) )
( prn "F - convert-names skips past labels" ) )
; ? ( quit )
2014-11-01 20:57:52 +00:00
; A rudimentary memory allocator . Eventually we want to write this in mu .
2014-11-01 22:06:24 +00:00
;
; No deallocation yet ; let ' s see how much code we can build in mu before we
; feel the need for it .
2014-11-01 20:57:52 +00:00
( reset )
( new - trace "new-primitive" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
( ( 1 integer - address ) < - new ( integer literal ) )
] ) ) )
2014-12-04 10:50:33 +00:00
( let routine make - routine ! main
( enq routine running - routines * )
( let before rep . routine ! alloc
; ? ( set dump - trace * )
( run )
; ? ( prn memory * )
( if ( ~ iso memory * .1 before )
( prn "F - 'new' returns current high-water mark" ) )
( if ( ~ iso rep . routine ! alloc ( + before 1 ) )
( prn "F - 'new' on primitive types increments high-water mark by their size" ) ) ) )
2014-11-01 20:57:52 +00:00
( reset )
( new - trace "new-array-literal" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
( ( 1 type - array - address ) < - new ( type - array literal ) ( 5 literal ) )
] ) ) )
2014-12-04 10:50:33 +00:00
( let routine make - routine ! main
( enq routine running - routines * )
( let before rep . routine ! alloc
( run )
; ? ( prn memory * )
( if ( ~ iso memory * .1 before )
( prn "F - 'new' on array with literal size returns current high-water mark" ) )
( if ( ~ iso rep . routine ! alloc ( + before 6 ) )
( prn "F - 'new' on primitive arrays increments high-water mark by their size" ) ) ) )
2014-11-01 20:57:52 +00:00
( reset )
( new - trace "new-array-direct" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
2014-11-01 20:57:52 +00:00
( ( 1 integer ) < - copy ( 5 literal ) )
2014-11-25 05:09:07 +00:00
( ( 2 type - array - address ) < - new ( type - array literal ) ( 1 integer ) )
] ) ) )
2014-12-04 10:50:33 +00:00
( let routine make - routine ! main
( enq routine running - routines * )
( let before rep . routine ! alloc
( run )
; ? ( prn memory * )
( if ( ~ iso memory * .2 before )
( prn "F - 'new' on array with variable size returns current high-water mark" ) )
( if ( ~ iso rep . routine ! alloc ( + before 6 ) )
( prn "F - 'new' on primitive arrays increments high-water mark by their (variable) size" ) ) ) )
2014-11-01 20:57:52 +00:00
2014-11-01 20:58:58 +00:00
; 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
2014-11-01 22:06:24 +00:00
; variable called default - scope . When you initialize such a variable ( likely
2014-11-01 20:58:58 +00:00
; with a call to our just - defined memory allocator ) mu interprets memory
; locations as offsets from its value . If default - scope is set to 1000 , for
; example , reads and writes to memory location 1 will really go to 1001 .
;
; 'default-scope' 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
2014-11-01 22:06:24 +00:00
; actual scope allocation is independent . So you can define closures , or do
2014-11-01 20:58:58 +00:00
; even more funky things like share locals between two coroutines .
2014-11-01 19:43:45 +00:00
( reset )
( new - trace "set-default-scope" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
2014-11-01 19:43:45 +00:00
( ( default - scope scope - address ) < - new ( scope literal ) ( 2 literal ) )
2014-11-25 05:09:07 +00:00
( ( 1 integer ) < - copy ( 23 literal ) )
] ) ) )
2014-12-04 10:50:33 +00:00
( let routine make - routine ! main
( enq routine running - routines * )
( let before rep . routine ! alloc
; ? ( set dump - trace * )
( run )
; ? ( prn memory * )
( if ( ~ and ( ~ is 23 memory * .1 )
( is 23 ( memory * ( + before 1 ) ) ) )
( prn "F - default-scope implicitly modifies variable locations" ) ) ) )
2014-11-01 19:43:45 +00:00
( reset )
( new - trace "set-default-scope-skips-offset" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
2014-11-01 19:43:45 +00:00
( ( default - scope scope - address ) < - new ( scope literal ) ( 2 literal ) )
2014-11-25 05:09:07 +00:00
( ( 1 integer ) < - copy ( 23 offset ) )
] ) ) )
2014-12-04 10:50:33 +00:00
( let routine make - routine ! main
( enq routine running - routines * )
( let before rep . routine ! alloc
; ? ( set dump - trace * )
( run )
; ? ( prn memory * )
( if ( ~ and ( ~ is 23 memory * .1 )
( is 23 ( memory * ( + before 1 ) ) ) )
( prn "F - default-scope skips 'offset' types just like literals" ) ) ) )
2014-11-01 19:43:45 +00:00
( reset )
( new - trace "default-scope-bounds-check" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
2014-11-01 19:43:45 +00:00
( ( default - scope scope - address ) < - new ( scope literal ) ( 2 literal ) )
2014-11-25 05:09:07 +00:00
( ( 2 integer ) < - copy ( 23 literal ) )
] ) ) )
2014-11-01 19:43:45 +00:00
; ? ( set dump - trace * )
( run ' main )
; ? ( prn memory * )
2014-11-21 22:36:22 +00:00
( let routine ( car completed - routines * )
( if ( no rep . routine ! error )
2014-11-01 19:43:45 +00:00
( prn "F - default-scope checks bounds" ) ) )
( reset )
( new - trace "default-scope-and-get-indirect" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
2014-11-01 19:43:45 +00:00
( ( default - scope scope - address ) < - new ( scope 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 ) )
2014-11-25 05:09:07 +00:00
( ( 3 integer global ) < - get ( 1 integer - boolean - pair - address deref ) ( 0 offset ) )
] ) ) )
2014-11-01 19:43:45 +00:00
; ? ( = dump - trace * ( obj blacklist ' ( "sz" "m" "setm" "addr" "cvt0" "cvt1" ) ) )
( run ' main )
; ? ( prn memory * )
2014-11-21 22:36:22 +00:00
; ? ( prn completed - routines * )
( each routine completed - routines *
( aif rep . routine ! error ( prn "error - " it ) ) )
2014-11-01 19:43:45 +00:00
( if ( ~ is 34 memory * .3 )
( prn "F - indirect 'get' works in the presence of default-scope" ) )
; ? ( quit )
( reset )
( new - trace "default-scope-and-index-indirect" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
2014-11-01 19:43:45 +00:00
( ( default - scope scope - address ) < - new ( scope 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 ) )
2014-11-25 05:09:07 +00:00
( ( 3 integer global ) < - index ( 1 integer - array - address deref ) ( 2 offset ) )
] ) ) )
2014-11-29 03:28:13 +00:00
; ? ( = dump - trace * ( obj whitelist ' ( "run" "array-info" ) ) )
2014-11-01 19:43:45 +00:00
( run ' main )
; ? ( prn memory * )
2014-11-21 22:36:22 +00:00
; ? ( prn completed - routines * )
( each routine completed - routines *
( aif rep . routine ! error ( prn "error - " it ) ) )
2014-11-01 19:43:45 +00:00
( if ( ~ is 34 memory * .3 )
( prn "F - indirect 'index' works in the presence of default-scope" ) )
; ? ( quit )
( reset )
2014-11-25 06:43:47 +00:00
( new - trace "convert-names-default-scope" )
2014-11-27 07:23:44 +00:00
( = traces * ( queue ) )
2014-11-01 19:43:45 +00:00
( if ( ~ iso ( convert - names
' ( ( ( x integer ) < - copy ( 4 literal ) )
( ( y integer ) < - copy ( 2 literal ) )
2014-11-01 22:06:24 +00:00
; unsafe in general ; don 't write random values to ' default - scope '
2014-11-01 19:43:45 +00:00
( ( default - scope integer ) < - add ( x integer ) ( y integer ) ) ) )
' ( ( ( 1 integer ) < - copy ( 4 literal ) )
( ( 2 integer ) < - copy ( 2 literal ) )
( ( default - scope integer ) < - add ( 1 integer ) ( 2 integer ) ) ) )
( prn "F - convert-names never renames default-scope" ) )
( reset )
( new - trace "suppress-default-scope" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
2014-11-01 19:43:45 +00:00
( ( default - scope scope - address ) < - new ( scope literal ) ( 2 literal ) )
2014-11-25 05:09:07 +00:00
( ( 1 integer global ) < - copy ( 23 literal ) )
] ) ) )
2014-12-04 10:50:33 +00:00
( let routine make - routine ! main
( enq routine running - routines * )
( let before rep . routine ! alloc
; ? ( set dump - trace * )
( run )
; ? ( prn memory * )
( if ( ~ and ( is 23 memory * .1 )
( ~ is 23 ( memory * ( + before 1 ) ) ) )
( prn "F - default-scope skipped for locations with metadata 'global'" ) ) ) )
; ? ( quit )
2014-11-01 19:43:45 +00:00
2014-11-29 08:57:06 +00:00
( reset )
( new - trace "array-copy-indirect-scoped" )
( add - code
' ( ( def main [
( ( 10 integer ) < - copy ( 30 literal ) ) ; pretend allocation
( ( default - scope scope - address ) < - copy ( 10 literal ) ) ; unsafe
( ( 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 - array - address ) < - copy ( 11 literal ) ) ; unsafe
( ( 7 integer - boolean - pair - array ) < - copy ( 6 integer - boolean - pair - array - address deref ) )
] ) ) )
; ? ( set dump - trace * )
; ? ( = dump - trace * ( obj whitelist ' ( "run" "m" "sizeof" ) ) )
( run ' main )
; ? ( prn memory * )
( each routine completed - routines *
( aif rep . routine ! error ( prn "error - " it ) ) )
( if ( ~ iso memory * .17 2 )
( prn "F - indirect array copy in the presence of 'default-scope'" ) )
; ? ( quit )
2014-11-29 09:03:32 +00:00
( reset )
( new - trace "len-array-indirect-scoped" )
( add - code
' ( ( def main [
( ( 10 integer ) < - copy ( 30 literal ) ) ; pretend allocation
( ( default - scope scope - address ) < - copy ( 10 literal ) ) ; unsafe
( ( 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 ( 11 literal ) ) ; unsafe
2014-12-13 01:54:31 +00:00
( ( 7 integer ) < - length ( 6 integer - boolean - pair - array - address deref ) )
2014-11-29 09:03:32 +00:00
] ) ) )
; ? ( = dump - trace * ( obj whitelist ' ( "run" "addr" "sz" "array-len" ) ) )
( run ' main )
; ? ( prn memory * )
( if ( ~ iso memory * .17 2 )
( prn "F - 'len' accesses length of array address" ) )
; ? ( quit )
2014-11-07 21:00:44 +00:00
; ; Dynamic dispatch
;
2014-11-01 22:06:24 +00:00
; Putting it all together , here ' s how you define generic functions that run
; different code based on the types of their args .
2014-10-15 01:24:46 +00:00
( reset )
2014-10-15 06:11:44 +00:00
( new - trace "dispatch-clause" )
; ? ( set dump - trace * )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def test1 [
2014-11-04 07:35:06 +00:00
; 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
2014-11-01 22:06:24 +00:00
( ( default - scope scope - address ) < - new ( scope literal ) ( 20 literal ) )
2014-12-13 01:54:31 +00:00
( ( first - arg - box tagged - value - address ) < - next - input )
2014-11-01 22:06:24 +00:00
; if given integers , add them
2014-10-15 01:24:46 +00:00
{ begin
2014-11-01 22:06:24 +00:00
( ( first - arg integer ) ( match ? boolean ) < - maybe - coerce ( first - arg - box tagged - value - address deref ) ( integer literal ) )
( break - unless ( match ? boolean ) )
2014-12-13 01:54:31 +00:00
( ( second - arg - box tagged - value - address ) < - next - input )
2014-11-01 22:06:24 +00:00
( ( 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 ) )
2014-10-15 01:24:46 +00:00
}
2014-11-25 05:09:07 +00:00
( reply ( nil literal ) )
] )
( def main [
2014-10-15 06:11:44 +00:00
( ( 1 tagged - value - address ) < - new - tagged - value ( integer literal ) ( 34 literal ) )
( ( 2 tagged - value - address ) < - new - tagged - value ( integer literal ) ( 3 literal ) )
2014-11-25 05:09:07 +00:00
( ( 3 integer ) < - test1 ( 1 tagged - value - address ) ( 2 tagged - value - address ) )
] ) ) )
2014-10-15 01:24:46 +00:00
( run ' main )
; ? ( prn memory * )
2014-10-15 06:11:44 +00:00
( if ( ~ is memory * .3 37 )
2014-10-15 01:24:46 +00:00
( prn "F - an example function that checks that its oarg is an integer" ) )
; ? ( quit )
; todo - test that reply increments pc for caller frame after popping current frame
( reset )
2014-10-15 06:11:44 +00:00
( new - trace "dispatch-multiple-clauses" )
2014-10-15 01:24:46 +00:00
; ? ( set dump - trace * )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def test1 [
2014-11-01 22:06:24 +00:00
( ( default - scope scope - address ) < - new ( scope literal ) ( 20 literal ) )
2014-12-13 01:54:31 +00:00
( ( first - arg - box tagged - value - address ) < - next - input )
2014-11-01 22:06:24 +00:00
; if given integers , add them
2014-10-15 01:24:46 +00:00
{ begin
2014-11-01 22:06:24 +00:00
( ( first - arg integer ) ( match ? boolean ) < - maybe - coerce ( first - arg - box tagged - value - address deref ) ( integer literal ) )
( break - unless ( match ? boolean ) )
2014-12-13 01:54:31 +00:00
( ( second - arg - box tagged - value - address ) < - next - input )
2014-11-01 22:06:24 +00:00
( ( 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 ) )
2014-10-15 01:24:46 +00:00
}
2014-11-01 22:06:24 +00:00
; if given booleans , or them ( it ' s a silly kind of generic function )
2014-10-15 01:24:46 +00:00
{ begin
2014-11-01 22:06:24 +00:00
( ( first - arg boolean ) ( match ? boolean ) < - maybe - coerce ( first - arg - box tagged - value - address deref ) ( boolean literal ) )
( break - unless ( match ? boolean ) )
2014-12-13 01:54:31 +00:00
( ( second - arg - box tagged - value - address ) < - next - input )
2014-11-01 22:06:24 +00:00
( ( 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 ) )
2014-10-15 06:11:44 +00:00
}
2014-11-25 05:09:07 +00:00
( reply ( nil literal ) )
] )
( def main [
2014-10-15 06:11:44 +00:00
( ( 1 tagged - value - address ) < - new - tagged - value ( boolean literal ) ( t literal ) )
( ( 2 tagged - value - address ) < - new - tagged - value ( boolean literal ) ( nil literal ) )
2014-11-25 05:09:07 +00:00
( ( 3 boolean ) < - test1 ( 1 tagged - value - address ) ( 2 tagged - value - address ) )
] ) ) )
2014-10-15 01:24:46 +00:00
; ? ( each stmt function * ! test - fn
; ? ( prn " " stmt ) )
( run ' main )
; ? ( wipe dump - trace * )
; ? ( prn memory * )
2014-10-15 06:11:44 +00:00
( if ( ~ is memory * .3 t )
2014-10-15 01:24:46 +00:00
( prn "F - an example function that can do different things (dispatch) based on the type of its args or oargs" ) )
; ? ( quit )
( reset )
2014-10-15 06:11:44 +00:00
( new - trace "dispatch-multiple-calls" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def test1 [
2014-11-01 22:06:24 +00:00
( ( default - scope scope - address ) < - new ( scope literal ) ( 20 literal ) )
2014-12-13 01:54:31 +00:00
( ( first - arg - box tagged - value - address ) < - next - input )
2014-11-01 22:06:24 +00:00
; if given integers , add them
2014-10-15 01:24:46 +00:00
{ begin
2014-11-01 22:06:24 +00:00
( ( first - arg integer ) ( match ? boolean ) < - maybe - coerce ( first - arg - box tagged - value - address deref ) ( integer literal ) )
( break - unless ( match ? boolean ) )
2014-12-13 01:54:31 +00:00
( ( second - arg - box tagged - value - address ) < - next - input )
2014-11-01 22:06:24 +00:00
( ( 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 ) )
2014-10-15 01:24:46 +00:00
}
2014-11-01 22:06:24 +00:00
; if given booleans , or them ( it ' s a silly kind of generic function )
2014-10-15 01:24:46 +00:00
{ begin
2014-11-01 22:06:24 +00:00
( ( first - arg boolean ) ( match ? boolean ) < - maybe - coerce ( first - arg - box tagged - value - address deref ) ( boolean literal ) )
( break - unless ( match ? boolean ) )
2014-12-13 01:54:31 +00:00
( ( second - arg - box tagged - value - address ) < - next - input )
2014-11-01 22:06:24 +00:00
( ( 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 ) )
2014-10-15 06:11:44 +00:00
}
2014-11-25 05:09:07 +00:00
( reply ( nil literal ) )
] )
( def main [
2014-10-15 06:11:44 +00:00
( ( 1 tagged - value - address ) < - new - tagged - value ( boolean literal ) ( t literal ) )
( ( 2 tagged - value - address ) < - new - tagged - value ( boolean literal ) ( nil literal ) )
( ( 3 boolean ) < - test1 ( 1 tagged - value - address ) ( 2 tagged - value - address ) )
( ( 10 tagged - value - address ) < - new - tagged - value ( integer literal ) ( 34 literal ) )
( ( 11 tagged - value - address ) < - new - tagged - value ( integer literal ) ( 3 literal ) )
2014-11-25 05:09:07 +00:00
( ( 12 integer ) < - test1 ( 10 tagged - value - address ) ( 11 tagged - value - address ) )
] ) ) )
2014-10-15 01:24:46 +00:00
( run ' main )
; ? ( prn memory * )
2014-10-15 06:11:44 +00:00
( if ( ~ and ( is memory * .3 t ) ( is memory * .12 37 ) )
2014-10-15 01:24:46 +00:00
( prn "F - different calls can exercise different clauses of the same function" ) )
2014-11-07 21:00:44 +00:00
; ; Concurrency
;
2014-10-10 22:04:14 +00:00
; A rudimentary process scheduler . You can 'run' multiple functions at once ,
; and they share the virtual processor .
2014-11-01 22:06:24 +00:00
;
2014-10-10 22:04:14 +00:00
; There 's also a ' fork ' primitive to let functions create new threads of
2014-10-30 03:01:34 +00:00
; execution ( we call them routines ) .
2014-11-01 22:06:24 +00:00
;
2014-10-10 22:04:14 +00:00
; 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 .
2014-08-29 03:44:16 +00:00
( reset )
2014-10-07 17:26:14 +00:00
( new - trace "scheduler" )
2014-11-27 07:23:44 +00:00
( = traces * ( queue ) )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def f1 [
( ( 1 integer ) < - copy ( 3 literal ) )
] )
( def f2 [
( ( 2 integer ) < - copy ( 4 literal ) )
] ) ) )
2014-11-06 19:36:16 +00:00
( run 'f1 ' f2 )
( when ( ~ iso 2 curr - cycle * )
( prn "F - scheduler didn't run the right number of instructions: " curr - cycle * ) )
2014-08-29 03:44:16 +00:00
( if ( ~ 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" )
) )
2014-10-07 17:26:14 +00:00
2014-11-06 18:28:46 +00:00
( reset )
( new - trace "scheduler-alternate" )
2014-11-27 07:23:44 +00:00
( = traces * ( queue ) )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def f1 [
2014-11-06 18:28:46 +00:00
( ( 1 integer ) < - copy ( 3 literal ) )
2014-11-25 05:09:07 +00:00
( ( 1 integer ) < - copy ( 3 literal ) )
] )
( def f2 [
( ( 2 integer ) < - copy ( 4 literal ) )
2014-11-06 18:28:46 +00:00
( ( 2 integer ) < - copy ( 4 literal ) )
2014-11-25 05:09:07 +00:00
] ) ) )
2014-11-06 23:24:16 +00:00
( = scheduling - interval * 1 )
( run 'f1 ' f2 )
2014-11-06 18:28:46 +00:00
( check - trace - contents "scheduler alternates between routines"
' ( ( "run" "f1 0" )
( "run" "f2 0" )
( "run" "f1 1" )
( "run" "f2 1" )
) )
2014-11-21 23:07:33 +00:00
( reset )
( new - trace "scheduler-sleep" )
2014-11-27 07:23:44 +00:00
( = traces * ( queue ) )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def f1 [
( ( 1 integer ) < - copy ( 3 literal ) )
] )
( def f2 [
( ( 2 integer ) < - copy ( 4 literal ) )
] ) ) )
2014-11-21 23:07:33 +00:00
; 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
2014-11-22 02:21:15 +00:00
( = rep . routine ! sleep ' ( 23 literal ) )
2014-11-21 23:07:33 +00:00
( set sleeping - routines * . routine ) )
; not yet time for it to wake up
( = curr - cycle * 23 )
2014-11-22 02:21:15 +00:00
; ? ( set dump - trace * )
; ? ( = dump - trace * ( obj whitelist ' ( "run" "schedule" ) ) )
2014-11-21 23:07:33 +00:00
( update - scheduler - state )
( if ( ~ is 1 len . running - routines * )
( prn "F - scheduler lets routines sleep" ) )
( reset )
( new - trace "scheduler-wakeup" )
2014-11-27 07:23:44 +00:00
( = traces * ( queue ) )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def f1 [
( ( 1 integer ) < - copy ( 3 literal ) )
] )
( def f2 [
( ( 2 integer ) < - copy ( 4 literal ) )
] ) ) )
2014-11-21 23:07:33 +00:00
; 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
2014-11-22 02:21:15 +00:00
( = rep . routine ! sleep ' ( 23 literal ) )
2014-11-21 23:07:33 +00:00
( set sleeping - routines * . routine ) )
; time for it to wake up
( = curr - cycle * 24 )
( update - scheduler - state )
( if ( ~ is 2 len . running - routines * )
( prn "F - scheduler wakes up sleeping routines at the right time" ) )
2014-11-22 04:37:24 +00:00
( reset )
( new - trace "scheduler-sleep-location" )
2014-11-27 07:23:44 +00:00
( = traces * ( queue ) )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def f1 [
( ( 1 integer ) < - copy ( 3 literal ) )
] )
( def f2 [
( ( 2 integer ) < - copy ( 4 literal ) )
] ) ) )
2014-11-22 04:37:24 +00:00
; add one baseline routine to run ( empty running - routines * handled below )
( enq make - routine ! f1 running - routines * )
( assert ( is 1 len . running - routines * ) )
2014-11-23 16:47:19 +00:00
; blocked routine waiting for location 23 to change
2014-11-22 04:37:24 +00:00
( let routine make - routine ! f2
2014-11-23 16:47:19 +00:00
( = rep . routine ! sleep ' ( 23 0 ) )
2014-11-22 04:37:24 +00:00
( set sleeping - routines * . routine ) )
2014-11-23 16:47:19 +00:00
; leave memory location 23 unchanged
2014-11-22 04:37:24 +00:00
( = 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 * )
2014-11-23 16:47:19 +00:00
; routine remains blocked
2014-11-22 04:37:24 +00:00
( if ( ~ is 1 len . running - routines * )
( prn "F - scheduler lets routines block on locations" ) )
; ? ( quit )
( reset )
( new - trace "scheduler-wakeup-location" )
2014-11-27 07:23:44 +00:00
( = traces * ( queue ) )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def f1 [
( ( 1 integer ) < - copy ( 3 literal ) )
] )
( def f2 [
( ( 2 integer ) < - copy ( 4 literal ) )
] ) ) )
2014-11-22 04:37:24 +00:00
; add one baseline routine to run ( empty running - routines * handled below )
( enq make - routine ! f1 running - routines * )
( assert ( is 1 len . running - routines * ) )
2014-11-23 16:47:19 +00:00
; blocked routine waiting for location 23 to change
2014-11-22 04:37:24 +00:00
( let routine make - routine ! f2
2014-11-23 16:47:19 +00:00
( = rep . routine ! sleep ' ( 23 0 ) )
2014-11-22 04:37:24 +00:00
( set sleeping - routines * . routine ) )
2014-11-23 16:47:19 +00:00
; change memory location 23
2014-11-22 04:37:24 +00:00
( = memory * .23 1 )
( update - scheduler - state )
2014-11-23 16:47:19 +00:00
; routine unblocked
2014-11-22 04:37:24 +00:00
( if ( ~ is 2 len . running - routines * )
( prn "F - scheduler unblocks routines blocked on locations" ) )
2014-11-22 02:31:48 +00:00
( reset )
( new - trace "scheduler-skip" )
2014-11-27 07:23:44 +00:00
( = traces * ( queue ) )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def f1 [
( ( 1 integer ) < - copy ( 3 literal ) )
] ) ) )
2014-11-22 02:31:48 +00:00
; running - routines * is empty
( assert ( empty running - routines * ) )
; sleeping routine
( let routine make - routine ! f1
( = rep . routine ! sleep ' ( 23 literal ) )
( set sleeping - routines * . routine ) )
; long time left for it to wake up
( = curr - cycle * 0 )
( update - scheduler - state )
( assert ( is curr - cycle * 24 ) )
( if ( ~ is 1 len . running - routines * )
( prn "F - scheduler skips ahead to earliest sleeping routines when nothing to run" ) )
2014-11-22 04:47:48 +00:00
( reset )
( new - trace "scheduler-deadlock" )
2014-11-27 07:23:44 +00:00
( = traces * ( queue ) )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def f1 [
( ( 1 integer ) < - copy ( 3 literal ) )
] ) ) )
2014-11-22 04:47:48 +00:00
( assert ( empty running - routines * ) )
( assert ( empty completed - routines * ) )
; blocked routine
( let routine make - routine ! f1
2014-11-23 16:47:19 +00:00
( = rep . routine ! sleep ' ( 23 0 ) )
2014-11-22 04:47:48 +00:00
( set sleeping - routines * . routine ) )
2014-11-23 16:47:19 +00:00
; location it 's waiting on is ' unchanged '
2014-11-22 04:47:48 +00:00
( = 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 )
2014-11-22 08:22:22 +00:00
( reset )
( new - trace "scheduler-deadlock2" )
2014-11-27 07:23:44 +00:00
( = traces * ( queue ) )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def f1 [
( ( 1 integer ) < - copy ( 3 literal ) )
] ) ) )
2014-11-22 08:22:22 +00:00
; running - routines * is empty
( assert ( empty running - routines * ) )
; blocked routine
( let routine make - routine ! f1
2014-11-23 16:47:19 +00:00
( = rep . routine ! sleep ' ( 23 0 ) )
2014-11-22 08:22:22 +00:00
( 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" ) )
2014-11-06 23:38:00 +00:00
( reset )
( new - trace "sleep" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def f1 [
2014-11-06 23:38:00 +00:00
( sleep ( 1 literal ) )
( ( 1 integer ) < - copy ( 3 literal ) )
2014-11-25 05:09:07 +00:00
( ( 1 integer ) < - copy ( 3 literal ) )
] )
( def f2 [
( ( 2 integer ) < - copy ( 4 literal ) )
2014-11-06 23:38:00 +00:00
( ( 2 integer ) < - copy ( 4 literal ) )
2014-11-25 05:09:07 +00:00
] ) ) )
2014-11-06 23:38:00 +00:00
; ? ( = 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" )
) )
2014-11-07 00:08:16 +00:00
( reset )
( new - trace "sleep-long" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def f1 [
2014-11-07 00:08:16 +00:00
( sleep ( 20 literal ) )
( ( 1 integer ) < - copy ( 3 literal ) )
2014-11-25 05:09:07 +00:00
( ( 1 integer ) < - copy ( 3 literal ) )
] )
( def f2 [
( ( 2 integer ) < - copy ( 4 literal ) )
2014-11-07 00:08:16 +00:00
( ( 2 integer ) < - copy ( 4 literal ) )
2014-11-25 05:09:07 +00:00
] ) ) )
2014-11-07 00:08:16 +00:00
; ? ( = 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" )
) )
2014-11-07 03:12:56 +00:00
( reset )
( new - trace "sleep-location" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def f1 [
2014-11-07 03:12:56 +00:00
; waits for memory location 1 to be set , before computing its successor
( ( 1 integer ) < - copy ( 0 literal ) )
( sleep ( 1 integer ) )
2014-11-25 05:09:07 +00:00
( ( 2 integer ) < - add ( 1 integer ) ( 1 literal ) )
] )
( def f2 [
2014-11-07 03:12:56 +00:00
( sleep ( 30 literal ) )
2014-11-25 05:09:07 +00:00
( ( 1 integer ) < - copy ( 3 literal ) ) ; set to value
] ) ) )
2014-11-07 03:12:56 +00:00
; ? ( = dump - trace * ( obj whitelist ' ( "run" "schedule" ) ) )
2014-11-07 05:44:16 +00:00
; ? ( set dump - trace * )
2014-11-07 03:12:56 +00:00
( run 'f1 ' f2 )
2014-11-21 22:36:22 +00:00
; ? ( prn int - canon . memory * )
( each routine completed - routines *
( aif rep . routine ! error ( prn "error - " it ) ) )
2014-11-07 03:12:56 +00:00
( if ( ~ is memory * .2 4 ) ; successor of value
2014-11-22 04:37:24 +00:00
( prn "F - sleep can block on a memory location" ) )
2014-11-07 03:12:56 +00:00
; ? ( quit )
2014-11-21 22:36:22 +00:00
( reset )
( new - trace "sleep-scoped-location" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def f1 [
2014-11-23 16:47:19 +00:00
; waits for memory location 1 to be changed , before computing its successor
( ( 10 integer ) < - copy ( 5 literal ) ) ; array of locals
2014-11-21 22:36:22 +00:00
( ( default - scope scope - address ) < - copy ( 10 literal ) )
2014-11-23 16:47:19 +00:00
( ( 1 integer ) < - copy ( 23 literal ) ) ; really location 11
2014-11-21 22:36:22 +00:00
( sleep ( 1 integer ) )
2014-11-25 05:09:07 +00:00
( ( 2 integer ) < - add ( 1 integer ) ( 1 literal ) )
] )
( def f2 [
2014-11-21 22:36:22 +00:00
( sleep ( 30 literal ) )
2014-11-25 05:09:07 +00:00
( ( 11 integer ) < - copy ( 3 literal ) ) ; set to value
] ) ) )
2014-11-21 22:36:22 +00:00
; ? ( = dump - trace * ( obj whitelist ' ( "run" "schedule" ) ) )
( run 'f1 ' f2 )
( if ( ~ is memory * .12 4 ) ; successor of value
2014-11-22 04:37:24 +00:00
( prn "F - sleep can block on a scoped memory location" ) )
2014-11-21 22:36:22 +00:00
; ? ( quit )
2014-11-19 08:11:05 +00:00
( reset )
( new - trace "fork" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def f1 [
( fork ( f2 fn ) )
] )
( def f2 [
( ( 2 integer ) < - copy ( 4 literal ) )
] ) ) )
2014-11-19 08:11:05 +00:00
( run ' f1 )
( if ( ~ iso memory * .2 4 )
( prn "F - fork works" ) )
2014-11-19 08:19:57 +00:00
( reset )
( new - trace "fork-with-args" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def f1 [
( fork ( f2 fn ) ( 4 literal ) )
] )
( def f2 [
2014-12-13 01:54:31 +00:00
( ( 2 integer ) < - next - input )
2014-11-25 05:09:07 +00:00
] ) ) )
2014-11-19 08:19:57 +00:00
( run ' f1 )
( if ( ~ iso memory * .2 4 )
( prn "F - fork can pass args" ) )
2014-11-19 08:27:10 +00:00
( reset )
( new - trace "fork-copies-args" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def f1 [
2014-11-19 08:27:10 +00:00
( ( default - scope scope - address ) < - new ( scope literal ) ( 5 literal ) )
( ( x integer ) < - copy ( 4 literal ) )
( fork ( f2 fn ) ( x integer ) )
2014-11-25 05:09:07 +00:00
( ( x integer ) < - copy ( 0 literal ) ) ; should be ignored
] )
( def f2 [
2014-12-13 01:54:31 +00:00
( ( 2 integer ) < - next - input )
2014-11-25 05:09:07 +00:00
] ) ) )
2014-11-19 08:27:10 +00:00
( run ' f1 )
( if ( ~ iso memory * .2 4 )
( prn "F - fork passes args by value" ) )
2014-10-30 03:01:34 +00:00
; The scheduler needs to keep track of the call stack for each routine .
2014-10-10 22:04:14 +00:00
; 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 .
2014-10-30 05:19:03 +00:00
; Routines can throw errors .
( reset )
( new - trace "array-bounds-check" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
2014-10-30 05:19:03 +00:00
( ( 1 integer ) < - copy ( 2 literal ) )
( ( 2 integer ) < - copy ( 23 literal ) )
( ( 3 integer ) < - copy ( 24 literal ) )
2014-11-25 05:09:07 +00:00
( ( 4 integer ) < - index ( 1 integer - array ) ( 2 literal ) )
] ) ) )
2014-10-30 05:19:03 +00:00
; ? ( set dump - trace * )
( run ' main )
; ? ( prn memory * )
2014-11-21 22:36:22 +00:00
( let routine ( car completed - routines * )
( if ( no rep . routine ! error )
2014-10-30 05:19:03 +00:00
( prn "F - 'index' throws an error if out of bounds" ) ) )
2014-11-07 21:00:44 +00:00
; ; Synchronization
;
; Mu synchronizes using channels rather than locks , like Erlang and Go .
2014-11-01 22:06:24 +00:00
;
2014-11-04 21:45:35 +00:00
; 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 .
2014-11-07 21:00:44 +00:00
;
; 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 .
2014-11-04 08:01:57 +00:00
2014-11-07 21:00:44 +00:00
; 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 .
2014-11-04 08:01:57 +00:00
( reset )
( new - trace "channel-new" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
2014-11-07 03:38:33 +00:00
( ( 1 channel - address ) < - new - channel ( 3 literal ) )
( ( 2 integer ) < - get ( 1 channel - address deref ) ( first - full offset ) )
2014-11-25 05:09:07 +00:00
( ( 3 integer ) < - get ( 1 channel - address deref ) ( first - free offset ) )
] ) ) )
2014-11-04 08:01:57 +00:00
; ? ( set dump - trace * )
2014-11-04 21:45:35 +00:00
( run ' main )
; ? ( prn memory * )
2014-11-07 03:38:33 +00:00
( if ( or ( ~ is 0 memory * .2 )
( ~ is 0 memory * .3 ) )
2014-11-04 21:45:35 +00:00
( prn "F - 'new-channel' initializes 'first-full and 'first-free to 0" ) )
2014-11-04 08:01:57 +00:00
2014-11-04 21:46:31 +00:00
( reset )
( new - trace "channel-write" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
2014-11-04 21:46:31 +00:00
( ( 1 channel - address ) < - new - channel ( 3 literal ) )
( ( 2 integer - address ) < - new ( integer literal ) )
( ( 2 integer - address deref ) < - copy ( 34 literal ) )
2014-11-29 18:34:20 +00:00
( ( 3 tagged - value ) < - save - type ( 2 integer - address ) )
( ( 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 ) )
2014-11-25 05:09:07 +00:00
] ) ) )
2014-11-04 21:46:31 +00:00
; ? ( set dump - trace * )
; ? ( = dump - trace * ( obj blacklist ' ( "sz" "m" "setm" "addr" "array-len" "cvt0" "cvt1" ) ) )
2014-11-07 20:33:12 +00:00
; ? ( = dump - trace * ( obj whitelist ' ( "jump" ) ) )
2014-11-04 21:46:31 +00:00
( run ' main )
2014-11-07 20:33:12 +00:00
; ? ( prn canon . memory * )
2014-11-29 18:34:20 +00:00
( if ( or ( ~ is 0 memory * .5 )
( ~ is 1 memory * .6 ) )
2014-11-04 21:46:31 +00:00
( prn "F - 'write' enqueues item to channel" ) )
2014-11-07 20:33:12 +00:00
; ? ( quit )
2014-11-04 21:46:31 +00:00
2014-11-05 02:35:13 +00:00
( reset )
( new - trace "channel-read" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
2014-11-05 02:35:13 +00:00
( ( 1 channel - address ) < - new - channel ( 3 literal ) )
( ( 2 integer - address ) < - new ( integer literal ) )
( ( 2 integer - address deref ) < - copy ( 34 literal ) )
2014-11-29 18:34:20 +00:00
( ( 3 tagged - value ) < - save - type ( 2 integer - address ) )
( ( 1 channel - address deref ) < - write ( 1 channel - address ) ( 3 tagged - value ) )
( ( 5 tagged - value ) ( 1 channel - address deref ) < - read ( 1 channel - address ) )
( ( 7 integer - address ) < - maybe - coerce ( 5 tagged - value ) ( integer - address literal ) )
( ( 8 integer ) < - get ( 1 channel - address deref ) ( first - full offset ) )
( ( 9 integer ) < - get ( 1 channel - address deref ) ( first - free offset ) )
2014-11-25 05:09:07 +00:00
] ) ) )
2014-11-05 02:35:13 +00:00
; ? ( set dump - trace * )
; ? ( = dump - trace * ( obj blacklist ' ( "sz" "m" "setm" "addr" "array-len" "cvt0" "cvt1" ) ) )
( run ' main )
; ? ( prn int - canon . memory * )
2014-11-29 18:34:20 +00:00
( if ( ~ is memory * .7 memory * .2 )
2014-11-05 02:35:13 +00:00
( prn "F - 'read' returns written value" ) )
2014-11-29 18:34:20 +00:00
( if ( or ( ~ is 1 memory * .8 )
( ~ is 1 memory * .9 ) )
2014-11-05 02:35:13 +00:00
( prn "F - 'read' dequeues item from channel" ) )
2014-11-07 20:33:12 +00:00
( reset )
( new - trace "channel-write-wrap" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
2014-11-15 22:58:58 +00:00
; channel with 1 slot
( ( 1 channel - address ) < - new - channel ( 1 literal ) )
2014-11-07 20:33:12 +00:00
; write a value
( ( 2 integer - address ) < - new ( integer literal ) )
( ( 2 integer - address deref ) < - copy ( 34 literal ) )
2014-11-29 18:34:20 +00:00
( ( 3 tagged - value ) < - save - type ( 2 integer - address ) )
( ( 1 channel - address deref ) < - write ( 1 channel - address ) ( 3 tagged - value ) )
2014-11-07 20:33:12 +00:00
; first - free will now be 1
2014-11-29 18:34:20 +00:00
( ( 5 integer ) < - get ( 1 channel - address deref ) ( first - free offset ) )
2014-11-07 20:33:12 +00:00
; read one value
2014-11-22 08:31:31 +00:00
( _ ( 1 channel - address deref ) < - read ( 1 channel - address ) )
2014-11-07 20:33:12 +00:00
; write a second value ; verify that first - free wraps around to 0 .
2014-11-29 18:34:20 +00:00
( ( 1 channel - address deref ) < - write ( 1 channel - address ) ( 3 tagged - value ) )
( ( 6 integer ) < - get ( 1 channel - address deref ) ( first - free offset ) )
2014-11-25 05:09:07 +00:00
] ) ) )
2014-11-07 20:33:12 +00:00
; ? ( set dump - trace * )
; ? ( = dump - trace * ( obj blacklist ' ( "sz" "m" "setm" "addr" "array-len" "cvt0" "cvt1" ) ) )
( run ' main )
; ? ( prn canon . memory * )
2014-11-29 18:34:20 +00:00
( if ( or ( ~ is 1 memory * .5 )
( ~ is 0 memory * .6 ) )
2014-11-07 20:33:12 +00:00
( prn "F - 'write' can wrap pointer back to start" ) )
( reset )
( new - trace "channel-read-wrap" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
2014-11-15 22:58:58 +00:00
; channel with 1 slot
( ( 1 channel - address ) < - new - channel ( 1 literal ) )
2014-11-07 20:33:12 +00:00
; write a value
( ( 2 integer - address ) < - new ( integer literal ) )
( ( 2 integer - address deref ) < - copy ( 34 literal ) )
2014-11-29 18:34:20 +00:00
( ( 3 tagged - value ) < - save - type ( 2 integer - address ) )
( ( 1 channel - address deref ) < - write ( 1 channel - address ) ( 3 tagged - value ) )
2014-11-07 20:33:12 +00:00
; read one value
2014-11-22 08:31:31 +00:00
( _ ( 1 channel - address deref ) < - read ( 1 channel - address ) )
2014-11-07 20:33:12 +00:00
; first - full will now be 1
2014-11-29 18:34:20 +00:00
( ( 5 integer ) < - get ( 1 channel - address deref ) ( first - full offset ) )
2014-11-07 20:33:12 +00:00
; write a second value
2014-11-29 18:34:20 +00:00
( ( 1 channel - address deref ) < - write ( 1 channel - address ) ( 3 tagged - value ) )
2014-11-07 20:33:12 +00:00
; read second value ; verify that first - full wraps around to 0 .
2014-11-22 08:31:31 +00:00
( _ ( 1 channel - address deref ) < - read ( 1 channel - address ) )
2014-11-29 18:34:20 +00:00
( ( 6 integer ) < - get ( 1 channel - address deref ) ( first - full offset ) )
2014-11-25 05:09:07 +00:00
] ) ) )
2014-11-07 20:33:12 +00:00
; ? ( set dump - trace * )
; ? ( = dump - trace * ( obj blacklist ' ( "sz" "m" "setm" "addr" "array-len" "cvt0" "cvt1" ) ) )
( run ' main )
; ? ( prn canon . memory * )
2014-11-29 18:34:20 +00:00
( if ( or ( ~ is 1 memory * .5 )
( ~ is 0 memory * .6 ) )
2014-11-07 20:33:12 +00:00
( prn "F - 'read' can wrap pointer back to start" ) )
2014-11-07 22:09:59 +00:00
( reset )
( new - trace "channel-new-empty-not-full" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
2014-11-07 22:09:59 +00:00
( ( 1 channel - address ) < - new - channel ( 3 literal ) )
( ( 2 boolean ) < - empty ? ( 1 channel - address deref ) )
2014-11-25 05:09:07 +00:00
( ( 3 boolean ) < - full ? ( 1 channel - address deref ) )
] ) ) )
2014-11-07 22:09:59 +00:00
; ? ( set dump - trace * )
( run ' main )
; ? ( prn memory * )
( if ( 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" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
2014-11-07 22:09:59 +00:00
( ( 1 channel - address ) < - new - channel ( 3 literal ) )
( ( 2 integer - address ) < - new ( integer literal ) )
( ( 2 integer - address deref ) < - copy ( 34 literal ) )
2014-11-29 18:34:20 +00:00
( ( 3 tagged - value ) < - save - type ( 2 integer - address ) )
( ( 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 ) )
2014-11-25 05:09:07 +00:00
] ) ) )
2014-11-07 22:09:59 +00:00
; ? ( set dump - trace * )
( run ' main )
; ? ( prn memory * )
2014-11-29 18:34:20 +00:00
( if ( or ( ~ is nil memory * .5 )
( ~ is nil memory * .6 ) )
2014-11-07 22:09:59 +00:00
( prn "F - a channel after writing is never empty" ) )
( reset )
( new - trace "channel-write-full" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
2014-11-15 22:58:58 +00:00
( ( 1 channel - address ) < - new - channel ( 1 literal ) )
2014-11-07 22:09:59 +00:00
( ( 2 integer - address ) < - new ( integer literal ) )
( ( 2 integer - address deref ) < - copy ( 34 literal ) )
2014-11-29 18:34:20 +00:00
( ( 3 tagged - value ) < - save - type ( 2 integer - address ) )
( ( 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 ) )
2014-11-25 05:09:07 +00:00
] ) ) )
2014-11-07 22:09:59 +00:00
; ? ( set dump - trace * )
( run ' main )
; ? ( prn memory * )
2014-11-29 18:34:20 +00:00
( if ( or ( ~ is nil memory * .5 )
( ~ is t memory * .6 ) )
2014-11-07 22:09:59 +00:00
( prn "F - a channel after writing may be full" ) )
( reset )
( new - trace "channel-read-not-full" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
2014-11-07 22:09:59 +00:00
( ( 1 channel - address ) < - new - channel ( 3 literal ) )
( ( 2 integer - address ) < - new ( integer literal ) )
( ( 2 integer - address deref ) < - copy ( 34 literal ) )
2014-11-29 18:34:20 +00:00
( ( 3 tagged - value ) < - save - type ( 2 integer - address ) )
( ( 1 channel - address deref ) < - write ( 1 channel - address ) ( 3 tagged - value ) )
( ( 1 channel - address deref ) < - write ( 1 channel - address ) ( 3 tagged - value ) )
2014-11-22 08:31:31 +00:00
( _ ( 1 channel - address deref ) < - read ( 1 channel - address ) )
2014-11-29 18:34:20 +00:00
( ( 5 boolean ) < - empty ? ( 1 channel - address deref ) )
( ( 6 boolean ) < - full ? ( 1 channel - address deref ) )
2014-11-25 05:09:07 +00:00
] ) ) )
2014-11-07 22:09:59 +00:00
; ? ( set dump - trace * )
( run ' main )
; ? ( prn memory * )
2014-11-29 18:34:20 +00:00
( if ( or ( ~ is nil memory * .5 )
( ~ is nil memory * .6 ) )
2014-11-07 22:09:59 +00:00
( prn "F - a channel after reading is never full" ) )
2014-11-07 21:00:44 +00:00
2014-11-07 22:09:59 +00:00
( reset )
( new - trace "channel-read-empty" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
2014-11-07 22:09:59 +00:00
( ( 1 channel - address ) < - new - channel ( 3 literal ) )
( ( 2 integer - address ) < - new ( integer literal ) )
( ( 2 integer - address deref ) < - copy ( 34 literal ) )
2014-11-29 18:34:20 +00:00
( ( 3 tagged - value ) < - save - type ( 2 integer - address ) )
( ( 1 channel - address deref ) < - write ( 1 channel - address ) ( 3 tagged - value ) )
2014-11-22 08:31:31 +00:00
( _ ( 1 channel - address deref ) < - read ( 1 channel - address ) )
2014-11-29 18:34:20 +00:00
( ( 5 boolean ) < - empty ? ( 1 channel - address deref ) )
( ( 6 boolean ) < - full ? ( 1 channel - address deref ) )
2014-11-25 05:09:07 +00:00
] ) ) )
2014-11-07 22:09:59 +00:00
; ? ( set dump - trace * )
( run ' main )
; ? ( prn memory * )
2014-11-29 18:34:20 +00:00
( if ( or ( ~ is t memory * .5 )
( ~ is nil memory * .6 ) )
2014-11-07 22:09:59 +00:00
( prn "F - a channel after reading may be empty" ) )
2014-11-07 21:00:44 +00:00
2014-11-08 05:39:00 +00:00
; 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" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
2014-11-08 05:39:00 +00:00
( ( 1 channel - address ) < - new - channel ( 3 literal ) )
; channel is empty , but receives a read
2014-11-25 05:09:07 +00:00
( ( 2 tagged - value ) ( 1 channel - address deref ) < - read ( 1 channel - address ) )
] ) ) )
2014-11-08 05:39:00 +00:00
; ? ( set dump - trace * )
; ? ( = dump - trace * ( obj whitelist ' ( "run" ) ) )
( run ' main )
; ? ( prn int - canon . memory * )
; ? ( prn sleeping - routines * )
2014-11-22 03:29:37 +00:00
; ? ( prn completed - routines * )
2014-11-08 05:39:00 +00:00
; read should cause the routine to sleep , and
; the sole sleeping routine should trigger the deadlock detector
2014-11-21 22:36:22 +00:00
( let routine ( car completed - routines * )
2014-11-22 03:29:37 +00:00
( when ( or ( no routine )
( no rep . routine ! error )
2014-11-21 22:36:22 +00:00
( ~ posmatch "deadlock" rep . routine ! error ) )
2014-11-08 05:39:00 +00:00
( prn "F - 'read' on empty channel blocks (puts the routine to sleep until the channel gets data)" ) ) )
; ? ( quit )
2014-11-07 21:00:44 +00:00
2014-11-08 05:39:00 +00:00
( reset )
( new - trace "channel-write-block" )
2014-11-25 05:09:07 +00:00
( add - code
' ( ( def main [
2014-11-08 05:39:00 +00:00
( ( 1 channel - address ) < - new - channel ( 1 literal ) )
( ( 2 integer - address ) < - new ( integer literal ) )
( ( 2 integer - address deref ) < - copy ( 34 literal ) )
2014-11-29 18:34:20 +00:00
( ( 3 tagged - value ) < - save - type ( 2 integer - address ) )
( ( 1 channel - address deref ) < - write ( 1 channel - address ) ( 3 tagged - value ) )
2014-11-08 05:39:00 +00:00
; channel has capacity 1 , but receives a second write
2014-11-29 18:34:20 +00:00
( ( 1 channel - address deref ) < - write ( 1 channel - address ) ( 3 tagged - value ) )
2014-11-25 05:09:07 +00:00
] ) ) )
2014-11-08 05:39:00 +00:00
; ? ( set dump - trace * )
2014-11-22 05:35:05 +00:00
; ? ( = dump - trace * ( obj whitelist ' ( "run" "schedule" "addr" ) ) )
2014-11-08 05:39:00 +00:00
( run ' main )
; ? ( prn int - canon . memory * )
2014-11-22 05:35:05 +00:00
; ? ( prn running - routines * )
; ? ( prn sleeping - routines * )
; ? ( prn completed - routines * )
2014-11-08 05:39:00 +00:00
; second write should cause the routine to sleep , and
; the sole sleeping routine should trigger the deadlock detector
2014-11-21 22:36:22 +00:00
( let routine ( car completed - routines * )
2014-11-22 03:29:37 +00:00
( when ( or ( no routine )
( no rep . routine ! error )
2014-11-21 22:36:22 +00:00
( ~ posmatch "deadlock" rep . routine ! error ) )
2014-11-08 05:39:00 +00:00
( prn "F - 'write' on full channel blocks (puts the routine to sleep until the channel gets data)" ) ) )
2014-11-22 05:35:05 +00:00
; ? ( quit )
2014-11-07 21:00:44 +00:00
2014-12-04 10:57:03 +00:00
( reset )
( new - trace "channel-handoff" )
( add - code
' ( ( def f1 [
( ( default - scope scope - address ) < - new ( scope literal ) ( 30 literal ) )
( ( chan channel - address ) < - new - channel ( 3 literal ) )
( fork ( f2 fn ) ( chan channel - address ) )
( ( 1 tagged - value global ) < - read ( chan channel - address ) ) ; output
] )
( def f2 [
( ( default - scope scope - address ) < - new ( scope literal ) ( 30 literal ) )
( ( n integer - address ) < - new ( integer literal ) )
( ( n integer - address deref ) < - copy ( 24 literal ) )
2014-12-13 01:54:31 +00:00
( ( ochan channel - address ) < - next - input )
2014-12-04 10:57:03 +00:00
( ( x tagged - value ) < - save - type ( n integer - address ) )
( ( 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 ' f1 )
; ? ( prn memory * )
( each routine completed - routines *
( aif rep . routine ! error ( prn "error - " it ) ) )
( if ( ~ is 24 ( memory * memory * .2 ) ) ; location 1 contains tagged - value * x above
( prn "F - channels are meant to be shared between routines" ) )
; ? ( quit )
2014-11-21 22:36:22 +00:00
2014-11-07 21:00:44 +00:00
; ; 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 )
2014-11-25 06:43:47 +00:00
( new - trace "convert-quotes-defer" )
2014-11-27 07:23:44 +00:00
( = traces * ( queue ) )
2014-11-07 21:00:44 +00:00
( if ( ~ 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'" ) )
2014-12-04 02:08:42 +00:00
( reset )
( new - trace "convert-quotes-defer-reply" )
( = traces * ( queue ) )
( if ( ~ 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" ) )
2014-12-04 02:19:40 +00:00
( reset )
( new - trace "convert-quotes-defer-reply-arg" )
( = traces * ( queue ) )
( if ( ~ 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" ) )
2014-11-25 02:56:15 +00:00
( reset )
2014-11-25 06:43:47 +00:00
( new - trace "convert-quotes-label" )
2014-11-27 07:23:44 +00:00
( = traces * ( queue ) )
2014-11-25 02:56:15 +00:00
( if ( ~ 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" ) )
2014-11-25 03:27:52 +00:00
( reset )
2014-11-25 06:43:47 +00:00
( new - trace "before" )
2014-11-27 07:23:44 +00:00
( = traces * ( queue ) )
2014-11-25 05:40:59 +00:00
( add - code ' ( ( before label1 [
( ( 2 integer ) < - copy ( 0 literal ) )
] ) ) )
2014-11-25 03:27:52 +00:00
( if ( ~ iso ( as cons before * ! label1 )
' ( ; fragment
(
( ( 2 integer ) < - copy ( 0 literal ) ) ) ) )
2014-11-25 05:40:59 +00:00
( prn "F - 'before' records fragments of code to insert before labels" ) )
2014-11-25 03:27:52 +00:00
( if ( ~ 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 )
2014-11-25 06:43:47 +00:00
( new - trace "before-multiple" )
2014-11-27 07:23:44 +00:00
( = traces * ( queue ) )
2014-11-25 05:40:59 +00:00
( add - code ' ( ( before label1 [
( ( 2 integer ) < - copy ( 0 literal ) )
] )
( before label1 [
( ( 3 integer ) < - copy ( 0 literal ) )
] ) ) )
2014-11-25 03:27:52 +00:00
( if ( ~ iso ( as cons before * ! label1 )
' ( ; fragment
(
( ( 2 integer ) < - copy ( 0 literal ) ) )
(
( ( 3 integer ) < - copy ( 0 literal ) ) ) ) )
2014-11-25 05:40:59 +00:00
( prn "F - 'before' records fragments in order" ) )
2014-11-25 03:27:52 +00:00
( if ( ~ 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" ) )
2014-11-27 05:36:14 +00:00
( reset )
( new - trace "before-scoped" )
2014-11-27 07:23:44 +00:00
( = traces * ( queue ) )
2014-11-27 05:36:14 +00:00
( add - code ' ( ( before f / label1 [ ; label1 only inside function f
( ( 2 integer ) < - copy ( 0 literal ) )
] ) ) )
( if ( ~ 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" )
2014-11-27 07:23:44 +00:00
( = traces * ( queue ) )
2014-11-27 05:36:14 +00:00
( add - code ' ( ( before f / label1 [ ; label1 only inside function f
( ( 2 integer ) < - copy ( 0 literal ) )
] ) ) )
( if ( ~ 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" ) )
2014-11-25 03:27:52 +00:00
( reset )
2014-11-25 06:43:47 +00:00
( new - trace "after" )
2014-11-27 07:23:44 +00:00
( = traces * ( queue ) )
2014-11-25 05:40:59 +00:00
( add - code ' ( ( after label1 [
( ( 2 integer ) < - copy ( 0 literal ) )
] ) ) )
2014-11-25 03:27:52 +00:00
( if ( ~ iso ( as cons after * ! label1 )
' ( ; fragment
(
( ( 2 integer ) < - copy ( 0 literal ) ) ) ) )
2014-11-25 05:40:59 +00:00
( prn "F - 'after' records fragments of code to insert after labels" ) )
2014-11-25 03:27:52 +00:00
( if ( ~ 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 )
2014-11-25 06:43:47 +00:00
( new - trace "after-multiple" )
2014-11-27 07:23:44 +00:00
( = traces * ( queue ) )
2014-11-25 05:40:59 +00:00
( add - code ' ( ( after label1 [
( ( 2 integer ) < - copy ( 0 literal ) )
] )
( after label1 [
( ( 3 integer ) < - copy ( 0 literal ) )
] ) ) )
2014-11-25 03:27:52 +00:00
( if ( ~ iso ( as cons after * ! label1 )
' ( ; fragment
(
( ( 3 integer ) < - copy ( 0 literal ) ) )
(
( ( 2 integer ) < - copy ( 0 literal ) ) ) ) )
2014-11-25 05:40:59 +00:00
( prn "F - 'after' records fragments in *reverse* order" ) )
2014-11-25 03:27:52 +00:00
( if ( ~ 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 )
2014-11-25 06:43:47 +00:00
( new - trace "before-after" )
2014-11-27 07:23:44 +00:00
( = traces * ( queue ) )
2014-11-25 05:40:59 +00:00
( add - code ' ( ( before label1 [
( ( 2 integer ) < - copy ( 0 literal ) )
] )
( after label1 [
( ( 3 integer ) < - copy ( 0 literal ) )
] ) ) )
2014-11-25 03:27:52 +00:00
( if ( and ( ~ iso ( as cons before * ! label1 )
' ( ; fragment
(
( ( 2 integer ) < - copy ( 0 literal ) ) ) ) )
( ~ iso ( as cons after * ! label1 )
' ( ; fragment
(
( ( 3 integer ) < - copy ( 0 literal ) ) ) ) ) )
2014-11-25 05:40:59 +00:00
( prn "F - 'before' and 'after' fragments work together" ) )
2014-11-25 03:27:52 +00:00
( if ( ~ 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 )
2014-11-25 06:43:47 +00:00
( new - trace "before-after-multiple" )
2014-11-27 07:23:44 +00:00
( = traces * ( queue ) )
2014-11-25 05:40:59 +00:00
( add - code ' ( ( before label1 [
2014-11-25 03:27:52 +00:00
( ( 2 integer ) < - copy ( 0 literal ) )
2014-11-25 05:40:59 +00:00
( ( 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 ) )
] ) ) )
2014-11-25 03:27:52 +00:00
( if ( 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 ) ) ) ) ) )
2014-11-25 05:40:59 +00:00
( prn "F - multiple 'before' and 'after' fragments at once" ) )
2014-11-25 03:27:52 +00:00
( if ( ~ 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" ) )
2014-11-27 07:23:44 +00:00
( reset )
2014-11-25 06:43:47 +00:00
( new - trace "before-after-independent" )
2014-11-27 07:23:44 +00:00
( = traces * ( queue ) )
2014-11-25 03:27:52 +00:00
( if ( ~ iso ( do
( reset )
2014-11-25 05:40:59 +00:00
( 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 ) )
] ) ) )
2014-11-25 03:27:52 +00:00
( list before * ! label1 after * ! label1 ) )
( do
( reset )
2014-11-25 05:40:59 +00:00
( 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 ) )
] ) ) )
2014-11-25 03:27:52 +00:00
( list before * ! label1 after * ! label1 ) ) )
( prn "F - order matters within 'before' and 'after' fragments, but not *between* 'before' and 'after' fragments" ) )
2014-11-25 06:05:56 +00:00
( reset )
2014-11-25 06:43:47 +00:00
( new - trace "before-after-braces" )
2014-11-27 07:23:44 +00:00
( = traces * ( queue ) )
( = function * ( table ) )
2014-11-25 06:05:56 +00:00
( add - code ' ( ( after label1 [
( ( 1 integer ) < - copy ( 0 literal ) )
] )
( def f1 [
{ begin
label1
}
] ) ) )
2014-11-25 06:24:22 +00:00
( freeze - functions )
2014-11-25 06:05:56 +00:00
( if ( ~ iso function * ! f1
' ( label1
( ( 1 integer ) < - copy ( 0 literal ) ) ) )
( prn "F - before/after works inside blocks" ) )
2014-11-25 06:24:22 +00:00
( reset )
2014-11-25 06:43:47 +00:00
( new - trace "before-after-any-order" )
2014-11-27 07:23:44 +00:00
( = traces * ( queue ) )
( = function * ( table ) )
2014-11-25 06:24:22 +00:00
( add - code ' ( ( def f1 [
{ begin
label1
}
] )
( after label1 [
( ( 1 integer ) < - copy ( 0 literal ) )
] ) ) )
( freeze - functions )
( if ( ~ iso function * ! f1
' ( label1
( ( 1 integer ) < - copy ( 0 literal ) ) ) )
( prn "F - before/after can come after the function they need to modify" ) )
2014-11-25 06:44:42 +00:00
( reset )
( new - trace "multiple-defs" )
2014-11-27 07:23:44 +00:00
( = traces * ( queue ) )
( = function * ( table ) )
2014-11-25 06:44:42 +00:00
( add - code ' ( ( def f1 [
( ( 1 integer ) < - copy ( 0 literal ) )
] )
( def f1 [
( ( 2 integer ) < - copy ( 0 literal ) )
] ) ) )
( freeze - functions )
( if ( ~ 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!" )
2014-11-27 07:23:44 +00:00
( = traces * ( queue ) )
( = function * ( table ) )
2014-11-25 06:44:42 +00:00
( add - code ' ( ( def f1 [
( ( 1 integer ) < - copy ( 0 literal ) )
] )
( def ! f1 [
( ( 2 integer ) < - copy ( 0 literal ) )
] ) ) )
( freeze - functions )
( if ( ~ iso function * ! f1
' ( ( ( 2 integer ) < - copy ( 0 literal ) ) ) )
( prn "F - 'def!' clears all previous clauses" ) )
2014-11-27 06:26:55 +00:00
; ; - - -
2014-12-04 02:52:56 +00:00
; helper
( def memory - contains - array ( addr value )
; ? ( prn "Looking for @value starting at @addr, size @memory*.addr vs @len.value" )
( and ( >= memory * . addr len . value )
( loop ( addr ( + addr 1 )
idx 0 )
; ? ( prn "comparing @memory*.addr and @value.idx" )
( if ( >= idx len . value )
t
( ~ is memory * . addr value . idx )
( do1 nil
( prn "@addr should contain @value.idx but contains @memory*.addr" ) )
: else
( recur ( + addr 1 ) ( + idx 1 ) ) ) ) ) )
2014-11-27 06:26:55 +00:00
( reset )
( new - trace "string-new" )
( add - code ' ( ( def main [
2014-11-27 06:48:48 +00:00
( ( 1 string - address ) < - new ( string literal ) ( 5 literal ) )
2014-11-27 06:26:55 +00:00
] ) ) )
2014-12-04 10:50:33 +00:00
( let routine make - routine ! main
( enq routine running - routines * )
( let before rep . routine ! alloc
( run )
( if ( ~ iso rep . routine ! alloc ( + before 5 1 ) )
( prn "F - 'new' allocates arrays of bytes for strings" ) ) ) )
2014-11-27 06:26:55 +00:00
2014-11-27 06:43:51 +00:00
; Convenience: initialize strings using string literals
( reset )
( new - trace "string-literal" )
( add - code ' ( ( def main [
2014-11-27 06:48:48 +00:00
( ( 1 string - address ) < - new "hello" )
2014-11-27 06:43:51 +00:00
] ) ) )
2014-12-04 10:50:33 +00:00
( let routine make - routine ! main
( enq routine running - routines * )
( let before rep . routine ! alloc
( run )
( if ( ~ iso rep . routine ! alloc ( + before 5 1 ) )
( prn "F - 'new' allocates arrays of bytes for string literals" ) )
( if ( ~ memory - contains - array before "hello" )
( prn "F - 'new' initializes allocated memory to string literal" ) ) ) )
2014-11-27 08:34:29 +00:00
( reset )
( new - trace "strcat" )
( add - code ' ( ( def main [
( ( 1 string - address ) < - new "hello," )
( ( 2 string - address ) < - new " world!" )
( ( 3 string - address ) < - strcat ( 1 string - address ) ( 2 string - address ) )
] ) ) )
( run ' main )
2014-12-04 02:36:41 +00:00
( if ( ~ memory - contains - array memory * .3 "hello, world!" )
2014-11-27 08:34:29 +00:00
( prn "F - 'strcat' concatenates strings" ) )
2014-11-27 06:43:51 +00:00
2014-11-27 18:14:03 +00:00
( reset )
( new - trace "interpolate" )
( add - code ' ( ( def 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 )
2014-12-04 02:36:41 +00:00
( if ( ~ memory - contains - array memory * .3 "hello, abc!" )
2014-11-27 18:14:03 +00:00
( prn "F - 'interpolate' splices strings" ) )
( reset )
( new - trace "interpolate-empty" )
( add - code ' ( ( def 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 )
2014-12-04 02:36:41 +00:00
( if ( ~ memory - contains - array memory * .3 "hello!" )
2014-11-27 18:14:03 +00:00
( prn "F - 'interpolate' without underscore returns template" ) )
( reset )
( new - trace "interpolate-at-start" )
( add - code ' ( ( def 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 )
2014-12-04 02:36:41 +00:00
( if ( ~ memory - contains - array memory * .3 "abc, hello" )
2014-11-27 18:14:03 +00:00
( prn "F - 'interpolate' splices strings at start" ) )
( reset )
( new - trace "interpolate-at-end" )
( add - code ' ( ( def 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 )
2014-12-04 02:36:41 +00:00
( if ( ~ memory - contains - array memory * .3 "hello, abc" )
2014-11-27 18:14:03 +00:00
( prn "F - 'interpolate' splices strings at start" ) )
2014-11-29 09:38:54 +00:00
( reset )
( new - trace "interpolate-varargs" )
( add - code ' ( ( def 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 ) ) ) )
2014-12-04 02:36:41 +00:00
( if ( ~ memory - contains - array memory * .5 "hello, abc, def, and ghi!" )
2014-11-29 09:38:54 +00:00
( prn "F - 'interpolate' splices in any number of strings" ) )
2014-11-29 03:31:43 +00:00
; ; unit tests for various helpers
; addr
( reset )
( = routine * nil )
( if ( ~ is 4 ( addr ' ( 4 integer ) ) )
( prn "F - directly addressed operands are their own address" ) )
( if ( ~ is 4 ( addr ' ( 4 integer - address ) ) )
( prn "F - directly addressed operands are their own address - 2" ) )
( if ( ~ is 4 ( addr ' ( 4 literal ) ) )
( prn "F - 'addr' doesn't understand literals" ) )
( = memory * .4 23 )
( if ( ~ is 23 ( addr ' ( 4 integer - address deref ) ) )
( prn "F - 'addr' works with indirectly-addressed 'deref'" ) )
( = memory * .3 4 )
( if ( ~ is 23 ( addr ' ( 3 integer - address - address deref deref ) ) )
( prn "F - 'addr' works with multiple 'deref'" ) )
( = routine * make - routine ! foo )
( if ( ~ is 4 ( addr ' ( 4 integer ) ) )
( prn "F - directly addressed operands are their own address inside routines" ) )
( if ( ~ is 4 ( addr ' ( 4 integer - address ) ) )
( prn "F - directly addressed operands are their own address inside routines - 2" ) )
( if ( ~ is 4 ( addr ' ( 4 literal ) ) )
( prn "F - 'addr' doesn't understand literals inside routines" ) )
( = memory * .4 23 )
( if ( ~ is 23 ( addr ' ( 4 integer - address deref ) ) )
( prn "F - 'addr' works with indirectly-addressed 'deref' inside routines" ) )
( = rep . routine * ! call - stack .0 ! default - scope 10 )
( = memory * .10 5 ) ; bounds check for default - scope
( if ( ~ is 14 ( addr ' ( 4 integer ) ) )
( prn "F - directly addressed operands in routines add default-scope" ) )
( if ( ~ is 14 ( addr ' ( 4 integer - address ) ) )
( prn "F - directly addressed operands in routines add default-scope - 2" ) )
( if ( ~ is 14 ( addr ' ( 4 literal ) ) )
( prn "F - 'addr' doesn't understand literals" ) )
( = memory * .14 23 )
( if ( ~ is 23 ( addr ' ( 4 integer - address deref ) ) )
( prn "F - 'addr' adds default-scope before 'deref', not after" ) )
; deref
( reset )
( = memory * .3 4 )
( if ( ~ iso '(4 integer) (deref ' ( 3 integer - address deref ) ) )
( prn "F - 'deref' handles simple addresses" ) )
( if ( ~ iso '(4 integer deref) (deref ' ( 3 integer - address deref deref ) ) )
( prn "F - 'deref' deletes just one deref" ) )
( = memory * .4 5 )
( if ( ~ iso '(5 integer) (deref:deref ' ( 3 integer - address - address deref deref ) ) )
( prn "F - 'deref' can be chained" ) )
; absolutize
( reset )
( if ( ~ iso '(4 integer) (absolutize ' ( 4 integer ) ) )
( prn "F - 'absolutize' works without routine" ) )
( = routine * make - routine ! foo )
( if ( ~ iso '(4 integer) (absolutize ' ( 4 integer ) ) )
( prn "F - 'absolutize' works without default-scope" ) )
( = rep . routine * ! call - stack .0 ! default - scope 10 )
( = memory * .10 5 ) ; bounds check for default - scope
( if ( ~ iso '(14 integer global) (absolutize ' ( 4 integer ) ) )
( prn "F - 'absolutize' works with default-scope" ) )
( absolutize ' ( 5 integer ) )
( if ( ~ posmatch "no room" rep . routine * ! error )
( prn "F - 'absolutize' checks against default-scope bounds" ) )
; sizeof
( reset )
( if ( ~ is 1 sizeof ! integer )
( prn "F - 'sizeof' works on primitives" ) )
( if ( ~ is 1 sizeof ! integer - address )
( prn "F - 'sizeof' works on addresses" ) )
( if ( ~ is 2 sizeof ! integer - boolean - pair )
( prn "F - 'sizeof' works on records" ) )
( if ( ~ is 3 sizeof ! integer - point - pair )
( prn "F - 'sizeof' works on records with record fields" ) )
( if ( ~ is 1 ( sizeof ' ( 34 integer ) ) )
( prn "F - 'sizeof' works on primitive operands" ) )
( if ( ~ is 1 ( sizeof ' ( 34 integer - address ) ) )
( prn "F - 'sizeof' works on address operands" ) )
( if ( ~ is 2 ( sizeof ' ( 34 integer - boolean - pair ) ) )
( prn "F - 'sizeof' works on record operands" ) )
( if ( ~ is 3 ( sizeof ' ( 34 integer - point - pair ) ) )
( prn "F - 'sizeof' works on record operands with record fields" ) )
( if ( ~ is 2 ( sizeof ' ( 34 integer - boolean - pair - address deref ) ) )
( prn "F - 'sizeof' works on pointers to records" ) )
2014-11-29 08:57:06 +00:00
( = memory * .35 4 ) ; size of array
( = memory * .34 35 )
; ? ( = dump - trace * ( obj whitelist ' ( "sizeof" ) ) )
( if ( ~ is 9 ( sizeof ' ( 34 integer - boolean - pair - array - address deref ) ) )
( prn "F - 'sizeof' works on pointers to arrays" ) )
; ? ( quit )
2014-11-29 03:31:43 +00:00
( = memory * .4 23 )
( if ( ~ is 24 ( sizeof ' ( 4 integer - array ) ) )
( prn "F - 'sizeof' reads array lengths from memory" ) )
( = memory * .3 4 )
( if ( ~ is 24 ( sizeof ' ( 3 integer - array - address deref ) ) )
( prn "F - 'sizeof' handles pointers to arrays" ) )
( = memory * .14 34 )
( = routine * make - routine ! foo )
( if ( ~ is 24 ( sizeof ' ( 4 integer - array ) ) )
( prn "F - 'sizeof' reads array lengths from memory inside routines" ) )
( = rep . routine * ! call - stack .0 ! default - scope 10 )
( = memory * .10 5 ) ; bounds check for default - scope
( if ( ~ is 35 ( sizeof ' ( 4 integer - array ) ) )
( prn "F - 'sizeof' reads array lengths from memory using default-scope" ) )
2014-11-29 08:57:06 +00:00
( = memory * .35 4 ) ; size of array
( = memory * .14 35 )
; ? ( = dump - trace * ( obj whitelist ' ( "sizeof" ) ) )
( aif rep . routine * ! error ( prn "error - " it ) )
( if ( ~ is 9 ( sizeof ' ( 4 integer - boolean - pair - array - address deref ) ) )
( prn "F - 'sizeof' works on pointers to arrays using default-scope" ) )
; ? ( quit )
2014-11-29 03:31:43 +00:00
; m
( reset )
( if ( ~ is 4 ( m ' ( 4 literal ) ) )
( prn "F - 'm' avoids reading memory for literals" ) )
( if ( ~ is 4 ( m ' ( 4 offset ) ) )
( prn "F - 'm' avoids reading memory for offsets" ) )
( = memory * .4 34 )
( if ( ~ is 34 ( m ' ( 4 integer ) ) )
( prn "F - 'm' reads memory for simple types" ) )
( = memory * .3 4 )
( if ( ~ is 34 ( m ' ( 3 integer - address deref ) ) )
( prn "F - 'm' redirects addresses" ) )
( = memory * .2 3 )
( if ( ~ is 34 ( m ' ( 2 integer - address - address deref deref ) ) )
( prn "F - 'm' multiply redirects addresses" ) )
( if ( ~ iso ( annotate 'record ' ( 34 nil ) ) ( m ' ( 4 integer - boolean - pair ) ) )
( prn "F - 'm' supports compound records" ) )
( = memory * .5 35 )
( = memory * .6 36 )
( if ( ~ iso ( annotate 'record ' ( 34 35 36 ) ) ( m ' ( 4 integer - point - pair ) ) )
( prn "F - 'm' supports records with compound fields" ) )
( if ( ~ iso ( annotate 'record ' ( 34 35 36 ) ) ( m ' ( 3 integer - point - pair - address deref ) ) )
( prn "F - 'm' supports indirect access to records" ) )
( = memory * .4 2 )
( if ( ~ iso ( annotate 'record ' ( 2 35 36 ) ) ( m ' ( 4 integer - array ) ) )
( prn "F - 'm' supports access to arrays" ) )
( if ( ~ iso ( annotate 'record ' ( 2 35 36 ) ) ( m ' ( 3 integer - array - address deref ) ) )
( prn "F - 'm' supports indirect access to arrays" ) )
; setm
( reset )
( setm ' ( 4 integer ) 34 )
( if ( ~ is 34 memory * .4 )
( prn "F - 'setm' writes primitives to memory" ) )
( setm ' ( 3 integer - address ) 4 )
( if ( ~ is 4 memory * .3 )
( prn "F - 'setm' writes addresses to memory" ) )
( setm ' ( 3 integer - address deref ) 35 )
( if ( ~ is 35 memory * .4 )
( prn "F - 'setm' redirects writes" ) )
( = memory * .2 3 )
( setm ' ( 2 integer - address - address deref deref ) 36 )
( if ( ~ is 36 memory * .4 )
( prn "F - 'setm' multiply redirects writes" ) )
( setm '(4 integer-integer-pair) (annotate ' record ' ( 23 24 ) ) )
2014-12-04 02:52:56 +00:00
( if ( ~ memory - contains 4 ' ( 23 24 ) )
2014-11-29 03:31:43 +00:00
( prn "F - 'setm' writes compound records" ) )
2014-12-04 02:34:42 +00:00
( assert ( is memory * .7 nil ) )
2014-11-29 03:31:43 +00:00
( setm '(7 integer-point-pair) (annotate ' record ' ( 23 24 25 ) ) )
2014-12-04 02:52:56 +00:00
( if ( ~ memory - contains 7 ' ( 23 24 25 ) )
2014-11-29 03:31:43 +00:00
( prn "F - 'setm' writes records with compound fields" ) )
( = routine * make - routine ! foo )
( setm '(4 integer-point-pair) (annotate ' record ' ( 33 34 ) ) )
( if ( ~ 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 ) ) )
2014-12-04 02:52:56 +00:00
( if ( ~ memory - contains 4 ' ( 43 44 45 ) )
2014-11-29 03:31:43 +00:00
( prn "F - 'setm' supports indirect writes to records" ) )
( setm '(2 integer-point-pair-address-address deref deref) (annotate ' record ' ( 53 54 55 ) ) )
2014-12-04 02:52:56 +00:00
( if ( ~ memory - contains 4 ' ( 53 54 55 ) )
2014-11-29 03:31:43 +00:00
( prn "F - 'setm' supports multiply indirect writes to records" ) )
( setm '(4 integer-array) (annotate ' record ' ( 2 31 32 ) ) )
2014-12-04 02:52:56 +00:00
( if ( ~ memory - contains 4 ' ( 2 31 32 ) )
2014-11-29 03:31:43 +00:00
( prn "F - 'setm' writes arrays" ) )
( setm '(3 integer-array-address deref) (annotate ' record ' ( 2 41 42 ) ) )
2014-12-04 02:52:56 +00:00
( if ( ~ memory - contains 4 ' ( 2 41 42 ) )
2014-11-29 03:31:43 +00:00
( prn "F - 'setm' supports indirect writes to arrays" ) )
( = routine * make - routine ! foo )
( setm '(4 integer-array) (annotate ' record ' ( 2 31 32 33 ) ) )
( if ( ~ posmatch "invalid array" rep . routine * ! error )
( prn "F - 'setm' checks that array written is well-formed" ) )
2014-11-29 08:57:06 +00:00
( = routine * make - routine ! foo )
; ? ( prn 111 )
; ? ( = dump - trace * ( obj whitelist ' ( "sizeof" "setm" ) ) )
( setm '(4 integer-boolean-pair-array) (annotate ' record ' ( 2 31 nil 32 nil 33 ) ) )
( if ( ~ 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 ) ) )
( if ( posmatch "invalid array" rep . routine * ! error )
( prn "F - 'setm' checks that array of records is well-formed - 2" ) )
2014-11-29 03:31:43 +00:00
( wipe routine * )
2014-10-10 22:04:14 +00:00
( reset ) ; end file with this to persist the trace for the final test