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-12-13 08:33:20 +00:00
( selective - load "mu.arc" section - level )
2014-12-04 10:50:33 +00:00
; ? ( quit )
2014-07-06 07:07:03 +00:00
2014-12-14 07:31:52 +00:00
( section 20
2014-12-13 08:49:58 +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
2015-01-09 08:59:13 +00:00
; idealized syntax above . For now they will look like this:
2014-10-10 22:04:14 +00:00
;
2015-01-09 08:59:13 +00:00
; ( function f [
; ( oarg1 oarg2 ... < - op arg1 arg2 ... )
; ...
; ...
; ] )
2014-10-10 22:04:14 +00:00
;
2015-01-09 08:59:13 +00:00
; Each arg / oarg can contain metadata separated by slashes and colons . In this
; first example below , the only metadata is types: 'integer' for a memory
; location containing an integer , and 'literal' for a value included directly
; in code . ( Assembly languages traditionally call them 'immediate' operands . )
; In the future a simple tool will check that the types line up as expected in
; each op . A different tool might add types where they aren ' t provided .
; Instead of a monolithic compiler I want to build simple , lightweight tools
; that can be combined in various ways , say for using different typecheckers
; in different subsystems .
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
2015-01-09 08:59:13 +00:00
; look for it when reading the code examples . Everything outside 'add-code' is
; just test - harness details that can be skipped at first .
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
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-12-14 17:46:49 +00:00
( 1 : integer < - copy 23 : literal )
2014-11-25 05:09:07 +00:00
] ) ) )
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
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-12-14 17:46:49 +00:00
( 1 : integer < - copy 1 : literal )
( 2 : integer < - copy 3 : literal )
( 3 : integer < - add 1 : integer 2 : integer )
2014-11-25 05:09:07 +00:00
] ) ) )
2014-10-18 23:58:51 +00:00
( run ' main )
2014-12-15 10:00:18 +00:00
; ? ( prn memory * )
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-12-15 10:00:18 +00:00
; ? ( quit )
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
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-12-14 17:46:49 +00:00
( 1 : integer < - add 2 : literal 3 : literal )
2014-11-25 05:09:07 +00:00
] ) ) )
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
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-12-14 17:46:49 +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
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-12-14 17:46:49 +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
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-12-14 17:46:49 +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
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-12-14 17:46:49 +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
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-12-14 17:46:49 +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
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-12-14 17:46:49 +00:00
( 1 : boolean < - and t:literal nil:literal )
2014-11-25 05:09:07 +00:00
] ) ) )
2014-12-14 17:46:49 +00:00
; ? ( set dump - trace * )
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
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-12-14 17:46:49 +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
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-12-14 17:46:49 +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
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-12-14 17:46:49 +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
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-12-14 17:46:49 +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
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-12-14 17:46:49 +00:00
( 1 : integer < - copy 8 : literal )
( jump 1 : offset )
( 2 : integer < - copy 3 : literal ) ; should be skipped
2014-11-25 05:09:07 +00:00
( reply )
] ) ) )
2014-12-14 17:46:49 +00:00
; ? ( set dump - trace * )
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-12-14 17:46:49 +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-target" )
2014-11-25 05:09:07 +00:00
( add - code
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-12-14 17:46:49 +00:00
( 1 : integer < - copy 8 : literal )
( jump 1 : offset )
( 2 : integer < - copy 3 : literal ) ; should be skipped
2014-07-12 05:26:19 +00:00
( reply )
2014-12-14 17:46:49 +00:00
( 3 : integer < - copy 34 : literal )
2014-11-25 05:09:07 +00:00
] ) ) ) ; 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
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-12-14 17:46:49 +00:00
( 2 : integer < - copy 1 : literal )
( 1 : boolean < - equal 1 : literal 2 : integer )
( jump - if 1 : boolean 1 : offset )
( 2 : integer < - copy 3 : literal )
2014-07-12 05:26:19 +00:00
( reply )
2014-12-14 17:46:49 +00:00
( 3 : integer < - copy 34 : literal )
2014-11-25 05:09:07 +00:00
] ) ) )
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
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-12-14 17:46:49 +00:00
( 1 : boolean < - equal 1 : literal 2 : literal )
( jump - if 3 : boolean 1 : offset )
( 2 : integer < - copy 3 : literal )
2014-07-12 05:26:19 +00:00
( reply )
2014-12-14 17:46:49 +00:00
( 3 : integer < - copy 34 : literal )
2014-11-25 05:09:07 +00:00
] ) ) )
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
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-12-14 17:46:49 +00:00
( 1 : integer < - copy 2 : literal )
( 2 : integer < - copy 1 : literal )
2014-10-07 16:29:40 +00:00
; loop
2014-12-14 17:46:49 +00:00
( 2 : integer < - add 2 : integer 2 : integer )
( 3 : boolean < - equal 1 : integer 2 : integer )
( jump - if 3 : boolean - 3 : offset ) ; to loop
( 4 : integer < - copy 3 : literal )
2014-07-17 16:21:27 +00:00
( reply )
2014-12-14 17:46:49 +00:00
( 3 : integer < - copy 34 : literal )
2014-11-25 05:09:07 +00:00
] ) ) )
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
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-12-14 17:46:49 +00:00
( 1 : integer < - copy 2 : literal )
( 2 : integer < - copy 1 : literal )
2014-11-27 16:49:18 +00:00
loop
2014-12-14 17:46:49 +00:00
( 2 : integer < - add 2 : integer 2 : integer )
( 3 : boolean < - equal 1 : integer 2 : integer )
( jump - if 3 : boolean loop:offset )
( 4 : integer < - copy 3 : literal )
2014-11-27 16:49:18 +00:00
( reply )
2014-12-14 17:46:49 +00:00
( 3 : integer < - copy 34 : literal )
2014-11-27 16:49:18 +00:00
] ) ) )
; ? ( 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-12-14 17:46:49 +00:00
; ? ( quit )
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
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-12-14 17:46:49 +00:00
( 1 : integer < - copy 34 : literal )
( 2 : integer < - copy 1 : integer )
2014-11-25 05:09:07 +00:00
] ) ) )
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 .
2015-01-09 08:59:13 +00:00
; Indicated by the metadata '/deref' . Usually requires an address type .
2014-10-10 22:04:14 +00:00
; 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
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-12-14 17:46:49 +00:00
( 1 : integer - address < - copy 2 : literal ) ; unsafe ; can ' t do this in general
( 2 : integer < - copy 34 : literal )
( 3 : integer < - copy 1 : integer - address / deref )
2014-11-25 05:09:07 +00:00
] ) ) )
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
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-12-14 17:46:49 +00:00
( 1 : integer - address < - copy 2 : literal )
( 2 : integer < - copy 34 : literal )
( 1 : integer - address / deref < - add 2 : integer 2 : literal )
2014-11-25 05:09:07 +00:00
] ) ) )
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
2014-12-17 18:39:58 +00:00
; provides first - class support for compound types: arrays and and - records .
2014-10-10 22:04:14 +00:00
;
2014-12-17 18:39:58 +00:00
; 'get' accesses fields in and - records
2014-10-10 22:04:14 +00:00
; '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
2014-12-17 18:52:54 +00:00
; ( see type * in mu . arc for the complete list of types ; we ' ll add to it over
2014-10-28 18:32:00 +00:00
; 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 )
2014-12-17 18:52:54 +00:00
( each ( typ typeinfo ) type *
2014-12-17 18:39:58 +00:00
( when typeinfo ! and - record
2014-11-07 05:45:07 +00:00
( 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
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-12-14 17:46:49 +00:00
( 1 : integer < - copy 34 : literal )
( 2 : boolean < - copy nil:literal )
( 3 : boolean < - get 1 : integer - boolean - pair 1 : offset )
( 4 : integer < - get 1 : integer - boolean - pair 0 : offset )
2014-11-25 05:09:07 +00:00
] ) ) )
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 ) )
2014-12-17 18:39:58 +00:00
( prn "F - 'get' accesses fields of and-records" ) )
2014-12-14 17:46:49 +00:00
; ? ( quit )
2014-08-20 04:33:48 +00:00
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
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-12-14 17:46:49 +00:00
( 1 : integer < - copy 34 : literal )
( 2 : boolean < - copy nil:literal )
( 3 : integer - boolean - pair - address < - copy 1 : literal )
( 4 : boolean < - get 3 : integer - boolean - pair - address / deref 1 : offset )
( 5 : integer < - get 3 : integer - boolean - pair - address / deref 0 : offset )
2014-11-25 05:09:07 +00:00
] ) ) )
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 ) )
2014-12-17 18:39:58 +00:00
( prn "F - 'get' accesses fields of and-record address" ) )
2014-10-05 22:02:28 +00:00
2014-11-29 03:52:50 +00:00
( reset )
( new - trace "get-indirect-repeated" )
( add - code
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-12-14 17:46:49 +00:00
( 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 )
2014-11-29 03:52:50 +00:00
] ) ) )
( 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
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-12-14 17:46:49 +00:00
( 1 : integer < - copy 34 : literal )
( 2 : integer < - copy 35 : literal )
( 3 : integer < - copy 36 : literal )
( 4 : integer - integer - pair < - get 1 : integer - point - pair 1 : offset )
2014-11-25 05:09:07 +00:00
] ) ) )
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
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-12-14 17:46:49 +00:00
( 1 : integer < - copy 34 : literal )
( 2 : boolean < - copy t:literal )
( 3 : boolean - address < - get - address 1 : integer - boolean - pair 1 : offset )
2014-11-25 05:09:07 +00:00
] ) ) )
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 ) )
2014-12-17 18:39:58 +00:00
( prn "F - 'get-address' returns address of fields of and-records" ) )
2014-10-05 18:34:23 +00:00
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
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-12-14 17:46:49 +00:00
( 1 : integer < - copy 34 : literal )
( 2 : boolean < - copy t:literal )
( 3 : integer - boolean - pair - address < - copy 1 : literal )
( 4 : boolean - address < - get - address 3 : integer - boolean - pair - address / deref 1 : offset )
2014-11-25 05:09:07 +00:00
] ) ) )
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-12-17 18:39:58 +00:00
( prn "F - 'get-address' accesses fields of and-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
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-12-14 17:46:49 +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 - boolean - pair < - index 1 : integer - boolean - pair - array 1 : literal )
2014-11-25 05:09:07 +00:00
] ) ) )
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
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-12-14 17:46:49 +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 < - index 1 : integer - boolean - pair - array 6 : integer )
2014-11-25 05:09:07 +00:00
] ) ) )
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
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-12-14 17:46:49 +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 )
( 8 : integer - boolean - pair < - index 7 : integer - boolean - pair - array - address / deref 6 : integer )
2014-11-25 05:09:07 +00:00
] ) ) )
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
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-12-14 17:46:49 +00:00
( 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 )
2014-11-29 03:28:13 +00:00
] ) ) )
( 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
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-12-14 17:46:49 +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 - address < - index - address 1 : integer - boolean - pair - array 6 : integer )
2014-11-25 05:09:07 +00:00
] ) ) )
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
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-12-14 17:46:49 +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 )
( 8 : integer - boolean - pair - address < - index - address 7 : integer - boolean - pair - array - address / deref 6 : integer )
2014-11-25 05:09:07 +00:00
] ) ) )
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
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-12-14 17:46:49 +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 < - 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
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-12-14 17:46:49 +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 )
( 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
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-12-14 17:46:49 +00:00
( 1 : integer < - sizeof integer - boolean - pair:literal )
2014-11-25 05:09:07 +00:00
] ) ) )
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
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-12-14 17:46:49 +00:00
( 1 : integer < - sizeof integer - point - pair:literal )
2014-11-25 05:09:07 +00:00
] ) ) )
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
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-12-14 17:46:49 +00:00
( 1 : integer < - copy 34 : literal )
( 2 : boolean < - copy nil:literal )
( 4 : boolean < - copy t:literal )
( 3 : integer - boolean - pair < - copy 1 : integer - boolean - pair )
2014-11-25 05:09:07 +00:00
] ) ) )
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
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-12-14 17:46:49 +00:00
( 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 )
2014-11-29 04:11:59 +00:00
] ) ) )
; ? ( = 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-12-14 07:31:52 +00:00
) ; section 20
2014-12-13 08:49:58 +00:00
2014-12-13 08:33:20 +00:00
( section 100
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
2015-01-06 19:01:24 +00:00
;
; The payload of a tagged value must occupy just one location . Save pointers
; to records .
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
2014-12-13 02:07:30 +00:00
' ( ( function main [
2015-01-06 19:01:24 +00:00
( 1 : type < - copy integer:literal )
( 2 : integer < - copy 34 : literal )
( 3 : integer 4 : boolean < - maybe - coerce 1 : tagged - value integer:literal )
2014-11-25 05:09:07 +00:00
] ) ) )
2014-12-04 10:50:33 +00:00
; ? ( set dump - trace * )
2014-10-18 23:58:51 +00:00
( run ' main )
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 ) ) )
2015-01-06 19:01:24 +00:00
; ? ( prn memory * )
( if ( or ( ~ is memory * .3 34 )
( ~ is memory * .4 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
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-12-14 17:46:49 +00:00
( 1 : type < - copy integer - address:literal )
2015-01-06 19:01:24 +00:00
( 2 : integer < - copy 34 : literal )
( 3 : boolean 4 : boolean < - maybe - coerce 1 : tagged - value boolean:literal )
2014-11-25 05:09:07 +00:00
] ) ) )
2014-10-18 23:58:51 +00:00
( run ' main )
2014-10-12 21:10:14 +00:00
; ? ( prn memory * )
2015-01-06 19:01:24 +00:00
( if ( or ( ~ is memory * .3 0 )
( ~ is memory * .4 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
2014-12-13 02:07:30 +00:00
' ( ( function main [
2015-01-06 19:01:24 +00:00
( 1 : integer < - copy 34 : literal )
( 2 : tagged - value < - save - type 1 : integer )
2014-11-25 05:09:07 +00:00
] ) ) )
2014-10-24 18:38:02 +00:00
( run ' main )
; ? ( prn memory * )
2015-01-06 19:01:24 +00:00
( if ( ~ iso memory * ( obj 1 34 2 ' integer 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 )
2014-12-28 21:03:50 +00:00
( new - trace "init-tagged-value" )
2014-11-25 05:09:07 +00:00
( add - code
2014-12-13 02:07:30 +00:00
' ( ( function main [
2015-01-06 19:01:24 +00:00
( 1 : integer < - copy 34 : literal )
( 2 : tagged - value - address < - init - tagged - value integer:literal 1 : integer )
( 3 : integer 4 : boolean < - maybe - coerce 2 : tagged - value - address / deref integer:literal )
2014-11-25 05:09:07 +00:00
] ) ) )
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 * )
2015-01-06 19:01:24 +00:00
( if ( or ( ~ is memory * .3 34 )
( ~ is memory * .4 t ) )
2014-12-28 21:03:50 +00:00
( prn "F - 'init-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-12-17 18:39:58 +00:00
; Now that we can package values together with their types , we can construct a
; dynamically typed list .
2014-10-12 21:10:14 +00:00
( reset )
( new - trace "list" )
; ? ( set dump - trace * )
2014-11-25 05:09:07 +00:00
( add - code
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-10-12 21:10:14 +00:00
; 1 points at first node: tagged - value ( int 34 )
2014-12-14 17:46:49 +00:00
( 1 : list - address < - new list:literal )
( 2 : tagged - value - address < - list - value - address 1 : list - address )
2015-01-06 19:01:24 +00:00
( 3 : type - address < - get - address 2 : tagged - value - address / deref type:offset )
2014-12-14 20:36:42 +00:00
( 3 : type - address / deref < - copy integer:literal )
2015-01-06 19:01:24 +00:00
( 4 : location < - get - address 2 : tagged - value - address / deref payload:offset )
2014-12-14 20:36:42 +00:00
( 4 : location / deref < - copy 34 : literal )
2015-01-06 19:01:24 +00:00
( 5 : list - address - address < - get - address 1 : list - address / deref cdr:offset )
2014-12-14 20:36:42 +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 )
2014-12-14 20:36:42 +00:00
( 6 : list - address < - copy 5 : list - address - address / deref )
2014-12-14 17:46:49 +00:00
( 7 : tagged - value - address < - list - value - address 6 : list - address )
2015-01-06 19:01:24 +00:00
( 8 : type - address < - get - address 7 : tagged - value - address / deref type:offset )
2014-12-14 20:36:42 +00:00
( 8 : type - address / deref < - copy boolean:literal )
2015-01-06 19:01:24 +00:00
( 9 : location < - get - address 7 : tagged - value - address / deref payload:offset )
2014-12-14 20:36:42 +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
2014-12-29 17:20:51 +00:00
; ? ( = dump - trace * ( obj whitelist ' ( "run" ) ) )
; ? ( set dump - trace * )
2014-12-04 10:50:33 +00:00
( run )
; ? ( prn memory * )
2014-12-29 17:20:51 +00:00
( each routine completed - routines *
( aif rep . routine ! error ( prn "error - " it ) ) )
2014-12-04 10:50:33 +00:00
( 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
2014-12-13 02:07:30 +00:00
' ( ( function test2 [
2014-12-14 17:46:49 +00:00
( 10 : list - address < - list - next 1 : list - address )
2014-11-25 05:09:07 +00:00
] ) ) )
2014-12-29 17:20:51 +00:00
; ? ( set dump - trace * )
2014-10-13 01:04:29 +00:00
( run ' test2 )
; ? ( prn memory * )
2014-12-29 17:20:51 +00:00
( each routine completed - routines *
( aif rep . routine ! error ( prn "error - " it ) ) )
2014-10-13 01:04:29 +00:00
( if ( ~ is memory * .10 memory * .6 )
( prn "F - 'list-next can move a list pointer to the next node" ) )
2014-12-29 17:20:51 +00:00
; ? ( quit )
2014-10-12 21:10:14 +00:00
2014-12-28 21:03:50 +00:00
; 'init-list' takes a variable number of args and constructs a list containing
2015-01-06 19:01:24 +00:00
; them . Just integers for now .
2014-10-25 09:32:30 +00:00
( reset )
2014-12-28 21:03:50 +00:00
( new - trace "init-list" )
2014-11-25 05:09:07 +00:00
( add - code
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-12-28 21:03:50 +00:00
( 1 : integer < - init - list 3 : literal 4 : literal 5 : literal )
2014-11-25 05:09:07 +00:00
] ) ) )
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 ) ) ) ) ) ) )
2014-12-28 21:03:50 +00:00
( prn "F - 'init-list' can construct a list of integers" ) ) )
2014-10-25 09:32:30 +00:00
2014-12-13 08:33:20 +00:00
) ; section 100
2014-12-14 07:31:52 +00:00
( section 20
2014-12-13 08:49:58 +00:00
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
2014-12-13 02:07:30 +00:00
' ( ( function test1 [
2014-12-14 17:46:49 +00:00
( 3 : integer < - add 1 : integer 2 : integer )
2014-11-25 05:09:07 +00:00
] )
2014-12-13 02:07:30 +00:00
( function main [
2014-12-14 17:46:49 +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
2014-12-13 02:07:30 +00:00
' ( ( function test1 [
2014-12-14 17:46:49 +00:00
( 1 : integer < - copy 1 : literal )
2014-11-25 05:09:07 +00:00
] )
2014-12-13 02:07:30 +00:00
( function main [
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 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
2014-12-13 02:07:30 +00:00
' ( ( function test1 [
2014-12-14 17:46:49 +00:00
( 3 : integer < - add 1 : integer 2 : integer )
2014-10-10 22:04:14 +00:00
( reply )
2014-12-14 17:46:49 +00:00
( 4 : integer < - copy 34 : literal )
2014-11-25 05:09:07 +00:00
] )
2014-12-13 02:07:30 +00:00
( function main [
2014-12-14 17:46:49 +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
2014-12-13 02:07:30 +00:00
' ( ( function test1 [
2014-12-14 17:46:49 +00:00
( 3 : integer < - test2 )
2014-11-25 05:09:07 +00:00
] )
2014-12-13 02:07:30 +00:00
( function test2 [
2014-12-14 17:46:49 +00:00
( reply 2 : integer )
2014-11-25 05:09:07 +00:00
] )
2014-12-13 02:07:30 +00:00
( function main [
2014-12-14 17:46:49 +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
2014-12-13 02:07:30 +00:00
' ( ( function test1 [
2014-12-14 17:46:49 +00:00
( 3 : integer < - add 1 : integer 2 : integer )
2014-10-10 22:04:14 +00:00
( reply )
2014-12-14 17:46:49 +00:00
( 4 : integer < - copy 34 : literal )
2014-11-25 05:09:07 +00:00
] )
2014-12-13 02:07:30 +00:00
( function main [
2014-12-14 17:46:49 +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 )
2014-12-26 03:39:32 +00:00
( reset )
( new - trace "reply-increments-caller-pc" )
( add - code
' ( ( function callee [
( reply )
] )
( function caller [
( 1 : integer < - copy 0 : literal )
( 2 : integer < - copy 0 : literal )
] ) ) )
2014-12-30 23:13:51 +00:00
( freeze function * )
2014-12-26 03:39:32 +00:00
( = routine * ( make - routine ' caller ) )
( assert ( is 0 pc . routine * ) )
( push - stack routine * ' callee ) ; pretend call was at first instruction of caller
( run - for - time - slice 1 )
( if ( ~ is 1 pc . routine * )
( prn "F - 'reply' should increment pc in caller (to move past calling instruction)" ) )
2014-10-10 22:04:14 +00:00
( reset )
( new - trace "new-fn-arg-sequential" )
2014-11-25 05:09:07 +00:00
( add - code
2014-12-13 02:07:30 +00:00
' ( ( function test1 [
2014-12-14 17:46:49 +00:00
( 4 : integer < - next - input )
( 5 : integer < - next - input )
( 3 : integer < - add 4 : integer 5 : integer )
2014-10-10 22:04:14 +00:00
( reply )
2014-12-14 17:46:49 +00:00
( 4 : integer < - copy 34 : literal )
2014-11-25 05:09:07 +00:00
] )
2014-12-13 02:07:30 +00:00
( function main [
2014-12-14 17:46:49 +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
2014-12-13 02:07:30 +00:00
' ( ( function test1 [
2014-12-14 17:46:49 +00:00
( 5 : integer < - input 1 : literal )
( 4 : integer < - input 0 : literal )
( 3 : integer < - add 4 : integer 5 : integer )
2014-10-10 22:04:14 +00:00
( reply )
2014-12-14 17:46:49 +00:00
( 4 : integer < - copy 34 : literal ) ; should never run
2014-11-27 14:04:25 +00:00
] )
2014-12-13 02:07:30 +00:00
( function main [
2014-12-14 17:46:49 +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
2014-12-13 02:07:30 +00:00
' ( ( function test1 [
2014-12-14 17:46:49 +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
2014-12-13 02:07:30 +00:00
( function main [
2014-12-14 17:46:49 +00:00
( test1 1 : literal 2 : literal 3 : literal )
2014-11-27 14:16:02 +00:00
] ) ) )
( 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
2014-12-13 02:07:30 +00:00
' ( ( function test1 [
2014-12-14 17:46:49 +00:00
( 4 : integer 5 : boolean < - next - input )
2014-11-25 05:09:07 +00:00
] )
2014-12-13 02:07:30 +00:00
( function main [
2014-12-14 17:46:49 +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
2014-12-13 02:07:30 +00:00
' ( ( function test1 [
2014-12-14 17:46:49 +00:00
( 4 : integer < - next - input )
( 5 : integer < - next - input )
2014-11-25 05:09:07 +00:00
] )
2014-12-13 02:07:30 +00:00
( function main [
2014-12-14 17:46:49 +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
2014-12-13 02:07:30 +00:00
' ( ( function test1 [
2014-12-14 17:46:49 +00:00
( 4 : integer < - next - input )
( 5 : integer 6 : boolean < - next - input )
2014-11-25 05:09:07 +00:00
] )
2014-12-13 02:07:30 +00:00
( function main [
2014-12-14 17:46:49 +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
2014-12-13 02:07:30 +00:00
' ( ( function test1 [
2014-12-14 17:46:49 +00:00
( 4 : integer < - next - input )
( 5 : integer < - copy 34 : literal )
( 5 : integer 6 : boolean < - next - input )
2014-11-25 05:09:07 +00:00
] )
2014-12-13 02:07:30 +00:00
( function main [
2014-12-14 17:46:49 +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
2014-12-13 02:07:30 +00:00
' ( ( function test1 [
2014-10-12 17:49:08 +00:00
; if given two args , adds them ; if given one arg , increments
2014-12-14 17:46:49 +00:00
( 4 : integer < - next - input )
( 5 : integer 6 : boolean < - next - input )
2014-10-12 17:49:08 +00:00
{ begin
2014-12-14 17:46:49 +00:00
( break - if 6 : boolean )
( 5 : integer < - copy 1 : literal )
2014-10-12 17:49:08 +00:00
}
2014-12-14 17:46:49 +00:00
( 7 : integer < - add 4 : integer 5 : integer )
2014-11-25 05:09:07 +00:00
] )
2014-12-13 02:07:30 +00:00
( function main [
2014-12-14 17:46:49 +00:00
( test1 34 : literal )
2014-11-25 05:09:07 +00:00
] ) ) )
2014-12-14 17:46:49 +00:00
; ? ( set dump - trace * )
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
2014-12-13 02:07:30 +00:00
' ( ( function test1 [
2014-12-14 17:46:49 +00:00
( 1 : integer < - copy 0 : literal ) ; overwrite caller memory
( 2 : integer < - next - input )
2014-11-25 05:09:07 +00:00
] ) ; arg not clobbered
2014-12-13 02:07:30 +00:00
( function main [
2014-12-14 17:46:49 +00:00
( 1 : integer < - copy 34 : literal )
( test1 1 : integer )
2014-11-25 05:09:07 +00:00
] ) ) )
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
2014-12-13 02:07:30 +00:00
' ( ( function test1 [
2014-12-14 17:46:49 +00:00
( 4 : integer - boolean - pair < - next - input )
2014-11-28 04:09:45 +00:00
] )
2014-12-13 02:07:30 +00:00
( function main [
2014-12-14 17:46:49 +00:00
( 1 : integer < - copy 34 : literal )
( 2 : boolean < - copy nil:literal )
( test1 1 : integer - boolean - pair )
2014-11-28 04:09:45 +00:00
] ) ) )
( 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
2014-12-13 02:07:30 +00:00
' ( ( function test1 [
2014-12-14 17:46:49 +00:00
( 4 : integer - boolean - pair < - next - input )
2014-11-28 04:09:45 +00:00
] )
2014-12-13 02:07:30 +00:00
( function main [
2014-12-14 17:46:49 +00:00
( 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 )
2014-11-28 04:09:45 +00:00
] ) ) )
( 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
2014-12-13 02:07:30 +00:00
' ( ( function test1 [
2014-12-14 17:46:49 +00:00
( 4 : integer < - next - input )
( 5 : integer < - next - input )
( 6 : integer < - add 4 : integer 5 : integer )
( reply 6 : integer )
( 4 : integer < - copy 34 : literal )
2014-11-25 05:09:07 +00:00
] )
2014-12-13 02:07:30 +00:00
( function main [
2014-12-14 17:46:49 +00:00
( 1 : integer < - copy 1 : literal )
( 2 : integer < - copy 3 : literal )
( 3 : integer < - 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 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
2014-12-13 02:07:30 +00:00
' ( ( function test1 [
2014-12-14 17:46:49 +00:00
( 4 : integer < - next - input )
( 5 : integer < - next - input )
( 6 : integer < - add 4 : integer 5 : integer )
( reply 6 : integer 5 : integer )
( 4 : integer < - copy 34 : literal )
2014-11-25 05:09:07 +00:00
] )
2014-12-13 02:07:30 +00:00
( function main [
2014-12-14 17:46:49 +00:00
( 1 : integer < - copy 1 : literal )
( 2 : integer < - copy 3 : literal )
( 3 : integer 7 : integer < - 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 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
2014-12-13 02:07:30 +00:00
' ( ( function test1 [
2014-12-14 17:46:49 +00:00
( 4 : integer < - next - input )
( 5 : integer < - next - input )
( 6 : integer < - add 4 : integer 5 : integer )
( prepare - reply 6 : integer 5 : integer )
2014-10-31 23:22:21 +00:00
( reply )
2014-12-14 17:46:49 +00:00
( 4 : integer < - copy 34 : literal )
2014-11-25 05:09:07 +00:00
] )
2014-12-13 02:07:30 +00:00
( function main [
2014-12-14 17:46:49 +00:00
( 1 : integer < - copy 1 : literal )
( 2 : integer < - copy 3 : literal )
( 3 : integer 7 : integer < - test1 1 : integer 2 : integer )
2014-11-25 05:09:07 +00:00
] ) ) )
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-12-14 15:24:42 +00:00
) ; section 20
( section 11
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
2014-12-14 17:46:49 +00:00
' ( ( ( ( 1 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
( ( ( 2 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
( ( ( 3 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
2014-11-27 16:48:38 +00:00
{ begin ; 'begin' is just a hack because racket turns braces into parens
2014-12-14 17:46:49 +00:00
( ( ( 4 boolean ) ) < - ( ( not - equal ) ) ( ( 1 integer ) ) ( ( 3 integer ) ) )
( ( ( break - if ) ) ( ( 4 boolean ) ) )
( ( ( 5 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
2014-10-19 00:57:24 +00:00
}
2014-12-14 17:46:49 +00:00
( ( ( reply ) ) ) ) )
' ( ( ( ( 1 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
( ( ( 2 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
( ( ( 3 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
( ( ( 4 boolean ) ) < - ( ( not - equal ) ) ( ( 1 integer ) ) ( ( 3 integer ) ) )
( ( ( jump - if ) ) ( ( 4 boolean ) ) ( ( 1 offset ) ) )
( ( ( 5 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
( ( ( reply ) ) ) ) )
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
2014-12-14 17:46:49 +00:00
' ( ( ( ( 1 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
( ( ( 2 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
( ( ( 3 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
2014-10-19 00:57:24 +00:00
{ begin
2014-12-14 17:46:49 +00:00
( ( ( break ) ) )
2014-10-19 00:57:24 +00:00
}
2014-12-14 17:46:49 +00:00
( ( ( reply ) ) ) ) )
' ( ( ( ( 1 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
( ( ( 2 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
( ( ( 3 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
( ( ( jump ) ) ( ( 0 offset ) ) )
( ( ( reply ) ) ) ) )
2014-07-17 16:21:27 +00:00
( 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
2014-12-14 17:46:49 +00:00
' ( ( ( ( 1 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
( ( ( 2 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
( ( ( 3 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
2014-10-19 00:57:24 +00:00
{ begin
2014-12-14 17:46:49 +00:00
( ( ( 4 boolean ) ) < - ( ( not - equal ) ) ( ( 1 integer ) ) ( ( 3 integer ) ) )
( ( ( break - if ) ) ( ( 4 boolean ) ) )
2014-10-19 00:57:24 +00:00
{ begin
2014-12-14 17:46:49 +00:00
( ( ( 5 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
2014-10-19 00:57:24 +00:00
}
}
2014-12-14 17:46:49 +00:00
( ( ( reply ) ) ) ) )
' ( ( ( ( 1 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
( ( ( 2 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
( ( ( 3 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
( ( ( 4 boolean ) ) < - ( ( not - equal ) ) ( ( 1 integer ) ) ( ( 3 integer ) ) )
( ( ( jump - if ) ) ( ( 4 boolean ) ) ( ( 1 offset ) ) )
( ( ( 5 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
( ( ( reply ) ) ) ) )
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
2014-12-14 17:46:49 +00:00
' ( ( ( ( 1 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
2014-11-23 14:06:04 +00:00
{ begin
2014-12-14 17:46:49 +00:00
( ( ( break ) ) )
( ( ( 2 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
2014-11-23 14:06:04 +00:00
}
{ begin
2014-12-14 17:46:49 +00:00
( ( ( break ) ) )
( ( ( 3 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
2014-11-23 14:06:04 +00:00
}
2014-12-14 17:46:49 +00:00
( ( ( 4 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) ) ) )
' ( ( ( ( 1 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
( ( ( jump ) ) ( ( 1 offset ) ) )
( ( ( 2 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
( ( ( jump ) ) ( ( 1 offset ) ) )
( ( ( 3 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
( ( ( 4 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) ) ) )
2014-11-23 14:06:04 +00:00
( 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
2014-12-14 17:46:49 +00:00
' ( ( ( ( 1 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
( ( ( 2 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
2014-10-19 00:57:24 +00:00
{ begin
2014-12-14 17:46:49 +00:00
( ( ( 3 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
2014-10-19 00:57:24 +00:00
{ begin
2014-12-14 17:46:49 +00:00
( ( ( 4 boolean ) ) < - ( ( not - equal ) ) ( ( 1 integer ) ) ( ( 3 integer ) ) )
2014-10-19 00:57:24 +00:00
}
2014-12-14 17:46:49 +00:00
( ( ( loop - if ) ) ( ( 4 boolean ) ) )
( ( ( 5 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
2014-10-19 00:57:24 +00:00
}
2014-12-14 17:46:49 +00:00
( ( ( reply ) ) ) ) )
' ( ( ( ( 1 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
( ( ( 2 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
( ( ( 3 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
( ( ( 4 boolean ) ) < - ( ( not - equal ) ) ( ( 1 integer ) ) ( ( 3 integer ) ) )
( ( ( jump - if ) ) ( ( 4 boolean ) ) ( ( - 3 offset ) ) )
( ( ( 5 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
( ( ( reply ) ) ) ) )
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
2014-12-14 17:46:49 +00:00
' ( ( ( ( 1 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
2014-11-23 06:26:11 +00:00
foo
2014-12-14 17:46:49 +00:00
( ( ( 2 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) ) ) )
' ( ( ( ( 1 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
2014-11-23 06:26:11 +00:00
foo
2014-12-14 17:46:49 +00:00
( ( ( 2 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) ) ) )
2014-11-23 06:26:11 +00:00
( 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
2014-12-14 17:46:49 +00:00
' ( ( ( ( 1 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
2014-11-23 06:26:11 +00:00
{ begin
2014-12-14 17:46:49 +00:00
( ( ( break ) ) )
2014-11-23 06:26:11 +00:00
foo
}
2014-12-14 17:46:49 +00:00
( ( ( 2 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) ) ) )
' ( ( ( ( 1 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
( ( ( jump ) ) ( ( 1 offset ) ) )
2014-11-23 06:26:11 +00:00
foo
2014-12-14 17:46:49 +00:00
( ( ( 2 integer ) ) < - ( ( copy ) ) ( ( 0 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
2014-12-14 17:46:49 +00:00
' ( ( ( ( 1 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
2014-11-23 14:06:04 +00:00
{ begin
2014-12-14 17:46:49 +00:00
( ( ( break ) ) )
2014-11-23 14:06:04 +00:00
foo
}
2014-12-14 17:46:49 +00:00
( ( ( 2 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
2014-11-23 14:06:04 +00:00
{ begin
2014-12-14 17:46:49 +00:00
( ( ( break ) ) )
( ( ( 3 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
2014-11-23 14:06:04 +00:00
}
2014-12-14 17:46:49 +00:00
( ( ( 4 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) ) ) )
' ( ( ( ( 1 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
( ( ( jump ) ) ( ( 1 offset ) ) )
2014-11-23 14:06:04 +00:00
foo
2014-12-14 17:46:49 +00:00
( ( ( 2 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
( ( ( jump ) ) ( ( 1 offset ) ) )
( ( ( 3 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
( ( ( 4 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) ) ) )
2014-11-23 14:06:04 +00:00
( 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
2014-12-14 17:46:49 +00:00
' ( ( ( ( 1 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
2014-11-27 17:30:43 +00:00
{ begin
{ begin
2014-12-14 17:46:49 +00:00
( ( ( break ) ) ( ( 2 blocks ) ) )
2014-11-27 17:30:43 +00:00
}
2014-12-14 17:46:49 +00:00
( ( ( 2 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
( ( ( 3 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
( ( ( 4 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
( ( ( 5 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
2014-11-27 17:30:43 +00:00
} ) )
2014-12-14 17:46:49 +00:00
' ( ( ( ( 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 ) ) ) ) )
2014-11-27 17:30:43 +00:00
( prn "F - 'break' can take an extra arg with number of nested blocks to exit" ) )
2014-12-14 15:42:31 +00:00
; ? ( quit )
2014-11-27 17:30:43 +00:00
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-12-14 15:42:31 +00:00
( if ( ~ iso ( convert - braces
2014-12-14 17:46:49 +00:00
' ( ( ( ( 1 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
( ( ( 2 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
2014-12-14 15:42:31 +00:00
{ begin
2014-12-14 17:46:49 +00:00
( ( ( 3 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
( ( ( loop ) ) )
2014-12-14 15:42:31 +00:00
} ) )
2014-12-14 17:46:49 +00:00
' ( ( ( ( 1 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
( ( ( 2 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
( ( ( 3 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
( ( ( jump ) ) ( ( - 2 offset ) ) ) ) )
2014-12-14 15:42:31 +00:00
( prn "F - 'loop' jumps to start of containing block" ) )
2014-12-14 15:24:42 +00:00
; ? ( quit )
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-12-14 15:42:31 +00:00
( if ( ~ iso ( convert - braces
2014-12-14 17:46:49 +00:00
' ( ( ( ( 1 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
( ( ( 2 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
2014-12-14 15:42:31 +00:00
{ begin
2014-12-14 17:46:49 +00:00
( ( ( 3 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
2014-12-14 15:42:31 +00:00
{ begin
2014-12-14 17:46:49 +00:00
( ( ( 4 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
2014-12-14 15:42:31 +00:00
}
2014-12-14 17:46:49 +00:00
( ( ( loop ) ) )
2014-12-14 15:42:31 +00:00
} ) )
2014-12-14 17:46:49 +00:00
' ( ( ( ( 1 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
( ( ( 2 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
( ( ( 3 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
( ( ( 4 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
( ( ( jump ) ) ( ( - 3 offset ) ) ) ) )
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-11-27 17:30:43 +00:00
( reset )
( new - trace "loop-multiple" )
( = traces * ( queue ) )
; ? ( = dump - trace * ( obj whitelist ' ( "-" ) ) )
( if ( ~ iso ( convert - braces
2014-12-14 17:46:49 +00:00
' ( ( ( ( 1 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
2014-11-27 17:30:43 +00:00
{ begin
2014-12-14 17:46:49 +00:00
( ( ( 2 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
( ( ( 3 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
2014-11-27 17:30:43 +00:00
{ begin
2014-12-14 17:46:49 +00:00
( ( ( loop ) ) ( ( 2 blocks ) ) )
2014-11-27 17:30:43 +00:00
}
} ) )
2014-12-14 17:46:49 +00:00
' ( ( ( ( 1 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
( ( ( 2 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
( ( ( 3 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
( ( ( jump ) ) ( ( - 3 offset ) ) ) ) )
2014-11-27 17:30:43 +00:00
( prn "F - 'loop' can take an extra arg with number of nested blocks to exit" ) )
2014-12-14 16:06:32 +00:00
; ? ( quit )
2014-11-27 17:30:43 +00:00
2014-12-14 17:46:49 +00:00
( reset )
( new - trace "convert-labels" )
( = traces * ( queue ) )
( if ( ~ iso ( convert - labels
' ( loop
( ( ( jump ) ) ( ( loop offset ) ) ) ) )
' ( loop
( ( ( jump ) ) ( ( - 2 offset ) ) ) ) )
( prn "F - 'convert-labels' rewrites jumps to labels" ) )
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-12-14 16:06:32 +00:00
; ? ( set dump - trace * )
2014-11-01 19:43:45 +00:00
( if ( ~ iso ( convert - names
2014-12-14 17:46:49 +00:00
' ( ( ( ( x integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
( ( ( y integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
( ( ( z integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) ) ) )
' ( ( ( ( 1 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
( ( ( 2 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
( ( ( 3 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) ) ) )
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
2014-12-14 16:15:15 +00:00
; copying 0 into pair is meaningless ; just for testing
2014-12-14 17:46:49 +00:00
' ( ( ( ( x integer - boolean - pair ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
( ( ( y integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) ) ) )
' ( ( ( ( 1 integer - boolean - pair ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
( ( ( 3 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) ) ) )
2014-11-04 21:43:57 +00:00
( 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-12-14 16:06:32 +00:00
; ? ( set dump - trace * )
2014-11-01 19:43:45 +00:00
( if ( ~ iso ( convert - names
2014-12-14 17:46:49 +00:00
' ( ( ( ( x integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
( ( ( y integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
2014-12-14 16:06:32 +00:00
; nil location is meaningless ; just for testing
2014-12-14 17:46:49 +00:00
( ( ( nil integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) ) ) )
' ( ( ( ( 1 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
( ( ( 2 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
( ( ( nil integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) ) ) )
2014-11-01 19:43:45 +00:00
( prn "F - convert-names never renames nil" ) )
2014-12-14 20:36:42 +00:00
( reset )
( new - trace "convert-names-string" )
; ? ( set dump - trace * )
( if ( ~ iso ( convert - names
' ( ( ( ( 1 integer - address ) ) < - ( ( new ) ) "foo" ) ) )
' ( ( ( ( 1 integer - address ) ) < - ( ( new ) ) "foo" ) ) )
( prn "convert-names passes through raw strings (just a convenience arg for 'new')" ) )
2014-11-04 06:32:56 +00:00
( reset )
2014-12-27 06:21:25 +00:00
( new - trace "convert-names-raw" )
2014-11-27 07:23:44 +00:00
( = traces * ( queue ) )
2014-11-04 06:32:56 +00:00
( if ( ~ iso ( convert - names
2014-12-14 17:46:49 +00:00
' ( ( ( ( x integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
2014-12-27 06:21:25 +00:00
( ( ( y integer ) ( raw ) ) < - ( ( copy ) ) ( ( 0 literal ) ) ) ) )
2014-12-14 17:46:49 +00:00
' ( ( ( ( 1 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
2014-12-27 06:21:25 +00:00
( ( ( y integer ) ( raw ) ) < - ( ( copy ) ) ( ( 0 literal ) ) ) ) )
( prn "F - convert-names never renames raw operands" ) )
2014-11-04 06:32:56 +00:00
2014-12-14 16:06:32 +00:00
( reset )
( new - trace "convert-names-literal" )
( = traces * ( queue ) )
( if ( ~ iso ( convert - names
; meaningless ; just for testing
2014-12-14 17:46:49 +00:00
' ( ( ( ( x literal ) ) < - ( ( copy ) ) ( ( 0 literal ) ) ) ) )
' ( ( ( ( x literal ) ) < - ( ( copy ) ) ( ( 0 literal ) ) ) ) )
2014-12-14 16:06:32 +00:00
( prn "F - convert-names never renames literals" ) )
2015-01-01 05:15:26 +00:00
( reset )
( new - trace "convert-names-literal-2" )
( = traces * ( queue ) )
( if ( ~ iso ( convert - names
' ( ( ( ( x boolean ) ) < - ( ( copy ) ) ( ( x literal ) ) ) ) )
' ( ( ( ( 1 boolean ) ) < - ( ( copy ) ) ( ( x literal ) ) ) ) )
( prn "F - convert-names never renames literals, even when the name matches a variable" ) )
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
2014-12-14 17:46:49 +00:00
' ( ( ( ( x integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
( ( ( y integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
2014-12-14 16:11:39 +00:00
; meaningless ; just for testing
2014-12-14 17:46:49 +00:00
( ( ( z fn ) ) < - ( ( copy ) ) ( ( 0 literal ) ) ) ) )
' ( ( ( ( 1 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
( ( ( 2 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
( ( ( z fn ) ) < - ( ( copy ) ) ( ( 0 literal ) ) ) ) )
2014-12-14 16:06:32 +00:00
( prn "F - convert-names never renames fns" ) )
2014-11-01 23:34:33 +00:00
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-12-17 22:03:34 +00:00
; ? ( = dump - trace * ( obj whitelist ' ( "cn0" ) ) )
2014-11-04 06:34:58 +00:00
( if ( ~ iso ( convert - names
2014-12-14 17:46:49 +00:00
' ( ( ( ( x integer ) ) < - ( ( get ) ) ( ( 34 integer - boolean - pair ) ) ( ( bool offset ) ) ) ) )
' ( ( ( ( 1 integer ) ) < - ( ( get ) ) ( ( 34 integer - boolean - pair ) ) ( ( 1 offset ) ) ) ) )
2014-11-04 06:34:58 +00:00
( 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
2014-12-14 17:46:49 +00:00
' ( ( ( ( bool boolean ) ) < - ( ( copy ) ) ( ( t literal ) ) )
( ( ( x integer ) ) < - ( ( get ) ) ( ( 34 integer - boolean - pair ) ) ( ( bool offset ) ) ) ) ) )
2014-11-04 06:34:58 +00:00
( 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
2014-12-14 17:46:49 +00:00
' ( ( ( ( x integer ) ) < - ( ( get ) ) ( ( 34 integer - boolean - pair ) ) ( ( bool offset ) ) )
( ( ( bool boolean ) ) < - ( ( copy ) ) ( ( t literal ) ) ) ) ) )
2014-11-04 06:34:58 +00:00
( 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-12-17 22:03:34 +00:00
; ? ( = dump - trace * ( obj whitelist ' ( "cn0" ) ) )
2014-11-04 07:58:06 +00:00
( if ( ~ iso ( convert - names
2014-12-14 17:46:49 +00:00
' ( ( ( ( x integer ) ) < - ( ( get ) ) ( ( 34 integer - boolean - pair - address ) ( deref ) ) ( ( bool offset ) ) ) ) )
' ( ( ( ( 1 integer ) ) < - ( ( get ) ) ( ( 34 integer - boolean - pair - address ) ( deref ) ) ( ( 1 offset ) ) ) ) )
2014-11-04 07:58:06 +00:00
( prn "F - convert-names replaces field offsets for record addresses" ) )
2014-12-17 22:03:34 +00:00
; ? ( quit )
2014-11-04 07:58:06 +00:00
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
2014-12-14 17:46:49 +00:00
' ( ( ( ( 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 ) ) ) ) )
2014-11-07 08:56:42 +00:00
( 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
2014-12-14 17:46:49 +00:00
' ( ( ( ( 1 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
2014-11-23 06:26:11 +00:00
foo ) )
2014-12-14 17:46:49 +00:00
' ( ( ( ( 1 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
2014-11-23 06:26:11 +00:00
foo ) )
( prn "F - convert-names skips past labels" ) )
; ? ( quit )
2014-12-14 16:06:32 +00:00
) ; section 11
( section 20
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
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-12-14 17:46:49 +00:00
( 1 : integer - address < - new integer:literal )
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 before rep . routine ! alloc
; ? ( set dump - trace * )
( run )
2014-12-17 22:03:34 +00:00
; ? ( prn memory * )
2014-12-04 10:50:33 +00:00
( 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-12-17 22:03:34 +00:00
; ? ( quit )
2014-11-01 20:57:52 +00:00
( reset )
( new - trace "new-array-literal" )
2014-11-25 05:09:07 +00:00
( add - code
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-12-14 17:46:49 +00:00
( 1 : type - array - address < - new type - array:literal 5 : literal )
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 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
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-12-14 17:46:49 +00:00
( 1 : integer < - copy 5 : literal )
( 2 : type - array - address < - new type - array:literal 1 : integer )
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 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
2015-01-03 02:13:04 +00:00
; variable called default - space . 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
2015-01-03 02:13:04 +00:00
; locations as offsets from its value . If default - space is set to 1000 , for
2014-11-01 20:58:58 +00:00
; example , reads and writes to memory location 1 will really go to 1001 .
;
2015-01-03 02:13:04 +00:00
; 'default-space' is itself hard - coded to be function - local ; it ' s nil in a new
2014-11-01 20:58:58 +00:00
; function , and it ' s restored when functions return to their callers . But the
2015-01-03 02:13:04 +00:00
; actual space 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 )
2015-01-03 02:13:04 +00:00
( new - trace "set-default-space" )
2014-11-25 05:09:07 +00:00
( add - code
2014-12-13 02:07:30 +00:00
' ( ( function main [
2015-01-03 02:13:04 +00:00
( default - space:space - address < - new space:literal 2 : literal )
2014-12-14 17:46:49 +00:00
( 1 : integer < - copy 23 : literal )
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 before rep . routine ! alloc
; ? ( set dump - trace * )
( run )
; ? ( prn memory * )
( if ( ~ and ( ~ is 23 memory * .1 )
2014-12-29 17:20:51 +00:00
( is 23 ( memory * ( + before 2 ) ) ) )
2015-01-03 02:13:04 +00:00
( prn "F - default-space implicitly modifies variable locations" ) ) ) )
2014-12-29 17:20:51 +00:00
; ? ( quit )
2014-11-01 19:43:45 +00:00
( reset )
2015-01-03 02:13:04 +00:00
( new - trace "set-default-space-skips-offset" )
2014-11-25 05:09:07 +00:00
( add - code
2014-12-13 02:07:30 +00:00
' ( ( function main [
2015-01-03 02:13:04 +00:00
( default - space:space - address < - new space:literal 2 : literal )
2014-12-14 17:46:49 +00:00
( 1 : integer < - copy 23 : 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 before rep . routine ! alloc
; ? ( set dump - trace * )
( run )
; ? ( prn memory * )
( if ( ~ and ( ~ is 23 memory * .1 )
2014-12-29 17:20:51 +00:00
( is 23 ( memory * ( + before 2 ) ) ) )
2015-01-03 02:13:04 +00:00
( prn "F - default-space skips 'offset' types just like literals" ) ) ) )
2014-11-01 19:43:45 +00:00
( reset )
2015-01-03 02:13:04 +00:00
( new - trace "default-space-bounds-check" )
2014-11-25 05:09:07 +00:00
( add - code
2014-12-13 02:07:30 +00:00
' ( ( function main [
2015-01-03 02:13:04 +00:00
( default - space:space - address < - new space:literal 2 : literal )
2014-12-14 17:46:49 +00:00
( 2 : integer < - copy 23 : literal )
2014-11-25 05:09:07 +00:00
] ) ) )
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 )
2015-01-03 02:13:04 +00:00
( prn "F - default-space checks bounds" ) ) )
2014-11-01 19:43:45 +00:00
( reset )
2015-01-03 02:13:04 +00:00
( new - trace "default-space-and-get-indirect" )
2014-11-25 05:09:07 +00:00
( add - code
2014-12-13 02:07:30 +00:00
' ( ( function main [
2015-01-03 02:13:04 +00:00
( default - space:space - address < - new space:literal 5 : literal )
2014-12-14 17:46:49 +00:00
( 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-12-27 06:21:25 +00:00
( 3 : integer /raw <- get 1:integer-boolean-pair-address/ deref 0 : offset )
2014-11-25 05:09:07 +00:00
] ) ) )
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 )
2015-01-03 02:13:04 +00:00
( prn "F - indirect 'get' works in the presence of default-space" ) )
2014-11-01 19:43:45 +00:00
; ? ( quit )
( reset )
2015-01-03 02:13:04 +00:00
( new - trace "default-space-and-index-indirect" )
2014-11-25 05:09:07 +00:00
( add - code
2014-12-13 02:07:30 +00:00
' ( ( function main [
2015-01-03 02:13:04 +00:00
( default - space:space - address < - new space:literal 5 : literal )
2014-12-14 17:46:49 +00:00
( 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-12-27 06:21:25 +00:00
( 3 : integer /raw <- index 1:integer-array-address/ deref 2 : offset )
2014-11-25 05:09:07 +00:00
] ) ) )
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 )
2015-01-03 02:13:04 +00:00
( prn "F - indirect 'index' works in the presence of default-space" ) )
2014-11-01 19:43:45 +00:00
; ? ( quit )
( reset )
2015-01-03 02:13:04 +00:00
( new - trace "convert-names-default-space" )
2014-11-27 07:23:44 +00:00
( = traces * ( queue ) )
2014-11-01 19:43:45 +00:00
( if ( ~ iso ( convert - names
2014-12-14 17:46:49 +00:00
' ( ( ( ( x integer ) ) < - ( ( copy ) ) ( ( 4 literal ) ) )
( ( ( y integer ) ) < - ( ( copy ) ) ( ( 2 literal ) ) )
2015-01-03 02:13:04 +00:00
; unsafe in general ; don 't write random values to ' default - space '
( ( ( default - space integer ) ) < - ( ( add ) ) ( ( x integer ) ) ( ( y integer ) ) ) ) )
2014-12-14 17:46:49 +00:00
' ( ( ( ( 1 integer ) ) < - ( ( copy ) ) ( ( 4 literal ) ) )
( ( ( 2 integer ) ) < - ( ( copy ) ) ( ( 2 literal ) ) )
2015-01-03 02:13:04 +00:00
( ( ( default - space integer ) ) < - ( ( add ) ) ( ( 1 integer ) ) ( ( 2 integer ) ) ) ) )
( prn "F - convert-names never renames default-space" ) )
2014-11-01 19:43:45 +00:00
( reset )
2015-01-03 02:13:04 +00:00
( new - trace "suppress-default-space" )
2014-11-25 05:09:07 +00:00
( add - code
2014-12-13 02:07:30 +00:00
' ( ( function main [
2015-01-03 02:13:04 +00:00
( default - space:space - address < - new space:literal 2 : literal )
2014-12-27 06:21:25 +00:00
( 1 : integer / raw < - copy 23 : literal )
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 before rep . routine ! alloc
; ? ( set dump - trace * )
( run )
; ? ( prn memory * )
( if ( ~ and ( is 23 memory * .1 )
( ~ is 23 ( memory * ( + before 1 ) ) ) )
2015-01-03 02:13:04 +00:00
( prn "F - default-space skipped for locations with metadata 'raw'" ) ) ) )
2014-12-04 10:50:33 +00:00
; ? ( 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
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-12-14 17:46:49 +00:00
( 10 : integer < - copy 30 : literal ) ; pretend allocation
2015-01-03 02:13:04 +00:00
( default - space:space - address < - copy 10 : literal ) ; unsafe
2014-12-29 17:20:51 +00:00
( 1 : integer < - copy 2 : literal ) ; raw location 12
2014-12-14 17:46:49 +00:00
( 2 : integer < - copy 23 : literal )
( 3 : boolean < - copy nil:literal )
( 4 : integer < - copy 24 : literal )
( 5 : boolean < - copy t:literal )
2014-12-29 17:20:51 +00:00
( 6 : integer - boolean - pair - array - address < - copy 12 : literal ) ; unsafe
2014-12-14 17:46:49 +00:00
( 7 : integer - boolean - pair - array < - copy 6 : integer - boolean - pair - array - address / deref )
2014-11-29 08:57:06 +00:00
] ) ) )
; ? ( 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 ) ) )
2014-12-29 17:20:51 +00:00
( if ( ~ iso memory * .18 2 ) ; variable 7
2015-01-03 02:13:04 +00:00
( prn "F - indirect array copy in the presence of 'default-space'" ) )
2014-11-29 08:57:06 +00:00
; ? ( quit )
2014-11-29 09:03:32 +00:00
( reset )
( new - trace "len-array-indirect-scoped" )
( add - code
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-12-14 17:46:49 +00:00
( 10 : integer < - copy 30 : literal ) ; pretend allocation
2015-01-03 02:13:04 +00:00
( default - space:space - address < - copy 10 : literal ) ; unsafe
2014-12-29 17:20:51 +00:00
( 1 : integer < - copy 2 : literal ) ; raw location 12
2014-12-14 17:46:49 +00:00
( 2 : integer < - copy 23 : literal )
( 3 : boolean < - copy nil:literal )
( 4 : integer < - copy 24 : literal )
( 5 : boolean < - copy t:literal )
2014-12-29 17:20:51 +00:00
( 6 : integer - address < - copy 12 : literal ) ; unsafe
2014-12-14 17:46:49 +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 * )
2014-12-29 17:20:51 +00:00
( if ( ~ iso memory * .18 2 )
2014-11-29 09:03:32 +00:00
( prn "F - 'len' accesses length of array address" ) )
; ? ( quit )
2014-12-27 06:03:19 +00:00
( reset )
2015-01-03 02:13:04 +00:00
( new - trace "default-space-shared" )
2014-12-27 06:03:19 +00:00
( add - code
' ( ( function init - counter [
2015-01-03 02:13:04 +00:00
( default - space:space - address < - new space:literal 30 : literal )
2014-12-27 06:03:19 +00:00
( 1 : integer < - copy 3 : literal ) ; initialize to 3
2015-01-03 02:13:04 +00:00
( reply default - space:space - address )
2014-12-27 06:03:19 +00:00
] )
( function increment - counter [
2015-01-03 02:13:04 +00:00
( default - space:space - address < - next - input )
2014-12-27 06:03:19 +00:00
( 1 : integer < - add 1 : integer 1 : literal ) ; increment
( reply 1 : integer )
] )
( function main [
2015-01-03 02:13:04 +00:00
( 1 : space - address < - init - counter )
( 2 : integer < - increment - counter 1 : space - address )
( 3 : integer < - increment - counter 1 : space - address )
2014-12-27 06:03:19 +00:00
] ) ) )
( run ' main )
( each routine completed - routines *
( aif rep . routine ! error ( prn "error - " it ) ) )
; ? ( prn memory * )
( if ( or ( ~ is memory * .2 4 )
( ~ is memory * .3 5 ) )
( prn "F - multiple calls to a function can share locals" ) )
; ? ( quit )
2014-12-30 09:27:26 +00:00
( reset )
2015-01-03 02:13:04 +00:00
( new - trace "default-space-closure" )
2014-12-30 09:27:26 +00:00
( add - code
' ( ( function init - counter [
2015-01-03 02:13:04 +00:00
( default - space:space - address < - new space:literal 30 : literal )
2014-12-30 09:27:26 +00:00
( 1 : integer < - copy 3 : literal ) ; initialize to 3
2015-01-03 02:13:04 +00:00
( reply default - space:space - address )
2014-12-30 09:27:26 +00:00
] )
( function increment - counter [
2015-01-03 02:13:04 +00:00
( default - space:space - address < - new space:literal 30 : literal )
( 0 : space - address < - next - input ) ; share outer space
2014-12-30 09:27:26 +00:00
( 1 : integer /space:1 <- add 1:integer/s pace:1 1 : literal ) ; increment
( 1 : integer < - copy 34 : literal ) ; dummy
( reply 1 : integer / space:1 )
] )
( function main [
2015-01-03 02:13:04 +00:00
( 1 : space - address < - init - counter )
( 2 : integer < - increment - counter 1 : space - address )
( 3 : integer < - increment - counter 1 : space - address )
2014-12-30 09:27:26 +00:00
] ) ) )
2014-12-30 22:52:58 +00:00
; ? ( set dump - trace * )
( run ' main )
( each routine completed - routines *
( aif rep . routine ! error ( prn "error - " it ) ) )
; ? ( prn memory * )
( if ( or ( ~ is memory * .2 4 )
( ~ is memory * .3 5 ) )
( prn "F - multiple calls to a function can share locals" ) )
; ? ( quit )
( reset )
2015-01-03 02:13:04 +00:00
( new - trace "default-space-closure-with-names" )
2014-12-30 22:52:58 +00:00
( add - code
' ( ( function init - counter [
2015-01-03 02:13:04 +00:00
( default - space:space - address < - new space:literal 30 : literal )
2014-12-30 22:52:58 +00:00
( x:integer < - copy 23 : literal )
( y:integer < - copy 3 : literal ) ; correct copy of y
2015-01-03 02:13:04 +00:00
( reply default - space:space - address )
2014-12-30 22:52:58 +00:00
] )
( function increment - counter [
2015-01-03 02:13:04 +00:00
( default - space:space - address < - new space:literal 30 : literal )
( 0 : space - address / names:init - counter < - next - input ) ; outer space must be created by 'init-counter' above
2014-12-30 22:52:58 +00:00
( y:integer /space:1 <- add y:integer/s pace:1 1 : literal ) ; increment
( y:integer < - copy 34 : literal ) ; dummy
( reply y:integer / space:1 )
] )
( function main [
2015-01-03 02:13:04 +00:00
( 1 : space - address / names:init - counter < - init - counter )
( 2 : integer < - increment - counter 1 : space - address / names:init - counter )
( 3 : integer < - increment - counter 1 : space - address / names:init - counter )
2014-12-30 22:52:58 +00:00
] ) ) )
; ? ( set dump - trace * )
2014-12-30 09:27:26 +00:00
( run ' main )
( each routine completed - routines *
( aif rep . routine ! error ( prn "error - " it ) ) )
; ? ( prn memory * )
( if ( or ( ~ is memory * .2 4 )
( ~ is memory * .3 5 ) )
( prn "F - multiple calls to a function can share locals" ) )
; ? ( quit )
2014-12-14 16:06:32 +00:00
) ; section 20
2014-12-13 08:49:58 +00:00
2014-12-13 08:33:20 +00:00
( section 100
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
2014-12-13 02:07:30 +00:00
' ( ( function 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
2015-01-03 02:13:04 +00:00
( default - space:space - address < - new space:literal 20 : literal )
2014-12-14 20:36:42 +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-12-14 20:36:42 +00:00
( first - arg:integer match ? : boolean < - maybe - coerce first - arg - box:tagged - value - address / deref integer:literal )
( break - unless match ? : boolean )
( second - arg - box:tagged - value - address < - next - input )
( second - arg:integer < - maybe - coerce second - arg - box:tagged - value - address / deref integer:literal )
( result:integer < - add first - arg:integer second - arg:integer )
( reply result:integer )
2014-10-15 01:24:46 +00:00
}
2014-12-14 20:36:42 +00:00
( reply nil:literal )
2014-11-25 05:09:07 +00:00
] )
2014-12-13 02:07:30 +00:00
( function main [
2014-12-28 21:03:50 +00:00
( 1 : tagged - value - address < - init - tagged - value integer:literal 34 : literal )
( 2 : tagged - value - address < - init - tagged - value integer:literal 3 : literal )
2014-12-14 17:46:49 +00:00
( 3 : integer < - test1 1 : tagged - value - address 2 : tagged - value - address )
2014-11-25 05:09:07 +00:00
] ) ) )
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 )
( 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
2014-12-13 02:07:30 +00:00
' ( ( function test1 [
2015-01-03 02:13:04 +00:00
( default - space:space - address < - new space:literal 20 : literal )
2014-12-14 20:36:42 +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-12-14 20:36:42 +00:00
( first - arg:integer match ? : boolean < - maybe - coerce first - arg - box:tagged - value - address / deref integer:literal )
( break - unless match ? : boolean )
( second - arg - box:tagged - value - address < - next - input )
( second - arg:integer < - maybe - coerce second - arg - box:tagged - value - address / deref integer:literal )
( result:integer < - add first - arg:integer second - arg:integer )
( reply result:integer )
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-12-14 20:36:42 +00:00
( first - arg:boolean match ? : boolean < - maybe - coerce first - arg - box:tagged - value - address / deref boolean:literal )
( break - unless match ? : boolean )
( second - arg - box:tagged - value - address < - next - input )
( second - arg:boolean < - maybe - coerce second - arg - box:tagged - value - address / deref boolean:literal )
( result:boolean < - or first - arg:boolean second - arg:boolean )
( reply result:integer )
2014-10-15 06:11:44 +00:00
}
2014-12-14 20:36:42 +00:00
( reply nil:literal )
2014-11-25 05:09:07 +00:00
] )
2014-12-13 02:07:30 +00:00
( function main [
2014-12-28 21:03:50 +00:00
( 1 : tagged - value - address < - init - tagged - value boolean:literal t:literal )
( 2 : tagged - value - address < - init - tagged - value boolean:literal nil:literal )
2014-12-14 17:46:49 +00:00
( 3 : boolean < - test1 1 : tagged - value - address 2 : tagged - value - address )
2014-11-25 05:09:07 +00:00
] ) ) )
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
2014-12-13 02:07:30 +00:00
' ( ( function test1 [
2015-01-03 02:13:04 +00:00
( default - space:space - address < - new space:literal 20 : literal )
2014-12-14 20:36:42 +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-12-14 20:36:42 +00:00
( first - arg:integer match ? : boolean < - maybe - coerce first - arg - box:tagged - value - address / deref integer:literal )
( break - unless match ? : boolean )
( second - arg - box:tagged - value - address < - next - input )
( second - arg:integer < - maybe - coerce second - arg - box:tagged - value - address / deref integer:literal )
( result:integer < - add first - arg:integer second - arg:integer )
( reply result:integer )
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-12-14 20:36:42 +00:00
( first - arg:boolean match ? : boolean < - maybe - coerce first - arg - box:tagged - value - address / deref boolean:literal )
( break - unless match ? : boolean )
( second - arg - box:tagged - value - address < - next - input )
( second - arg:boolean < - maybe - coerce second - arg - box:tagged - value - address / deref boolean:literal )
( result:boolean < - or first - arg:boolean second - arg:boolean )
( reply result:integer )
2014-10-15 06:11:44 +00:00
}
2014-12-14 20:36:42 +00:00
( reply nil:literal )
2014-11-25 05:09:07 +00:00
] )
2014-12-13 02:07:30 +00:00
( function main [
2014-12-28 21:03:50 +00:00
( 1 : tagged - value - address < - init - tagged - value boolean:literal t:literal )
( 2 : tagged - value - address < - init - tagged - value boolean:literal nil:literal )
2014-12-14 17:46:49 +00:00
( 3 : boolean < - test1 1 : tagged - value - address 2 : tagged - value - address )
2014-12-28 21:03:50 +00:00
( 10 : tagged - value - address < - init - tagged - value integer:literal 34 : literal )
( 11 : tagged - value - address < - init - tagged - value integer:literal 3 : literal )
2014-12-14 17:46:49 +00:00
( 12 : integer < - test1 10 : tagged - value - address 11 : tagged - value - address )
2014-11-25 05:09:07 +00:00
] ) ) )
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-12-24 09:00:36 +00:00
; We can also dispatch based on the type of the operands or results at the
; caller .
( reset )
( new - trace "dispatch-otype" )
( add - code
' ( ( function test1 [
( 4 : type < - otype 0 : offset )
{ begin
( 5 : boolean < - equal 4 : type integer:literal )
( break - unless 5 : boolean )
( 6 : integer < - next - input )
( 7 : integer < - next - input )
( 8 : integer < - add 6 : integer 7 : integer )
}
( reply 8 : integer )
] )
( function main [
( 1 : integer < - test1 1 : literal 3 : literal )
] ) ) )
( run ' main )
; ? ( prn memory * )
( if ( ~ iso memory * .1 4 )
( prn "F - an example function that checks that its oarg is an integer" ) )
; ? ( quit )
( reset )
( new - trace "dispatch-otype-multiple-clauses" )
; ? ( set dump - trace * )
( add - code
' ( ( function test1 [
( 4 : type < - otype 0 : offset )
{ begin
; integer needed ? add args
( 5 : boolean < - equal 4 : type integer:literal )
( break - unless 5 : boolean )
( 6 : integer < - next - input )
( 7 : integer < - next - input )
( 8 : integer < - add 6 : integer 7 : integer )
( reply 8 : integer )
}
{ begin
; boolean needed ? 'or' args
( 5 : boolean < - equal 4 : type boolean:literal )
( break - unless 5 : boolean 4 : offset )
( 6 : boolean < - next - input )
( 7 : boolean < - next - input )
( 8 : boolean < - or 6 : boolean 7 : boolean )
( reply 8 : boolean )
} ] )
( function main [
( 1 : boolean < - test1 t:literal t:literal )
] ) ) )
; ? ( each stmt function * ! test1
; ? ( prn " " stmt ) )
( run ' main )
; ? ( wipe dump - trace * )
; ? ( prn memory * )
( if ( ~ is memory * .1 t )
( prn "F - an example function that can do different things (dispatch) based on the type of its args or oargs" ) )
; ? ( quit )
( reset )
( new - trace "dispatch-otype-multiple-calls" )
( add - code
' ( ( function test1 [
( 4 : type < - otype 0 : offset )
{ begin
( 5 : boolean < - equal 4 : type integer:literal )
( break - unless 5 : boolean )
( 6 : integer < - next - input )
( 7 : integer < - next - input )
( 8 : integer < - add 6 : integer 7 : integer )
( reply 8 : integer )
}
{ begin
( 5 : boolean < - equal 4 : type boolean:literal )
( break - unless 5 : boolean )
( 6 : boolean < - next - input )
( 7 : boolean < - next - input )
( 8 : boolean < - or 6 : boolean 7 : boolean )
( reply 8 : boolean )
} ] )
( function main [
( 1 : boolean < - test1 t:literal t:literal )
( 2 : integer < - test1 3 : literal 4 : literal )
] ) ) )
( run ' main )
; ? ( prn memory * )
( if ( ~ and ( is memory * .1 t ) ( is memory * .2 7 ) )
( prn "F - different calls can exercise different clauses of the same function" ) )
2014-12-13 08:33:20 +00:00
) ; section 100
2014-12-14 07:31:52 +00:00
( section 20
2014-12-13 08:49:58 +00:00
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
2014-12-13 02:07:30 +00:00
' ( ( function f1 [
2014-12-14 17:46:49 +00:00
( 1 : integer < - copy 3 : literal )
2014-11-25 05:09:07 +00:00
] )
2014-12-13 02:07:30 +00:00
( function f2 [
2014-12-14 17:46:49 +00:00
( 2 : integer < - copy 4 : literal )
2014-11-25 05:09:07 +00:00
] ) ) )
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
2014-12-13 02:07:30 +00:00
' ( ( function f1 [
2015-01-09 07:06:30 +00:00
( 1 : integer < - copy 0 : literal )
( 1 : integer < - copy 0 : literal )
2014-11-25 05:09:07 +00:00
] )
2014-12-13 02:07:30 +00:00
( function f2 [
2015-01-09 07:06:30 +00:00
( 2 : integer < - copy 0 : literal )
( 2 : integer < - copy 0 : literal )
2014-11-25 05:09:07 +00:00
] ) ) )
2015-01-10 11:32:14 +00:00
; ? ( = dump - trace * ( obj whitelist ' ( "schedule" ) ) )
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
2014-12-13 02:07:30 +00:00
' ( ( function f1 [
2015-01-09 07:06:30 +00:00
( 1 : integer < - copy 0 : literal )
2014-11-25 05:09:07 +00:00
] )
2014-12-13 02:07:30 +00:00
( function f2 [
2015-01-09 07:06:30 +00:00
( 2 : integer < - copy 0 : literal )
2014-11-25 05:09:07 +00:00
] ) ) )
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
2015-01-09 07:21:56 +00:00
( = rep . routine ! sleep ' ( for - some - cycles 23 ) )
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
2014-12-13 02:07:30 +00:00
' ( ( function f1 [
2015-01-09 07:06:30 +00:00
( 1 : integer < - copy 0 : literal )
2014-11-25 05:09:07 +00:00
] )
2014-12-13 02:07:30 +00:00
( function f2 [
2015-01-09 07:06:30 +00:00
( 2 : integer < - copy 0 : literal )
2014-11-25 05:09:07 +00:00
] ) ) )
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
2015-01-09 07:21:56 +00:00
( = rep . routine ! sleep ' ( for - some - cycles 23 ) )
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
2014-12-13 02:07:30 +00:00
' ( ( function f1 [
2015-01-09 07:06:30 +00:00
( 1 : integer < - copy 0 : literal )
2014-11-25 05:09:07 +00:00
] )
2014-12-13 02:07:30 +00:00
( function f2 [
2015-01-09 07:06:30 +00:00
( 2 : integer < - copy 0 : literal )
2014-11-25 05:09:07 +00:00
] ) ) )
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
2015-01-09 07:21:56 +00:00
( = rep . routine ! sleep ' ( until - location - changes 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
2014-12-13 02:07:30 +00:00
' ( ( function f1 [
2015-01-09 07:06:30 +00:00
( 1 : integer < - copy 0 : literal )
2014-11-25 05:09:07 +00:00
] )
2014-12-13 02:07:30 +00:00
( function f2 [
2015-01-09 07:06:30 +00:00
( 2 : integer < - copy 0 : literal )
2014-11-25 05:09:07 +00:00
] ) ) )
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
2015-01-09 07:21:56 +00:00
( = rep . routine ! sleep ' ( until - location - changes 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
2014-12-13 02:07:30 +00:00
' ( ( function f1 [
2015-01-09 07:06:30 +00:00
( 1 : integer < - copy 0 : literal )
2014-11-25 05:09:07 +00:00
] ) ) )
2014-11-22 02:31:48 +00:00
; running - routines * is empty
( assert ( empty running - routines * ) )
; sleeping routine
( let routine make - routine ! f1
2015-01-09 07:21:56 +00:00
( = rep . routine ! sleep ' ( for - some - cycles 34 ) )
2014-11-22 02:31:48 +00:00
( set sleeping - routines * . routine ) )
; long time left for it to wake up
( = curr - cycle * 0 )
( update - scheduler - state )
2015-01-09 07:11:28 +00:00
( assert ( is curr - cycle * 35 ) )
2014-11-22 02:31:48 +00:00
( 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
2014-12-13 02:07:30 +00:00
' ( ( function f1 [
2015-01-09 07:06:30 +00:00
( 1 : integer < - copy 0 : literal )
2014-11-25 05:09:07 +00:00
] ) ) )
2014-11-22 04:47:48 +00:00
( assert ( empty running - routines * ) )
( assert ( empty completed - routines * ) )
; blocked routine
( let routine make - routine ! f1
2015-01-09 07:21:56 +00:00
( = rep . routine ! sleep ' ( until - location - changes 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
2014-12-13 02:07:30 +00:00
' ( ( function f1 [
2015-01-09 07:06:30 +00:00
( 1 : integer < - copy 0 : literal )
2014-11-25 05:09:07 +00:00
] ) ) )
2014-11-22 08:22:22 +00:00
; running - routines * is empty
( assert ( empty running - routines * ) )
; blocked routine
( let routine make - routine ! f1
2015-01-09 07:21:56 +00:00
( = rep . routine ! sleep ' ( until - location - changes 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" ) )
2015-01-10 11:32:14 +00:00
( reset )
( new - trace "scheduler-account-slice" )
; function running an infinite loop
( add - code
' ( ( function f1 [
{ begin
( 1 : integer < - copy 0 : literal )
( loop )
}
] ) ) )
( let routine make - routine ! f1
( = rep . routine ! limit 10 )
( enq routine running - routines * ) )
( = scheduling - interval * 20 )
( run )
( when ( or ( empty completed - routines * )
( ~ is - 10 ( ( rep completed - routines * .0 ) ' limit ) ) )
( prn "F - when given a low cycle limit, a routine runs to end of time slice" ) )
( reset )
( new - trace "scheduler-account-slice-multiple" )
; function running an infinite loop
( add - code
' ( ( function f1 [
{ begin
( 1 : integer < - copy 0 : literal )
( loop )
}
] ) ) )
( let routine make - routine ! f1
( = rep . routine ! limit 100 )
( enq routine running - routines * ) )
( = scheduling - interval * 20 )
( run )
( when ( or ( empty completed - routines * )
( ~ is - 0 ( ( rep completed - routines * .0 ) ' limit ) ) )
( prn "F - when given a high limit, a routine successfully stops after multiple time slices" ) )
( reset )
( new - trace "scheduler-account-run-while-asleep" )
( add - code
; f1 needs 4 cycles of sleep time , 4 cycles of work
' ( ( function f1 [
( sleep for - some - cycles:literal 4 : literal )
( i:integer < - copy 0 : literal )
( i:integer < - copy 0 : literal )
( i:integer < - copy 0 : literal )
( i:integer < - copy 0 : literal )
] ) ) )
( let routine make - routine ! f1
( = rep . routine ! limit 6 ) ; enough time excluding sleep
( enq routine running - routines * ) )
( = scheduling - interval * 1 )
; ? ( = dump - trace * ( obj whitelist ' ( "schedule" ) ) )
( run )
; if time slept counts against limit , routine doesn ' t have time to complete
( when ( ran - to - completion ' f1 )
( prn "F - time slept counts against a routine's cycle limit" ) )
; ? ( quit )
( reset )
( new - trace "scheduler-account-stop-on-preempt" )
( add - code
' ( ( function baseline [
( i:integer < - copy 0 : literal )
{ begin
( done ? : boolean < - greater - or - equal i:integer 10 : literal )
( break - if done ? : boolean )
( 1 : integer < - add i:integer 1 : literal )
( loop )
}
] )
( function f1 [
( i:integer < - copy 0 : literal )
{ begin
( done ? : boolean < - greater - or - equal i:integer 6 : literal )
( break - if done ? : boolean )
( 1 : integer < - add i:integer 1 : literal )
( loop )
}
] ) ) )
( let routine make - routine ! baseline
( enq routine running - routines * ) )
; now add the routine we care about
( let routine make - routine ! f1
( = rep . routine ! limit 40 ) ; less than 2 x time f1 needs to complete
( enq routine running - routines * ) )
( = scheduling - interval * 1 )
; if baseline 's time were to count against f1' s limit , it wouldn ' t be able to
; complete .
( when ( ~ ran - to - completion ' f1 )
( prn "F - preempted time doesn't count against a routine's limit" ) )
; ? ( quit )
( reset )
( new - trace "scheduler-sleep-timeout" )
( add - code
' ( ( function baseline [
( i:integer < - copy 0 : literal )
{ begin
( done ? : boolean < - greater - or - equal i:integer 10 : literal )
( break - if done ? : boolean )
( 1 : integer < - add i:integer 1 : literal )
( loop )
}
] )
( function f1 [
( sleep for - some - cycles:literal 10 : literal ) ; less time than baseline would take to run
] ) ) )
; add baseline routine to prevent cycle - skipping
( let routine make - routine ! baseline
( enq routine running - routines * ) )
; now add the routine we care about
( let routine make - routine ! f1
( = rep . routine ! limit 4 ) ; less time than f1 would take to run
( enq routine running - routines * ) )
( = scheduling - interval * 1 )
; ? ( = dump - trace * ( obj whitelist ' ( "schedule" ) ) )
( run )
( when ( ran - to - completion ' f1 )
( prn "F - sleeping routines can time out" ) )
; ? ( quit )
2014-11-06 23:38:00 +00:00
( reset )
( new - trace "sleep" )
2014-11-25 05:09:07 +00:00
( add - code
2014-12-13 02:07:30 +00:00
' ( ( function f1 [
2015-01-09 07:21:56 +00:00
( sleep for - some - cycles:literal 1 : literal )
2015-01-09 07:06:30 +00:00
( 1 : integer < - copy 0 : literal )
( 1 : integer < - copy 0 : literal )
2014-11-25 05:09:07 +00:00
] )
2014-12-13 02:07:30 +00:00
( function f2 [
2015-01-09 07:06:30 +00:00
( 2 : integer < - copy 0 : literal )
( 2 : integer < - copy 0 : 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
2014-12-13 02:07:30 +00:00
' ( ( function f1 [
2015-01-09 07:21:56 +00:00
( sleep for - some - cycles:literal 20 : literal )
2015-01-09 07:06:30 +00:00
( 1 : integer < - copy 0 : literal )
( 1 : integer < - copy 0 : literal )
2014-11-25 05:09:07 +00:00
] )
2014-12-13 02:07:30 +00:00
( function f2 [
2015-01-09 07:06:30 +00:00
( 2 : integer < - copy 0 : literal )
( 2 : integer < - copy 0 : 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
2014-12-13 02:07:30 +00:00
' ( ( function f1 [
2014-11-07 03:12:56 +00:00
; waits for memory location 1 to be set , before computing its successor
2014-12-14 17:46:49 +00:00
( 1 : integer < - copy 0 : literal )
2015-01-09 07:21:56 +00:00
( sleep until - location - changes:literal 1 : integer )
2014-12-14 17:46:49 +00:00
( 2 : integer < - add 1 : integer 1 : literal )
2014-11-25 05:09:07 +00:00
] )
2014-12-13 02:07:30 +00:00
( function f2 [
2015-01-09 07:21:56 +00:00
( sleep for - some - cycles:literal 30 : literal )
2014-12-14 17:46:49 +00:00
( 1 : integer < - copy 3 : literal ) ; set to value
2014-11-25 05:09:07 +00:00
] ) ) )
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
2014-12-13 02:07:30 +00:00
' ( ( function f1 [
2014-11-23 16:47:19 +00:00
; waits for memory location 1 to be changed , before computing its successor
2014-12-14 17:46:49 +00:00
( 10 : integer < - copy 5 : literal ) ; array of locals
2015-01-03 02:13:04 +00:00
( default - space:space - address < - copy 10 : literal )
2014-12-29 17:20:51 +00:00
( 1 : integer < - copy 23 : literal ) ; really location 12
2015-01-09 07:21:56 +00:00
( sleep until - location - changes:literal 1 : integer )
2014-12-14 17:46:49 +00:00
( 2 : integer < - add 1 : integer 1 : literal )
2014-11-25 05:09:07 +00:00
] )
2014-12-13 02:07:30 +00:00
( function f2 [
2015-01-09 07:21:56 +00:00
( sleep for - some - cycles:literal 30 : literal )
2014-12-29 17:20:51 +00:00
( 12 : integer < - copy 3 : literal ) ; set to value
2014-11-25 05:09:07 +00:00
] ) ) )
2014-11-21 22:36:22 +00:00
; ? ( = dump - trace * ( obj whitelist ' ( "run" "schedule" ) ) )
( run 'f1 ' f2 )
2014-12-29 17:20:51 +00:00
( if ( ~ is memory * .13 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
2014-12-13 02:07:30 +00:00
' ( ( function f1 [
2015-01-10 21:07:36 +00:00
( 1 : integer < - copy 4 : literal )
2014-11-25 05:09:07 +00:00
] )
2015-01-10 21:07:36 +00:00
( function main [
( fork f1:fn )
2014-11-25 05:09:07 +00:00
] ) ) )
2015-01-10 21:07:36 +00:00
( run ' main )
( if ( ~ iso memory * .1 4 )
2014-11-19 08:11:05 +00:00
( prn "F - fork works" ) )
2015-01-10 21:10:23 +00:00
( reset )
( new - trace "fork-returns-id" )
( add - code
' ( ( function f1 [
( 1 : integer < - copy 4 : literal )
] )
( function main [
( 2 : integer < - fork f1:fn )
] ) ) )
( run ' main )
; ? ( prn memory * )
( if ( no memory * .2 )
( prn "F - fork returns a pid for the new routine" ) )
( reset )
( new - trace "fork-returns-unique-id" )
( add - code
' ( ( function f1 [
( 1 : integer < - copy 4 : literal )
] )
( function main [
( 2 : integer < - fork f1:fn )
( 3 : integer < - fork f1:fn )
] ) ) )
( run ' main )
( if ( or ( no memory * .2 )
( no memory * .3 )
( is memory * .2 memory * .3 ) )
( prn "F - fork returns a unique pid everytime" ) )
2014-11-19 08:19:57 +00:00
( reset )
( new - trace "fork-with-args" )
2014-11-25 05:09:07 +00:00
( add - code
2014-12-13 02:07:30 +00:00
' ( ( function f1 [
2014-12-14 17:46:49 +00:00
( 2 : integer < - next - input )
2015-01-10 21:07:36 +00:00
] )
( function main [
( fork f1:fn nil:literal /globals nil:literal/ limit 4 : literal )
2014-11-25 05:09:07 +00:00
] ) ) )
2015-01-10 21:07:36 +00:00
( run ' main )
2014-11-19 08:19:57 +00:00
( 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
2014-12-13 02:07:30 +00:00
' ( ( function f1 [
2015-01-10 21:07:36 +00:00
( 2 : integer < - next - input )
] )
( function main [
2015-01-03 02:13:04 +00:00
( default - space:space - address < - new space:literal 5 : literal )
2014-12-14 17:46:49 +00:00
( x:integer < - copy 4 : literal )
2015-01-10 21:07:36 +00:00
( fork f1:fn nil:literal /globals nil:literal/ limit x:integer )
2014-12-14 17:46:49 +00:00
( x:integer < - copy 0 : literal ) ; should be ignored
2014-11-25 05:09:07 +00:00
] ) ) )
2015-01-10 21:07:36 +00:00
( run ' main )
2014-11-19 08:27:10 +00:00
( if ( ~ iso memory * .2 4 )
( prn "F - fork passes args by value" ) )
2014-12-28 23:57:55 +00:00
( reset )
( new - trace "fork-global" )
( add - code
' ( ( function f1 [
( 1 : integer /raw <- copy 2:integer/s pace:global )
] )
( function main [
2015-01-03 02:13:04 +00:00
( default - space:space - address < - new space:literal 5 : literal )
2014-12-28 23:57:55 +00:00
( 2 : integer < - copy 4 : literal )
2015-01-10 20:38:14 +00:00
( fork f1:fn default - space:space - address /globals nil:literal/ limit )
2014-12-28 23:57:55 +00:00
] ) ) )
( run ' main )
( each routine completed - routines *
( awhen rep . routine ! error ( prn "error - " it ) ) )
( if ( ~ iso memory * .1 4 )
( prn "F - fork can take a space of global variables to access" ) )
2015-01-10 20:38:14 +00:00
( reset )
( new - trace "fork-limit" )
( add - code
' ( ( function f1 [
{ begin
( loop )
}
] )
( function main [
( fork f1:fn nil:literal /globals 30:literal/ limit )
] ) ) )
( = scheduling - interval * 5 )
( run ' main )
( each routine completed - routines *
( awhen rep . routine ! error ( prn "error - " it ) ) )
( when ( ran - to - completion ' f1 )
( prn "F - fork can specify a maximum cycle limit" ) )
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
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-12-14 17:46:49 +00:00
( 1 : integer < - copy 2 : literal )
( 2 : integer < - copy 23 : literal )
( 3 : integer < - copy 24 : literal )
( 4 : integer < - index 1 : integer - array 2 : literal )
2014-11-25 05:09:07 +00:00
] ) ) )
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-12-14 07:31:52 +00:00
) ; section 20
2014-12-13 08:49:58 +00:00
2014-12-13 08:33:20 +00:00
( section 100
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
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-12-28 21:03:50 +00:00
( 1 : channel - address < - init - channel 3 : literal )
2014-12-14 20:36:42 +00:00
( 2 : integer < - get 1 : channel - address / deref first - full:offset )
( 3 : integer < - get 1 : channel - address / deref first - free:offset )
2014-11-25 05:09:07 +00:00
] ) ) )
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-12-28 21:03:50 +00:00
( prn "F - 'init-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
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-12-28 21:03:50 +00:00
( 1 : channel - address < - init - channel 3 : literal )
2015-01-06 07:57:19 +00:00
( 2 : integer < - copy 34 : literal )
( 3 : tagged - value < - save - type 2 : integer )
2014-12-14 20:36:42 +00:00
( 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-12-30 22:37:04 +00:00
; ? ( prn function * ! write )
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-12-30 22:37:04 +00:00
; ? ( = dump - trace * ( obj whitelist ' ( "run" "reply" ) ) )
2014-11-04 21:46:31 +00:00
( run ' main )
2014-12-30 22:37:04 +00:00
( each routine completed - routines *
( aif rep . routine ! error ( prn "error - " it ) ) )
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
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-12-28 21:03:50 +00:00
( 1 : channel - address < - init - channel 3 : literal )
2015-01-06 07:57:19 +00:00
( 2 : integer < - copy 34 : literal )
( 3 : tagged - value < - save - type 2 : integer )
2014-12-14 20:36:42 +00:00
( 1 : channel - address / deref < - write 1 : channel - address 3 : tagged - value )
( 5 : tagged - value 1 : channel - address / deref < - read 1 : channel - address )
2015-01-06 07:57:19 +00:00
( 7 : integer < - maybe - coerce 5 : tagged - value integer:literal )
2014-12-14 20:36:42 +00:00
( 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 * )
2015-01-06 07:57:19 +00:00
( if ( ~ is memory * .7 34 )
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
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-11-15 22:58:58 +00:00
; channel with 1 slot
2014-12-28 21:03:50 +00:00
( 1 : channel - address < - init - channel 1 : literal )
2014-11-07 20:33:12 +00:00
; write a value
2015-01-06 07:57:19 +00:00
( 2 : integer < - copy 34 : literal )
( 3 : tagged - value < - save - type 2 : integer )
2014-12-14 20:36:42 +00:00
( 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-12-14 20:36:42 +00:00
( 5 : integer < - get 1 : channel - address / deref first - free:offset )
2014-11-07 20:33:12 +00:00
; read one value
2014-12-14 20:36:42 +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-12-14 20:36:42 +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
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-11-15 22:58:58 +00:00
; channel with 1 slot
2014-12-28 21:03:50 +00:00
( 1 : channel - address < - init - channel 1 : literal )
2014-11-07 20:33:12 +00:00
; write a value
2015-01-06 07:57:19 +00:00
( 2 : integer < - copy 34 : literal )
( 3 : tagged - value < - save - type 2 : integer )
2014-12-14 20:36:42 +00:00
( 1 : channel - address / deref < - write 1 : channel - address 3 : tagged - value )
2014-11-07 20:33:12 +00:00
; read one value
2014-12-14 20:36:42 +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-12-14 20:36:42 +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-12-14 20:36:42 +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-12-14 20:36:42 +00:00
( _ 1 : channel - address / deref < - read 1 : channel - address )
( 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
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-12-28 21:03:50 +00:00
( 1 : channel - address < - init - channel 3 : literal )
2014-12-14 20:36:42 +00:00
( 2 : boolean < - empty ? 1 : channel - address / deref )
( 3 : 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 * )
( 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
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-12-28 21:03:50 +00:00
( 1 : channel - address < - init - channel 3 : literal )
2015-01-06 07:57:19 +00:00
( 2 : integer < - copy 34 : literal )
( 3 : tagged - value < - save - type 2 : integer )
2014-12-14 20:36:42 +00:00
( 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
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-12-28 21:03:50 +00:00
( 1 : channel - address < - init - channel 1 : literal )
2015-01-06 07:57:19 +00:00
( 2 : integer < - copy 34 : literal )
( 3 : tagged - value < - save - type 2 : integer )
2014-12-14 20:36:42 +00:00
( 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
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-12-28 21:03:50 +00:00
( 1 : channel - address < - init - channel 3 : literal )
2015-01-06 07:57:19 +00:00
( 2 : integer < - copy 34 : literal )
( 3 : tagged - value < - save - type 2 : integer )
2014-12-14 20:36:42 +00:00
( 1 : channel - address / deref < - write 1 : channel - address 3 : tagged - value )
( 1 : channel - address / deref < - write 1 : channel - address 3 : tagged - value )
( _ 1 : channel - address / deref < - read 1 : channel - address )
( 5 : boolean < - empty ? 1 : channel - address / deref )
( 6 : boolean < - full ? 1 : channel - address / deref )
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
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-12-28 21:03:50 +00:00
( 1 : channel - address < - init - channel 3 : literal )
2015-01-06 07:57:19 +00:00
( 2 : integer < - copy 34 : literal )
( 3 : tagged - value < - save - type 2 : integer )
2014-12-14 20:36:42 +00:00
( 1 : channel - address / deref < - write 1 : channel - address 3 : tagged - value )
( _ 1 : channel - address / deref < - read 1 : channel - address )
( 5 : boolean < - empty ? 1 : channel - address / deref )
( 6 : boolean < - full ? 1 : channel - address / deref )
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
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-12-28 21:03:50 +00:00
( 1 : channel - address < - init - channel 3 : literal )
2014-11-08 05:39:00 +00:00
; channel is empty , but receives a read
2014-12-14 20:36:42 +00:00
( 2 : tagged - value 1 : channel - address / deref < - read 1 : channel - address )
2014-11-25 05:09:07 +00:00
] ) ) )
2014-11-08 05:39:00 +00:00
; ? ( set dump - trace * )
2014-12-14 20:36:42 +00:00
; ? ( = dump - trace * ( obj whitelist ' ( "run" "schedule" ) ) )
2014-11-08 05:39:00 +00:00
( 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
2014-12-13 02:07:30 +00:00
' ( ( function main [
2014-12-28 21:03:50 +00:00
( 1 : channel - address < - init - channel 1 : literal )
2015-01-06 07:57:19 +00:00
( 2 : integer < - copy 34 : literal )
( 3 : tagged - value < - save - type 2 : integer )
2014-12-14 20:36:42 +00:00
( 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-12-14 20:36:42 +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
2014-12-29 00:42:18 +00:00
' ( ( function consumer [
2015-01-03 02:13:04 +00:00
( default - space:space - address < - new space:literal 30 : literal )
2014-12-29 00:42:18 +00:00
( chan:channel - address < - init - channel 3 : literal ) ; create a channel
2015-01-10 20:38:14 +00:00
( fork producer:fn nil:literal /globals nil:literal/ limit chan:channel - address ) ; fork a routine to produce a value in it
2014-12-29 00:42:18 +00:00
( 1 : tagged - value / raw < - read chan:channel - address ) ; wait for input on channel
2014-12-04 10:57:03 +00:00
] )
2014-12-29 00:42:18 +00:00
( function producer [
2015-01-03 02:13:04 +00:00
( default - space:space - address < - new space:literal 30 : literal )
2015-01-06 07:57:19 +00:00
( n:integer < - copy 24 : literal )
2014-12-14 20:36:42 +00:00
( ochan:channel - address < - next - input )
2015-01-06 07:57:19 +00:00
( x:tagged - value < - save - type n:integer )
2014-12-14 20:36:42 +00:00
( ochan:channel - address / deref < - write ochan:channel - address x:tagged - value )
2014-12-04 10:57:03 +00:00
] ) ) )
; ? ( set dump - trace * )
; ? ( = dump - trace * ( obj whitelist ' ( "schedule" "run" "addr" ) ) )
; ? ( = dump - trace * ( obj whitelist ' ( "-" ) ) )
2014-12-29 00:42:18 +00:00
( run ' consumer )
2014-12-04 10:57:03 +00:00
; ? ( prn memory * )
( each routine completed - routines *
( aif rep . routine ! error ( prn "error - " it ) ) )
2015-01-06 07:57:19 +00:00
( if ( ~ is 24 memory * .2 ) ; location 1 contains tagged - value x above
2014-12-04 10:57:03 +00:00
( prn "F - channels are meant to be shared between routines" ) )
; ? ( quit )
2014-11-21 22:36:22 +00:00
2014-12-29 00:42:18 +00:00
( reset )
( new - trace "channel-handoff-routine" )
( add - code
' ( ( function consumer [
2015-01-03 02:13:04 +00:00
( default - space:space - address < - new space:literal 30 : literal )
2014-12-29 00:42:18 +00:00
( 1 : channel - address < - init - channel 3 : literal ) ; create a channel
2015-01-10 20:38:14 +00:00
( fork producer:fn default - space:space - address /globals nil:literal/ limit ) ; pass it as a global to another routine
2014-12-29 00:42:18 +00:00
( 1 : tagged - value / raw < - read 1 : channel - address ) ; wait for input on channel
] )
( function producer [
2015-01-03 02:13:04 +00:00
( default - space:space - address < - new space:literal 30 : literal )
2015-01-06 07:57:19 +00:00
( n:integer < - copy 24 : literal )
( x:tagged - value < - save - type n:integer )
2014-12-29 00:42:18 +00:00
( 1 : channel - address /space:global/ deref < - write 1 : channel - address / space:global x:tagged - value )
] ) ) )
( run ' consumer )
( each routine completed - routines *
( aif rep . routine ! error ( prn "error - " it ) ) )
2015-01-06 07:57:19 +00:00
( if ( ~ is 24 memory * .2 ) ; location 1 contains tagged - value x above
2014-12-29 00:42:18 +00:00
( prn "F - channels are meant to be shared between routines" ) )
2014-12-13 08:33:20 +00:00
) ; section 100
2014-12-14 07:31:52 +00:00
( section 10
2014-12-13 10:07:48 +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
2014-12-13 23:02:04 +00:00
' ( ( 1 : integer < - copy 4 : literal )
2014-11-07 21:00:44 +00:00
( defer [
2014-12-13 23:02:04 +00:00
( 3 : integer < - copy 6 : literal )
2014-11-07 21:00:44 +00:00
] )
2014-12-13 23:02:04 +00:00
( 2 : integer < - copy 5 : literal ) ) )
' ( ( 1 : integer < - copy 4 : literal )
( 2 : integer < - copy 5 : literal )
( 3 : integer < - copy 6 : literal ) ) )
2014-11-07 21:00:44 +00:00
( 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
2014-12-13 23:02:04 +00:00
' ( ( 1 : integer < - copy 0 : literal )
2014-12-04 02:08:42 +00:00
( defer [
2014-12-13 23:02:04 +00:00
( 5 : integer < - copy 0 : literal )
2014-12-04 02:08:42 +00:00
] )
2014-12-13 23:02:04 +00:00
( 2 : integer < - copy 0 : literal )
2014-12-04 02:08:42 +00:00
( reply )
2014-12-13 23:02:04 +00:00
( 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 )
2014-12-04 02:08:42 +00:00
( reply )
2014-12-13 23:02:04 +00:00
( 3 : integer < - copy 0 : literal )
( 4 : integer < - copy 0 : literal )
( 5 : integer < - copy 0 : literal ) ) )
2014-12-04 02:08:42 +00:00
( 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
2014-12-13 23:02:04 +00:00
' ( ( 1 : integer < - copy 0 : literal )
2014-12-04 02:19:40 +00:00
( defer [
2014-12-13 23:02:04 +00:00
( 5 : integer < - copy 0 : literal )
2014-12-04 02:19:40 +00:00
] )
2014-12-13 23:02:04 +00:00
( 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 )
2014-12-04 02:19:40 +00:00
( reply )
2014-12-13 23:02:04 +00:00
( 3 : integer < - copy 0 : literal )
( 4 : integer < - copy 0 : literal )
( 5 : integer < - copy 0 : literal ) ) )
2014-12-04 02:19:40 +00:00
( 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
2014-12-13 23:02:04 +00:00
' ( ( 1 : integer < - copy 4 : literal )
2014-11-25 02:56:15 +00:00
foo
2014-12-13 23:02:04 +00:00
( 2 : integer < - copy 5 : literal ) ) )
' ( ( 1 : integer < - copy 4 : literal )
2014-11-25 02:56:15 +00:00
foo
2014-12-13 23:02:04 +00:00
( 2 : integer < - copy 5 : literal ) ) )
2014-11-25 02:56:15 +00:00
( 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 ) )
2015-01-09 08:44:24 +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
(
2014-12-13 23:02:04 +00:00
( 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
2014-12-13 23:02:04 +00:00
' ( ( 1 : integer < - copy 0 : literal )
2014-11-25 03:27:52 +00:00
label1
2014-12-13 23:02:04 +00:00
( 3 : integer < - copy 0 : literal ) ) )
' ( ( 1 : integer < - copy 0 : literal )
( 2 : integer < - copy 0 : literal )
2014-11-25 03:27:52 +00:00
label1
2014-12-13 23:02:04 +00:00
( 3 : integer < - copy 0 : literal ) ) )
2014-11-25 03:27:52 +00:00
( 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 ) )
2015-01-09 08:44:24 +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
(
2014-12-13 23:02:04 +00:00
( 2 : integer < - copy 0 : literal ) )
2014-11-25 03:27:52 +00:00
(
2014-12-13 23:02:04 +00:00
( 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
2014-12-13 23:02:04 +00:00
' ( ( 1 : integer < - copy 0 : literal )
2014-11-25 03:27:52 +00:00
label1
2014-12-13 23:02:04 +00:00
( 4 : integer < - copy 0 : literal ) ) )
' ( ( 1 : integer < - copy 0 : literal )
( 2 : integer < - copy 0 : literal )
( 3 : integer < - copy 0 : literal )
2014-11-25 03:27:52 +00:00
label1
2014-12-13 23:02:04 +00:00
( 4 : integer < - copy 0 : literal ) ) )
2014-11-25 03:27:52 +00:00
( 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 ) )
2015-01-09 08:44:24 +00:00
( add - code
' ( ( before f / label1 [ ; label1 only inside function f
( 2 : integer < - copy 0 : literal )
] ) ) )
2014-11-27 05:36:14 +00:00
( if ( ~ iso ( insert - code
2014-12-13 23:02:04 +00:00
' ( ( 1 : integer < - copy 0 : literal )
2014-11-27 05:36:14 +00:00
label1
2014-12-13 23:02:04 +00:00
( 3 : integer < - copy 0 : literal ) )
2014-11-27 05:36:14 +00:00
' f )
2014-12-13 23:02:04 +00:00
' ( ( 1 : integer < - copy 0 : literal )
( 2 : integer < - copy 0 : literal )
2014-11-27 05:36:14 +00:00
label1
2014-12-13 23:02:04 +00:00
( 3 : integer < - copy 0 : literal ) ) )
2014-11-27 05:36:14 +00:00
( 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 ) )
2015-01-09 08:44:24 +00:00
( add - code
' ( ( before f / label1 [ ; label1 only inside function f
( 2 : integer < - copy 0 : literal )
] ) ) )
2014-11-27 05:36:14 +00:00
( if ( ~ iso ( insert - code
2014-12-13 23:02:04 +00:00
' ( ( 1 : integer < - copy 0 : literal )
2014-11-27 05:36:14 +00:00
label1
2014-12-13 23:02:04 +00:00
( 3 : integer < - copy 0 : literal ) ) )
' ( ( 1 : integer < - copy 0 : literal )
2014-11-27 05:36:14 +00:00
label1
2014-12-13 23:02:04 +00:00
( 3 : integer < - copy 0 : literal ) ) )
2014-11-27 05:36:14 +00:00
( 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 ) )
2015-01-09 08:44:24 +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
(
2014-12-13 23:02:04 +00:00
( 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
2014-12-13 23:02:04 +00:00
' ( ( 1 : integer < - copy 0 : literal )
2014-11-25 03:27:52 +00:00
label1
2014-12-13 23:02:04 +00:00
( 3 : integer < - copy 0 : literal ) ) )
' ( ( 1 : integer < - copy 0 : literal )
2014-11-25 03:27:52 +00:00
label1
2014-12-13 23:02:04 +00:00
( 2 : integer < - copy 0 : literal )
( 3 : integer < - copy 0 : literal ) ) )
2014-11-25 03:27:52 +00:00
( 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 ) )
2015-01-09 08:44:24 +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
(
2014-12-13 23:02:04 +00:00
( 3 : integer < - copy 0 : literal ) )
2014-11-25 03:27:52 +00:00
(
2014-12-13 23:02:04 +00:00
( 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
2014-12-13 23:02:04 +00:00
' ( ( 1 : integer < - copy 0 : literal )
2014-11-25 03:27:52 +00:00
label1
2014-12-13 23:02:04 +00:00
( 4 : integer < - copy 0 : literal ) ) )
' ( ( 1 : integer < - copy 0 : literal )
2014-11-25 03:27:52 +00:00
label1
2014-12-13 23:02:04 +00:00
( 3 : integer < - copy 0 : literal )
( 2 : integer < - copy 0 : literal )
( 4 : integer < - copy 0 : literal ) ) )
2014-11-25 03:27:52 +00:00
( 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 ) )
2015-01-09 08:44:24 +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
(
2014-12-13 23:02:04 +00:00
( 2 : integer < - copy 0 : literal ) ) ) )
2014-11-25 03:27:52 +00:00
( ~ iso ( as cons after * ! label1 )
' ( ; fragment
(
2014-12-13 23:02:04 +00:00
( 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
2014-12-13 23:02:04 +00:00
' ( ( 1 : integer < - copy 0 : literal )
2014-11-25 03:27:52 +00:00
label1
2014-12-13 23:02:04 +00:00
( 4 : integer < - copy 0 : literal ) ) )
' ( ( 1 : integer < - copy 0 : literal )
( 2 : integer < - copy 0 : literal )
2014-11-25 03:27:52 +00:00
label1
2014-12-13 23:02:04 +00:00
( 3 : integer < - copy 0 : literal )
( 4 : integer < - copy 0 : literal ) ) )
2014-11-25 03:27:52 +00:00
( 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 ) )
2015-01-09 08:44:24 +00:00
( add - code
' ( ( before label1 [
( 2 : integer < - copy 0 : literal )
( 3 : integer < - copy 0 : literal )
] )
( after label1 [
( 4 : integer < - copy 0 : literal )
] )
( before label1 [
( 5 : integer < - copy 0 : literal )
] )
( after label1 [
( 6 : integer < - copy 0 : literal )
( 7 : integer < - copy 0 : literal )
] ) ) )
2014-11-25 03:27:52 +00:00
( if ( or ( ~ iso ( as cons before * ! label1 )
' ( ; fragment
(
2014-12-13 23:02:04 +00:00
( 2 : integer < - copy 0 : literal )
( 3 : integer < - copy 0 : literal ) )
2014-11-25 03:27:52 +00:00
(
2014-12-13 23:02:04 +00:00
( 5 : integer < - copy 0 : literal ) ) ) )
2014-11-25 03:27:52 +00:00
( ~ iso ( as cons after * ! label1 )
' ( ; fragment
(
2014-12-13 23:02:04 +00:00
( 6 : integer < - copy 0 : literal )
( 7 : integer < - copy 0 : literal ) )
2014-11-25 03:27:52 +00:00
(
2014-12-13 23:02:04 +00:00
( 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
2014-12-13 23:02:04 +00:00
' ( ( 1 : integer < - copy 0 : literal )
2014-11-25 03:27:52 +00:00
label1
2014-12-13 23:02:04 +00:00
( 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 )
2014-11-25 03:27:52 +00:00
label1
2014-12-13 23:02:04 +00:00
( 6 : integer < - copy 0 : literal )
( 7 : integer < - copy 0 : literal )
( 4 : integer < - copy 0 : literal )
( 8 : integer < - copy 0 : literal ) ) )
2014-11-25 03:27:52 +00:00
( 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 )
2015-01-09 08:44:24 +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 )
2015-01-09 08:44:24 +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 ) ) )
2014-12-13 22:51:58 +00:00
( prn "F - order matters between 'before' and between 'after' fragments, but not *across* 'before' and 'after' fragments" ) )
2014-11-25 03:27:52 +00:00
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 ) )
2015-01-09 08:44:24 +00:00
( add - code
' ( ( after label1 [
( 1 : integer < - copy 0 : literal )
] )
( function f1 [
{ begin
label1
}
] ) ) )
2014-12-13 22:00:14 +00:00
; ? ( = dump - trace * ( obj whitelist ' ( "cn0" ) ) )
2014-12-30 23:13:51 +00:00
( freeze function * )
2014-11-25 06:05:56 +00:00
( if ( ~ iso function * ! f1
' ( label1
2014-12-13 22:00:14 +00:00
( ( ( 1 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) ) ) )
2014-11-25 06:05:56 +00:00
( 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 ) )
2015-01-09 08:44:24 +00:00
( add - code
' ( ( function f1 [
{ begin
label1
}
] )
( after label1 [
( 1 : integer < - copy 0 : literal )
] ) ) )
2014-12-30 23:13:51 +00:00
( freeze function * )
2014-11-25 06:24:22 +00:00
( if ( ~ iso function * ! f1
' ( label1
2014-12-13 22:00:14 +00:00
( ( ( 1 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) ) ) )
2014-11-25 06:24:22 +00:00
( prn "F - before/after can come after the function they need to modify" ) )
2014-12-13 22:00:14 +00:00
; ? ( quit )
2014-11-25 06:24:22 +00:00
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 ) )
2015-01-09 08:44:24 +00:00
( add - code
' ( ( function f1 [
( 1 : integer < - copy 0 : literal )
] )
( function f1 [
( 2 : integer < - copy 0 : literal )
] ) ) )
2014-12-30 23:13:51 +00:00
( freeze function * )
2014-11-25 06:44:42 +00:00
( if ( ~ iso function * ! f1
2014-12-13 22:00:14 +00:00
' ( ( ( ( 2 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) )
( ( ( 1 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) ) ) )
2014-11-25 06:44:42 +00:00
( 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 ) )
2015-01-09 08:44:24 +00:00
( add - code
' ( ( function f1 [
( 1 : integer < - copy 0 : literal )
] )
( function ! f1 [
( 2 : integer < - copy 0 : literal )
] ) ) )
2014-12-30 23:13:51 +00:00
( freeze function * )
2014-11-25 06:44:42 +00:00
( if ( ~ iso function * ! f1
2014-12-13 22:00:14 +00:00
' ( ( ( ( 2 integer ) ) < - ( ( copy ) ) ( ( 0 literal ) ) ) ) )
2014-11-25 06:44:42 +00:00
( prn "F - 'def!' clears all previous clauses" ) )
2014-12-14 07:31:52 +00:00
) ; section 10
2014-12-13 10:07:48 +00:00
2014-11-27 06:26:55 +00:00
; ; - - -
2014-12-13 08:33:20 +00:00
( section 100 ; string utilities
2014-11-27 06:26:55 +00:00
( reset )
( new - trace "string-new" )
2015-01-09 08:44:24 +00:00
( add - code
' ( ( function main [
( 1 : string - address < - new string: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 )
( 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" )
2015-01-09 08:44:24 +00:00
( add - code
' ( ( function main [
( 1 : string - address < - new "hello" )
] ) ) )
2014-12-04 10:50:33 +00:00
( let routine make - routine ! main
( enq routine running - routines * )
( let before rep . routine ! alloc
2014-12-14 20:36:42 +00:00
; ? ( set dump - trace * )
; ? ( = dump - trace * ( obj whitelist ' ( "schedule" "run" "addr" ) ) )
2014-12-04 10:50:33 +00:00
( 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" )
2015-01-09 08:44:24 +00:00
( add - code
' ( ( function main [
( 1 : string - address < - new "hello," )
( 2 : string - address < - new " world!" )
( 3 : string - address < - strcat 1 : string - address 2 : string - address )
] ) ) )
2014-11-27 08:34:29 +00:00
( 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" )
2015-01-09 08:44:24 +00:00
( add - code
' ( ( function main [
( 1 : string - address < - new "hello, _!" )
( 2 : string - address < - new "abc" )
( 3 : string - address < - interpolate 1 : string - address 2 : string - address )
] ) ) )
2014-11-27 18:14:03 +00:00
; ? ( = 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" )
2015-01-09 08:44:24 +00:00
( add - code
' ( ( function main [
( 1 : string - address < - new "hello!" )
( 2 : string - address < - new "abc" )
( 3 : string - address < - interpolate 1 : string - address 2 : string - address )
] ) ) )
2014-11-27 18:14:03 +00:00
; ? ( = 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" )
2015-01-09 08:44:24 +00:00
( add - code
' ( ( function main [
( 1 : string - address < - new "_, hello!" )
( 2 : string - address < - new "abc" )
( 3 : string - address < - interpolate 1 : string - address 2 : string - address )
] ) ) )
2014-11-27 18:14:03 +00:00
; ? ( = 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" )
2015-01-09 08:44:24 +00:00
( add - code
' ( ( function main [
( 1 : string - address < - new "hello, _" )
( 2 : string - address < - new "abc" )
( 3 : string - address < - interpolate 1 : string - address 2 : string - address )
] ) ) )
2014-11-27 18:14:03 +00:00
; ? ( = 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" )
2015-01-09 08:44:24 +00:00
( add - code
' ( ( function main [
( 1 : string - address < - new "hello, _, _, and _!" )
( 2 : string - address < - new "abc" )
( 3 : string - address < - new "def" )
( 4 : string - address < - new "ghi" )
( 5 : string - address < - interpolate 1 : string - address 2 : string - address 3 : string - address 4 : string - address )
] ) ) )
2014-11-29 09:38:54 +00:00
; ? ( = 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-12-20 02:57:11 +00:00
( reset )
( new - trace "string-find-next" )
2015-01-09 08:44:24 +00:00
( add - code
' ( ( function main [
( 1 : string - address < - new "a/b" )
( 2 : integer < - find - next 1 : string - address ( ( #\/ literal)) 0:literal)
] ) ) )
2014-12-20 02:57:11 +00:00
( run ' main )
( if ( ~ is memory * .2 1 )
( prn "F - 'find-next' finds first location of a character" ) )
( reset )
( new - trace "string-find-next-empty" )
2015-01-09 08:44:24 +00:00
( add - code
' ( ( function main [
( 1 : string - address < - new "" )
( 2 : integer < - find - next 1 : string - address ( ( #\/ literal)) 0:literal)
] ) ) )
2014-12-20 02:57:11 +00:00
( run ' main )
( each routine completed - routines *
( aif rep . routine ! error ( prn "error - " it ) ) )
( if ( ~ is memory * .2 0 )
( prn "F - 'find-next' finds first location of a character" ) )
( reset )
( new - trace "string-find-next-initial" )
2015-01-09 08:44:24 +00:00
( add - code
' ( ( function main [
( 1 : string - address < - new "/abc" )
( 2 : integer < - find - next 1 : string - address ( ( #\/ literal)) 0:literal)
] ) ) )
2014-12-20 02:57:11 +00:00
( run ' main )
( if ( ~ is memory * .2 0 )
( prn "F - 'find-next' handles prefix match" ) )
( reset )
( new - trace "string-find-next-final" )
2015-01-09 08:44:24 +00:00
( add - code
' ( ( function main [
( 1 : string - address < - new "abc/" )
( 2 : integer < - find - next 1 : string - address ( ( #\/ literal)) 0:literal)
] ) ) )
2014-12-20 02:57:11 +00:00
( run ' main )
; ? ( prn memory * .2 )
( if ( ~ is memory * .2 3 )
( prn "F - 'find-next' handles suffix match" ) )
( reset )
( new - trace "string-find-next-missing" )
2015-01-09 08:44:24 +00:00
( add - code
' ( ( function main [
( 1 : string - address < - new "abc" )
( 2 : integer < - find - next 1 : string - address ( ( #\/ literal)) 0:literal)
] ) ) )
2014-12-20 02:57:11 +00:00
( run ' main )
; ? ( prn memory * .2 )
( if ( ~ is memory * .2 3 )
( prn "F - 'find-next' handles no match" ) )
( reset )
( new - trace "string-find-next-invalid-index" )
2015-01-09 08:44:24 +00:00
( add - code
' ( ( function main [
( 1 : string - address < - new "abc" )
( 2 : integer < - find - next 1 : string - address ( ( #\/ literal)) 4:literal)
] ) ) )
2014-12-20 02:57:11 +00:00
; ? ( = dump - trace * ( obj whitelist ' ( "run" ) ) )
( run ' main )
( each routine completed - routines *
( aif rep . routine ! error ( prn "error - " it ) ) )
; ? ( prn memory * .2 )
( if ( ~ is memory * .2 4 )
( prn "F - 'find-next' skips invalid index (past end of string)" ) )
( reset )
( new - trace "string-find-next-first" )
2015-01-09 08:44:24 +00:00
( add - code
' ( ( function main [
( 1 : string - address < - new "ab/c/" )
( 2 : integer < - find - next 1 : string - address ( ( #\/ literal)) 0:literal)
] ) ) )
2014-12-20 02:57:11 +00:00
( run ' main )
( if ( ~ is memory * .2 2 )
( prn "F - 'find-next' finds first of multiple options" ) )
( reset )
( new - trace "string-find-next-second" )
2015-01-09 08:44:24 +00:00
( add - code
' ( ( function main [
( 1 : string - address < - new "ab/c/" )
( 2 : integer < - find - next 1 : string - address ( ( #\/ literal)) 3:literal)
] ) ) )
2014-12-20 02:57:11 +00:00
( run ' main )
( if ( ~ is memory * .2 4 )
( prn "F - 'find-next' finds second of multiple options" ) )
2014-12-20 06:18:41 +00:00
( reset )
( new - trace "string-split" )
2015-01-09 08:44:24 +00:00
( add - code
' ( ( function main [
( 1 : string - address < - new "a/b" )
( 2 : string - address - array - address < - split 1 : string - address ( ( #\/ literal)))
] ) ) )
2014-12-20 06:18:41 +00:00
; ? ( set dump - trace * )
( run ' main )
( each routine completed - routines *
( aif rep . routine ! error ( prn "error - " it ) ) )
( let base memory * .2
; ? ( prn base " " memory * . base )
( if ( or ( ~ is memory * . base 2 )
; ? ( do1 nil prn .111 )
( ~ memory - contains - array ( memory * ( + base 1 ) ) "a" )
; ? ( do1 nil prn .111 )
( ~ memory - contains - array ( memory * ( + base 2 ) ) "b" ) )
( prn "F - 'split' cuts string at delimiter" ) ) )
( reset )
( new - trace "string-split2" )
2015-01-09 08:44:24 +00:00
( add - code
' ( ( function main [
( 1 : string - address < - new "a/b/c" )
( 2 : string - address - array - address < - split 1 : string - address ( ( #\/ literal)))
] ) ) )
2014-12-20 06:18:41 +00:00
; ? ( set dump - trace * )
( run ' main )
( each routine completed - routines *
( aif rep . routine ! error ( prn "error - " it ) ) )
( let base memory * .2
; ? ( prn base " " memory * . base )
( if ( or ( ~ is memory * . base 3 )
; ? ( do1 nil prn .111 )
( ~ memory - contains - array ( memory * ( + base 1 ) ) "a" )
; ? ( do1 nil prn .111 )
( ~ memory - contains - array ( memory * ( + base 2 ) ) "b" )
; ? ( do1 nil prn .111 )
( ~ memory - contains - array ( memory * ( + base 3 ) ) "c" ) )
( prn "F - 'split' cuts string at two delimiters" ) ) )
( reset )
( new - trace "string-split-missing" )
2015-01-09 08:44:24 +00:00
( add - code
' ( ( function main [
( 1 : string - address < - new "abc" )
( 2 : string - address - array - address < - split 1 : string - address ( ( #\/ literal)))
] ) ) )
2014-12-20 06:18:41 +00:00
( run ' main )
( each routine completed - routines *
( aif rep . routine ! error ( prn "error - " it ) ) )
( let base memory * .2
( if ( or ( ~ is memory * . base 1 )
( ~ memory - contains - array ( memory * ( + base 1 ) ) "abc" ) )
( prn "F - 'split' handles missing delimiter" ) ) )
( reset )
( new - trace "string-split-empty" )
2015-01-09 08:44:24 +00:00
( add - code
' ( ( function main [
( 1 : string - address < - new "" )
( 2 : string - address - array - address < - split 1 : string - address ( ( #\/ literal)))
] ) ) )
2014-12-20 06:18:41 +00:00
; ? ( = dump - trace * ( obj whitelist ' ( "run" ) ) )
( run ' main )
( each routine completed - routines *
( aif rep . routine ! error ( prn "error - " it ) ) )
( let base memory * .2
; ? ( prn base " " memory * . base )
( if ( ~ is memory * . base 0 )
( prn "F - 'split' handles empty string" ) ) )
( reset )
( new - trace "string-split-empty-piece" )
2015-01-09 08:44:24 +00:00
( add - code
' ( ( function main [
( 1 : string - address < - new "a/b//c" )
( 2 : string - address - array - address < - split 1 : string - address ( ( #\/ literal)))
] ) ) )
2014-12-20 06:18:41 +00:00
( run ' main )
( each routine completed - routines *
( aif rep . routine ! error ( prn "error - " it ) ) )
( let base memory * .2
( if ( or ( ~ is memory * . base 4 )
( ~ memory - contains - array ( memory * ( + base 1 ) ) "a" )
( ~ memory - contains - array ( memory * ( + base 2 ) ) "b" )
( ~ memory - contains - array ( memory * ( + base 3 ) ) "" )
( ~ memory - contains - array ( memory * ( + base 4 ) ) "c" ) )
( prn "F - 'split' cuts string at two delimiters" ) ) )
2014-12-13 08:33:20 +00:00
) ; section 100 for string utilities
2014-12-17 19:01:38 +00:00
( reset )
( new - trace "parse-and-record" )
2015-01-09 08:44:24 +00:00
( add - code
' ( ( and - record foo [
x:string
y:integer
z:boolean
] ) ) )
2014-12-17 19:01:38 +00:00
( if ( ~ iso type * ! foo ( obj size 3 and - record t elems '((string) (integer) (boolean)) fields ' ( x y z ) ) )
( prn "F - 'add-code' can add new and-records" ) )
2014-11-29 03:31:43 +00:00
; ; unit tests for various helpers
2014-12-13 10:07:48 +00:00
; tokenize - args
2014-12-18 07:10:49 +00:00
( prn "== tokenize-args" )
2014-12-13 10:07:48 +00:00
( assert:iso ' ( ( a b ) ( c d ) )
( tokenize - arg ' a:b / c:d ) )
2014-12-26 03:21:01 +00:00
; numbers are not symbols
2014-12-13 10:07:48 +00:00
( assert:iso ' ( ( a b ) ( 1 d ) )
( tokenize - arg ' a:b / 1 : d ) )
2014-12-26 03:21:01 +00:00
; special symbols are skipped
2014-12-13 10:07:48 +00:00
( assert:iso ' < -
( tokenize - arg ' < - ) )
2014-12-14 07:26:15 +00:00
( assert:iso ' _
( tokenize - arg ' _ ) )
2014-12-13 10:07:48 +00:00
2014-12-14 16:14:13 +00:00
; idempotent
( assert:iso ( tokenize - arg:tokenize - arg ' a:b / c:d )
( tokenize - arg ' a:b / c:d ) )
2014-12-13 10:31:57 +00:00
; support labels
2015-01-03 02:13:04 +00:00
( assert:iso ' ( ( ( ( default - space space - address ) ) < - ( ( new ) ) ( ( space literal ) ) ( ( 30 literal ) ) )
2014-12-13 10:07:48 +00:00
foo )
( tokenize - args
2015-01-03 02:13:04 +00:00
' ( ( default - space:space - address < - new space:literal 30 : literal )
2014-12-13 10:07:48 +00:00
foo ) ) )
2014-12-13 10:31:57 +00:00
; support braces
2015-01-03 02:13:04 +00:00
( assert:iso ' ( ( ( ( default - space space - address ) ) < - ( ( new ) ) ( ( space literal ) ) ( ( 30 literal ) ) )
2014-12-13 10:31:57 +00:00
foo
{ begin
bar
( ( ( a b ) ) < - ( ( op ) ) ( ( c d ) ) ( ( e f ) ) )
} )
( tokenize - args
2015-01-03 02:13:04 +00:00
' ( ( default - space:space - address < - new space:literal 30 : literal )
2014-12-13 10:31:57 +00:00
foo
{ begin
bar
( a:b < - op c:d e:f )
} ) ) )
2014-12-28 02:27:54 +00:00
; space
( prn "== space" )
( reset )
( if ( ~ iso 0 ( space ' ( ( 4 integer ) ) ) )
( prn "F - 'space' is 0 by default" ) )
( if ( ~ iso 1 ( space ' ( ( 4 integer ) ( space 1 ) ) ) )
( prn "F - 'space' picks up space when available" ) )
( if ( ~ iso 'global (space ' ( ( 4 integer ) ( space global ) ) ) )
( prn "F - 'space' understands routine-global space" ) )
2014-12-13 09:11:33 +00:00
; absolutize
2014-12-18 07:10:49 +00:00
( prn "== absolutize" )
2014-12-13 09:11:33 +00:00
( reset )
2014-12-13 10:07:48 +00:00
( if ( ~ iso '((4 integer)) (absolutize ' ( ( 4 integer ) ) ) )
2014-12-13 09:11:33 +00:00
( prn "F - 'absolutize' works without routine" ) )
( = routine * make - routine ! foo )
2014-12-13 10:07:48 +00:00
( if ( ~ iso '((4 integer)) (absolutize ' ( ( 4 integer ) ) ) )
2015-01-03 02:13:04 +00:00
( prn "F - 'absolutize' works without default-space" ) )
( = rep . routine * ! call - stack .0 ! default - space 10 )
( = memory * .10 5 ) ; bounds check for default - space
2014-12-29 17:20:51 +00:00
( if ( ~ iso ' ( ( 15 integer ) ( raw ) )
2014-12-13 10:07:48 +00:00
( absolutize ' ( ( 4 integer ) ) ) )
2015-01-03 02:13:04 +00:00
( prn "F - 'absolutize' works with default-space" ) )
2014-12-13 10:07:48 +00:00
( absolutize ' ( ( 5 integer ) ) )
2014-12-13 09:11:33 +00:00
( if ( ~ posmatch "no room" rep . routine * ! error )
2015-01-03 02:13:04 +00:00
( prn "F - 'absolutize' checks against default-space bounds" ) )
2014-12-17 22:03:34 +00:00
( if ( ~ iso '((_ integer)) (absolutize ' ( ( _ integer ) ) ) )
( prn "F - 'absolutize' passes dummy args right through" ) )
2014-12-28 02:27:54 +00:00
( = memory * .20 5 ) ; pretend array
( = rep . routine * ! globals 20 ) ; provide it to routine global
2014-12-29 17:20:51 +00:00
( if ( ~ iso ' ( ( 22 integer ) ( raw ) )
2014-12-28 02:27:54 +00:00
( absolutize ' ( ( 1 integer ) ( space global ) ) ) )
( prn "F - 'absolutize' handles variables in the global space" ) )
2014-12-17 22:03:34 +00:00
; deref
2014-12-18 07:10:49 +00:00
( prn "== deref" )
2014-12-17 22:03:34 +00:00
( 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" ) )
2014-12-18 04:49:23 +00:00
( if ( ~ iso ' ( ( 5 integer ) ( foo ) )
( deref:deref ' ( ( 3 integer - address - address )
( deref )
( foo )
( deref ) ) ) )
( prn "F - 'deref' skips junk" ) )
2014-12-13 09:11:33 +00:00
2014-11-29 03:31:43 +00:00
; addr
2014-12-18 07:10:49 +00:00
( prn "== addr" )
2014-11-29 03:31:43 +00:00
( reset )
( = routine * nil )
2014-12-13 10:07:48 +00:00
; ? ( prn 111 )
( if ( ~ is 4 ( addr ' ( ( 4 integer ) ) ) )
2014-11-29 03:31:43 +00:00
( prn "F - directly addressed operands are their own address" ) )
2014-12-13 10:07:48 +00:00
; ? ( quit )
( if ( ~ is 4 ( addr ' ( ( 4 integer - address ) ) ) )
2014-11-29 03:31:43 +00:00
( prn "F - directly addressed operands are their own address - 2" ) )
2014-12-13 10:07:48 +00:00
( if ( ~ is 4 ( addr ' ( ( 4 literal ) ) ) )
2014-11-29 03:31:43 +00:00
( prn "F - 'addr' doesn't understand literals" ) )
2014-12-13 10:07:48 +00:00
; ? ( prn 201 )
2014-11-29 03:31:43 +00:00
( = memory * .4 23 )
2014-12-13 10:07:48 +00:00
; ? ( prn 202 )
( if ( ~ is 23 ( addr ' ( ( 4 integer - address ) ( deref ) ) ) )
2014-11-29 03:31:43 +00:00
( prn "F - 'addr' works with indirectly-addressed 'deref'" ) )
2014-12-13 10:07:48 +00:00
; ? ( quit )
2014-11-29 03:31:43 +00:00
( = memory * .3 4 )
2014-12-13 10:07:48 +00:00
( if ( ~ is 23 ( addr ' ( ( 3 integer - address - address ) ( deref ) ( deref ) ) ) )
2014-11-29 03:31:43 +00:00
( prn "F - 'addr' works with multiple 'deref'" ) )
( = routine * make - routine ! foo )
2014-12-13 10:07:48 +00:00
( if ( ~ is 4 ( addr ' ( ( 4 integer ) ) ) )
2014-11-29 03:31:43 +00:00
( prn "F - directly addressed operands are their own address inside routines" ) )
2014-12-13 10:07:48 +00:00
( if ( ~ is 4 ( addr ' ( ( 4 integer - address ) ) ) )
2014-11-29 03:31:43 +00:00
( prn "F - directly addressed operands are their own address inside routines - 2" ) )
2014-12-13 10:07:48 +00:00
( if ( ~ is 4 ( addr ' ( ( 4 literal ) ) ) )
2014-11-29 03:31:43 +00:00
( prn "F - 'addr' doesn't understand literals inside routines" ) )
( = memory * .4 23 )
2014-12-13 10:07:48 +00:00
( if ( ~ is 23 ( addr ' ( ( 4 integer - address ) ( deref ) ) ) )
2014-11-29 03:31:43 +00:00
( prn "F - 'addr' works with indirectly-addressed 'deref' inside routines" ) )
2014-12-13 10:07:48 +00:00
; ? ( prn 301 )
2015-01-03 02:13:04 +00:00
( = rep . routine * ! call - stack .0 ! default - space 10 )
2014-12-13 10:07:48 +00:00
; ? ( prn 302 )
2015-01-03 02:13:04 +00:00
( = memory * .10 5 ) ; bounds check for default - space
2014-12-13 10:07:48 +00:00
; ? ( prn 303 )
2014-12-29 17:20:51 +00:00
( if ( ~ is 15 ( addr ' ( ( 4 integer ) ) ) )
2015-01-03 02:13:04 +00:00
( prn "F - directly addressed operands in routines add default-space" ) )
2014-12-13 10:07:48 +00:00
; ? ( quit )
2014-12-29 17:20:51 +00:00
( if ( ~ is 15 ( addr ' ( ( 4 integer - address ) ) ) )
2015-01-03 02:13:04 +00:00
( prn "F - directly addressed operands in routines add default-space - 2" ) )
2014-12-29 17:20:51 +00:00
( if ( ~ is 15 ( addr ' ( ( 4 literal ) ) ) )
2014-11-29 03:31:43 +00:00
( prn "F - 'addr' doesn't understand literals" ) )
2014-12-29 17:20:51 +00:00
( = memory * .15 23 )
2014-12-13 10:07:48 +00:00
( if ( ~ is 23 ( addr ' ( ( 4 integer - address ) ( deref ) ) ) )
2015-01-03 02:13:04 +00:00
( prn "F - 'addr' adds default-space before 'deref', not after" ) )
2014-12-13 10:07:48 +00:00
; ? ( quit )
2014-11-29 03:31:43 +00:00
2014-12-13 10:07:48 +00:00
; array - len
2014-12-18 07:10:49 +00:00
( prn "== array-len" )
2014-12-13 10:07:48 +00:00
( reset )
( = memory * .35 4 )
( if ( ~ is 4 ( array - len ' ( ( 35 integer - boolean - pair - array ) ) ) )
( prn "F - 'array-len'" ) )
( = memory * .34 35 )
( if ( ~ is 4 ( array - len ' ( ( 34 integer - boolean - pair - array - address ) ( deref ) ) ) )
( prn "F - 'array-len'" ) )
; ? ( quit )
2014-11-29 03:31:43 +00:00
; sizeof
2014-12-18 07:10:49 +00:00
( prn "== sizeof" )
2014-11-29 03:31:43 +00:00
( reset )
2014-12-17 22:03:34 +00:00
; ? ( set dump - trace * )
2014-12-13 10:07:48 +00:00
; ? ( prn 401 )
2014-12-17 22:03:34 +00:00
( if ( ~ is 1 ( sizeof ' ( ( _ integer ) ) ) )
2014-11-29 03:31:43 +00:00
( prn "F - 'sizeof' works on primitives" ) )
2014-12-17 22:03:34 +00:00
( if ( ~ is 1 ( sizeof ' ( ( _ integer - address ) ) ) )
2014-11-29 03:31:43 +00:00
( prn "F - 'sizeof' works on addresses" ) )
2014-12-17 22:03:34 +00:00
( if ( ~ is 2 ( sizeof ' ( ( _ integer - boolean - pair ) ) ) )
2014-12-17 18:39:58 +00:00
( prn "F - 'sizeof' works on and-records" ) )
2014-12-17 22:03:34 +00:00
( if ( ~ is 3 ( sizeof ' ( ( _ integer - point - pair ) ) ) )
2014-12-17 18:39:58 +00:00
( prn "F - 'sizeof' works on and-records with and-record fields" ) )
2014-11-29 03:31:43 +00:00
2014-12-13 10:07:48 +00:00
; ? ( prn 410 )
( if ( ~ is 1 ( sizeof ' ( ( 34 integer ) ) ) )
2014-11-29 03:31:43 +00:00
( prn "F - 'sizeof' works on primitive operands" ) )
2014-12-13 10:07:48 +00:00
( if ( ~ is 1 ( sizeof ' ( ( 34 integer - address ) ) ) )
2014-11-29 03:31:43 +00:00
( prn "F - 'sizeof' works on address operands" ) )
2014-12-13 10:07:48 +00:00
( if ( ~ is 2 ( sizeof ' ( ( 34 integer - boolean - pair ) ) ) )
2014-12-17 18:39:58 +00:00
( prn "F - 'sizeof' works on and-record operands" ) )
2014-12-13 10:07:48 +00:00
( if ( ~ is 3 ( sizeof ' ( ( 34 integer - point - pair ) ) ) )
2014-12-17 18:39:58 +00:00
( prn "F - 'sizeof' works on and-record operands with and-record fields" ) )
2014-12-13 10:07:48 +00:00
( if ( ~ is 2 ( sizeof ' ( ( 34 integer - boolean - pair - address ) ( deref ) ) ) )
2014-12-17 18:39:58 +00:00
( prn "F - 'sizeof' works on pointers to and-records" ) )
2014-11-29 08:57:06 +00:00
( = memory * .35 4 ) ; size of array
( = memory * .34 35 )
2014-12-13 10:07:48 +00:00
; ? ( = dump - trace * ( obj whitelist ' ( "sizeof" "array-len" ) ) )
( if ( ~ is 9 ( sizeof ' ( ( 34 integer - boolean - pair - array - address ) ( deref ) ) ) )
2014-11-29 08:57:06 +00:00
( prn "F - 'sizeof' works on pointers to arrays" ) )
; ? ( quit )
2014-11-29 03:31:43 +00:00
2014-12-13 10:07:48 +00:00
; ? ( prn 420 )
2014-11-29 03:31:43 +00:00
( = memory * .4 23 )
2014-12-13 10:07:48 +00:00
( if ( ~ is 24 ( sizeof ' ( ( 4 integer - array ) ) ) )
2014-11-29 03:31:43 +00:00
( prn "F - 'sizeof' reads array lengths from memory" ) )
( = memory * .3 4 )
2014-12-13 10:07:48 +00:00
( if ( ~ is 24 ( sizeof ' ( ( 3 integer - array - address ) ( deref ) ) ) )
2014-11-29 03:31:43 +00:00
( prn "F - 'sizeof' handles pointers to arrays" ) )
2014-12-29 17:20:51 +00:00
( = memory * .15 34 )
2014-11-29 03:31:43 +00:00
( = routine * make - routine ! foo )
2014-12-13 10:07:48 +00:00
( if ( ~ is 24 ( sizeof ' ( ( 4 integer - array ) ) ) )
2014-11-29 03:31:43 +00:00
( prn "F - 'sizeof' reads array lengths from memory inside routines" ) )
2015-01-03 02:13:04 +00:00
( = rep . routine * ! call - stack .0 ! default - space 10 )
( = memory * .10 5 ) ; bounds check for default - space
2014-12-13 10:07:48 +00:00
( if ( ~ is 35 ( sizeof ' ( ( 4 integer - array ) ) ) )
2015-01-03 02:13:04 +00:00
( prn "F - 'sizeof' reads array lengths from memory using default-space" ) )
2014-11-29 08:57:06 +00:00
( = memory * .35 4 ) ; size of array
2014-12-29 17:20:51 +00:00
( = memory * .15 35 )
2014-11-29 08:57:06 +00:00
; ? ( = dump - trace * ( obj whitelist ' ( "sizeof" ) ) )
( aif rep . routine * ! error ( prn "error - " it ) )
2014-12-13 10:07:48 +00:00
( if ( ~ is 9 ( sizeof ' ( ( 4 integer - boolean - pair - array - address ) ( deref ) ) ) )
2015-01-03 02:13:04 +00:00
( prn "F - 'sizeof' works on pointers to arrays using default-space" ) )
2014-11-29 08:57:06 +00:00
; ? ( quit )
2014-11-29 03:31:43 +00:00
; m
2014-12-18 07:10:49 +00:00
( prn "== m" )
2014-11-29 03:31:43 +00:00
( reset )
2014-12-13 10:07:48 +00:00
( if ( ~ is 4 ( m ' ( ( 4 literal ) ) ) )
2014-11-29 03:31:43 +00:00
( prn "F - 'm' avoids reading memory for literals" ) )
2014-12-13 10:07:48 +00:00
( if ( ~ is 4 ( m ' ( ( 4 offset ) ) ) )
2014-11-29 03:31:43 +00:00
( prn "F - 'm' avoids reading memory for offsets" ) )
( = memory * .4 34 )
2014-12-13 10:07:48 +00:00
( if ( ~ is 34 ( m ' ( ( 4 integer ) ) ) )
2014-11-29 03:31:43 +00:00
( prn "F - 'm' reads memory for simple types" ) )
( = memory * .3 4 )
2014-12-13 10:07:48 +00:00
( if ( ~ is 34 ( m ' ( ( 3 integer - address ) ( deref ) ) ) )
2014-11-29 03:31:43 +00:00
( prn "F - 'm' redirects addresses" ) )
( = memory * .2 3 )
2014-12-13 10:07:48 +00:00
( if ( ~ is 34 ( m ' ( ( 2 integer - address - address ) ( deref ) ( deref ) ) ) )
2014-11-29 03:31:43 +00:00
( prn "F - 'm' multiply redirects addresses" ) )
2014-12-13 10:07:48 +00:00
( if ( ~ iso ( annotate 'record ' ( 34 nil ) ) ( m ' ( ( 4 integer - boolean - pair ) ) ) )
2014-11-29 03:31:43 +00:00
( prn "F - 'm' supports compound records" ) )
( = memory * .5 35 )
( = memory * .6 36 )
2014-12-13 10:07:48 +00:00
( if ( ~ iso ( annotate 'record ' ( 34 35 36 ) ) ( m ' ( ( 4 integer - point - pair ) ) ) )
2014-11-29 03:31:43 +00:00
( prn "F - 'm' supports records with compound fields" ) )
2014-12-13 10:07:48 +00:00
( if ( ~ iso ( annotate 'record ' ( 34 35 36 ) ) ( m ' ( ( 3 integer - point - pair - address ) ( deref ) ) ) )
2014-11-29 03:31:43 +00:00
( prn "F - 'm' supports indirect access to records" ) )
( = memory * .4 2 )
2014-12-13 10:07:48 +00:00
( if ( ~ iso ( annotate 'record ' ( 2 35 36 ) ) ( m ' ( ( 4 integer - array ) ) ) )
2014-11-29 03:31:43 +00:00
( prn "F - 'm' supports access to arrays" ) )
2014-12-13 10:07:48 +00:00
( if ( ~ iso ( annotate 'record ' ( 2 35 36 ) ) ( m ' ( ( 3 integer - array - address ) ( deref ) ) ) )
2014-11-29 03:31:43 +00:00
( prn "F - 'm' supports indirect access to arrays" ) )
2014-12-28 02:27:54 +00:00
( = routine * make - routine ! foo )
( = memory * .10 5 ) ; fake array
2014-12-29 17:20:51 +00:00
( = memory * .12 34 )
2014-12-28 02:27:54 +00:00
( = rep . routine * ! globals 10 )
( if ( ~ iso 34 ( m ' ( ( 1 integer ) ( space global ) ) ) )
( prn "F - 'm' supports access to per-routine globals" ) )
2014-11-29 03:31:43 +00:00
; setm
2014-12-18 07:10:49 +00:00
( prn "== setm" )
2014-11-29 03:31:43 +00:00
( reset )
2014-12-13 10:07:48 +00:00
( setm ' ( ( 4 integer ) ) 34 )
2014-11-29 03:31:43 +00:00
( if ( ~ is 34 memory * .4 )
( prn "F - 'setm' writes primitives to memory" ) )
2014-12-13 10:07:48 +00:00
( setm ' ( ( 3 integer - address ) ) 4 )
2014-11-29 03:31:43 +00:00
( if ( ~ is 4 memory * .3 )
( prn "F - 'setm' writes addresses to memory" ) )
2014-12-13 10:07:48 +00:00
( setm ' ( ( 3 integer - address ) ( deref ) ) 35 )
2014-11-29 03:31:43 +00:00
( if ( ~ is 35 memory * .4 )
( prn "F - 'setm' redirects writes" ) )
( = memory * .2 3 )
2014-12-13 10:07:48 +00:00
( setm ' ( ( 2 integer - address - address ) ( deref ) ( deref ) ) 36 )
2014-11-29 03:31:43 +00:00
( if ( ~ is 36 memory * .4 )
( prn "F - 'setm' multiply redirects writes" ) )
2014-12-13 10:07:48 +00:00
; ? ( prn 505 )
( 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-12-13 10:07:48 +00:00
; ? ( prn 506 )
( 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 )
2014-12-13 10:07:48 +00:00
( setm '((4 integer-point-pair)) (annotate ' record ' ( 33 34 ) ) )
2014-11-29 03:31:43 +00:00
( if ( ~ posmatch "incorrect size" rep . routine * ! error )
( prn "F - 'setm' checks size of target" ) )
( wipe routine * )
2014-12-13 10:07:48 +00:00
( 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" ) )
2014-12-13 10:07:48 +00:00
( 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" ) )
2014-12-13 10:07:48 +00:00
( 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" ) )
2014-12-13 10:07:48 +00:00
( 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 )
2014-12-13 10:07:48 +00:00
( setm '((4 integer-array)) (annotate ' record ' ( 2 31 32 33 ) ) )
2014-11-29 03:31:43 +00:00
( 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" ) ) )
2014-12-13 10:07:48 +00:00
( setm '((4 integer-boolean-pair-array)) (annotate ' record ' ( 2 31 nil 32 nil 33 ) ) )
2014-11-29 08:57:06 +00:00
( if ( ~ posmatch "invalid array" rep . routine * ! error )
( prn "F - 'setm' checks that array of records is well-formed" ) )
( = routine * make - routine ! foo )
; ? ( prn 222 )
2014-12-13 10:07:48 +00:00
( setm '((4 integer-boolean-pair-array)) (annotate ' record ' ( 2 31 nil 32 nil ) ) )
2014-11-29 08:57:06 +00:00
( 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