(ero "initializing mu.. (takes ~5s)") ;; profiler (http://arclanguage.org/item?id=11556) ; Keeping this right on top as a reminder to profile before guessing at why my ; program is slow. (mac proc (name params . body) `(def ,name ,params ,@body nil)) (mac filter-log (msg f x) `(ret x@ ,x (prn ,msg (,f x@)))) (= times* (table)) (mac deftimed (name args . body) `(do (def ,(sym (string name "_core")) ,args ,@body) (def ,name ,args (let t0 (msec) (ret ans ,(cons (sym (string name "_core")) args) (update-time ,(string name) t0)))))) (proc update-time(name t0) ; call directly in recursive functions (or= times*.name (list 0 0)) (with ((a b) times*.name timing (- (msec) t0)) (= times*.name (list (+ a timing) (+ b 1))))) (def print-times() (prn (current-process-milliseconds)) (prn "gc " (current-gc-milliseconds)) (each (name time) (tablist times*) (prn name " " time))) ;; what happens when our virtual machine starts up (= initialization-fns* (queue)) (def reset () (each f (as cons initialization-fns*) (f))) (mac on-init body `(enq (fn () ,@body) initialization-fns*)) ;; persisting and checking traces for each test (= traces* (queue)) (= trace-dir* ".traces/") (ensure-dir trace-dir*) (= curr-trace-file* nil) (on-init (awhen curr-trace-file* (tofile (+ trace-dir* it) (each (label trace) (as cons traces*) (pr label ": " trace)))) (= curr-trace-file* nil) (= traces* (queue))) (def new-trace (filename) (prn "== @filename") ;? ) (= curr-trace-file* filename)) (= dump-trace* nil) (def trace (label . args) (when (or (is dump-trace* t) (and dump-trace* (is label "-")) (and dump-trace* (pos label dump-trace*!whitelist)) (and dump-trace* (no dump-trace*!whitelist) (~pos label dump-trace*!blacklist))) (apply prn label ": " args)) (enq (list label (apply tostring:prn args)) traces*) (car args)) (on-init (wipe dump-trace*)) (redef tr args ; why am I still returning to prn when debugging? Will this help? (do1 nil (apply trace "-" args))) (def tr2 (msg arg) (tr msg arg) arg) (def check-trace-contents (msg expected-contents) (unless (trace-contents-match expected-contents) (prn "F - " msg) (prn " trace contents") (print-trace-contents-mismatch expected-contents))) (def trace-contents-match (expected-contents) (each (label msg) (as cons traces*) (when (and expected-contents (is label expected-contents.0.0) (posmatch expected-contents.0.1 msg)) (pop expected-contents))) (no expected-contents)) (def print-trace-contents-mismatch (expected-contents) (each (label msg) (as cons traces*) (whenlet (expected-label expected-msg) expected-contents.0 (if (and (is label expected-label) (posmatch expected-msg msg)) (do (pr " * ") (pop expected-contents)) (pr " ")) (pr label ": " msg))) (prn " couldn't find") (each (expected-label expected-msg) expected-contents (prn " ! " expected-label ": " expected-msg))) (def check-trace-doesnt-contain (msg (label unexpected-contents)) (when (some (fn ((l s)) (and (is l label) (posmatch unexpected-contents msg))) (as cons traces*)) (prn "F - " msg) (prn " trace contents") (each (l msg) (as cons traces*) (if (and (is l label) (posmatch unexpected-contents msg)) (pr " X ") (pr " ")) (pr label ": " msg)))) ;; virtual machine state ; things that a future assembler will need separate memory for: ; code; types; args channel ; at compile time: mapping names to locations (on-init (= type* (table)) ; name -> type info (= memory* (table)) ; address -> value (make this a vector?) (= function* (table)) ; name -> [instructions] ; transforming mu programs (= location* (table)) ; function -> {name -> index into default-space} (= next-space-generator* (table)) ; function -> name of function generating next space ; each function's next space will usually always come from a single function (= next-routine-id* 0) (= continuation* (table)) ) (on-init (= type* (obj ; Each type must be scalar or array, sum or product or primitive type (obj size 1) ; implicitly scalar and primitive type-address (obj size 1 address t elem '(type)) type-array (obj array t elem '(type)) type-array-address (obj size 1 address t elem '(type-array)) location (obj size 1 address t elem '(location)) ; assume it points to an atom integer (obj size 1) boolean (obj size 1) boolean-address (obj size 1 address t elem '(boolean)) byte (obj size 1) byte-address (obj size 1 address t elem '(byte)) string (obj array t elem '(byte)) ; inspired by Go ; an address contains the location of a specific type string-address (obj size 1 address t elem '(string)) string-address-address (obj size 1 address t elem '(string-address)) string-address-array (obj array t elem '(string-address)) string-address-array-address (obj size 1 address t elem '(string-address-array)) string-address-array-address-address (obj size 1 address t elem '(string-address-array-address)) ; 'character' will be of larger size when mu supports unicode ; we're currently undisciplined about mixing 'byte' and 'character' ; realistic test of indiscipline in general character (obj size 1) ; int32 like a Go rune character-address (obj size 1 address t elem '(character)) ; a buffer makes it easy to append to a string/array ; todo: make this generic ; data isn't a 'real' array: its length is stored outside it, ; so for example, 'print-string' won't work on it. buffer (obj size 2 and-record t elems '((integer) (string-address)) fields '(length data)) buffer-address (obj size 1 address t elem '(buffer)) ; a stream makes it easy to read from a string/array stream (obj size 2 and-record t elems '((integer) (string-address)) fields '(pointer data)) stream-address (obj size 1 address t elem '(stream)) ; isolating function calls space (obj array t elem '(location)) ; by convention index 0 points to outer space space-address (obj size 1 address t elem '(space)) ; arrays consist of an integer length followed by that many ; elements, all of the same type integer-array (obj array t elem '(integer)) integer-array-address (obj size 1 address t elem '(integer-array)) integer-array-address-address (obj size 1 address t elem '(integer-array-address)) integer-address (obj size 1 address t elem '(integer)) ; pointer to int integer-address-address (obj size 1 address t elem '(integer-address)) ; and-records consist of a multiple fields of different types integer-boolean-pair (obj size 2 and-record t elems '((integer) (boolean)) fields '(int bool)) integer-boolean-pair-address (obj size 1 address t elem '(integer-boolean-pair)) integer-boolean-pair-array (obj array t elem '(integer-boolean-pair)) integer-boolean-pair-array-address (obj size 1 address t elem '(integer-boolean-pair-array)) integer-integer-pair (obj size 2 and-record t elems '((integer) (integer))) integer-integer-pair-address (obj size 1 address t elem '(integer-integer-pair)) integer-point-pair (obj size 2 and-record t elems '((integer) (integer-integer-pair))) integer-point-pair-address (obj size 1 address t elem
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd">
<html>
<head>
<meta http-equiv="content-type" content="text/html; charset=UTF-8">
<title>Mu - 071rewrite_stash.cc</title>
<meta name="Generator" content="Vim/7.4">
<meta name="plugin-version" content="vim7.4_v2">
<meta name="syntax" content="cpp">
<meta name="settings" content="use_css,pre_wrap,no_foldcolumn,expand_tabs,prevent_copy=">
<meta name="colorscheme" content="minimal">
<style type="text/css">
<!--
pre { white-space: pre-wrap; font-family: monospace; color: #eeeeee; background-color: #080808; }
body { font-size: 12pt; font-family: monospace; color: #eeeeee; background-color: #080808; }
* { font-size: 12pt; font-size: 1em; }
.Constant { color: #00a0a0; }
.cSpecial { color: #008000; }
.traceContains { color: #008000; }
.Comment { color: #9090ff; }
.Delimiter { color: #800080; }
.Special { color: #c00000; }
.Identifier { color: #fcb165; }
.Normal { color: #eeeeee; background-color: #080808; padding-bottom: 1px; }
-->
</style>

<script type='text/javascript'>
<!--

-->
</script>
</head>
<body>
<pre id='vimCodeElement'>
<span class="Comment">//: when encountering other types, try to convert them to strings using</span>
<span class="Comment">//: 'to-text'</span>

<span class="Delimiter">:(scenarios transform)</span>
<span class="Delimiter">:(scenario rewrite_stashes_to_text)</span>
recipe main [
  local-scope
  <span class="Normal">n</span>:number<span class="Special"> &lt;- </span>copy <span class="Constant">34</span>
  stash n
]
<span class="traceContains">+transform: {stash_2_0: (&quot;address&quot; &quot;shared&quot; &quot;array&quot; &quot;character&quot;)} &lt;- to-text-line {n: &quot;number&quot;}</span>
<span class="traceContains">+transform: stash {stash_2_0: (&quot;address&quot; &quot;shared&quot; &quot;array&quot; &quot;character&quot;)}</span>

<span class="Comment">//: special case: rewrite attempts to stash contents of most arrays to avoid</span>
<span class="Comment">//: passing addresses around</span>

<span class="Delimiter">:(scenario rewrite_stashes_of_arrays)</span>
recipe main [
  local-scope
  <span class="Normal">n</span>:address:shared:array:number<span class="Special"> &lt;- </span><span class="Normal">new</span> number:type<span class="Delimiter">,</span> <span class="Constant">3</span>
  stash *n
]
<span class="traceContains">+transform: {stash_2_0: (&quot;address&quot; &quot;shared&quot; &quot;array&quot; &quot;character&quot;)} &lt;- array-to-text-line {n: (&quot;address&quot; &quot;shared&quot; &quot;array&quot; &quot;number&quot;)}</span>
<span class="traceContains">+transform: stash {stash_2_0: (&quot;address&quot; &quot;shared&quot; &quot;array&quot; &quot;character&quot;)}</span>

<span class="Delimiter">:(before &quot;End Instruction Inserting/Deleting Transforms&quot;)</span>
Transform<span class="Delimiter">.</span>push_back<span class="Delimiter">(</span>rewrite_stashes_to_text<span class="Delimiter">);</span>

<span class="Delimiter">:(code)</span>
<span class="Normal">void</span> rewrite_stashes_to_text<span class="Delimiter">(</span>recipe_ordinal r<span class="Delimiter">)</span> <span class="Delimiter">{</span>
  recipe&amp; caller = get<span class="Delimiter">(</span>Recipe<span class="Delimiter">,</span> r<span class="Delimiter">);</span>
  trace<span class="Delimiter">(</span><span class="Constant">9991</span><span class="Delimiter">,</span> <span class="Constant">&quot;transform&quot;</span><span class="Delimiter">)</span> &lt;&lt; <span class="Constant">&quot;--- rewrite 'stash' instructions in recipe &quot;</span> &lt;&lt; caller<span class="Delimiter">.</span>name &lt;&lt; end<span class="Delimiter">();</span>
  <span class="Comment">// in recipes without named locations, 'stash' is still not extensible</span>
  <span class="Normal">if</span> <span class="Delimiter">(</span>contains_numeric_locations<span class="Delimiter">(</span>caller<span class="Delimiter">))</span> <span class="Identifier">return</span><span class="Delimiter">;</span>
  check_or_set_types_by_name<span class="Delimiter">(</span>r<span class="Delimiter">);</span>  <span class="Comment">// prerequisite</span>
  rewrite_stashes_to_text<span class="Delimiter">(</span>caller<span class="Delimiter">);</span>
<span class="Delimiter">}</span>

<span class="Normal">void</span> rewrite_stashes_to_text<span class="Delimiter">(</span>recipe&amp; caller<span class="Delimiter">)</span> <span class="Delimiter">{</span>
  vector&lt;instruction&gt; new_instructions<span class="Delimiter">;</span>
  <span class="Normal">for</span> <span class="Delimiter">(</span><span class="Normal">int</span> i = <span class="Constant">0</span><span class="Delimiter">;</span> i &lt; SIZE<span class="Delimiter">(</span>caller<span class="Delimiter">.</span>steps<span class="Delimiter">);</span> ++i<span class="Delimiter">)</span> <span class="Delimiter">{</span>
    instruction&amp; inst = caller<span class="Delimiter">.</span>steps<span class="Delimiter">.</span>at<span class="Delimiter">(</span>i<span class="Delimiter">);</span>
    <span class="Normal">if</span> <span class="Delimiter">(</span>inst<span class="Delimiter">.</span>name == <span class="Constant">&quot;stash&quot;</span><span class="Delimiter">)</span> <span class="Delimiter">{</span>
      <span class="Normal">for</span> <span class="Delimiter">(</span><span class="Normal">int</span> j = <span class="Constant">0</span><span class="Delimiter">;</span> j &lt; SIZE<span class="Delimiter">(</span>inst<span class="Delimiter">.</span>ingredients<span class="Delimiter">);</span> ++j<span class="Delimiter">)</span> <span class="Delimiter">{</span>
        assert<span class="Delimiter">(</span>inst<span class="Delimiter">.</span>ingredients<span class="Delimiter">.</span>at<span class="Delimiter">(</span>j<span class="Delimiter">).</span>type<span class="Delimiter">);</span>
        <span class="Normal">if</span> <span class="Delimiter">(</span>is_literal<span class="Delimiter">(</span>inst<span class="Delimiter">.</span>ingredients<span class="Delimiter">.</span>at<span class="Delimiter">(</span>j<span class="Delimiter">)))</span> <span class="Identifier">continue</span><span class="Delimiter">;</span>
        <span class="Normal">if</span> <span class="Delimiter">(</span>is_mu_string<span class="Delimiter">(</span>inst<span class="Delimiter">.</span>ingredients<span class="Delimiter">.</span>at<span class="Delimiter">(</span>j<span class="Delimiter">)))</span> <span class="Identifier">continue</span><span class="Delimiter">;</span>
        instruction def<span class="Delimiter">;</span>
        <span class="Normal">if</span> <span class="Delimiter">(</span>is_address_of_array<span class="Delimiter">(</span>inst<span class="Delimiter">.</span>ingredients<span class="Delimiter">.</span>at<span class="Delimiter">(</span>j<span class="Delimiter">)))</span> <span class="Delimiter">{</span>
          def<span class="Delimiter">.</span>name = <span class="Constant">&quot;array-to-text-line&quot;</span><span class="Delimiter">;</span>
          reagent tmp = inst<span class="Delimiter">.</span>ingredients<span class="Delimiter">.</span>at<span class="Delimiter">(</span>j<span class="Delimiter">);</span>
          drop_one_lookup<span class="Delimiter">(</span>tmp<span class="Delimiter">);</span>
          def<span class="Delimiter">.</span>ingredients<span class="Delimiter">.</span>push_back<span class="Delimiter">(</span>tmp<span class="Delimiter">);</span>
        <span class="Delimiter">}</span>
        <span class="Normal">else</span> <span class="Delimiter">{</span>
          def<span class="Delimiter">.</span>name = <span class="Constant">&quot;to-text-line&quot;</span><span class="Delimiter">;</span>
          def<span class="Delimiter">.</span>ingredients<span class="Delimiter">.</span>push_back<span class="Delimiter">(</span>inst<span class="Delimiter">.</span>ingredients<span class="Delimiter">.</span>at<span class="Delimiter">(</span>j<span class="Delimiter">));</span>
        <span class="Delimiter">}</span>
        ostringstream ingredient_name<span class="Delimiter">;</span>
        ingredient_name &lt;&lt; <span class="Constant">&quot;stash_&quot;</span> &lt;&lt; i &lt;&lt; <span class="Constant">'_'</span> &lt;&lt; j &lt;&lt; <span class="Constant">&quot;:address:shared:array:character&quot;</span><span class="Delimiter">;</span>
        def<span class="Delimiter">.</span>products<span class="Delimiter">.</span>push_back<span class="Delimiter">(</span>reagent<span class="Delimiter">(</span>ingredient_name<span class="Delimiter">.</span>str<span class="Delimiter">()));</span>
        trace<span class="Delimiter">(</span><span class="Constant">9993</span><span class="Delimiter">,</span> <span class="Constant">&quot;transform&quot;</span><span class="Delimiter">)</span> &lt;&lt; to_string<span class="Delimiter">(</span>def<span class="Delimiter">)</span> &lt;&lt; end<span class="Delimiter">();</span>
        new_instructions<span class="Delimiter">.</span>push_back<span class="Delimiter">(</span>def<span class="Delimiter">);</span>
        inst<span class="Delimiter">.</span>ingredients<span class="Delimiter">.</span>at<span class="Delimiter">(</span>j<span class="Delimiter">).</span>clear<span class="Delimiter">();</span>  <span class="Comment">// reclaim old memory</span>
        inst<span class="Delimiter">.</span>ingredients<span class="Delimiter">.</span>at<span class="Delimiter">(</span>j<span class="Delimiter">)</span> = reagent<span class="Delimiter">(</span>ingredient_name<span class="Delimiter">.</span>str<span class="Delimiter">());</span>
      <span class="Delimiter">}</span>
    <span class="Delimiter">}</span>
    trace<span class="Delimiter">(</span><span class="Constant">9993</span><span class="Delimiter">,</span> <span class="Constant">&quot;transform&quot;</span><span class="Delimiter">)</span> &lt;&lt; to_string<span class="Delimiter">(</span>inst<span class="Delimiter">)</span> &lt;&lt; end<span class="Delimiter">();</span>
    new_instructions<span class="Delimiter">.</span>push_back<span class="Delimiter">(</span>inst<span class="Delimiter">);</span>
  <span class="Delimiter">}</span>
  caller<span class="Delimiter">.</span>steps<span class="Delimiter">.</span>swap<span class="Delimiter">(</span>new_instructions<span class="Delimiter">);</span>
<span class="Delimiter">}</span>

<span class="Normal">bool</span> is_address_of_array<span class="Delimiter">(</span>reagent x<span class="Delimiter">)</span> <span class="Delimiter">{</span>
  <span class="Normal">if</span> <span class="Delimiter">(</span>!canonize_type<span class="Delimiter">(</span>x<span class="Delimiter">))</span> <span class="Identifier">return</span> <span class="Constant">false</span><span class="Delimiter">;</span>
  <span class="Identifier">return</span> x<span class="Delimiter">.</span>type<span class="Delimiter">-&gt;</span>name == <span class="Constant">&quot;array&quot;</span><span class="Delimiter">;</span>
<span class="Delimiter">}</span>

<span class="Comment">//: Make sure that the new system is strictly better than just the 'stash'</span>
<span class="Comment">//: primitive by itself.</span>

<span class="Delimiter">:(scenarios run)</span>
<span class="Delimiter">:(scenario rewrite_stash_continues_to_fall_back_to_default_implementation)</span>
<span class="Comment"># type without a to-text implementation</span>
container foo [
  <span class="Normal">x</span>:number
  <span class="Normal">y</span>:number
]
recipe main [
  local-scope
  <span class="Normal">x</span>:foo<span class="Special"> &lt;- </span>merge <span class="Constant">34</span><span class="Delimiter">,</span> <span class="Constant">35</span>
  stash x
]
<span class="traceContains">+app: 34 35</span>

<span class="Delimiter">:(before &quot;End Primitive Recipe Declarations&quot;)</span>
TO_TEXT<span class="Delimiter">,</span>
<span class="Delimiter">:(before &quot;End Primitive Recipe Numbers&quot;)</span>
put<span class="Delimiter">(</span>Recipe_ordinal<span class="Delimiter">,</span> <span class="Constant">&quot;to-text&quot;</span><span class="Delimiter">,</span> TO_TEXT<span class="Delimiter">);</span>
<span class="Delimiter">:(before &quot;End Primitive Recipe Checks&quot;)</span>
<span class="Normal">case</span> TO_TEXT: <span class="Delimiter">{</span>
  <span class="Normal">if</span> <span class="Delimiter">(</span>SIZE<span class="Delimiter">(</span>inst<span class="Delimiter">.</span>ingredients<span class="Delimiter">)</span> != <span class="Constant">1</span><span class="Delimiter">)</span> <span class="Delimiter">{</span>
    raise &lt;&lt; maybe<span class="Delimiter">(</span>get<span class="Delimiter">(</span>Recipe<span class="Delimiter">,</span> r<span class="Delimiter">).</span>name<span class="Delimiter">)</span> &lt;&lt; <span class="Constant">&quot;'to-text' requires a single ingredient, but got '&quot;</span> &lt;&lt; to_original_string<span class="Delimiter">(</span>inst<span class="Delimiter">)</span> &lt;&lt; <span class="Constant">&quot;'</span><span class="cSpecial">\n</span><span class="Constant">&quot;</span> &lt;&lt; end<span class="Delimiter">();</span>
    <span class="Identifier">break</span><span class="Delimiter">;</span>
  <span class="Delimiter">}</span>
  <span class="Identifier">break</span><span class="Delimiter">;</span>
<span class="Delimiter">}</span>
<span class="Delimiter">:(before &quot;End Primitive Recipe Implementations&quot;)</span>
<span class="Normal">case</span> TO_TEXT: <span class="Delimiter">{</span>
  products<span class="Delimiter">.</span>resize<span class="Delimiter">(</span><span class="Constant">1</span><span class="Delimiter">);</span>
  products<span class="Delimiter">.</span>at<span class="Delimiter">(</span><span class="Constant">0</span><span class="Delimiter">).</span>push_back<span class="Delimiter">(</span>new_mu_string<span class="Delimiter">(</span>print_mu<span class="Delimiter">(</span>current_instruction<span class="Delimiter">().</span>ingredients<span class="Delimiter">.</span>at<span class="Delimiter">(</span><span class="Constant">0</span><span class="Delimiter">),</span> ingredients<span class="Delimiter">.</span>at<span class="Delimiter">(</span><span class="Constant">0</span><span class="Delimiter">))));</span>
  <span class="Identifier">break</span><span class="Delimiter">;</span>
<span class="Delimiter">}</span>
</pre>
</body>
</html>
<!-- vim: set foldmethod=manual : -->
generated by cgit-pink 1.4.1-2-gfad0 (git 2.36.2.497.gbbea4dcf42) at 2024-12-02 19:13:23 +0000
e literal))) (break-unless backspace?:boolean) (len:integer-address <- get-address line:buffer-address/deref length:offset) ; but only if we need to { begin ;? ($print (("backspace: " literal))) ;? 1 ;? ($print len:integer-address/deref) ;? 1 ;? ($print (("\n" literal))) ;? 1 (zero?:boolean <- lesser-or-equal len:integer-address/deref 0:literal) (break-if zero?:boolean) (len:integer-address/deref <- subtract len:integer-address/deref 1:literal) } (loop 2:blocks) } (line:buffer-address <- append line:buffer-address c:character) (line-done?:boolean <- equal c:character ((#\newline literal))) (break-if line-done?:boolean) (eof?:boolean <- equal c:character ((#\null literal))) (break-if eof?:boolean 2:blocks) (loop) } ; copy line into buffered-stdout (i:integer <- copy 0:literal) (line-contents:string-address <- get line:buffer-address/deref data:offset) (max:integer <- get line:buffer-address/deref length:offset) ;? ($print (("len: " literal))) ;? 1 ;? ($print max:integer) ;? 1 ;? ($print (("\n" literal))) ;? 1 { begin (done?:boolean <- greater-or-equal i:integer max:integer) (break-if done?:boolean) (c:character <- index line-contents:string-address/deref i:integer) (curr:tagged-value <- save-type c:character) ;? ($dump-channel 1093:literal) ;? 1 ;? ($start-tracing) ;? 1 ;? ($print (("bufferout: " literal))) ;? 2 ;? ($print c:character) ;? 1 ;? (x:integer <- character-to-integer c:character) ;? 1 ;? ($print x:integer) ;? 1 ;? ($print (("\n" literal))) ;? 2 (buffered-stdin:channel-address/deref <- write buffered-stdin:channel-address curr:tagged-value) ;? ($stop-tracing) ;? 1 ;? ($dump-channel 1093:literal) ;? 1 ;? ($quit) ;? 1 (i:integer <- add i:integer 1:literal) (loop) } (loop) } ) (init-fn clear-screen (default-space:space-address <- new space:literal 30:literal) (x:terminal-address <- next-input) { begin (break-unless x:terminal-address) ;? ($print (("AAA" literal))) (buf:string-address <- get x:terminal-address/deref data:offset) (max:integer <- length buf:string-address/deref) (i:integer <- copy 0:literal) { begin (done?:boolean <- greater-or-equal i:integer max:integer) (break-if done?:boolean) (x:byte-address <- index-address buf:string-address/deref i:integer) (x:byte-address/deref <- copy ((#\space literal))) (i:integer <- add i:integer 1:literal) (loop) } (reply) } (clear-host-screen) ) (init-fn cursor (default-space:space-address <- new space:literal 30:literal) (x:terminal-address <- next-input) (newrow:integer <- next-input) (newcol:integer <- next-input) { begin (break-unless x:terminal-address) (row:integer-address <- get-address x:terminal-address/deref cursor-row:offset) (row:integer-address/deref <- copy newrow:integer) (col:integer-address <- get-address x:terminal-address/deref cursor-col:offset) (col:integer-address/deref <- copy newcol:integer) (reply) } (cursor-on-host row:integer col:integer) ) (init-fn cursor-to-next-line (default-space:space-address <- new space:literal 30:literal) (x:terminal-address <- next-input) { begin (break-unless x:terminal-address) (row:integer-address <- get-address x:terminal-address/deref cursor-row:offset) ;? ($print row:integer-address/deref) ;? ($print (("\n" literal))) (row:integer-address/deref <- add row:integer-address/deref 1:literal) (col:integer-address <- get-address x:terminal-address/deref cursor-col:offset) ;? ($print col:integer-address/deref) ;? ($print (("\n" literal))) (col:integer-address/deref <- copy 0:literal) (reply) } (cursor-on-host-to-next-line) ) (init-fn cursor-down (default-space:space-address <- new space:literal 30:literal) (x:terminal-address <- next-input) ;? ($print ((#\# literal))) ;? 1 (height:integer-address <- get-address x:terminal-address/deref num-rows:offset) ;? ($print height:integer-address/deref) ;? 1 { begin (break-unless x:terminal-address) ;? ($print ((#\% literal))) ;? 1 (row:integer-address <- get-address x:terminal-address/deref cursor-row:offset) ;? ($print (("cursor down: " literal))) ;? 1 ;? ($print row:integer-address/deref) ;? 1 ;? ($print (("\n" literal))) ;? 1 { begin (bottom?:boolean <- greater-or-equal row:integer-address/deref height:integer-address/deref) (break-if bottom?:boolean) (row:integer-address/deref <- add row:integer-address/deref 1:literal) ;? ($print ((#\* literal))) ;? 1 ;? ($print row:integer-address/deref) ;? 1 } (reply) } (cursor-down-on-host) ) (init-fn cursor-up (default-space:space-address <- new space:literal 30:literal) (x:terminal-address <- next-input) { begin (break-unless x:terminal-address) (row:integer-address <- get-address x:terminal-address/deref cursor-row:offset) ;? ($print (("cursor up: " literal))) ;? 1 ;? ($print row:integer-address/deref) ;? 1 ;? ($print (("\n" literal))) ;? 1 { begin (top?:boolean <- lesser-or-equal row:integer-address/deref 0:literal) (break-if top?:boolean) (row:integer-address/deref <- subtract row:integer-address/deref 1:literal) } (reply) } (cursor-up-on-host) ) (init-fn cursor-left (default-space:space-address <- new space:literal 30:literal) (x:terminal-address <- next-input) { begin (break-unless x:terminal-address) (col:integer-address <- get-address x:terminal-address/deref cursor-col:offset) { begin (edge?:boolean <- lesser-or-equal col:integer-address/deref 0:literal) (break-if edge?:boolean) (col:integer-address/deref <- subtract col:integer-address/deref 1:literal) } (reply) } (cursor-left-on-host) ) (init-fn cursor-right (default-space:space-address <- new space:literal 30:literal) (x:terminal-address <- next-input) (width:integer-address <- get-address x:terminal-address/deref num-cols:offset) { begin (break-unless x:terminal-address) (col:integer-address <- get-address x:terminal-address/deref cursor-col:offset) { begin (edge?:boolean <- lesser-or-equal col:integer-address/deref width:integer-address/deref) (break-if edge?:boolean) (col:integer-address/deref <- add col:integer-address/deref 1:literal) } (reply) } (cursor-right-on-host) ) (init-fn replace-character (default-space:space-address <- new space:literal 30:literal) (x:terminal-address <- next-input) (c:character <- next-input) (print-character x:terminal-address c:character) (cursor-left x:terminal-address) ) (init-fn clear-line (default-space:space-address <- new space:literal 30:literal) (x:terminal-address <- next-input) { begin (break-unless x:terminal-address) (n:integer <- get x:terminal-address/deref num-cols:offset) (col:integer-address <- get-address x:terminal-address/deref cursor-col:offset) (orig-col:integer <- copy col:integer-address/deref) ; space over the entire line { begin (done?:boolean <- greater-or-equal col:integer-address/deref n:integer) (break-if done?:boolean) (print-character x:terminal-address ((#\space literal))) ; implicitly updates 'col' (loop) } ; now back to where the cursor was (col:integer-address/deref <- copy orig-col:integer) (reply) } (clear-line-on-host) ) (init-fn print-character (default-space:space-address <- new space:literal 30:literal) (x:terminal-address <- next-input) (c:character <- next-input) (fg:integer/color <- next-input) (bg:integer/color <- next-input) ;? ($print (("printing character to screen " literal))) ;? ($print c:character) ;? (reply) ;? ($print (("\n" literal))) { begin (break-unless x:terminal-address) (row:integer-address <- get-address x:terminal-address/deref cursor-row:offset) ;? ($print row:integer-address/deref) ;? 2 ;? ($print ((", " literal))) ;? 1 (col:integer-address <- get-address x:terminal-address/deref cursor-col:offset) ;? ($print col:integer-address/deref) ;? 1 ;? ($print (("\n" literal))) ;? 1 (width:integer <- get x:terminal-address/deref num-cols:offset) (t1:integer <- multiply row:integer-address/deref width:integer) (idx:integer <- add t1:integer col:integer-address/deref) (buf:string-address <- get x:terminal-address/deref data:offset) (cursor:byte-address <- index-address buf:string-address/deref idx:integer) (cursor:byte-address/deref <- copy c:character) ; todo: newline, etc. (col:integer-address/deref <- add col:integer-address/deref 1:literal) ; we don't rely on any auto-wrap functionality ; maybe die if we go out of screen bounds? (reply) } (print-character-to-host c:character fg:integer/color bg:integer/color) ) (init-fn print-string (default-space:space-address <- new space:literal 30:literal) (x:terminal-address <- next-input) (s:string-address <- next-input) (len:integer <- length s:string-address/deref) ;? ($print (("print/string: len: " literal))) ;? ($print len:integer) ;? ($print (("\n" literal))) (i:integer <- copy 0:literal) { begin (done?:boolean <- greater-or-equal i:integer len:integer) (break-if done?:boolean) (c:character <- index s:string-address/deref i:integer) (print-character x:terminal-address c:character) (i:integer <- add i:integer 1:literal) (loop) } ) (init-fn print-integer (default-space:space-address <- new space:literal 30:literal) (x:terminal-address <- next-input) (n:integer <- next-input) ; todo: other bases besides decimal ;? ($print (("AAA " literal))) ;? ($print n:integer) (s:string-address <- integer-to-decimal-string n:integer) ;? ($print s:string-address) (print-string x:terminal-address s:string-address) ) (init-fn init-buffer (default-space:space-address <- new space:literal 30:literal) (result:buffer-address <- new buffer:literal) (len:integer-address <- get-address result:buffer-address/deref length:offset) (len:integer-address/deref <- copy 0:literal) (s:string-address-address <- get-address result:buffer-address/deref data:offset) (capacity:integer <- next-input) (s:string-address-address/deref <- new string:literal capacity:integer) (reply result:buffer-address) ) (init-fn grow-buffer (default-space:space-address <- new space:literal 30:literal) (in:buffer-address <- next-input) ; double buffer size (x:string-address-address <- get-address in:buffer-address/deref data:offset) (oldlen:integer <- length x:string-address-address/deref/deref) ;? ($print oldlen:integer) ;? 1 (newlen:integer <- multiply oldlen:integer 2:literal) ;? ($print newlen:integer) ;? 1 (olddata:string-address <- copy x:string-address-address/deref) (x:string-address-address/deref <- new string:literal newlen:integer) ; copy old contents (i:integer <- copy 0:literal) { begin (done?:boolean <- greater-or-equal i:integer oldlen:integer) (break-if done?:boolean) (src:byte <- index olddata:string-address/deref i:integer) (dest:byte-address <- index-address x:string-address-address/deref/deref i:integer) (dest:byte-address/deref <- copy src:byte) (i:integer <- add i:integer 1:literal) (loop) } (reply in:buffer-address) ) (init-fn buffer-full? (default-space:space-address <- new space:literal 30:literal) (in:buffer-address <- next-input) (len:integer <- get in:buffer-address/deref length:offset) (s:string-address <- get in:buffer-address/deref data:offset) (capacity:integer <- length s:string-address/deref) (result:boolean <- greater-or-equal len:integer capacity:integer) (reply result:boolean) ) (init-fn buffer-index (default-space:space-address <- new space:literal 30:literal) (in:buffer-address <- next-input) (idx:integer <- next-input) { begin (len:integer <- get in:buffer-address/deref length:offset) (not-too-high?:boolean <- less-than idx:integer len:integer) (not-too-low?:boolean <- greater-or-equal idx:integer 0:literal) (in-bounds?:boolean <- and not-too-low?:boolean not-too-high?:boolean) (break-if in-bounds?:boolean) (assert nil:literal (("buffer-index out of bounds" literal))) } (s:string-address <- get in:buffer-address/deref data:offset) (result:character <- index s:string-address/deref idx:integer) (reply result:character) ) (init-fn to-array ; from buffer (default-space:space-address <- new space:literal 30:literal) (in:buffer-address <- next-input) (len:integer <- get in:buffer-address/deref length:offset) (s:string-address <- get in:buffer-address/deref data:offset) { begin ; test: ctrl-d -> s is nil -> to-array returns nil -> read-expression returns t -> exit repl (break-if s:string-address) (reply nil:literal) } ; we can't just return s because it is usually the wrong length (result:string-address <- new string:literal len:integer) (i:integer <- copy 0:literal) { begin (done?:boolean <- greater-or-equal i:integer len:integer) (break-if done?:boolean) (src:byte <- index s:string-address/deref i:integer) ;? (foo:integer <- character-to-integer src:byte) ;? 1 ;? ($print (("a: " literal))) ;? 1 ;? ($print foo:integer) ;? 1 ;? ($print ((#\newline literal))) ;? 1 (dest:byte-address <- index-address result:string-address/deref i:integer) (dest:byte-address/deref <- copy src:byte) (i:integer <- add i:integer 1:literal) (loop) } (reply result:string-address) ) (init-fn append (default-space:space-address <- new space:literal 30:literal) (in:buffer-address <- next-input) (c:character <- next-input) ;? ($print c:character) ;? 1 { begin ; grow buffer if necessary (full?:boolean <- buffer-full? in:buffer-address) ;? ($print (("aa\n" literal))) ;? 1 (break-unless full?:boolean) ;? ($print (("bb\n" literal))) ;? 1 (in:buffer-address <- grow-buffer in:buffer-address) ;? ($print (("cc\n" literal))) ;? 1 } (len:integer-address <- get-address in:buffer-address/deref length:offset) (s:string-address <- get in:buffer-address/deref data:offset) (dest:byte-address <- index-address s:string-address/deref len:integer-address/deref) (dest:byte-address/deref <- copy c:character) (len:integer-address/deref <- add len:integer-address/deref 1:literal) (reply in:buffer-address/same-as-arg:0) ) (init-fn last (default-space:space-address <- new space:literal 30:literal) (in:buffer-address <- next-input) (n:integer <- get in:buffer-address/deref length:offset) { begin ; if empty return nil (empty?:boolean <- equal n:integer 0:literal) (break-unless empty?:boolean) (reply nil:literal) } (n:integer <- subtract n:integer 1:literal) (s:string-address <- get in:buffer-address/deref data:offset) (result:character <- index s:string-address/deref n:integer) (reply result:character) ) (init-fn integer-to-decimal-string (default-space:space-address <- new space:literal 30:literal) (n:integer <- next-input) ; is it zero? { begin (zero?:boolean <- equal n:integer 0:literal) (break-unless zero?:boolean) (s:string-address <- new "0") (reply s:string-address) } ; save sign (negate-result:boolean <- copy nil:literal) { begin (negative?:boolean <- less-than n:integer 0:literal) (break-unless negative?:boolean) ;? ($print (("is negative " literal))) (negate-result:boolean <- copy t:literal) (n:integer <- multiply n:integer -1:literal) } ; add digits from right to left into intermediate buffer (tmp:buffer-address <- init-buffer 30:literal) (zero:character <- copy ((#\0 literal))) (digit-base:integer <- character-to-integer zero:character) { begin (done?:boolean <- equal n:integer 0:literal) (break-if done?:boolean) (n:integer digit:integer <- divide-with-remainder n:integer 10:literal) (digit-codepoint:integer <- add digit-base:integer digit:integer) (c:character <- integer-to-character digit-codepoint:integer) (tmp:buffer-address <- append tmp:buffer-address c:character) (loop) } ; add sign { begin (break-unless negate-result:boolean) (tmp:buffer-address <- append tmp:buffer-address ((#\- literal))) } ; reverse buffer into string result (len:integer <- get tmp:buffer-address/deref length:offset) (buf:string-address <- get tmp:buffer-address/deref data:offset) (result:string-address <- new string:literal len:integer) (i:integer <- subtract len:integer 1:literal) (j:integer <- copy 0:literal) { begin ; while (i >= 0) (done?:boolean <- less-than i:integer 0:literal) (break-if done?:boolean) ; result[j] = tmp[i] (src:byte <- index buf:string-address/deref i:integer) (dest:byte-address <- index-address result:string-address/deref j:integer) (dest:byte-address/deref <- copy src:byte) ; ++i (i:integer <- subtract i:integer 1:literal) ; --j (j:integer <- add j:integer 1:literal) (loop) } (reply result:string-address) ) (init-fn send-prints-to-stdout (default-space:space-address <- new space:literal 30:literal) (screen:terminal-address <- next-input) (stdout:channel-address <- next-input) ;? (i:integer <- copy 0:literal) ;? 1 { begin (x:tagged-value stdout:channel-address/deref <- read stdout:channel-address) (c:character <- maybe-coerce x:tagged-value character:literal) (done?:boolean <- equal c:character ((#\null literal))) (break-if done?:boolean) ;? ($print (("printing " literal))) ;? 1 ;? ($print i:integer) ;? 1 ;? ($print ((" -- " literal))) ;? 1 ;? (x:integer <- character-to-integer c:character) ;? 1 ;? ($print x:integer) ;? 1 ;? ($print (("\n" literal))) ;? 1 ;? (i:integer <- add i:integer 1:literal) ;? 1 (print-character screen:terminal-address c:character) (loop) } ) ; remember to call this before you clear the screen or at any other milestone ; in an interactive program (init-fn flush-stdout (default-space:boolean <- copy nil:literal) ; silence warning, but die if locals used (sleep for-some-cycles:literal 1:literal) ) (init-fn init-fake-terminal (default-space:space-address <- new space:literal 30:literal/capacity) (result:terminal-address <- new terminal:literal) (width:integer-address <- get-address result:terminal-address/deref num-cols:offset) (width:integer-address/deref <- next-input) (height:integer-address <- get-address result:terminal-address/deref num-rows:offset) (height:integer-address/deref <- next-input) (row:integer-address <- get-address result:terminal-address/deref cursor-row:offset) (row:integer-address/deref <- copy 0:literal) (col:integer-address <- get-address result:terminal-address/deref cursor-col:offset) (col:integer-address/deref <- copy 0:literal) (bufsize:integer <- multiply width:integer-address/deref height:integer-address/deref) (buf:string-address-address <- get-address result:terminal-address/deref data:offset) (buf:string-address-address/deref <- new string:literal bufsize:integer) (clear-screen result:terminal-address) (reply result:terminal-address) ) (init-fn divides? (default-space:space-address <- new space:literal 30:literal/capacity) (x:integer <- next-input) (y:integer <- next-input) (_ remainder:integer <- divide-with-remainder x:integer y:integer) (result:boolean <- equal remainder:integer 0:literal) (reply result:boolean) ) ; after all system software is loaded: ;? (= dump-trace* (obj whitelist '("cn0" "cn1"))) (freeze system-function*) ) ; section 100 for system software ;; initialization (reset) (awhen (pos "--" argv) ; batch mode: load all provided files and start at 'main' (map add-code:readfile (cut argv (+ it 1))) ;? (set dump-trace*) (run 'main) (if ($.current-charterm) ($.close-charterm)) (when ($.graphics-open?) ($.close-viewport Viewport) ($.close-graphics)) ;? (pr "\nmemory: ") ;? (write int-canon.memory*) (prn) (each routine completed-routines* (awhen rep.routine!error (prn "error - " it) ;? (prn routine) )) ) ; repl (def run-interactive (stmt) ; careful to avoid re-processing functions and adding noise to traces (= function*!interactive (convert-labels:convert-braces:tokenize-args (list stmt))) (add-next-space-generator function*!interactive 'interactive) (= location*!interactive (assign-names-to-location function*!interactive 'interactive location*!interactive)) (replace-names-with-location function*!interactive 'interactive) (= traces* (queue)) ; skip preprocessing (run-more 'interactive)) (when (no cdr.argv) (add-code:readfile "trace.mu") (wipe function*!main) (add-code:readfile "factorial.mu") ;? (add-code:readfile "chessboard.mu") ; takes too long (wipe function*!main) (freeze function*) (load-system-functions) (wipe interactive-commands*) (wipe interactive-traces*) (= interactive-cmdidx* 0) (= traces* (queue)) ;? (set dump-trace*) ;? 2 ; interactive mode (point break (while t (pr interactive-cmdidx*)(pr "> ") (let expr (read) (unless expr (break)) (push expr interactive-commands*) (run-interactive expr)) (push traces* interactive-traces*) (++ interactive-cmdidx*) ))) (if ($.current-charterm) ($.close-charterm)) (reset) ;? (print-times)